diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,624 @@ +New in 0.9.20: +============== + +Language updates +---------------- + +* Improved unification by implementing a pattern unification rule +* The syntax `{{n}} quotes n without resolving it, allowing short syntax + for defining new names. `{n} still quotes n to an existing name in scope. +* A new primitive operator prim__strSubstr for more efficient extraction of + substrings. External code generators should implement this. +* Changed scoping rules for unbound implicits: any name which would be a + valid unbound implicit is now *always* an unbound implicit. This is much + more resilient to changes in inputs, but does require that function names + be explicitly qualified when in argument position. + +Library updates +--------------- + +* The 'Neg' class now represents numeric types which can be negative. As +such, the (-) operator and 'abs' have been moved there from 'Num'. +* A special version of (-) on 'Nat' requires that the second argument is +smaller than or equal to the first. 'minus' retains the old behaviour, +returning Z if there is an underflow. +* New Logging Effects have been added to facilitate logging of effectful + programmes. + +Tool updates +------------ +* Records are now shown as records in :doc, rather than as the underlying + datatype + +Miscellaneous updates +--------------------- + +[None so far] + +New in 0.9.19: +-------------- +* The Idris Reference manual has been fleshed out with content originally found + on the GitHub wiki. +* The Show class has been moved into Prelude.Show and augmented with the method + showPrec, which allows correct parenthesization of showed terms. This comes + with the type Prec of precedences and a few helper functions. +* New REPL command :printerdepth that sets the pretty-printer to only descend to + some particular depth when printing. The default is set to a high number to + make it less dangerous to experiment with infinite structures. Infinite depth + can be set by calling :printerdepth with no argument. +* Compiler output shows applications of >>= in do-notation +* fromInteger i where i is an integer constant is now shown just as i in + compiler output +* An interactive shell, similar to the prover, for running reflected elaborator + actions. Access it with :elab from the REPL. +* New command-line option --highlight that causes Idris to save highlighting + information when successfully type checking. The information is in the same + format sent by the IDE mode, and is saved in a file with the extension ".idh". +* Highlighting information is saved by the parser as well, allowing it to highlight + keywords like "case", "of", "let", and "do" +* Use predicates instead of boolean equality proofs as preconditions + on List functions +* More flexible 'case' construct, allowing each branch to target different + types, provided that the case analysis does not affect the form of any + variable used in the right hand side of the case. +* Some improvements in interactive editing, particularly in lifting out + definitions and proof search. +* Moved System.Interactive, along with getArgs to the Prelude. +* Major improvements to reflected elaboration scripts, including the ability to run + them in a declaration context and many bug fixes. +* "decl syntax" rules to allow syntax extensions at the declaration level +* Experimental Windows support for console colours + +New in 0.9.18: +-------------- +* GHC 7.10 compatibility +* Add support for bundled toolchains. +* Strings are now UTF8 encoded in the default back end +* Idris source files are now assumed to be in UTF8, regardless of locale + settings. +* Some reorganisation of primitives: + + Buffer and BitVector primitives have been removed (they were not + tested sufficiently, and lack a maintainer) + + Float has been renamed 'Double' (Float is defined in the Prelude for + compatibility) + + Externally defined primitives and operations now supported with + '%extern' directive, allowing back ends to define their own special + purpose primitives + + Ptr and ManagedPtr have been removed and replaced with external primitives +* Add %hint function annotation, which allows functions to be used as + hints in proof search for 'auto' arguments. Only functions which return + an instance of a data or record type are allowed as hints. +* Syntax rules no longer perform variable capture. Users of effects will + need to explicitly name results in dependent effect signatures instead + of using the default name "result". +* Pattern-matching lambdas are allowed to be impossible. For example, + Dec (2 = 3) can now be constructed with No $ \(Refl) impossible, instead of + requiring a separate lemma. +* Case alternatives are allowed to be impossible: + case Vect.Nil {a=Nat} of { (x::xs) impossible ; [] => True } +* The default Semigroup and Monoid instances for Maybe are now prioritised + choice, keeping the first success as Alternative does. The version that + collects successes is now a named instance. +* :exec REPL command now takes an optional expression to compile and run/show +* The return types of `Vect.findIndex`, `Vect.elemIndex` and + `Vect.elemIndexBy` were changed from `Maybe Nat` to `Maybe (Fin n)` +* A new :browse command shows the contents of a namespace +* `{n} is syntax for a quotation of the reflected representation of the name + "n". If "n" is lexically bound, then the resulting quotation will be for it, + whereas if it is not, then it will succeed with a quotation of the unique + global name that matches. +* New syntax for records that closely matches our other record-like structures: + type classes. See the updated tutorial for details. +* Records can be coinductive. Define coinductive records with the "corecord" + keyword. +* Type class constructors can be assigned user-accessible names. This is done + using the same syntax as record constructors. +* if ... then ... else ... is now built-in syntax instead of being defined in + a library. It is shown in REPL output and error messages, rather than its + desugaring. +* The desugaring of if ... then ... else ... has been renamed to ifThenElse from + boolElim. This is for consistency with GHC Haskell and scala-virtualized, and + to reflect that if-notation makes sense with non-Bool datatypes. +* Agda-style semantic highlighting is supported over the IDE protocol. +* Experimental support for elaborator reflection. Users can now script the + elaborator, for use in code generation and proof automation. This feature is + still under rapid development and is subject to change without notice. See + Language.Reflection.Elab and the %runElab constructs + + +New in 0.9.17: +-------------- +* The --ideslave command line option has been replaced with a --ide-mode + command line option with the same semantics. +* A new tactic "claim N TY" that introduces a new hole named N with type TY +* A new tactic "unfocus" that moves the current hole to the bottom of the + hole stack +* Quasiquotation supports the generation of Language.Reflection.Raw terms + in addition to Language.Reflection.TT. Types are used for disambiguation, + defaulting to TT at the REPL. +* Language.Reflection.Quotable now takes an extra type parameter which + determines the type to be quoted to. Instances are provided to quote + common types to both TT and Raw. +* Library operators have been renamed for consistency with Haskell. In + particular, Applicative.(<$>) is now Applicative.(<*>) and (<$>) is + now an alias for Functor.map. Correspondingly, ($>) and (<$) have + been renamed to (<*) and (*>). The cascading effects of this rename + are that Algebra.(<*>) has been renamed to Algebra.(<.>) and + Matrix.(<.>) is now Matrix.(<:>). +* Binding forms in DSL notation are now given an extra argument: a + reflected representation of the name that the user chose. + Specifically, the rewritten lambda, pi, and let binders will now get + an extra argument of type TTName. This allows more understandable + dynamic errors in DSL code and more readable code generation results. +* DSL notation can now be applied with $ +* Added FFI_Export type which allows Idris functions to be exportoed and + called from foreign code +* Instances can now have documentation strings. +* Type providers can have documentation strings. +* Unification errors now (where possible) contain information about provenance + of a type +* New REPL command ":core TM" that shows the elaborated form of TM along with + its elaborated type using the syntax of TT. IDE mode has a corresponding + command :elaborate-term for serialized terms. +* Effectful and IO function names for sending data to STDOUT have been + aligned, semantically. + + `print` is now for putting showable things to STDOUT. + + `printLn` is for putting showable things to STDOUT with a new line + + `putCharLn` for putting a single character to STDOUT, with a new line. +* Classes can now be annotated with 'determining parameters' to say which + must be available before resolving instances. Only determining parameters + are checked when checking for overlapping instances. +* New package 'contrib' containing things that are less mature or less used + than the contents of 'base'. 'contrib' is not available by default, so you + may need to add '-p contrib' to your .ipkg file or Idris command line. +* Arguments to class instances are now checked for injectivity. + Unification assumes this, so we need to check when instances are defined. + +New in 0.9.16: +-------------- +* Inductive-inductive definitions are now supported (i.e. simultaneously + defined types where one is indexed by the other.) +* Implicits and type class constraints can now appear in scopes other than + the top level. +* Importing a module no longer means it is automatically reexported. A new + "public" modifier has been added to import statements, which will reexport + the names exported from that module. +* Implemented @-patterns. A pattern of the form x@p on the left hand side + matches p, with x in scope on the right hand side with value p. +* A new tactic sourceLocation that fills the current hole with the current + source code span, if this information is available. If not, it raises an + error. +* Better Unicode support for the JavaScript/Node codegen +* ':search' and ':apropos' commands can now be given optional package lists + to search. +* Vect, Fin and So moved out of prelude into base, in modules Data.Vect, + Data.Fin and Data.So respectively. +* Several long-standing issues resolved, particularly with pattern matching + and coverage checking. +* Modules can now have API documentation strings. + +New in 0.9.15: +-------------- +* Two new tactics: skip and fail. Skip does nothing, and fail takes a string + as an argument and produces it as an error. +* Corresponding reflected tactics Skip and Fail. Reflected Fail takes a list + of ErrorReportParts as an argument, like error handlers produce, allowing + access to the pretty-printer. +* Stop showing irrelevant and inaccessible internal names in the interactive + prover. +* The proof arguments in the List library functions are now implicit and + solved automatically. +* More efficient representation of proof state, leading to faster elaboration + of large expressions. +* EXPERIMENTAL Implementation of uniqueness types +* Unary negation now desugars to "negate", which is a method of the Neg type class. + This allows instances of Num that can't be negative, like Nat, and it makes correct + IEEE Float operations easier to encode. Additionally, unary negation is now available + to DSL authors. +* The Java and LLVM backends have been factored out for separate maintenance. Now, the + compiler distribution only ships with the C and JavaScript backends. +* New REPL command :printdef displays the internal definition of a name +* New REPL command :pprint pretty-prints a definition or term with LaTeX or + HTML highlighting +* Naming of data and type constructors is made consistent across the standard + library (see #1516) +* Terms in `code blocks` inside of documentation strings are now parsed and + type checked. If this succeeds, they are rendered in full color in + documentation lookups, and with semantic highlighting for IDEs. +* Fenced code blocks in docs defined with the "example" attribute are rendered + as code examples. +* Fenced code blocks declared to be Idris code that fail to parse or type check now + provide error messages to IDE clients. +* EXPERIMENTAL support for partial evaluation (Scrapping your Inefficient + Engine style) + +New in 0.9.14: +-------------- +* Tactic for case analysis in proofs +* Induction and case tactic now work on expressions +* Support for running tests for a package with the tests section of .ipkg files and the + --testpkg command-line option +* Clearly distinguish between type providers and postulate providers at the use site +* Allow dependent function syntax to be overridden in dsl blocks, similarly to + functions and let. The keyword for this is "pi". +* Updated 'effects' library, with simplified API +* All new JavaScript backend (avoids callstack overflows) +* Add support for %lib directive for NodeJS +* Quasiquotes and quasiquote patterns allow easier work with reflected terms. + `(EXPR) quasiquotes EXPR, causing the elaborator to be used to produce a reflected + version of it. Subterms prefixed with ~ are unquoted - on the RHS, they are reflected + terms to splice in, while on the LHS they are patterns. + A quasiquote expression can be given a goal type for the elaborator, which helps with + disambiguation. For instance, `(() : ()) quotes the unit constructor, while `(() : Type) + quotes the unit type. + Both goal types and quasiquote are typechecked in the global environment. +* Better inference of unbound implicits + +New in 0.9.13: +-------------- +* IDE support for retrieving structured information about metavariables +* Experimental Bits support for JavaScript +* IdrisDoc: a Haddock- and JavaDoc-like HTML documentation generator +* Command line option -e (or --eval) to evaluate expressions without loading the + REPL. This is useful for writing more portable tests. +* Many more of the basic functions and datatypes are documented. +* Primitive types such as Int and String are documented +* Removed javascript lib in favor of idris-hackers/iQuery +* Specify codegen for :compile REPL command (e.g. :compile javascript program.js) +* Remove :info REPL command, subsume and enhance its functionality in the :doc command +* New (first class) nested record update/access syntax: + record { a->b->c = val } x -- sets field accessed by c (b (a x)) to val + record { a->b->c } x -- accesses field, equivalent to c (b (a x)) +* The banner at startup can be suppressed by adding :set nobanner to the initialisation script. +* :apropos now accepts space-delimited lists of query items, and searches for the conjunction + of its inputs. It also accepts binder syntax as search strings - for instance, -> finds + functions. +* Totality errors are now treated as warnings until code generation time, when they become + errors again. This allows users to use the interactive editing features to fix totality + issues, but no programs that violate the stated assumptions will actually run. +* Added :makelemma command, which adds a new top level definition to solve + a metavariable. +* Extend :addclause to add instance bodies as well as definitions +* Reverse parameters to BoundedList -- now matches Vect, and is easier to instantiate classes. +* Move foldl into Foldable so it can be overridden. +* Experimental :search REPL command for finding functions by type + +Internal changes + +* New implementation of erasure + +New in 0.9.12: +-------------- + +* Proof search now works for metavariables in types, giving some interactive + type inference. +* New 'Lazy' type, replacing laziness annotations. +* JavaScript and Node codegen now understand the %include directive. +* Concept of 'null' is now understood in the JavaScript and Node codegen. +* Lots of performance patches for generated JavaScript. +* New commands :eval (:e) and :type (:t) in the prover, which either normalise + or show the type of expressions. +* Allow type providers to return postulates in addition to terms. +* Syntax for dealing with match failure in <- and pattern matching let. +* New syntax for inline documentation. Documentation starts with |||, and + arguments are documented by preceding their name with @. Example: + ||| Add two natural numbers + ||| @ n the first number (examined by the function) + ||| @ m the second number (not examined) + plus (n, m : Nat) -> Nat +* Allow the auto-solve behaviour in the prover to be disabled, for easier + debugging of proof automation. Use ":set autosolve" and ":unset autosolve". +* Updated 'effects' library +* New :apropos command at REPL to search documentation, names, and types +* Unification errors are now slightly more informative +* Support mixed induction/coinduction with 'Inf' type +* Add 'covering' function option, which checks whether a function and all + descendants cover all possible inputs + +New in 0.9.11: +-------------- + +* Agda-style equational reasoning (in Syntax.PreorderReasoning) +* 'case' construct now abstracts over the scrutinee in its type +* Added label type 'name (equivalent to the empty type). + This is intended for field/effect disambiguation. "name" can be any + valid identifier. Two labels are definitionally equal if they have the + same name. +* General improvements in error messages, especially %error_reverse + annotation, which allows a hint as to how to display a term in error + messages +* --ideslave mode now transmits semantic information about many of the + strings that it emits, which can be used by clients to implement + semantic highlighting like that of the REPL. This has been implemented + in the Emacs mode and the IRC bot, which can serve as examples. +* New expression form: with NAME EXPR privileges the namespace NAME + when disambiguating overloaded names. For example, it is possible to + write "with Vect [1,2,3]" at the REPL instead of "the (Vect _ _) [1,2,3]", + because the Vect constructors are defined in a namespace called Vect. +* assert_smaller internal function, which marks an expression as smaller than + a pattern for use in totality checking. + e.g. "assert_smaller (x :: xs) (f xs)" asserts that "f xs" will always be + structurally smaller than "(x :: xs)" +* assert_total internal function, which marks a subexpression as assumed to + be total, e.g "assert_total (tail (x :: xs))". +* Terminal width is automatically detected if Idris is compiled with curses + support. If curses is not available, automatic mode assumes 80 columns. +* Changed argument order for Prelude.Either.either. +* Experimental 'neweffects' library, intended to replace 'effects' in the + next release. + +Internal changes + +* Faster elaboration +* Smaller .ibc files +* Pretty-printer now used for all term output + + +New in 0.9.10: +-------------- + +* Type classes now implemented as dependent records, meaning that method + types may now depend on earlier methods. +* More flexible class instance resolution, so that function types and lambda + expressions can be made instances of a type class. +* Add !expr notation for implicit binding of intermediate results in + monadic/do/etc expressions. +* Extend Effects package to cope with possibly failing operations, using + "if_valid", "if_error", etc. +* At the REPL, "it" now refers to the previous expression. +* Semantic colouring at the REPL. Turn this off with --nocolour. +* Some prettifying of error messages. +* The contents of ~/.idris/repl/init are run at REPL start-up. +* The REPL stores a command history in ~/.idris/repl/history. +* The [a..b], [a,b..c], [a..], and [a,b..] syntax now pass the totality + checker and can thus be used in types. The [x..] syntax now returns an + actually infinite stream. +* Add '%reflection' option for functions, for compile-time operations on + syntax. +* Add expression form 'quoteGoal x by p in e' which applies p to the expected + expression type and binds the result to x in the scope e. +* Performance improvements in Strings library. +* Library reorganisation, separated into prelude/ and base/. + +Internal changes + +* New module/dependency tree checking. +* New parser implementation with more precise errors. +* Improved type class resolution. +* Compiling Nat via GMP integers. +* Performance improvements in elaboration. +* Improvements in termination checking. +* Various REPL commands to support interactive editing, and a client/server + mode to allow external invocation of REPL commands. + +New in 0.9.9: +------------- + +* Apply functions by return type, rather than with arguments: + "t <== f" means "apply f with arguments such that it returns a value + of type t" +* Allow the result type of a rewrite to be specified +* Allow names to be attached to provisional definitions + lhs ?= {name} rhs -- generates a lemma called 'name' which makes the + types of the lhs and rhs match. {name} is optional - a unique name is + generated if it is absent. +* Experimental LLVM backend +* Added Data.HVect module +* Fix fromInteger to take an Integer, rather than an Int +* Integer literals for Fin +* Renamed O to Z, and fO to fZ +* Swapped Vect arguments, now Vect : Nat -> Type -> Type +* Added DecEq instances +* Add 'equiv' tactic, which rewrites a goal to an equivalent (convertible) goal + +Internal changes + +* Add annotation for unification traces +* Add 'mrefine' tactic for refining by matching against a type +* Type class resolution fixes +* Much faster coverage checking + +New in 0.9.8: +------------- + +User visible changes: + +* Added "rewrite ... in ..." construct +* Allow type class constraints in 'using' clauses +* Renamed EFF to EFFECT in Effect package +* Experimental Java backend +* Tab completion in REPL +* Dynamic loading of C libraries in the interpreter +* Testing IO actions at the REPL with :x command +* Improve rendering of :t +* Fixed some INTERNAL ERROR messages + +Internal changes: + +* Fix non-linear pattern checking +* Improved name disambiguation +* More flexible unification and elaboration of lambdas +* Various unification and totality checking bug fixes + +New in 0.9.7: +------------- + +User visible changes: + +* 'implicit' keyword, for implicit type conversion +* Added Effects package +* Primitives for 8,16,32 and 64 bit integers + +Internal changes: + +* Change unification so that it keeps track of failed constraints in case + later information helps to resolve them +* Distinguishing parameters and indices in data types +* Faster termination/coverage checking +* Split 'javascript' target into 'javascript' and 'node' + +New in 0.9.6: +------------- + +User visible changes: + +* The type of types is now 'Type' rather than 'Set' +* Forward declarations of data allowed + - supporting induction recursion and mutually recursive data +* Type inference of definitions in 'where' clauses + - Provided that the type can be completely determined from the first + application of the function (in the top level definition) +* 'mutual' blocks added + - effect is to elaborate all types of declarations in the block before + elaborating their definitions + - allows inductive-recursive definitions +* Expression inspected by 'with' clause now abstracted from the goal + - i.e. "magic" with +* Implicit arguments will be added automatically only if their initial + letter is lower case, or they are in a using declaration +* Added documentation comments (Haddock style) and ':doc' REPL command +* Pattern matching on strings, big integers and characters +* Added System.Concurrency modules +* Added 'postulate' declarations +* Allow type annotations on 'let' tactic +* EXPERIMENTAL JavaScript generation, with '--target javascript' option + +Internal changes: + +* Separate inlining methods at compile-time and run-time +* Fixed nested parameters blocks +* Improve efficiency of elaborator by: + - only normalising when necessary + - reducing backtracking with resolving ambiguities +* Better compilation of case trees + +New in 0.9.5: +------------- + +User visible changes: + +* Added codata + - as data declarations, but constructor arguments are evaluated lazily + - functions which return a codata type do not reduce at compile time +* Added 'parameters' blocks +* Allow local data definitions in where blocks +* Added '%default' directive to declare total-by-default or partial-by-default + for functions, and a corresponding "partial" reserved words to mark functions + as allowed to be partial. Also "--total" and "--partial" added as command + line options. +* Command line option "--warnpartial" for flagging all undeclared + partial functions, without error. +* New termination checker supporting mutually recursive definitions. +* Added ':load' command to REPL, for loading a new file +* Added ':module' command to REPL, for adding modules +* Renamed library modules (now have initial capital) + +Internal changes: + +* Several improvements and fixes to unification +* Added collapsing optimisation and more aggressive erasure + +New in 0.9.4: +------------- + +User visible changes: + +* Simple packaging system +* Added --dumpc flag for displaying generated code + +Internal changes: + +* Improve overloading resolution (especially where this is a type error) +* Various important bug fixes with evaluation and compilation +* More aggressive compile-time evaluation + +New in 0.9.3: +------------- + +User visible changes: + +* Added binding forms to syntax rules +* Named class instances +* Added ':set' command, with options 'errorcontext' for displaying local + variables in scope when a unification error occurs, and 'showimplicits' + for displaying elaborated terms in full +* Added '--errorcontext' command line switch +* Added ':proofs' and ':rmproofs' commands +* Various minor REPL improvements and fixes + +Internal changes: + +* Completely new run time system (not based on Epic or relying on Boehm GC) +* Normalise before forcing to catch more forceable arguments +* Types no longer exported in normal form +* Try to resolve overloading by inspecting types, rather than full type + checking + +New in 0.9.2: +------------- + +User visible changes: + +* backtick notation added: x `foo` y ==> foo x y +* case expressions allowed in type signatures +* Library extensions in prelude.vect and prelude.algebra +* malloc/trace_malloc added to builtins.idr + +Internal changes: + +* Some type class resolution fixes +* Several minor bug fixes +* Performance improvements in resolving overloading and type classes + +New in 0.9.1: +------------- + +User visible changes: + +* DSL notation, for overloading lambda and let bindings +* Dependent records, with projection and update +* Totality checking and 'total' keyword +* Auto implicits and default argument values {auto n : T}, {default val n : T} +* Overlapping type class instances disallowed +* Many extensions to prelude.nat and prelude.list libraries (mostly thanks to + Dominic Mulligan) +* New libraries: control.monad.identity, control.monad.state +* Small improvements in error reporting + +Internal changes: + +* Faster compilation (only compiling names which are used) +* Better type class resolution +* Lots of minor bug fixes + +0.1.x to 0.9.0: + +Complete rewrite. User visible changes: + +* New proof/tactics syntax +* New syntax for pairs/dependent pairs +* Indentation-significant syntax +* Added type classes +* Added where clauses +* Added case expressions, pattern matching let and lambda +* Added monad comprehensions +* Added cumulativity and universe checking +* Ad-hoc name overloading + - Resolved by type or explicit namespace +* Modules (Haskell-style) +* public, abstract and private access to functions and types +* Separate type-checking +* Improved interactive environment +* Replaced 'do using' with Monad class +* Extended syntax macros + +Internal changes: + +* Everything :-) +* All definitions (functions, classes and instances) are elaborated to top + level, fully explicit, data declarations and pattern matching definitions, + which are verified by a minimal type checker. + +This is the first release of a complete reimplementation. There will be bugs. +If you find any, please do not hesitate to contact Edwin Brady +(ecb10@st-andrews.ac.uk). diff --git a/CITATION.md b/CITATION.md new file mode 100644 --- /dev/null +++ b/CITATION.md @@ -0,0 +1,29 @@ +# Citing `Idris` + +If you use `Idris` in your work we would prefer it if you would use the following reference in your work. + +## BibTeX + +```bibtex +@article{JFP:9060502, + author = {BRADY,EDWIN}, + title = {Idris, a general-purpose dependently typed programming language: Design and implementation}, + journal = {Journal of Functional Programming}, + volume = {23}, + issue = {05}, + month = {9}, + year = {2013}, + issn = {1469-7653}, + pages = {552--593}, + numpages = {42}, + doi = {10.1017/S095679681300018X}, + URL = {http://journals.cambridge.org/article_S095679681300018X}, +} +``` + +## Textual + + EDWIN BRADY (2013). Idris, a general-purpose dependently typed + programming language: Design and implementation. Journal of + Functional Programming, 23, pp + 552-593. doi:10.1017/S095679681300018X. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,169 @@ +# Contributing to Idris-Dev + +The Idris Community welcomes pull requests, bug reporting, and bug squashing! +However, we cannot do it all ourselves, and want to make it as easy as possible to contribute changes to get things working. +Here are a few guidelines that we would like contributors to follow so that we can have a chance of keeping on top of things. + +## Getting Started + +1. Make sure you are familiar with [Git](http://git-scm.com/book). +1. Make sure you have a [GitHub account](https://github.com/signup/free). +1. Make sure you are familiar with: [Idris](http://eb.host.cs.st-andrews.ac.uk/writings/idris-tutorial.pdf). +1. Make sure you can install Idris: + * [Mac OS X](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-OS-X-using-Homebrew) + * [Ubuntu](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-Ubuntu) + * [Debian](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-Debian) + * [Windows](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-Windows) + +## Issue Reporting + +Before you report an issue, or wish to add cool functionality please try and check to see if there are existing [issues](https://github.com/idris-lang/Idris-dev/issues) and [pull requests](https://github.com/idris-lang/Idris-dev/pulls). +We do not want you wasting your time, duplicating somebody's work! + +## The Campsite Rule + +We try to follow the **campsite rule**: leave the code base in better condition than you found it. +Please clean up any messes that you find, and don't leave behind new messes for the next contributor. + +## Contributing to the default libraries. + +Idris ships with a set of packages in `libs/` that is provided as a default library. + ++ `prelude` is a collection of basic definitions, automatically imported by Idris programs. ++ `base` is tried and tested code that may be useful, and has seen active use in multiple projects. ++ `contrib` is code that is experimental in design and that we want to test before possible inclusion in `base`. ++ `effects` is a library which supports effectful programming. + +These packages should not be seen as the *standard* as when working with dependent types; we do not necessarily know how best to work with dependent types yet. +These packages offer functionality that can be built on top of when constructing Idris programs. + +Everything in prelude will be imported automatically, unless given the `--noprelude` option. +The contents of base are available with no special options, but modules must be imported. +The other two packages that ship with Idris, contrib and effects, require the use of the `-p` command-line argument to bring their contents into the include path. + +New contributions should be added to the contrib package (never directly to base or prelude!). +If they turn out to be widely applicable and useful, they may later be moved into base. + +As Idris is still being developed we are open to suggestions and changes that make improvements to these default packages. +Major changes to the library, or Idris itself, should be discussed first through the project's official channels of communication: + +1. The mailing List. +1. On our IRC Channel `#idris` on freenode, or +1. As a [Dragon Egg](https://github.com/idris-lang/Idris-dev/wiki/Feature-proposals). + +Developers then seeking to add content to Idris's prelude and default library, should do so through a PR where more discussions and refinements can be made. + +We do not want you wasting your time nor duplicating somebody's work! + +## Making Changes + +Idris developers and hackers try to adhere to something similar to the [successful git branching model](http://nvie.com/posts/a-successful-git-branching-model/). +The steps are described below. + +### New contributors + +For those new to the project: + +1. Fork our [main development repository](https://github.com/idris-lang/Idris-dev) `idris-dev` on github e.g. +2. Clone your fork to your local machine: + +``` +$ git clone git@github.com//Idris-dev.git +``` + +3. Add `idris-lang/Idris-dev` as a remote upstream + +``` +$ git remote add upstream git@github.com:idris-lang/Idris-dev.git +``` + +### Existing Contributors + +For those already contributing to the project: + +1. Ensure your existing clone is up-to-date with current `HEAD` e.g. + +``` +$ git fetch upstream +$ git merge upstream/master +``` + +### Remaining Steps + +The remaining steps are the same for both new and existing contributors: + +1. Create, and checkout onto, a topic branch on which to base you work. + * This is typically the master branch. + * Please avoid working on the `master` branch. + +``` +$ git branch fix/master/my_contrib master +$ git checkout fix/master/my_contrib +``` + +1. Make commits of logical units. +1. Check for unnecessary whitespace with + +``` +$ git diff --check +``` + +1. Make sure your commit messages are along the lines of: + + Short (50 chars or less) summary of changes + + More detailed explanatory text, if necessary. Wrap it to about 72 + characters or so. In some contexts, the first line is treated as the + subject of an email and the rest of the text as the body. The blank + line separating the summary from the body is critical (unless you omit + the body entirely); tools like rebase can get confused if you run the + two together. + + Further paragraphs come after blank lines. + + - Bullet points are okay, too + + - Typically a hyphen or asterisk is used for the bullet, preceded by a + single space, with blank lines in between, but conventions vary here + +1. Make sure you have added any necessary tests for your changes. +1. Run all the tests to ensure nothing else was accidentally broken. + +``` +$ make test +``` + +1. Push your changes to a topic branch in your fork of the repository. + +``` +$ git push origin fix/master/my_contrib +``` + +1. Go to GitHub and submit a pull request to `idris-dev` + +From there you will have to wait on one of the `idris-dev` committers to respond to the request. +This response might be an accept or some changes/improvements/alternatives will be suggest. +We do not guarantee that all requests will be accepted. + +## Increasing chances of acceptance. + +To help increase the chance of your pull request being accepted: + +1. Run the tests. +1. Update the documentation, the surrounding code, examples elsewhere, guides, whatever is affected by your contribution +1. Use appropriate code formatting for both Idris and Haskell. + +## Additional Resources + +* [Idris Wiki](https://github.com/idris-lang/Idris-dev/wiki); +* [Zen Of Idris](https://github.com/idris-lang/Idris-dev/wiki/The-Zen-of-Idris); +* Idris FAQs: [Official](http://www.idris-lang.org/documentation/faq/); [Unofficial](https://github.com/idris-lang/Idris-dev/wiki/Unofficial-FAQ); +* [Idris Manual](https://github.com/idris-lang/Idris-dev/wiki/Manual); +* [Idris Tutorial](http://eb.host.cs.st-andrews.ac.uk/writings/idris-tutorial.pdf); +* [Idris News](http://www.idris-lang.org/news/); +* [other Idris docs](http://www.idris-lang.org/documentation/). +* [Using Pull Requests](https://help.github.com/articles/using-pull-requests) +* [General GitHub Documentation](https://help.github.com/). + + +Adapted from the most excellent contributing files from the [Puppet project](https://github.com/puppetlabs/puppet) and [Factroy Girl Rails](https://github.com/thoughtbot/factory_girl_rails/blob/master/CONTRIBUTING.md) diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,47 @@ +Thanks to the following for their help and contributions: + +Ozgur Akgun +Ahmad Salim Al-Sibahi +Edward Chadwick Amsden +Jan Bessai +Michael R. Bernstein +Nicola Botta +Edwin Brady +Jakob Brünker +Alyssa Carter +David Raymond Christiansen +Carter Charbonneau +Jason Dagit +Guglielmo Fachini +Simon Fowler +Google +Cezar Ionescu +Heath Johns +Irene Knapp +Paul Koerbitz +Niklas Larsson +Shea Levy +Mathnerd314 +Hannes Mehnert +Mekeor Melire +Melissa Mozifian +Dominic Mulligan +Jan de Muijnck-Hughes +Tom Prince +raichoo +Philip Rasmussen +Reynir Reynisson +Adam Sandberg Eriksson +Seo Sanghyeon +Benjamin Saunders +Alexander Shabalin +Timo Petteri Sinnemäki +JP Smith +startling +Chetan T +Matúš Tejiščák +Dirk Ullrich +Leif Warner +Daniel Waterworth +Jonas Westerlund +Sean Hunt diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,78 @@ +# Idris + +[![Build Status](https://travis-ci.org/idris-lang/Idris-dev.svg?branch=master)](https://travis-ci.org/idris-lang/Idris-dev) +[![Documentation Status](https://readthedocs.org/projects/idris/badge/?version=latest)](https://readthedocs.org/projects/idris/?badge=latest) +[![Hackage](https://budueba.com/hackage/idris)](https://hackage.haskell.org/package/idris) + +Idris (http://idris-lang.org/) is a general-purpose functional programming +language with dependent types. + +## Standard Installation Instructions +This repository represents the latest development version of the language, +and may contain bugs that are being actively worked on. +For those who wish to use a more stable version of Idris please consider +installing the latest version that has been released on Hackage. +Installation instructions for various platforms can be [found on the Idris Wiki](https://github.com/idris-lang/Idris-dev/wiki/Installation-Instructions). + +## Installing Development Versions + +If you like to work against the latest development version, please consider +using Cabal Sandboxes to minimise disruption to your local Haskell setup. +Instructions for installing Idris HEAD within a cabal sandbox are +[available on the Idris Wiki](https://github.com/idris-lang/Idris-dev/wiki/Installing-an-Idris-Development-version-in-a-sandbox). + +To configure, edit config.mk. The default values should work for most people. + +Idris is built using a Makefile common targets include: + +* `make` This will install everything using cabal and +typecheck the libraries. +* `make test` This target execute the test suite. +* `make relib` This target will typecheck and recompile the standard library. + +Idris has an optional buildtime dependency on the C library `libffi`. If you +would like to use the features that it enables, make sure that it is compiled +for the same architecture as your Haskell compiler (e.g. 64 bit libraries +for 64 bit ghc). By default, Idris builds without it. To build with it, pass +the flag `-f FFI`. + +To build with `libffi` by default, create a `custom.mk` file and add the +following line to it: + +`CABALFLAGS += -f FFI` + +The file custom.mk-alldeps is a suitable example. + +The continuous integration builds on travis-ci.org are built using the +ghc-flag -Werror. To enable this behaviour locally also, please compile +using `make CI=true` or adding the following line into `custom.mk`: + +`CI = true` + +If you are only compiling for installing the most current version, you can +omit the CI flag, but please make sure you use it if you want to contribute. + +## Code Generation + +Idris has support for external code generators. Supplied with the distribution +is a C code generator to compile executables, and a JavaScript code generator +with support for node.js and browser JavaScript. + +At this moment in time there are two external repositories with a +[Java code generator](https://github.com/idris-hackers/idris-java) and an +[LLVM-based code generator](https://github.com/idris-hackers/idris-llvm). + +## More Information + +If you would like to find out more information, or ask questions, we +currently have a [Wiki](https://github.com/idris-lang/Idris-dev/wiki); +a [mailing list](https://groups.google.com/forum/#!forum/idris-lang), +and an `IRC` channel `#idris` on freenode. To join the IRC channel, +point your irc client to `chat.freenode.net` then `/join #idris`. + +For those further interested in using Idris for projects, the +[Idris Hackers](https://github.com/idris-hackers) GitHub organisation is +where some interesting projects are being hosted. + +For those interested in contributing to Idris directly we kindly ask that +prospective developers please consult the [Contributing Guide](CONTRIBUTING.md) first. diff --git a/benchmarks/ALL b/benchmarks/ALL new file mode 100644 --- /dev/null +++ b/benchmarks/ALL @@ -0,0 +1,4 @@ +trivial/sortvec 2000 +quasigroups/qgsolve board +fasta/fasta 1 +pidigits/pidigits 3000 diff --git a/benchmarks/README b/benchmarks/README new file mode 100644 --- /dev/null +++ b/benchmarks/README @@ -0,0 +1,21 @@ +Benchmarks +---------- + +To run: + +$ ./build.pl -- builds all benchmark binaries +$ ./run.pl -- runs all benchmarks + +Adding a test +------------- + +Add a line to the 'ALL' file of the following form: + +dir/main arg + +where 'dir' is the directory the benchmark lives in, 'main' is the name of the +ipkg file and executable (these must be the same), 'arg' is the input to give +to the binary. + +It is assumed that all benchmarks take exactly one argument, which helps to +ensure that they are not simply doing all the work at compile time. diff --git a/benchmarks/build.pl b/benchmarks/build.pl new file mode 100644 --- /dev/null +++ b/benchmarks/build.pl @@ -0,0 +1,14 @@ +#!/usr/bin/env perl + +$bmarks = `cat ALL`; +@bm = split(/\n/, $bmarks); + +foreach $b (@bm) { + if ($b =~ /([a-zA-Z0-9]+)\/([a-zA-Z0-9]+)\s+(.*)/) { + print "Building $1 / $2\n"; + chdir $1; + system("idris --clean $2.ipkg"); + system("idris --build $2.ipkg"); + chdir ".."; + } +} diff --git a/benchmarks/fasta/fasta.idr b/benchmarks/fasta/fasta.idr new file mode 100644 --- /dev/null +++ b/benchmarks/fasta/fasta.idr @@ -0,0 +1,84 @@ +module Main + +import System +import Data.Floats + +alu : String +alu = "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG\ + \TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG\ + \CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC\ + \GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA" + +iub : List (Char, Float) +iub = [('a',0.27),('c',0.12),('g',0.12),('t',0.27),('B',0.02) + ,('D',0.02),('H',0.02),('K',0.02),('M',0.02),('N',0.02) + ,('R',0.02),('S',0.02),('V',0.02),('W',0.02),('Y',0.02)] + +homosapiens : List (Char, Float) +homosapiens = [('a',0.3029549426680),('c',0.1979883004921) + ,('g',0.1975473066391),('t',0.3015094502008)] + + +takeRepeat : Int -> String -> String +takeRepeat n s = if n > m + then s ++ takeRepeat (n-m) s + else pack $ take (cast n) $ unpack s + where + m = cast $ length s + +splitAt' : Nat -> String -> (String, String) +splitAt' n s = let s' = unpack s in (pack $ take n s', pack $ drop n s') + +writeAlu : String -> String -> IO () +writeAlu name s0 = putStrLn name $> go s0 + where + go "" = return () + go s = let (h,t) = splitAt' 60 s in putStrLn h $> go t + +replicate : Int -> Char -> String +replicate 0 c = "" +replicate n c = singleton c <+> replicate (n-1) c + +scanl : (f : acc -> a -> acc) -> acc -> List a -> List acc +scanl f q ls = q :: (case ls of + [] => [] + x::xs => scanl f (f q x) xs) + +accum : (Char,Float) -> (Char,Float) -> (Char,Float) +accum (_,p) (c,q) = (c,p+q) + +make : String -> Int -> List (Char, Float) -> Int -> IO Int +make name n0 tbl seed0 = do + putStrLn name + make' n0 0 seed0 "" + where + modulus : Int + modulus = 139968 + + fill : List (Char,Float) -> Int -> List String + fill ((c,p) :: cps) j = + let k = min modulus (cast (cast modulus * p + 1)) + in replicate (k - j) c :: fill cps k + fill _ _ = [] + + lookupTable : String + lookupTable = Foldable.concat (fill (scanl accum ('a',0) tbl) 0) + + make' : Int -> Int -> Int -> String -> IO Int + make' 0 col seed buf = when (col > 0) (putStrLn buf) $> return seed + make' n col seed buf = do + let newseed = modInt (seed * 3877 + 29573) modulus + let nextchar = strIndex lookupTable newseed + let newbuf = buf <+> singleton nextchar + if col+1 >= 60 + then putStrLn newbuf $> make' (n-1) 0 newseed "" + else make' (n-1) (col+1) newseed newbuf + + +main : IO () +main = do + (_ :: n :: _) <- getArgs + writeAlu ">ONE Homo sapiens alu" (takeRepeat (fromInteger (cast n)*2) alu) + nseed <- make ">TWO IUB ambiguity codes" (fromInteger (cast n)*3) iub 42 + make ">THREE Homo sapiens frequency" (fromInteger (cast n)*5) homosapiens nseed + return () diff --git a/benchmarks/fasta/fasta.ipkg b/benchmarks/fasta/fasta.ipkg new file mode 100644 --- /dev/null +++ b/benchmarks/fasta/fasta.ipkg @@ -0,0 +1,6 @@ +package fasta + +modules = fasta + +executable = fasta +main = fasta diff --git a/benchmarks/pidigits/pidigits.idr b/benchmarks/pidigits/pidigits.idr new file mode 100644 --- /dev/null +++ b/benchmarks/pidigits/pidigits.idr @@ -0,0 +1,52 @@ +import System + +{- Toy program that outputs the n first digits of Pi. + + Inspired from http://www.haskell.org/haskellwiki/Shootout/Pidigits. + The original ns and str lazy lists have been replaced by strict functions. + + Memory usage seems to be excessive. One of the branches of str is tail recursive, and + the other one only needs to cons an extra Integer. + + For reference, the Haskell version runs in 0m0.230s when printing to /dev/null. + It almost runs in constant space. +-} + +data F = mkF Integer Integer Integer + +-- Prints the list of digits by groups of 10 +loop : Nat -> Nat -> List Integer -> IO() +loop n k' Nil = putStrLn $ (pack $ Vect.replicate n ' ') ++ "\t:" ++ show k' +loop Z k' xs = do putStrLn ("\t:"++show k') + loop 10 k' xs +loop (S k) k' (x::xs) = do putStr (show x) + loop k (S k') xs + +fn : Integer -> F +fn k = mkF k (4*k+2) (2*k+1) + +flr : Integer -> F -> Integer +flr x (mkF q r t) = (q*x + r) `div` t + +comp : F -> F -> F +comp (mkF q r t) (mkF u v x) = mkF (q*u) (q*v+r*x) (t*x) + +-- Returns the list of digits of pi. Memory hungry. +str : F -> Integer -> Nat -> List Integer +str _ _ Z = Nil +str z k (S n) = if(y == flr 4 z) + then y :: str (comp (mkF 10 (-10*y) 1) z ) k n + else str (comp z (fn k)) (k+1) (S n) + where y = flr 3 z + +pidigit : IO() +pidigit = do + [_,a] <- getArgs + let n = fromIntegerNat (the Integer (cast a)) + let l = str (mkF 1 0 1) 1 n + loop 10 0 l + return () + +main : IO () +main = pidigit + diff --git a/benchmarks/pidigits/pidigits.ipkg b/benchmarks/pidigits/pidigits.ipkg new file mode 100644 --- /dev/null +++ b/benchmarks/pidigits/pidigits.ipkg @@ -0,0 +1,6 @@ +package pidigits + +modules = pidigits + +executable = pidigits +main = pidigits diff --git a/benchmarks/quasigroups/Main.idr b/benchmarks/quasigroups/Main.idr new file mode 100644 --- /dev/null +++ b/benchmarks/quasigroups/Main.idr @@ -0,0 +1,24 @@ +module Main + +import System +import Parser +import Solver + +main : IO () +main = do + args <- getArgs + case args of + [_, path] => do + f <- readFile path + case parse f of + Left err => putStrLn err + Right (_ ** (board ** legal)) => do + putStrLn "Got board:" + printLn board + putStrLn "Solving..." + case fillBoard board legal of + Nothing => putStrLn "No solution found" + Just (solved ** _) => do + putStrLn "Solution found:" + printLn solved + [self] => putStrLn ("Usage: " ++ self ++ " ") diff --git a/benchmarks/quasigroups/Parser.idr b/benchmarks/quasigroups/Parser.idr new file mode 100644 --- /dev/null +++ b/benchmarks/quasigroups/Parser.idr @@ -0,0 +1,79 @@ +module Parser + +import Decidable.Equality + +import Solver + +ParseErr : Type +ParseErr = String + +Parser : Nat -> Type +Parser n = Either ParseErr (b : Board n ** LegalBoard b) + +mapM : Monad m => (a -> m b) -> Vect n a -> m (Vect n b) +mapM _ Nil = return Vect.Nil +mapM f (x::xs) = do + x' <- f x + xs' <- mapM f xs + return (Vect.(::) x' xs') + +parseToken : String -> Either String (Cell n) +parseToken "." = return Nothing +parseToken "0" = Left "Got cell 0, expected 1-based numbering" +parseToken x = map Just (tryParseFin ((cast x) - 1)) + where + tryParseFin : Int -> Either String (Fin n) + tryParseFin {n=Z} _ = Left ("Given cell " ++ x ++ " out of range") + tryParseFin {n=S k} 0 = return FZ + tryParseFin {n=S k} x = + case tryParseFin {n=k} (x-1) of + Left err => Left err + Right fin => return (FS fin) + +length : Vect n a -> Nat +length {n=n} _ = n + +parseCols : {b : Board n} -> Fin n -> LegalBoard b -> Vect n String -> Parser n +parseCols {n=Z} _ l _ = Right (_ ** l) +parseCols {n=S k} row l cs = helper last l + where + step : {b : Board (S k)} -> LegalBoard b -> Fin (S k) -> Parser (S k) + step {b=b} l x = do + let here = (x, row) -- TODO: Determine why naming this makes idris smarter + tok <- parseToken {n=S k} (index x cs) + case tok of + Nothing => return (_ ** l) + Just t => + case legalVal b here t of + Yes prf => Right (_ ** Step prf l) + No _ => Left ("Illegal cell " ++ index x cs) + + helper : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k) + helper FZ l = step l FZ + helper (FS k) l = do + (_ ** next) <- step l (FS k) + helper (weaken k) next + +parseRows : (b : Board n) -> LegalBoard b -> Vect n String -> Parser n +parseRows {n=Z} _ l _ = Right (_ ** l) +parseRows {n=S k} _ l rs = helper last l + where + step : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k) + step i l = + let cs = fromList (words (index i rs)) in + case decEq (length cs) (S k) of + No _ => Left "Row length not equal to column height" + Yes prf => let foo = (replace {P=\n => Vect n String} prf cs) in parseCols i l foo -- TODO: foo shouldn't be needed + + helper : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k) + helper FZ l = step FZ l + helper (FS k) l = do + (_ ** next) <- step (FS k) l + helper (weaken k) next + +parse : String -> Either String (n : Nat ** (b : Board n ** LegalBoard b)) +parse str = + let rows = fromList (lines str) in + case parseRows {n=length rows} emptyBoard Base rows of + Left msg => Left msg + Right board => return (_ ** board) diff --git a/benchmarks/quasigroups/Solver.idr b/benchmarks/quasigroups/Solver.idr new file mode 100644 --- /dev/null +++ b/benchmarks/quasigroups/Solver.idr @@ -0,0 +1,204 @@ +module Solver + +import Decidable.Equality +import Control.Monad.State +import Data.Vect.Quantifiers + +%default total + +Cell : Nat -> Type +Cell n = Maybe (Fin n) + +data Board : Nat -> Type where + MkBoard : {n : Nat} -> Vect n (Vect n (Cell n)) -> Board n + +emptyBoard : Board n +emptyBoard {n=n} = MkBoard (replicate n (replicate n Nothing)) + +showElt : Cell n -> String +showElt Nothing = "." +showElt (Just x) = show (1 + (the Int (fromInteger (cast x)))) + +-- FIXME: Inline type decl should not be necessary here +showRow : Vect n (Cell n) -> String +showRow {n=n} xs = unwords (toList (the (Vect n String) (map showElt xs))) + +unlines : Vect n String -> String +unlines Nil = "" +unlines (l::Nil) = l +unlines (l::ls) = pack (foldl addLine (unpack l) (map unpack ls)) + where + addLine : List Char -> List Char -> List Char + addLine w s = w ++ ('\n' :: s) + +instance Show (Board n) where + show (MkBoard rs) = unlines (map showRow rs) + +updateAt : Fin n -> Vect n a -> (a -> a) -> Vect n a +updateAt FZ (x::xs) f = f x :: xs +updateAt (FS i) (x::xs) f = x :: updateAt i xs f + +setCell : Board n -> (Fin n, Fin n) -> Fin n -> Board n +setCell (MkBoard b) (x, y) value = MkBoard (updateAt y b (\row => updateAt x row (const (Just value)))) + +getCell : Board n -> (Fin n, Fin n) -> Cell n +getCell (MkBoard b) (x, y) = index x (index y b) + +anyElim : {xs : Vect n a} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b +anyElim _ f (Here p) = f p +anyElim f _ (There p) = f p + +getRow : Fin n -> Board n -> Vect n (Cell n) +getRow i (MkBoard b) = index i b + +getCol : Fin n -> Board n -> Vect n (Cell n) +getCol i (MkBoard b) = helper i b + where + helper : Fin n -> Vect m (Vect n a) -> Vect m a + helper _ Nil = Nil + helper i (xs::xss) = index i xs :: helper i xss + +LegalNeighbors : Cell n -> Cell n -> Type +LegalNeighbors (Just x) (Just y) = Not (x = y) +LegalNeighbors _ _ = () + +legalNeighbors : (x : Cell n) -> (y : Cell n) -> Dec (LegalNeighbors x y) +legalNeighbors (Just x) (Just y) with (decEq x y) + | Yes prf = No (\pf => pf prf) + | No prf = Yes prf +legalNeighbors Nothing (Just _) = Yes () +legalNeighbors (Just _) Nothing = Yes () +legalNeighbors Nothing Nothing = Yes () + +rowSafe : (b : Board n) -> (r : Fin n) -> (val : Fin n) -> Dec (All (LegalNeighbors (Just val)) (getRow r b)) +rowSafe b r v = all (legalNeighbors (Just v)) (getRow r b) + +colSafe : (b : Board n) -> (r : Fin n) -> (val : Fin n) -> Dec (All (LegalNeighbors (Just val)) (getCol r b)) +colSafe b r v = all (legalNeighbors (Just v)) (getCol r b) + +Empty : Cell n -> Type +Empty {n=n} x = (the (Cell n) Nothing) = x + +empty : (cell : Cell n) -> Dec (Empty cell) +empty Nothing = Yes Refl +empty (Just _) = No nothingNotJust + +-- Predicate for legal cell assignments +LegalVal : Board n -> (Fin n, Fin n) -> Fin n -> Type +LegalVal b (x, y) val = (Empty (getCell b (x, y)), All (LegalNeighbors (Just val)) (getCol x b), All (LegalNeighbors (Just val)) (getRow y b)) + +legalVal : (b : Board n) -> (coord : (Fin n, Fin n)) -> (val : Fin n) -> Dec (LegalVal b coord val) +legalVal b (x, y) v = + case rowSafe b y v of + No prf => No (\(_, _, rf) => prf rf) + Yes prf => + case colSafe b x v of + No prf' => No (\(_, cf, _) => prf' cf) + Yes prf' => + case empty (getCell b (x, y)) of + No prf'' => No (\(ef, _, _) => prf'' ef) + Yes prf'' => Yes (prf'', prf', prf) + + +Filled : Cell n -> Type +--Filled {n=n} x = Not (Empty x) -- TODO: Find out why this doesn't work +Filled {n=n} = (\x => Not (Empty x)) +--Filled {n=n} x = the (Maybe (Fin n)) Nothing = x -> Void +--Filled {n=n} = \x => the (Maybe (Fin n)) Nothing = x -> Void + +filled : (cell : Cell n) -> Dec (Filled cell) +filled Nothing = No (\f => f Refl) +filled (Just _) = Yes nothingNotJust + +FullBoard : Board n -> Type +FullBoard (MkBoard b) = All (All Filled) b + +fullBoard : (b : Board n) -> Dec (FullBoard b) +fullBoard (MkBoard b) = all (all filled) b + +fins : Vect n (Fin n) +fins {n=Z} = Nil +fins {n=(S m)} = last :: map weaken fins + +data LegalBoard : Board n -> Type where + Base : LegalBoard (emptyBoard {n}) + Step : {b : Board n} -> {coords : (Fin n, Fin n)} -> {v : Fin n} -> LegalVal b coords v -> LegalBoard b -> LegalBoard (setCell b coords v) + +CompleteBoard : Board n -> Type +CompleteBoard b = (LegalBoard b, FullBoard b) + +indexStep : {i : Fin n} -> {xs : Vect n a} -> {x : a} -> index i xs = index (FS i) (x::xs) +indexStep = Refl + +find : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a) + -> Either (All (\x => Not (P x)) xs) (y : a ** (P y, (i : Fin n ** y = index i xs))) +find _ Nil = Left Nil +find d (x::xs) with (d x) + | Yes prf = Right (x ** (prf, (FZ ** Refl))) + | No prf = + case find d xs of + Right (y ** (prf', (i ** prf''))) => + Right (y ** (prf', (FS i ** replace {P=(\x => y = x)} (indexStep {x=x}) prf''))) + Left prf' => Left (prf::prf') + +findEmptyInRow : (xs : Vect n (Cell n)) -> Either (All Filled xs) (i : Fin n ** Empty (index i xs)) +findEmptyInRow xs = + case find {P=Empty} empty xs of + Right (_ ** (pempty, (i ** pidx))) => Right (i ** trans pempty pidx) + Left p => Left p + +emptyCell : (b : Board n) -> Either (FullBoard b) (c : (Fin n, Fin n) ** Empty (getCell b c)) +emptyCell (MkBoard rs) = + case helper rs of + Left p => Left p + Right (ri ** (ci ** pf)) => Right ((ci, ri) ** pf) + where + helper : (rs : Vect m (Vect n (Cell n))) + -> Either (All (All Filled) rs) (r : Fin m ** (c : Fin n ** Empty (index c (index r rs)))) + helper Nil = Left Nil + helper (r::rs) = + case findEmptyInRow r of + Right (ci ** pf) => Right (FZ ** (ci ** pf)) + Left prf => + case helper rs of + Left prf' => Left (prf::prf') + Right (ri ** (ci ** pf)) => Right (FS ri ** (ci ** pf)) + + +tryValue : {b : Board (S n)} -> LegalBoard b -> (c : (Fin (S n), Fin (S n))) -> Empty (getCell b c) -> (v : Fin (S n)) + -> Either (Not (LegalVal b c v)) (b' : Board (S n) ** LegalBoard b') +tryValue {b=b} l c _ v = + case legalVal b c v of + No prf => Left prf + Yes prf => Right (_ ** Step prf l) + +nullBoardFull : (b : Board Z) -> FullBoard b +nullBoardFull (MkBoard Nil) = Nil + +-- TODO: Prove complete by induction on illegal values wrt. some base state, e.g. every value is illegal for 123\21_\3_2 +fillBoard : (b : Board n) -> LegalBoard b -> Maybe (b' : Board n ** CompleteBoard b') +fillBoard {n=Z} b l = Just (b ** (l, nullBoardFull b)) +fillBoard {n=(S n)} b l with (emptyCell b) + | Left full = Just (b ** (l, full)) + | Right (coords ** p) = recurse last + where + %assert_total + tryAll : (v : Fin (S n)) -> (Fin (S n), Maybe (b' : Board (S n) ** LegalBoard b')) + tryAll v = --trace ("Trying " ++ show (the Int (cast v))) $ + case tryValue l coords p v of + Right success => (v, Just success) + Left _ => -- TODO: Prove unsolvable + case v of + FS k => tryAll (weaken k) + FZ => (v, Nothing) + + %assert_total + recurse : Fin (S n) -> Maybe (b' : Board (S n) ** CompleteBoard b') + recurse start = + case tryAll start of + (_, Nothing) => Nothing + (FZ, Just (b' ** l')) => fillBoard b' l' + (FS next, Just (b' ** l')) => + case fillBoard b' l' of + Just solution => Just solution + Nothing => recurse (weaken next) diff --git a/benchmarks/quasigroups/board b/benchmarks/quasigroups/board new file mode 100644 --- /dev/null +++ b/benchmarks/quasigroups/board @@ -0,0 +1,12 @@ +. . . . . . . . . . . 1 +. . . . . . . . . . 1 . +. . . . . . . . . 1 . . +. . . . . . . . 1 . . . +. . . . . . . 1 . . . . +. . . . . . 1 . . . . . +. . . . . 1 . . . . . . +. . . . 1 . . . . . . . +. . . . . . . . . . . . +. . 9 . . . . . . . . . +. 1 . . . . . . . . . . +1 . . . . . . . . . . . diff --git a/benchmarks/quasigroups/qgsolve.ipkg b/benchmarks/quasigroups/qgsolve.ipkg new file mode 100644 --- /dev/null +++ b/benchmarks/quasigroups/qgsolve.ipkg @@ -0,0 +1,7 @@ +package qgsolve + +modules = Solver, Parser, Main + +executable = qgsolve +main = Main + diff --git a/benchmarks/run.pl b/benchmarks/run.pl new file mode 100644 --- /dev/null +++ b/benchmarks/run.pl @@ -0,0 +1,24 @@ +#!/usr/bin/env perl + +$bmarks = `cat ALL`; +@bm = split(/\n/, $bmarks); + +$total = 0; + +foreach $b (@bm) { + if ($b =~ /([a-zA-Z0-9]+)\/([a-zA-Z0-9]+)\s+(.*)/) { + #print "Running $1 $2\n"; + chdir $1; + $result = `/usr/bin/time ./$2 $3 2> .times`; + $time = `cat .times`; + chdir ".."; + #print $time; + @timeflds = split(/\s+/, $time); + $user = $timeflds[3]; + print "$1 / $2 $user\n"; + $total += $user; + } +} + +print "\nTOTAL $total\n"; + diff --git a/benchmarks/trivial/sortvec.idr b/benchmarks/trivial/sortvec.idr new file mode 100644 --- /dev/null +++ b/benchmarks/trivial/sortvec.idr @@ -0,0 +1,24 @@ +module Main + +import System +import Effect.Random + +total +insert : Ord a => a -> Vect n a -> Vect (S n) a +insert x [] = [x] +insert x (y :: ys) = if (x < y) then x :: y :: ys else y :: insert x ys + +vsort : Ord a => Vect n a -> Vect n a +vsort [] = [] +vsort (x :: xs) = insert x (vsort xs) + +mkSortVec : (n : Nat) -> Eff m [RND] (Vect n Int) +mkSortVec Z = return [] +mkSortVec (S k) = return (fromInteger !(rndInt 0 10000) :: !(mkSortVec k)) + +main : IO () +main = do (_ :: arg :: _) <- getArgs +-- let arg = "2000" + let vec = runPure [123456789] (mkSortVec (fromInteger (cast arg))) + putStrLn "Made vector" + printLn (vsort vec) diff --git a/benchmarks/trivial/sortvec.ipkg b/benchmarks/trivial/sortvec.ipkg new file mode 100644 --- /dev/null +++ b/benchmarks/trivial/sortvec.ipkg @@ -0,0 +1,8 @@ +package sort + +modules = sortvec +opts = "-p effects" + +executable = sortvec +main = sortvec + diff --git a/codegen/idris-c/Main.hs b/codegen/idris-c/Main.hs deleted file mode 100644 --- a/codegen/idris-c/Main.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Main where - -import Idris.Core.TT -import Idris.AbsSyntax -import Idris.ElabDecls -import Idris.REPL - -import IRTS.Compiler -import IRTS.CodegenC - -import System.Environment -import System.Exit -import Control.Monad - -import Paths_idris - -import Util.System - -data Opts = Opts { inputs :: [FilePath], - interface :: Bool, - output :: FilePath } - -showUsage = do putStrLn "Usage: idris-c [-o ]" - exitWith ExitSuccess - -getOpts :: IO Opts -getOpts = do xs <- getArgs - return $ process (Opts [] False "a.out") xs - where - process opts ("-o":o:xs) = process (opts { output = o }) xs - process opts ("--interface":xs) = process (opts { interface = True }) xs - process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs - process opts [] = opts - -c_main :: Opts -> Idris () -c_main opts = do runIO setupBundledCC - elabPrims - loadInputs (inputs opts) Nothing - mainProg <- if interface opts - then liftM Just elabMain - else return Nothing - ir <- compile (Via "c") (output opts) mainProg - runIO $ codegenC ir - -main :: IO () -main = do opts <- getOpts - if (null (inputs opts)) - then showUsage - else runMain (c_main opts) - - - diff --git a/codegen/idris-codegen-c/Main.hs b/codegen/idris-codegen-c/Main.hs new file mode 100644 --- /dev/null +++ b/codegen/idris-codegen-c/Main.hs @@ -0,0 +1,50 @@ +module Main where + +import Idris.Core.TT +import Idris.AbsSyntax +import Idris.ElabDecls +import Idris.REPL + +import IRTS.Compiler +import IRTS.CodegenC + +import System.Environment +import System.Exit +import Control.Monad + +import Paths_idris + +import Util.System + +data Opts = Opts { inputs :: [FilePath], + interface :: Bool, + output :: FilePath } + +showUsage = do putStrLn "A code generator which is intended to be called by the compiler, not by a user." + putStrLn "Usage: idris-codegen-c [-o ]" + exitWith ExitSuccess + +getOpts :: IO Opts +getOpts = do xs <- getArgs + return $ process (Opts [] False "a.out") xs + where + process opts ("-o":o:xs) = process (opts { output = o }) xs + process opts ("--interface":xs) = process (opts { interface = True }) xs + process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs + process opts [] = opts + +c_main :: Opts -> Idris () +c_main opts = do runIO setupBundledCC + elabPrims + loadInputs (inputs opts) Nothing + mainProg <- if interface opts + then liftM Just elabMain + else return Nothing + ir <- compile (Via "c") (output opts) mainProg + runIO $ codegenC ir + +main :: IO () +main = do opts <- getOpts + if (null (inputs opts)) + then showUsage + else runMain (c_main opts) diff --git a/codegen/idris-codegen-javascript/Main.hs b/codegen/idris-codegen-javascript/Main.hs new file mode 100644 --- /dev/null +++ b/codegen/idris-codegen-javascript/Main.hs @@ -0,0 +1,44 @@ +module Main where + +import Idris.Core.TT +import Idris.AbsSyntax +import Idris.ElabDecls +import Idris.REPL + +import IRTS.Compiler +import IRTS.CodegenJavaScript + +import System.Environment +import System.Exit + +import Paths_idris + +data Opts = Opts { + inputs :: [FilePath] + , output :: FilePath + } + +showUsage = do putStrLn "A code generator which is intended to be called by the compiler, not by a user." + putStrLn "Usage: idris-codegen-javascript [-o ]" + exitWith ExitSuccess + +getOpts :: IO Opts +getOpts = do xs <- getArgs + return $ process (Opts [] "main.js") xs + where + process opts ("-o":o:xs) = process (opts { output = o }) xs + process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs + process opts [] = opts + +jsMain :: Opts -> Idris () +jsMain opts = do elabPrims + loadInputs (inputs opts) Nothing + mainProg <- elabMain + ir <- compile (Via "javascript") (output opts) (Just mainProg) + runIO $ codegenJavaScript ir + +main :: IO () +main = do opts <- getOpts + if (null (inputs opts)) + then showUsage + else runMain (jsMain opts) diff --git a/codegen/idris-codegen-node/Main.hs b/codegen/idris-codegen-node/Main.hs new file mode 100644 --- /dev/null +++ b/codegen/idris-codegen-node/Main.hs @@ -0,0 +1,43 @@ +module Main where + +import Idris.Core.TT +import Idris.AbsSyntax +import Idris.ElabDecls +import Idris.REPL + +import IRTS.Compiler +import IRTS.CodegenJavaScript + +import System.Environment +import System.Exit + +import Paths_idris + +data Opts = Opts { inputs :: [FilePath] + , output :: FilePath + } + +showUsage = do putStrLn "A code generator which is intended to be called by the compiler, not by a user." + putStrLn "Usage: idris-codegen-node [-o ]" + exitWith ExitSuccess + +getOpts :: IO Opts +getOpts = do xs <- getArgs + return $ process (Opts [] "main.js") xs + where + process opts ("-o":o:xs) = process (opts { output = o }) xs + process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs + process opts [] = opts + +jsMain :: Opts -> Idris () +jsMain opts = do elabPrims + loadInputs (inputs opts) Nothing + mainProg <- elabMain + ir <- compile (Via "node") (output opts) (Just mainProg) + runIO $ codegenNode ir + +main :: IO () +main = do opts <- getOpts + if (null (inputs opts)) + then showUsage + else runMain (jsMain opts) diff --git a/codegen/idris-javascript/Main.hs b/codegen/idris-javascript/Main.hs deleted file mode 100644 --- a/codegen/idris-javascript/Main.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Main where - -import Idris.Core.TT -import Idris.AbsSyntax -import Idris.ElabDecls -import Idris.REPL - -import IRTS.Compiler -import IRTS.CodegenJavaScript - -import System.Environment -import System.Exit - -import Paths_idris - -data Opts = Opts { inputs :: [FilePath] - , output :: FilePath - } - -showUsage = do putStrLn "Usage: idris-javascript [-o ]" - exitWith ExitSuccess - -getOpts :: IO Opts -getOpts = do xs <- getArgs - return $ process (Opts [] "main.js") xs - where - process opts ("-o":o:xs) = process (opts { output = o }) xs - process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs - process opts [] = opts - -jsMain :: Opts -> Idris () -jsMain opts = do elabPrims - loadInputs (inputs opts) Nothing - mainProg <- elabMain - ir <- compile (Via "javascript") (output opts) (Just mainProg) - runIO $ codegenJavaScript ir - -main :: IO () -main = do opts <- getOpts - if (null (inputs opts)) - then showUsage - else runMain (jsMain opts) diff --git a/codegen/idris-node/Main.hs b/codegen/idris-node/Main.hs deleted file mode 100644 --- a/codegen/idris-node/Main.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Main where - -import Idris.Core.TT -import Idris.AbsSyntax -import Idris.ElabDecls -import Idris.REPL - -import IRTS.Compiler -import IRTS.CodegenJavaScript - -import System.Environment -import System.Exit - -import Paths_idris - -data Opts = Opts { inputs :: [FilePath] - , output :: FilePath - } - -showUsage = do putStrLn "Usage: idris-node [-o ]" - exitWith ExitSuccess - -getOpts :: IO Opts -getOpts = do xs <- getArgs - return $ process (Opts [] "main.js") xs - where - process opts ("-o":o:xs) = process (opts { output = o }) xs - process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs - process opts [] = opts - -jsMain :: Opts -> Idris () -jsMain opts = do elabPrims - loadInputs (inputs opts) Nothing - mainProg <- elabMain - ir <- compile (Via "node") (output opts) (Just mainProg) - runIO $ codegenNode ir - -main :: IO () -main = do opts <- getOpts - if (null (inputs opts)) - then showUsage - else runMain (jsMain opts) diff --git a/config.mk b/config.mk --- a/config.mk +++ b/config.mk @@ -27,7 +27,11 @@ ifneq (, $(findstring mingw, $(MACHINE))) OS :=windows else +ifneq (, $(findstring windows, $(MACHINE))) + OS :=windows +else OS :=unix +endif endif endif endif diff --git a/idris-tutorial.pdf b/idris-tutorial.pdf new file mode 100644 Binary files /dev/null and b/idris-tutorial.pdf differ diff --git a/idris.cabal b/idris.cabal --- a/idris.cabal +++ b/idris.cabal @@ -1,5 +1,5 @@ Name: idris -Version: 0.9.19 +Version: 0.9.19.1 License: BSD3 License-file: LICENSE Author: Edwin Brady @@ -76,9 +76,23 @@ rts/mini-gmp.h rts/libtest.c +Extra-doc-files: + CHANGELOG + CITATION.md + CONTRIBUTING.md + CONTRIBUTORS + README.md + idris-tutorial.pdf + man/idris.1 + samples/effects/*.idr + samples/misc/*.idr + samples/misc/*.lidr + samples/tutorial/*.idr + Extra-source-files: Makefile config.mk + stack.yaml rts/*.c rts/*.h @@ -143,36 +157,18 @@ test/reg004/run test/reg004/*.idr test/reg004/expected - test/reg005/run - test/reg005/*.idr - test/reg005/expected test/reg006/run test/reg006/*.idr test/reg006/expected test/reg007/run test/reg007/*.lidr test/reg007/expected - test/reg009/run - test/reg009/*.lidr - test/reg009/expected test/reg010/run test/reg010/*.idr test/reg010/expected - test/reg011/run - test/reg011/*.idr - test/reg011/expected - test/reg012/run - test/reg012/*.lidr - test/reg012/expected test/reg013/run test/reg013/*.idr test/reg013/expected - test/reg014/run - test/reg014/*.idr - test/reg014/expected - test/reg015/run - test/reg015/*.idr - test/reg015/expected test/reg016/run test/reg016/*.idr test/reg016/expected @@ -182,18 +178,9 @@ test/reg018/run test/reg018/*.idr test/reg018/expected - test/reg019/run - test/reg019/*.idr - test/reg019/expected test/reg020/run test/reg020/*.idr test/reg020/expected - test/reg021/run - test/reg021/*.idr - test/reg021/expected - test/reg022/run - test/reg022/*.idr - test/reg022/expected test/reg023/run test/reg023/*.idr test/reg023/expected @@ -203,9 +190,6 @@ test/reg025/run test/reg025/*.idr test/reg025/expected - test/reg026/run - test/reg026/*.idr - test/reg026/expected test/reg027/run test/reg027/*.idr test/reg027/expected @@ -215,18 +199,12 @@ test/reg029/run test/reg029/*.idr test/reg029/expected - test/reg030/run - test/reg030/*.idr - test/reg030/expected test/reg031/run test/reg031/*.idr test/reg031/expected test/reg032/run test/reg032/*.idr test/reg032/expected - test/reg033/run - test/reg033/*.idr - test/reg033/expected test/reg034/run test/reg034/*.idr test/reg034/expected @@ -365,6 +343,12 @@ test/basic013/run test/basic013/*.idr test/basic013/expected + test/basic014/run + test/basic014/*.idr + test/basic014/expected + test/basic015/run + test/basic015/*.idr + test/basic015/expected test/bignum001/run test/bignum001/*.idr @@ -569,6 +553,7 @@ test/primitives001/run test/primitives001/*.idr test/primitives001/expected + test/primitives001/input test/primitives002/run test/primitives002/expected test/primitives003/run @@ -606,6 +591,16 @@ test/proof010/run test/proof010/*.idr test/proof010/expected + + test/proofsearch001/run + test/proofsearch001/*.idr + test/proofsearch001/expected + test/proofsearch002/run + test/proofsearch002/*.idr + test/proofsearch002/expected + test/proofsearch003/run + test/proofsearch003/*.idr + test/proofsearch003/expected test/quasiquote001/run test/quasiquote001/*.idr @@ -695,6 +690,9 @@ test/totality009/run test/totality009/*.idr test/totality009/expected + test/totality010/run + test/totality010/*.idr + test/totality010/expected test/tutorial001/run test/tutorial001/*.idr @@ -738,7 +736,23 @@ test/docs003/*.idr test/docs003/expected + benchmarks/ALL + benchmarks/*.pl + benchmarks/README + benchmarks/fasta/fasta.idr + benchmarks/fasta/fasta.ipkg + + benchmarks/pidigits/pidigits.idr + benchmarks/pidigits/pidigits.ipkg + + benchmarks/quasigroups/board + benchmarks/quasigroups/*.idr + benchmarks/quasigroups/qgsolve.ipkg + + benchmarks/trivial/sortvec.idr + benchmarks/trivial/sortvec.ipkg + source-repository head type: git location: git://github.com/idris-lang/Idris-dev.git @@ -923,7 +937,7 @@ , trifecta >= 1.1 && < 1.6 , uniplate >=1.6 && < 1.7 , unordered-containers < 0.3 - , utf8-string <= 1 + , utf8-string < 1.1 , vector < 0.11 , vector-binary-instances < 0.3 , zip-archive > 0.2.3.5 && < 0.2.4 @@ -984,9 +998,9 @@ ghc-prof-options: -auto-all -caf-all ghc-options: -threaded -rtsopts -funbox-strict-fields -Executable idris-c +Executable idris-codegen-c Main-is: Main.hs - hs-source-dirs: codegen/idris-c + hs-source-dirs: codegen/idris-codegen-c Build-depends: idris , base @@ -997,9 +1011,9 @@ ghc-prof-options: -auto-all -caf-all ghc-options: -threaded -rtsopts -funbox-strict-fields -Executable idris-javascript +Executable idris-codegen-javascript Main-is: Main.hs - hs-source-dirs: codegen/idris-javascript + hs-source-dirs: codegen/idris-codegen-javascript Build-depends: idris , base @@ -1010,9 +1024,9 @@ ghc-prof-options: -auto-all -caf-all ghc-options: -threaded -rtsopts -funbox-strict-fields -Executable idris-node +Executable idris-codegen-node Main-is: Main.hs - hs-source-dirs: codegen/idris-node + hs-source-dirs: codegen/idris-codegen-node Build-depends: idris , base diff --git a/jsrts/Runtime-node.js b/jsrts/Runtime-node.js --- a/jsrts/Runtime-node.js +++ b/jsrts/Runtime-node.js @@ -10,14 +10,20 @@ return function() { var ret = ""; - + var b = new Buffer(1024); + var i = 0; while(true) { - var b = new Buffer(1); - fs.readSync(0, b, 0, 1 ) - if (b[0] == 10) + fs.readSync(0, b, i, 1 ) + if (b[i] == 10) { + ret = b.toString('utf8', 0, i); break; - else - ret += String.fromCharCode(b[0]); + } + i++; + if (i == b.length) { + nb = new Buffer (b.length*2); + b.copy(nb) + b = nb; + } } return ret; diff --git a/libs/base/Control/Category.idr b/libs/base/Control/Category.idr --- a/libs/base/Control/Category.idr +++ b/libs/base/Control/Category.idr @@ -10,7 +10,9 @@ instance Category Morphism where id = Mor id - (Mor f) . (Mor g) = Mor (f . g) + -- disambiguation needed below, because unification can now get further + -- here with Category.(.) and it's only type class resolution that fails! + (Mor f) . (Mor g) = with Basics (Mor (f . g)) instance Monad m => Category (Kleislimorphism m) where id = Kleisli (return . id) diff --git a/libs/base/Data/Bits.idr b/libs/base/Data/Bits.idr --- a/libs/base/Data/Bits.idr +++ b/libs/base/Data/Bits.idr @@ -42,7 +42,7 @@ | S (S (S _)) = natToBits' {n=3} (prim__truncInt_B64 0) x getPad : Nat -> machineTy n -getPad n = natToBits ((bitsUsed (nextBytes n)) - n) +getPad n = natToBits (minus (bitsUsed (nextBytes n)) n) public data Bits : Nat -> Type where diff --git a/libs/base/Data/Complex.idr b/libs/base/Data/Complex.idr --- a/libs/base/Data/Complex.idr +++ b/libs/base/Data/Complex.idr @@ -5,8 +5,6 @@ module Data.Complex -import Data.Floats - ------------------------------ Rectangular form infix 6 :+ @@ -57,20 +55,21 @@ ------------------------------ Conjugate -conjugate : Num a => Complex a -> Complex a +conjugate : Neg a => Complex a -> Complex a conjugate (r:+i) = (r :+ (0-i)) instance Functor Complex where - map f (r :+ i) = f r :+ f i - -instance Neg a => Neg (Complex a) where - negate = map negate + map f (r :+ i) = f r :+ f i -- We can't do "instance Num a => Num (Complex a)" because -- we need "abs" which needs "magnitude" which needs "sqrt" which needs Float instance Num (Complex Float) where (+) (a:+b) (c:+d) = ((a+c):+(b+d)) - (-) (a:+b) (c:+d) = ((a-c):+(b-d)) (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d)) fromInteger x = (fromInteger x:+0) + +instance Neg (Complex Float) where + negate = map negate + (-) (a:+b) (c:+d) = ((a-c):+(b-d)) abs (a:+b) = (magnitude (a:+b):+0) + diff --git a/libs/base/Data/Floats.idr b/libs/base/Data/Floats.idr deleted file mode 100644 --- a/libs/base/Data/Floats.idr +++ /dev/null @@ -1,59 +0,0 @@ -module Data.Floats - -%access public -%default total - -%include C "math.h" -%lib C "m" - -pi : Float -pi = 3.14159265358979323846 - -euler : Float -euler = 2.7182818284590452354 - -exp : Float -> Float -exp x = prim__floatExp x - -log : Float -> Float -log x = prim__floatLog x - -sin : Float -> Float -sin x = prim__floatSin x - -cos : Float -> Float -cos x = prim__floatCos x - -tan : Float -> Float -tan x = prim__floatTan x - -asin : Float -> Float -asin x = prim__floatASin x - -acos : Float -> Float -acos x = prim__floatACos x - -atan : Float -> Float -atan x = prim__floatATan x - -atan2 : Float -> Float -> Float -atan2 y x = atan (y/x) - -sinh : Float -> Float -sinh x = (exp x - exp (-x)) / 2 - -cosh : Float -> Float -cosh x = (exp x + exp (-x)) / 2 - -tanh : Float -> Float -tanh x = sinh x / cosh x - -sqrt : Float -> Float -sqrt x = prim__floatSqrt x - -floor : Float -> Float -floor x = prim__floatFloor x - -ceiling : Float -> Float -ceiling x = prim__floatCeil x - diff --git a/libs/base/Data/Mod2.idr b/libs/base/Data/Mod2.idr --- a/libs/base/Data/Mod2.idr +++ b/libs/base/Data/Mod2.idr @@ -40,9 +40,7 @@ instance Num (Mod2 n) where (+) = modBin plus - (-) = modBin minus (*) = modBin times - abs = id fromInteger = intToMod instance Cast (Mod2 n) (Bits n) where diff --git a/libs/base/Data/Vect.idr b/libs/base/Data/Vect.idr --- a/libs/base/Data/Vect.idr +++ b/libs/base/Data/Vect.idr @@ -1,12 +1,572 @@ module Data.Vect +import public Data.Fin import Language.Reflection -import public Data.VectType %access public %default total +infixr 7 :: + +||| Vectors: Generic lists with explicit length in the type +%elim +data Vect : Nat -> Type -> Type where + ||| Empty vector + Nil : Vect Z a + ||| A non-empty vector of length `S k`, consisting of a head element and + ||| the rest of the list, of length `k`. + (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a + +-- Hints for interactive editing +%name Vect xs,ys,zs,ws + -------------------------------------------------------------------------------- +-- Length +-------------------------------------------------------------------------------- + +||| Calculate the length of a `Vect`. +||| +||| **Note**: this is only useful if you don't already statically know the length +||| and you want to avoid matching the implicit argument for erasure reasons. +||| @ n the length (provably equal to the return value) +||| @ xs the vector +length : (xs : Vect n a) -> Nat +length [] = 0 +length (x::xs) = 1 + length xs + +||| Show that the length function on vectors in fact calculates the length +private lengthCorrect : (n : Nat) -> (xs : Vect n a) -> length xs = n +lengthCorrect Z [] = Refl +lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in Refl + +-------------------------------------------------------------------------------- +-- Indexing into vectors +-------------------------------------------------------------------------------- + +||| All but the first element of the vector +tail : Vect (S n) a -> Vect n a +tail (x::xs) = xs + +||| Only the first element of the vector +head : Vect (S n) a -> a +head (x::xs) = x + +||| The last element of the vector +last : Vect (S n) a -> a +last (x::[]) = x +last (x::y::ys) = last $ y::ys + +||| All but the last element of the vector +init : Vect (S n) a -> Vect n a +init (x::[]) = [] +init (x::y::ys) = x :: init (y::ys) + +||| Extract a particular element from a vector +index : Fin n -> Vect n a -> a +index FZ (x::xs) = x +index (FS k) (x::xs) = index k xs + + +||| Insert an element at a particular index +insertAt : Fin (S n) -> a -> Vect n a -> Vect (S n) a +insertAt FZ y xs = y :: xs +insertAt (FS k) y (x::xs) = x :: insertAt k y xs +insertAt (FS k) y [] = absurd k + +||| Construct a new vector consisting of all but the indicated element +deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a +deleteAt FZ (x::xs) = xs +deleteAt {n = S m} (FS k) (x::xs) = x :: deleteAt k xs +deleteAt {n = Z} (FS k) (x::xs) = absurd k +deleteAt _ [] impossible + +||| Replace an element at a particlar index with another +replaceAt : Fin n -> t -> Vect n t -> Vect n t +replaceAt FZ y (x::xs) = y :: xs +replaceAt (FS k) y (x::xs) = x :: replaceAt k y xs + +||| Replace the element at a particular index with the result of applying a function to it +||| @ i the index to replace at +||| @ f the update function +||| @ xs the vector to replace in +updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t +updateAt FZ f (x::xs) = f x :: xs +updateAt (FS k) f (x::xs) = x :: updateAt k f xs + +-------------------------------------------------------------------------------- +-- Subvectors +-------------------------------------------------------------------------------- + +||| Get the first n elements of a Vect +||| @ n the number of elements to take +take : (n : Nat) -> Vect (n + m) a -> Vect n a +take Z xs = [] +take (S k) (x :: xs) = x :: take k xs + +||| Remove the first n elements of a Vect +||| @ n the number of elements to remove +drop : (n : Nat) -> Vect (n + m) a -> Vect m a +drop Z xs = xs +drop (S k) (x :: xs) = drop k xs + +||| Take the longest prefix of a Vect such that all elements satisfy some +||| Boolean predicate. +||| +||| @ p the predicate +takeWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a) +takeWhile p [] = (_ ** []) +takeWhile p (x::xs) = + let (len ** ys) = takeWhile p xs + in if p x then + (S len ** x :: ys) + else + (_ ** []) + +||| Remove the longest prefix of a Vect such that all removed elements satisfy some +||| Boolean predicate. +||| +||| @ p the predicate +dropWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a) +dropWhile p [] = (_ ** []) +dropWhile p (x::xs) = + if p x then + dropWhile p xs + else + (_ ** x::xs) + +-------------------------------------------------------------------------------- +-- Transformations +-------------------------------------------------------------------------------- + +||| Reverse the order of the elements of a vector +reverse : Vect n a -> Vect n a +reverse xs = go [] xs + where go : Vect n a -> Vect m a -> Vect (n+m) a + go {n} acc [] = rewrite plusZeroRightNeutral n in acc + go {n} {m=S m} acc (x :: xs) = rewrite sym $ plusSuccRightSucc n m + in go (x::acc) xs + +||| Alternate an element between the other elements of a vector +||| @ sep the element to intersperse +||| @ xs the vector to separate with `sep` +intersperse : (sep : a) -> (xs : Vect n a) -> Vect (n + pred n) a +intersperse sep [] = [] +intersperse sep (x::xs) = x :: intersperse' sep xs + where + intersperse' : a -> Vect n a -> Vect (n + n) a + intersperse' sep [] = [] + intersperse' {n=S n} sep (x::xs) = rewrite sym $ plusSuccRightSucc n n + in sep :: x :: intersperse' sep xs + +-------------------------------------------------------------------------------- +-- Conversion from list (toList is provided by Foldable) +-------------------------------------------------------------------------------- + + +fromList' : Vect n a -> (l : List a) -> Vect (length l + n) a +fromList' ys [] = ys +fromList' {n} ys (x::xs) = + rewrite (plusSuccRightSucc (length xs) n) ==> + Vect (plus (length xs) (S n)) a in + fromList' (x::ys) xs + +||| Convert a list to a vector. +||| +||| The length of the list should be statically known. +fromList : (l : List a) -> Vect (length l) a +fromList l = + rewrite (sym $ plusZeroRightNeutral (length l)) in + reverse $ fromList' [] l + +-------------------------------------------------------------------------------- +-- Building (bigger) vectors +-------------------------------------------------------------------------------- + +||| Append two vectors +(++) : Vect m a -> Vect n a -> Vect (m + n) a +(++) [] ys = ys +(++) (x::xs) ys = x :: xs ++ ys + +||| Repeate some value n times +||| @ n the number of times to repeat it +||| @ x the value to repeat +replicate : (n : Nat) -> (x : a) -> Vect n a +replicate Z x = [] +replicate (S k) x = x :: replicate k x + +-------------------------------------------------------------------------------- +-- Zips and unzips +-------------------------------------------------------------------------------- + +||| Combine two equal-length vectors pairwise with some function +zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c +zipWith f [] [] = [] +zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys + +||| Combine three equal-length vectors into a vector with some function +zipWith3 : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d +zipWith3 f [] [] [] = [] +zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs + +||| Combine two equal-length vectors pairwise +zip : Vect n a -> Vect n b -> Vect n (a, b) +zip = zipWith (\x,y => (x,y)) + +||| Combine three equal-length vectors elementwise into a vector of tuples +zip3 : Vect n a -> Vect n b -> Vect n c -> Vect n (a, b, c) +zip3 = zipWith3 (\x,y,z => (x,y,z)) + +||| Convert a vector of pairs to a pair of vectors +unzip : Vect n (a, b) -> (Vect n a, Vect n b) +unzip [] = ([], []) +unzip ((l, r)::xs) with (unzip xs) + | (lefts, rights) = (l::lefts, r::rights) + +||| Convert a vector of three-tuples to a triplet of vectors +unzip3 : Vect n (a, b, c) -> (Vect n a, Vect n b, Vect n c) +unzip3 [] = ([], [], []) +unzip3 ((l,c,r)::xs) with (unzip3 xs) + | (lefts, centers, rights) = (l::lefts, c::centers, r::rights) + +-------------------------------------------------------------------------------- +-- Equality +-------------------------------------------------------------------------------- + +instance (Eq a) => Eq (Vect n a) where + (==) [] [] = True + (==) (x::xs) (y::ys) = x == y && xs == ys + + +-------------------------------------------------------------------------------- +-- Order +-------------------------------------------------------------------------------- + +instance Ord a => Ord (Vect n a) where + compare [] [] = EQ + compare (x::xs) (y::ys) = compare x y `thenCompare` compare xs ys + + +-------------------------------------------------------------------------------- +-- Maps +-------------------------------------------------------------------------------- + +instance Functor (Vect n) where + map f [] = [] + map f (x::xs) = f x :: map f xs + + +||| Map a partial function across a vector, returning those elements for which +||| the function had a value. +||| +||| The first projection of the resulting pair (ie the length) will always be +||| at most the length of the input vector. This is not, however, guaranteed +||| by the type. +||| +||| @ f the partial function (expressed by returning `Maybe`) +||| @ xs the vector to check for results +mapMaybe : (f : a -> Maybe b) -> (xs : Vect n a) -> (m : Nat ** Vect m b) +mapMaybe f [] = (_ ** []) +mapMaybe f (x::xs) = + let (len ** ys) = mapMaybe f xs + in case f x of + Just y => (S len ** y :: ys) + Nothing => ( len ** ys) + + +-------------------------------------------------------------------------------- +-- Folds +-------------------------------------------------------------------------------- + +foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> Vect n t -> acc +foldrImpl f e go [] = go e +foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs + +instance Foldable (Vect n) where + foldr f e xs = foldrImpl f e id xs + +-------------------------------------------------------------------------------- +-- Special folds +-------------------------------------------------------------------------------- + +||| Flatten a vector of equal-length vectors +concat : Vect m (Vect n a) -> Vect (m * n) a +concat [] = [] +concat (v::vs) = v ++ concat vs + +||| Foldr without seeding the accumulator +foldr1 : (t -> t -> t) -> Vect (S n) t -> t +foldr1 f (x::xs) = foldr f x xs + +||| Foldl without seeding the accumulator +foldl1 : (t -> t -> t) -> Vect (S n) t -> t +foldl1 f (x::xs) = foldl f x xs +-------------------------------------------------------------------------------- +-- Scans +-------------------------------------------------------------------------------- + +scanl : (b -> a -> b) -> b -> Vect n a -> Vect (S n) b +scanl f q [] = [q] +scanl f q (x::xs) = q :: scanl f (f q x) xs + +-------------------------------------------------------------------------------- +-- Membership tests +-------------------------------------------------------------------------------- + +||| Search for an item using a user-provided test +||| @ p the equality test +||| @ e the item to search for +||| @ xs the vector to search in +elemBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n a) -> Bool +elemBy p e [] = False +elemBy p e (x::xs) = p e x || elemBy p e xs + +||| Use the default Boolean equality on elements to search for an item +||| @ x what to search for +||| @ xs where to search +elem : Eq a => (x : a) -> (xs : Vect n a) -> Bool +elem = elemBy (==) + +||| Find the association of some key with a user-provided comparison +||| @ p the comparison operator for keys (True if they match) +||| @ e the key to look for +lookupBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n (a, b)) -> Maybe b +lookupBy p e [] = Nothing +lookupBy p e ((l, r)::xs) = if p e l then Just r else lookupBy p e xs + +||| Find the assocation of some key using the default Boolean equality test +lookup : Eq a => a -> Vect n (a, b) -> Maybe b +lookup = lookupBy (==) + +||| Check if any element of xs is found in elems by a user-provided comparison +||| @ p the comparison operator +||| @ elems the vector to search +||| @ xs what to search for +hasAnyBy : (p : a -> a -> Bool) -> (elems : Vect m a) -> (xs : Vect n a) -> Bool +hasAnyBy p elems [] = False +hasAnyBy p elems (x::xs) = elemBy p x elems || hasAnyBy p elems xs + +||| Check if any element of xs is found in elems using the default Boolean equality test +hasAny : Eq a => Vect m a -> Vect n a -> Bool +hasAny = hasAnyBy (==) + +-------------------------------------------------------------------------------- +-- Searching with a predicate +-------------------------------------------------------------------------------- + +||| Find the first element of the vector that satisfies some test +||| @ p the test to satisfy +find : (p : a -> Bool) -> (xs : Vect n a) -> Maybe a +find p [] = Nothing +find p (x::xs) = if p x then Just x else find p xs + +||| Find the index of the first element of the vector that satisfies some test +findIndex : (a -> Bool) -> Vect n a -> Maybe (Fin n) +findIndex p [] = Nothing +findIndex p (x :: xs) = if p x then Just 0 else map FS (findIndex p xs) + +||| Find the indices of all elements that satisfy some test +findIndices : (a -> Bool) -> Vect m a -> List (Fin m) +findIndices p [] = [] +findIndices p (x :: xs) = let is = map FS $ findIndices p xs + in if p x then 0 :: is else is + +elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe (Fin m) +elemIndexBy p e = findIndex $ p e + +elemIndex : Eq a => a -> Vect m a -> Maybe (Fin m) +elemIndex = elemIndexBy (==) + +elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> List (Fin m) +elemIndicesBy p e = findIndices $ p e + +elemIndices : Eq a => a -> Vect m a -> List (Fin m) +elemIndices = elemIndicesBy (==) + +-------------------------------------------------------------------------------- +-- Filters +-------------------------------------------------------------------------------- + +||| Find all elements of a vector that satisfy some test +filter : (a -> Bool) -> Vect n a -> (p ** Vect p a) +filter p [] = ( _ ** [] ) +filter p (x::xs) = + let (_ ** tail) = filter p xs + in if p x then + (_ ** x::tail) + else + (_ ** tail) + +||| Make the elements of some vector unique by some test +nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) +nubBy = nubBy' [] + where + nubBy' : Vect m a -> (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) + nubBy' acc p [] = (_ ** []) + nubBy' acc p (x::xs) with (elemBy p x acc) + | True = nubBy' acc p xs + | False with (nubBy' (x::acc) p xs) + | (_ ** tail) = (_ ** x::tail) + +||| Make the elements of some vector unique by the default Boolean equality +nub : Eq a => Vect n a -> (p ** Vect p a) +nub = nubBy (==) + +deleteBy : (a -> a -> Bool) -> a -> Vect n a -> (p ** Vect p a) +deleteBy _ _ [] = (_ ** []) +deleteBy eq x (y::ys) = + let (len ** zs) = deleteBy eq x ys + in if x `eq` y then (_ ** ys) else (S len ** y ::zs) + +delete : (Eq a) => a -> Vect n a -> (p ** Vect p a) +delete = deleteBy (==) + +-------------------------------------------------------------------------------- +-- Splitting and breaking lists +-------------------------------------------------------------------------------- + +||| A tuple where the first element is a Vect of the n first elements and +||| the second element is a Vect of the remaining elements of the original Vect +||| It is equivalent to (take n xs, drop n xs) +||| @ n the index to split at +||| @ xs the Vect to split in two +splitAt : (n : Nat) -> (xs : Vect (n + m) a) -> (Vect n a, Vect m a) +splitAt n xs = (take n xs, drop n xs) + +partition : (a -> Bool) -> Vect n a -> ((p ** Vect p a), (q ** Vect q a)) +partition p [] = ((_ ** []), (_ ** [])) +partition p (x::xs) = + let ((leftLen ** lefts), (rightLen ** rights)) = partition p xs in + if p x then + ((S leftLen ** x::lefts), (rightLen ** rights)) + else + ((leftLen ** lefts), (S rightLen ** x::rights)) + +-------------------------------------------------------------------------------- +-- Predicates +-------------------------------------------------------------------------------- + +isPrefixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool +isPrefixOfBy p [] right = True +isPrefixOfBy p left [] = False +isPrefixOfBy p (x::xs) (y::ys) = p x y && isPrefixOfBy p xs ys + +isPrefixOf : Eq a => Vect m a -> Vect n a -> Bool +isPrefixOf = isPrefixOfBy (==) + +isSuffixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool +isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right) + +isSuffixOf : Eq a => Vect m a -> Vect n a -> Bool +isSuffixOf = isSuffixOfBy (==) + +-------------------------------------------------------------------------------- +-- Conversions +-------------------------------------------------------------------------------- + +maybeToVect : Maybe a -> (p ** Vect p a) +maybeToVect Nothing = (_ ** []) +maybeToVect (Just j) = (_ ** [j]) + +vectToMaybe : Vect n a -> Maybe a +vectToMaybe [] = Nothing +vectToMaybe (x::xs) = Just x + +-------------------------------------------------------------------------------- +-- Misc +-------------------------------------------------------------------------------- + +catMaybes : Vect n (Maybe a) -> (p ** Vect p a) +catMaybes [] = (_ ** []) +catMaybes (Nothing::xs) = catMaybes xs +catMaybes ((Just j)::xs) = + let (_ ** tail) = catMaybes xs + in (_ ** j::tail) + +diag : Vect n (Vect n a) -> Vect n a +diag [] = [] +diag ((x::xs)::xss) = x :: diag (map tail xss) + +range : {n : Nat} -> Vect n (Fin n) +range {n=Z} = [] +range {n=S _} = FZ :: map FS range + +||| Transpose a Vect of Vects, turning rows into columns and vice versa. +||| +||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`. +transpose : {n : Nat} -> Vect m (Vect n a) -> Vect n (Vect m a) +transpose [] = replicate _ [] +transpose (x :: xs) = zipWith (::) x (transpose xs) + +-------------------------------------------------------------------------------- +-- Applicative/Monad/Traversable +-------------------------------------------------------------------------------- + +instance Applicative (Vect k) where + pure = replicate _ + + fs <*> vs = zipWith apply fs vs + +||| This monad is different from the List monad, (>>=) +||| uses the diagonal. +instance Monad (Vect n) where + m >>= f = diag (map f m) + +instance Traversable (Vect n) where + traverse f [] = pure Vect.Nil + traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |] + +-------------------------------------------------------------------------------- +-- Show +-------------------------------------------------------------------------------- + +instance Show a => Show (Vect n a) where + show = show . toList + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +vectConsCong : (x : a) -> (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> (x :: xs = x :: ys) +vectConsCong x xs xs Refl = Refl + +vectNilRightNeutral : (xs : Vect n a) -> xs ++ [] = xs +vectNilRightNeutral [] = Refl +vectNilRightNeutral (x :: xs) = + vectConsCong _ _ _ (vectNilRightNeutral xs) + +vectAppendAssociative : (x : Vect xLen a) -> (y : Vect yLen a) -> (z : Vect zLen a) -> x ++ (y ++ z) = (x ++ y) ++ z +vectAppendAssociative [] y z = Refl +vectAppendAssociative (x :: xs) ys zs = + vectConsCong _ _ _ (vectAppendAssociative xs ys zs) + +-------------------------------------------------------------------------------- +-- DecEq +-------------------------------------------------------------------------------- + +vectInjective1 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> x = y +vectInjective1 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl + +vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys +vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl + +instance DecEq a => DecEq (Vect n a) where + decEq [] [] = Yes Refl + decEq (x :: xs) (y :: ys) with (decEq x y) + decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys) + decEq (x :: xs) (x :: xs) | Yes Refl | Yes Refl = Yes Refl + decEq (x :: xs) (x :: ys) | Yes Refl | No neq = No (neq . vectInjective2) + decEq (x :: xs) (y :: ys) | No neq = No (neq . vectInjective1) + +{- The following definition is elaborated in a wrong case-tree. Examination pending. +instance DecEq a => DecEq (Vect n a) where + decEq [] [] = Yes Refl + decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys) + decEq (x :: xs) (x :: xs) | (Yes Refl, Yes Refl) = Yes Refl + decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p)) + decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p)) +-} + +-------------------------------------------------------------------------------- -- Elem -------------------------------------------------------------------------------- @@ -32,12 +592,6 @@ isElem x (y :: xs) | (No xneqy) with (isElem x xs) isElem x (y :: xs) | (No xneqy) | (Yes xinxs) = Yes (There xinxs) isElem x (y :: xs) | (No xneqy) | (No xninxs) = No (neitherHereNorThere xneqy xninxs) - -||| A tactic for discovering where, if anywhere, an element is in a vector -||| @ n how many elements to search before giving up -findElem : (n : Nat) -> List (TTName, Binder TT) -> TT -> Tactic -findElem Z ctxt goal = Refine "Here" `Seq` Solve -findElem (S n) ctxt goal = GoalType "Elem" (Try (Refine "Here" `Seq` Solve) (Refine "There" `Seq` (Solve `Seq` findElem n ctxt goal))) replaceElem : (xs : Vect k t) -> Elem x xs -> (y : t) -> (ys : Vect k t ** Elem y ys) replaceElem (x::xs) Here y = (y :: xs ** Here) diff --git a/libs/base/Data/VectType.idr b/libs/base/Data/VectType.idr deleted file mode 100644 --- a/libs/base/Data/VectType.idr +++ /dev/null @@ -1,601 +0,0 @@ -module Data.VectType - -import public Data.Fin - -%access public -%default total - -namespace Vect { - -infixr 7 :: - -||| Vectors: Generic lists with explicit length in the type -%elim -data Vect : Nat -> Type -> Type where - ||| Empty vector - Nil : Vect Z a - ||| A non-empty vector of length `S k`, consisting of a head element and - ||| the rest of the list, of length `k`. - (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a - --- Hints for interactive editing -%name Vect xs,ys,zs,ws - --------------------------------------------------------------------------------- --- Length --------------------------------------------------------------------------------- - -||| Calculate the length of a `Vect`. -||| -||| **Note**: this is only useful if you don't already statically know the length -||| and you want to avoid matching the implicit argument for erasure reasons. -||| @ n the length (provably equal to the return value) -||| @ xs the vector -length : (xs : Vect n a) -> Nat -length [] = 0 -length (x::xs) = 1 + length xs - -||| Show that the length function on vectors in fact calculates the length -private lengthCorrect : (n : Nat) -> (xs : Vect n a) -> length xs = n -lengthCorrect Z [] = Refl -lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in Refl - --------------------------------------------------------------------------------- --- Indexing into vectors --------------------------------------------------------------------------------- - -||| All but the first element of the vector -tail : Vect (S n) a -> Vect n a -tail (x::xs) = xs - -||| Only the first element of the vector -head : Vect (S n) a -> a -head (x::xs) = x - -||| The last element of the vector -last : Vect (S n) a -> a -last (x::[]) = x -last (x::y::ys) = last $ y::ys - -||| All but the last element of the vector -init : Vect (S n) a -> Vect n a -init (x::[]) = [] -init (x::y::ys) = x :: init (y::ys) - -||| Extract a particular element from a vector -index : Fin n -> Vect n a -> a -index FZ (x::xs) = x -index (FS k) (x::xs) = index k xs - - -||| Insert an element at a particular index -insertAt : Fin (S n) -> a -> Vect n a -> Vect (S n) a -insertAt FZ y xs = y :: xs -insertAt (FS k) y (x::xs) = x :: insertAt k y xs -insertAt (FS k) y [] = absurd k - -||| Construct a new vector consisting of all but the indicated element -deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a -deleteAt FZ (x::xs) = xs -deleteAt {n = S m} (FS k) (x::xs) = x :: deleteAt k xs -deleteAt {n = Z} (FS k) (x::xs) = absurd k -deleteAt _ [] impossible - -||| Replace an element at a particlar index with another -replaceAt : Fin n -> t -> Vect n t -> Vect n t -replaceAt FZ y (x::xs) = y :: xs -replaceAt (FS k) y (x::xs) = x :: replaceAt k y xs - -||| Replace the element at a particular index with the result of applying a function to it -||| @ i the index to replace at -||| @ f the update function -||| @ xs the vector to replace in -updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t -updateAt FZ f (x::xs) = f x :: xs -updateAt (FS k) f (x::xs) = x :: updateAt k f xs - --------------------------------------------------------------------------------- --- Subvectors --------------------------------------------------------------------------------- - -||| Get the first n elements of a Vect -||| @ n the number of elements to take -take : (n : Nat) -> Vect (n + m) a -> Vect n a -take Z xs = [] -take (S k) (x :: xs) = x :: take k xs - -||| Remove the first n elements of a Vect -||| @ n the number of elements to remove -drop : (n : Nat) -> Vect (n + m) a -> Vect m a -drop Z xs = xs -drop (S k) (x :: xs) = drop k xs - -||| Take the longest prefix of a Vect such that all elements satisfy some -||| Boolean predicate. -||| -||| @ p the predicate -takeWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a) -takeWhile p [] = (_ ** []) -takeWhile p (x::xs) = - let (len ** ys) = takeWhile p xs - in if p x then - (S len ** x :: ys) - else - (_ ** []) - -||| Remove the longest prefix of a Vect such that all removed elements satisfy some -||| Boolean predicate. -||| -||| @ p the predicate -dropWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a) -dropWhile p [] = (_ ** []) -dropWhile p (x::xs) = - if p x then - dropWhile p xs - else - (_ ** x::xs) - --------------------------------------------------------------------------------- --- Transformations --------------------------------------------------------------------------------- - -||| Reverse the order of the elements of a vector -reverse : Vect n a -> Vect n a -reverse xs = go [] xs - where go : Vect n a -> Vect m a -> Vect (n+m) a - go {n} acc [] = rewrite plusZeroRightNeutral n in acc - go {n} {m=S m} acc (x :: xs) = rewrite sym $ plusSuccRightSucc n m - in go (x::acc) xs - -||| Alternate an element between the other elements of a vector -||| @ sep the element to intersperse -||| @ xs the vector to separate with `sep` -intersperse : (sep : a) -> (xs : Vect n a) -> Vect (n + pred n) a -intersperse sep [] = [] -intersperse sep (x::xs) = x :: intersperse' sep xs - where - intersperse' : a -> Vect n a -> Vect (n + n) a - intersperse' sep [] = [] - intersperse' {n=S n} sep (x::xs) = rewrite sym $ plusSuccRightSucc n n - in sep :: x :: intersperse' sep xs - --------------------------------------------------------------------------------- --- Conversion from list (toList is provided by Foldable) --------------------------------------------------------------------------------- - - -fromList' : Vect n a -> (l : List a) -> Vect (length l + n) a -fromList' ys [] = ys -fromList' {n} ys (x::xs) = - rewrite (plusSuccRightSucc (length xs) n) ==> - Vect (plus (length xs) (S n)) a in - fromList' (x::ys) xs - -||| Convert a list to a vector. -||| -||| The length of the list should be statically known. -fromList : (l : List a) -> Vect (length l) a -fromList l = - rewrite (sym $ plusZeroRightNeutral (length l)) in - reverse $ fromList' [] l - --------------------------------------------------------------------------------- --- Building (bigger) vectors --------------------------------------------------------------------------------- - -||| Append two vectors -(++) : Vect m a -> Vect n a -> Vect (m + n) a -(++) [] ys = ys -(++) (x::xs) ys = x :: xs ++ ys - -||| Repeate some value n times -||| @ n the number of times to repeat it -||| @ x the value to repeat -replicate : (n : Nat) -> (x : a) -> Vect n a -replicate Z x = [] -replicate (S k) x = x :: replicate k x - --------------------------------------------------------------------------------- --- Zips and unzips --------------------------------------------------------------------------------- - -||| Combine two equal-length vectors pairwise with some function -zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c -zipWith f [] [] = [] -zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys - -||| Combine three equal-length vectors into a vector with some function -zipWith3 : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d -zipWith3 f [] [] [] = [] -zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs - -||| Combine two equal-length vectors pairwise -zip : Vect n a -> Vect n b -> Vect n (a, b) -zip = zipWith (\x,y => (x,y)) - -||| Combine three equal-length vectors elementwise into a vector of tuples -zip3 : Vect n a -> Vect n b -> Vect n c -> Vect n (a, b, c) -zip3 = zipWith3 (\x,y,z => (x,y,z)) - -||| Convert a vector of pairs to a pair of vectors -unzip : Vect n (a, b) -> (Vect n a, Vect n b) -unzip [] = ([], []) -unzip ((l, r)::xs) with (unzip xs) - | (lefts, rights) = (l::lefts, r::rights) - -||| Convert a vector of three-tuples to a triplet of vectors -unzip3 : Vect n (a, b, c) -> (Vect n a, Vect n b, Vect n c) -unzip3 [] = ([], [], []) -unzip3 ((l,c,r)::xs) with (unzip3 xs) - | (lefts, centers, rights) = (l::lefts, c::centers, r::rights) - --------------------------------------------------------------------------------- --- Equality --------------------------------------------------------------------------------- - -instance (Eq a) => Eq (Vect n a) where - (==) [] [] = True - (==) (x::xs) (y::ys) = - if x == y then - xs == ys - else - False - - --------------------------------------------------------------------------------- --- Order --------------------------------------------------------------------------------- - -instance Ord a => Ord (Vect n a) where - compare [] [] = EQ - compare (x::xs) (y::ys) = - if x /= y then - compare x y - else - compare xs ys - - --------------------------------------------------------------------------------- --- Maps --------------------------------------------------------------------------------- - -instance Functor (Vect n) where - map f [] = [] - map f (x::xs) = f x :: map f xs - - -||| Map a partial function across a vector, returning those elements for which -||| the function had a value. -||| -||| The first projection of the resulting pair (ie the length) will always be -||| at most the length of the input vector. This is not, however, guaranteed -||| by the type. -||| -||| @ f the partial function (expressed by returning `Maybe`) -||| @ xs the vector to check for results -mapMaybe : (f : a -> Maybe b) -> (xs : Vect n a) -> (m : Nat ** Vect m b) -mapMaybe f [] = (_ ** []) -mapMaybe f (x::xs) = - let (len ** ys) = mapMaybe f xs - in case f x of - Just y => (S len ** y :: ys) - Nothing => ( len ** ys) - - --------------------------------------------------------------------------------- --- Folds --------------------------------------------------------------------------------- - -total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> Vect n t -> acc -foldrImpl f e go [] = go e -foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs - -instance Foldable (Vect n) where - foldr f e xs = foldrImpl f e id xs - --------------------------------------------------------------------------------- --- Special folds --------------------------------------------------------------------------------- - -||| Flatten a vector of equal-length vectors -concat : Vect m (Vect n a) -> Vect (m * n) a -concat [] = [] -concat (v::vs) = v ++ concat vs - -||| Foldr without seeding the accumulator -foldr1 : (t -> t -> t) -> Vect (S n) t -> t -foldr1 f (x::xs) = foldr f x xs - -||| Foldl without seeding the accumulator -foldl1 : (t -> t -> t) -> Vect (S n) t -> t -foldl1 f (x::xs) = foldl f x xs --------------------------------------------------------------------------------- --- Scans --------------------------------------------------------------------------------- - -scanl : (b -> a -> b) -> b -> Vect n a -> Vect (S n) b -scanl f q [] = [q] -scanl f q (x::xs) = q :: scanl f (f q x) xs - --------------------------------------------------------------------------------- --- Membership tests --------------------------------------------------------------------------------- - -||| Search for an item using a user-provided test -||| @ p the equality test -||| @ e the item to search for -||| @ xs the vector to search in -elemBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n a) -> Bool -elemBy p e [] = False -elemBy p e (x::xs) with (p e x) - | True = True - | False = elemBy p e xs - -||| Use the default Boolean equality on elements to search for an item -||| @ x what to search for -||| @ xs where to search -elem : Eq a => (x : a) -> (xs : Vect n a) -> Bool -elem = elemBy (==) - -||| Find the association of some key with a user-provided comparison -||| @ p the comparison operator for keys (True if they match) -||| @ e the key to look for -lookupBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n (a, b)) -> Maybe b -lookupBy p e [] = Nothing -lookupBy p e ((l, r)::xs) with (p e l) - | True = Just r - | False = lookupBy p e xs - -||| Find the assocation of some key using the default Boolean equality test -lookup : Eq a => a -> Vect n (a, b) -> Maybe b -lookup = lookupBy (==) - -||| Check if any element of xs is found in elems by a user-provided comparison -||| @ p the comparison operator -||| @ elems the vector to search -||| @ xs what to search for -hasAnyBy : (p : a -> a -> Bool) -> (elems : Vect m a) -> (xs : Vect n a) -> Bool -hasAnyBy p elems [] = False -hasAnyBy p elems (x::xs) with (elemBy p x elems) - | True = True - | False = hasAnyBy p elems xs - -||| Check if any element of xs is found in elems using the default Boolean equality test -hasAny : Eq a => Vect m a -> Vect n a -> Bool -hasAny = hasAnyBy (==) - --------------------------------------------------------------------------------- --- Searching with a predicate --------------------------------------------------------------------------------- - -||| Find the first element of the vector that satisfies some test -||| @ p the test to satisfy -find : (p : a -> Bool) -> (xs : Vect n a) -> Maybe a -find p [] = Nothing -find p (x::xs) with (p x) - | True = Just x - | False = find p xs - -||| Find the index of the first element of the vector that satisfies some test -findIndex : (a -> Bool) -> Vect n a -> Maybe (Fin n) -findIndex p [] = Nothing -findIndex p (x :: xs) with (p x) - | True = Just 0 - | False = map FS (findIndex p xs) - -||| Find the indices of all elements that satisfy some test -total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat) -findIndices = findIndices' 0 - where - total findIndices' : Nat -> (a -> Bool) -> Vect m a -> (p ** Vect p Nat) - findIndices' cnt p [] = (_ ** []) - findIndices' cnt p (x::xs) with (findIndices' (S cnt) p xs) - | (_ ** tail) = - if p x then - (_ ** cnt::tail) - else - (_ ** tail) - -elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe (Fin m) -elemIndexBy p e = findIndex $ p e - -elemIndex : Eq a => a -> Vect m a -> Maybe (Fin m) -elemIndex = elemIndexBy (==) - -total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat) -elemIndicesBy p e = findIndices $ p e - -total elemIndices : Eq a => a -> Vect m a -> (p ** Vect p Nat) -elemIndices = elemIndicesBy (==) - --------------------------------------------------------------------------------- --- Filters --------------------------------------------------------------------------------- - -||| Find all elements of a vector that satisfy some test -total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a) -filter p [] = ( _ ** [] ) -filter p (x::xs) with (filter p xs) - | (_ ** tail) = - if p x then - (_ ** x::tail) - else - (_ ** tail) - -||| Make the elements of some vector unique by some test -nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) -nubBy = nubBy' [] - where - nubBy' : Vect m a -> (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) - nubBy' acc p [] = (_ ** []) - nubBy' acc p (x::xs) with (elemBy p x acc) - | True = nubBy' acc p xs - | False with (nubBy' (x::acc) p xs) - | (_ ** tail) = (_ ** x::tail) - -||| Make the elements of some vector unique by the default Boolean equality -nub : Eq a => Vect n a -> (p ** Vect p a) -nub = nubBy (==) - -deleteBy : (a -> a -> Bool) -> a -> Vect n a -> (p ** Vect p a) -deleteBy _ _ [] = (_ ** []) -deleteBy eq x (y::ys) = - let (len ** zs) = deleteBy eq x ys - in if x `eq` y then (_ ** ys) else (S len ** y ::zs) - -delete : (Eq a) => a -> Vect n a -> (p ** Vect p a) -delete = deleteBy (==) - --------------------------------------------------------------------------------- --- Splitting and breaking lists --------------------------------------------------------------------------------- - -||| A tuple where the first element is a Vect of the n first elements and -||| the second element is a Vect of the remaining elements of the original Vect -||| It is equivalent to (take n xs, drop n xs) -||| @ n the index to split at -||| @ xs the Vect to split in two -splitAt : (n : Nat) -> (xs : Vect (n + m) a) -> (Vect n a, Vect m a) -splitAt n xs = (take n xs, drop n xs) - -partition : (a -> Bool) -> Vect n a -> ((p ** Vect p a), (q ** Vect q a)) -partition p [] = ((_ ** []), (_ ** [])) -partition p (x::xs) = - let ((leftLen ** lefts), (rightLen ** rights)) = partition p xs in - if p x then - ((S leftLen ** x::lefts), (rightLen ** rights)) - else - ((leftLen ** lefts), (S rightLen ** x::rights)) - --------------------------------------------------------------------------------- --- Predicates --------------------------------------------------------------------------------- - -isPrefixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool -isPrefixOfBy p [] right = True -isPrefixOfBy p left [] = False -isPrefixOfBy p (x::xs) (y::ys) with (p x y) - | True = isPrefixOfBy p xs ys - | False = False - -isPrefixOf : Eq a => Vect m a -> Vect n a -> Bool -isPrefixOf = isPrefixOfBy (==) - -isSuffixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool -isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right) - -isSuffixOf : Eq a => Vect m a -> Vect n a -> Bool -isSuffixOf = isSuffixOfBy (==) - --------------------------------------------------------------------------------- --- Conversions --------------------------------------------------------------------------------- - -total maybeToVect : Maybe a -> (p ** Vect p a) -maybeToVect Nothing = (_ ** []) -maybeToVect (Just j) = (_ ** [j]) - -total vectToMaybe : Vect n a -> Maybe a -vectToMaybe [] = Nothing -vectToMaybe (x::xs) = Just x - --------------------------------------------------------------------------------- --- Misc --------------------------------------------------------------------------------- - -catMaybes : Vect n (Maybe a) -> (p ** Vect p a) -catMaybes [] = (_ ** []) -catMaybes (Nothing::xs) = catMaybes xs -catMaybes ((Just j)::xs) with (catMaybes xs) - | (_ ** tail) = (_ ** j::tail) - -diag : Vect n (Vect n a) -> Vect n a -diag [] = [] -diag ((x::xs)::xss) = x :: diag (map tail xss) - -range : Vect n (Fin n) -range {n=Z} = [] -range {n=S _} = FZ :: map FS range - -||| Transpose a Vect of Vects, turning rows into columns and vice versa. -||| -||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`. -transpose : Vect m (Vect n a) -> Vect n (Vect m a) -transpose [] = replicate _ [] -transpose (x :: xs) = zipWith (::) x (transpose xs) - --------------------------------------------------------------------------------- --- Applicative/Monad/Traversable --------------------------------------------------------------------------------- - -instance Applicative (Vect k) where - pure = replicate _ - - fs <*> vs = zipWith apply fs vs - -||| This monad is different from the List monad, (>>=) -||| uses the diagonal. -instance Monad (Vect n) where - m >>= f = diag (map f m) - -instance Traversable (Vect n) where - traverse f [] = pure Vect.Nil - traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |] - --------------------------------------------------------------------------------- --- Show --------------------------------------------------------------------------------- - -instance Show a => Show (Vect n a) where - show = show . toList - --------------------------------------------------------------------------------- --- Properties --------------------------------------------------------------------------------- - -vectConsCong : (x : a) -> (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> (x :: xs = x :: ys) -vectConsCong x xs xs Refl = Refl - -vectNilRightNeutral : (xs : Vect n a) -> xs ++ [] = xs -vectNilRightNeutral [] = Refl -vectNilRightNeutral (x :: xs) = - vectConsCong _ _ _ (vectNilRightNeutral xs) - -vectAppendAssociative : (x : Vect xLen a) -> (y : Vect yLen a) -> (z : Vect zLen a) -> x ++ (y ++ z) = (x ++ y) ++ z -vectAppendAssociative [] y z = Refl -vectAppendAssociative (x :: xs) ys zs = - vectConsCong _ _ _ (vectAppendAssociative xs ys zs) - -} - --------------------------------------------------------------------------------- --- DecEq --------------------------------------------------------------------------------- - -total -vectInjective1 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> x = y -vectInjective1 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl - -total -vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys -vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl - -instance DecEq a => DecEq (Vect n a) where - decEq [] [] = Yes Refl - decEq (x :: xs) (y :: ys) with (decEq x y) - decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys) - decEq (x :: xs) (x :: xs) | Yes Refl | Yes Refl = Yes Refl - decEq (x :: xs) (x :: ys) | Yes Refl | No neq = No (neq . vectInjective2) - decEq (x :: xs) (y :: ys) | No neq = No (neq . vectInjective1) - -{- The following definition is elaborated in a wrong case-tree. Examination pending. -instance DecEq a => DecEq (Vect n a) where - decEq [] [] = Yes Refl - decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys) - decEq (x :: xs) (x :: xs) | (Yes Refl, Yes Refl) = Yes Refl - decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p)) - decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p)) --} - --- For the primitives, we have to cheat because we don't have access to their --- internal implementations. diff --git a/libs/base/base.ipkg b/libs/base/base.ipkg --- a/libs/base/base.ipkg +++ b/libs/base/base.ipkg @@ -13,9 +13,9 @@ Data.Morphisms, Data.Bits, Data.Mod2, - Data.Fin, Data.Vect, Data.VectType, + Data.Fin, Data.Vect, Data.HVect, Data.Vect.Quantifiers, - Data.Floats, Data.Complex, + Data.Complex, Data.Erased, Data.List, Data.So, diff --git a/libs/contrib/Classes/Verified.idr b/libs/contrib/Classes/Verified.idr --- a/libs/contrib/Classes/Verified.idr +++ b/libs/contrib/Classes/Verified.idr @@ -17,12 +17,10 @@ (g1 : a -> b) -> (g2 : b -> c) -> map (g2 . g1) x = (map g2 . map g1) x - - class (Applicative f, VerifiedFunctor f) => VerifiedApplicative (f : Type -> Type) where applicativeMap : (x : f a) -> (g : a -> b) -> map g x = pure g <*> x - applicativeIdentity : (x : f a) -> pure id <*> x = x + applicativeIdentity : (x : f a) -> pure Basics.id <*> x = x applicativeComposition : (x : f a) -> (g1 : f (a -> b)) -> (g2 : f (b -> c)) -> ((pure (.) <*> g2) <*> g1) <*> x = g2 <*> (g1 <*> x) applicativeHomomorphism : (x : a) -> (g : a -> b) -> @@ -30,14 +28,13 @@ applicativeInterchange : (x : a) -> (g : f (a -> b)) -> g <*> pure x = pure (\g' : a -> b => g' x) <*> g - class (Monad m, VerifiedApplicative m) => VerifiedMonad (m : Type -> Type) where monadApplicative : (mf : m (a -> b)) -> (mx : m a) -> mf <*> mx = mf >>= \f => mx >>= \x => pure (f x) monadLeftIdentity : (x : a) -> (f : a -> m b) -> return x >>= f = f x - monadRightIdentity : (mx : m a) -> mx >>= return = mx + monadRightIdentity : (mx : m a) -> mx >>= Monad.return = mx monadAssociativity : (mx : m a) -> (f : a -> m b) -> (g : b -> m c) -> (mx >>= f) >>= g = mx >>= (\x => f x >>= g) @@ -53,8 +50,8 @@ class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where - total monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l - total monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r + total monoidNeutralIsNeutralL : (l : a) -> l <+> Algebra.neutral = l + total monoidNeutralIsNeutralR : (r : a) -> Algebra.neutral <+> r = r -- instance VerifiedMonoid Nat where -- monoidNeutralIsNeutralL = plusZeroRightNeutral @@ -65,8 +62,8 @@ monoidNeutralIsNeutralR xs = Refl class (VerifiedMonoid a, Group a) => VerifiedGroup a where - total groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral - total groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral + total groupInverseIsInverseL : (l : a) -> l <+> inverse l = Algebra.neutral + total groupInverseIsInverseR : (r : a) -> inverse r <+> r = Algebra.neutral class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where total abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l @@ -77,12 +74,12 @@ total ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <.> r = (l <.> r) <+> (c <.> r) class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where - total ringWithUnityIsUnityL : (l : a) -> l <.> unity = l - total ringWithUnityIsUnityR : (r : a) -> unity <.> r = r + total ringWithUnityIsUnityL : (l : a) -> l <.> Algebra.unity = l + total ringWithUnityIsUnityR : (r : a) -> Algebra.unity <.> r = r --class (VerifiedRingWithUnity a, Field a) => VerifiedField a where --- total fieldInverseIsInverseL : (l : a) -> (notId : Not (l = neutral)) -> l <.> (inverseM l notId) = unity --- total fieldInverseIsInverseR : (r : a) -> (notId : Not (r = neutral)) -> (inverseM r notId) <.> r = unity +-- total fieldInverseIsInverseL : (l : a) -> (notId : Not (l = neutral)) -> l <.> (inverseM l notId) = Algebra.unity +-- total fieldInverseIsInverseR : (r : a) -> (notId : Not (r = neutral)) -> (inverseM r notId) <.> r = Algebra.unity class JoinSemilattice a => VerifiedJoinSemilattice a where @@ -96,10 +93,10 @@ total meetSemilatticeMeetIsIdempotent : (e : a) -> meet e e = e class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where - total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = e + total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e Algebra.bottom = e class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where - total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = e + total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e Algebra.top = e class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where total latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l @@ -110,7 +107,7 @@ --class (VerifiedRingWithUnity a, VerifiedAbelianGroup b, Module a b) => VerifiedModule a b where -- total moduleScalarMultiplyComposition : (x,y : a) -> (v : b) -> x <#> (y <#> v) = (x <.> y) <#> v --- total moduleScalarUnityIsUnity : (v : b) -> unity {a} <#> v = v +-- total moduleScalarUnityIsUnity : (v : b) -> Algebra.unity {a} <#> v = v -- total moduleScalarMultDistributiveWRTVectorAddition : (s : a) -> (v, w : b) -> s <#> (v <+> w) = (s <#> v) <+> (s <#> w) -- total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v) diff --git a/libs/contrib/Control/Algebra.idr b/libs/contrib/Control/Algebra.idr --- a/libs/contrib/Control/Algebra.idr +++ b/libs/contrib/Control/Algebra.idr @@ -113,7 +113,7 @@ ||| forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c) ||| forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c) class RingWithUnity a => Field a where - inverseM : (x : a) -> Not (x = neutral) -> a + inverseM : (x : a) -> Not (x = Algebra.neutral) -> a sum' : (Foldable t, Monoid a) => t a -> a sum' = concat diff --git a/libs/contrib/Data/Matrix/Numeric.idr b/libs/contrib/Data/Matrix/Numeric.idr --- a/libs/contrib/Data/Matrix/Numeric.idr +++ b/libs/contrib/Data/Matrix/Numeric.idr @@ -24,11 +24,14 @@ instance Num a => Num (Vect n a) where (+) = zipWith (+) - (-) = zipWith (+) (*) = zipWith (*) - abs = id fromInteger n = replicate _ (fromInteger n) +instance Neg a => Neg (Vect n a) where + (-) = zipWith (-) + abs = map abs + negate = map negate + ----------------------------------------------------------------------- -- Vector functions ----------------------------------------------------------------------- @@ -88,7 +91,7 @@ (><) x y = col x <> row y ||| Matrix commutator -(<<>>) : Num a => Matrix n n a -> Matrix n n a -> Matrix n n a +(<<>>) : Neg a => Matrix n n a -> Matrix n n a -> Matrix n n a (<<>>) m1 m2 = (m1 <> m2) - (m2 <> m1) ||| Matrix anti-commutator @@ -112,17 +115,17 @@ ----------------------------------------------------------------------- ||| Alternating sum -altSum : Num a => Vect n a -> a +altSum : Neg a => Vect n a -> a altSum (x::y::zs) = (x - y) + altSum zs altSum [x] = x altSum [] = 0 ||| Determinant of a 2-by-2 matrix -det2 : Num a => Matrix 2 2 a -> a +det2 : Neg a => Matrix 2 2 a -> a det2 [[x1,x2],[y1,y2]] = x1*y2 - x2*y1 ||| Determinant of a square matrix -det : Num a => Matrix (S (S n)) (S (S n)) a -> a +det : Neg a => Matrix (S (S n)) (S (S n)) a -> a det {n} m = case n of Z => det2 m (S k) => altSum . map (\c => indices FZ c m * det (subMatrix FZ c m)) diff --git a/libs/contrib/Data/Nat/DivMod/IteratedSubtraction.idr b/libs/contrib/Data/Nat/DivMod/IteratedSubtraction.idr --- a/libs/contrib/Data/Nat/DivMod/IteratedSubtraction.idr +++ b/libs/contrib/Data/Nat/DivMod/IteratedSubtraction.idr @@ -47,7 +47,7 @@ ltToLTE (LTStep lt) = lteSuccRight $ ltToLTE lt ||| Subtraction gives a result that is actually smaller. -minusLT' : (x,y : Nat) -> x - y `LT'` S x +minusLT' : (x,y : Nat) -> minus x y `LT'` S x minusLT' Z y = LTSucc minusLT' (S k) Z = LTSucc minusLT' (S k) (S j) = LTStep (minusLT' k j) diff --git a/libs/contrib/Data/ZZ.idr b/libs/contrib/Data/ZZ.idr --- a/libs/contrib/Data/ZZ.idr +++ b/libs/contrib/Data/ZZ.idr @@ -28,11 +28,6 @@ show (Pos n) = show n show (NegS n) = "-" ++ show (S n) -instance Neg ZZ where - negate (Pos Z) = Pos Z - negate (Pos (S n)) = NegS n - negate (NegS n) = Pos (S n) - negNat : Nat -> ZZ negNat Z = Pos Z negNat (S n) = NegS n @@ -51,10 +46,6 @@ plusZ (Pos n) (NegS m) = minusNatZ n (S m) plusZ (NegS n) (Pos m) = minusNatZ m (S n) -||| Subtract two `ZZ`s. Consider using `(-) {a=ZZ}`. -subZ : ZZ -> ZZ -> ZZ -subZ n m = plusZ n (negate m) - instance Eq ZZ where (Pos n) == (Pos m) = n == m (NegS n) == (NegS m) = n == m @@ -85,10 +76,22 @@ instance Num ZZ where (+) = plusZ - (-) = subZ (*) = multZ - abs = cast . absZ fromInteger = fromInt + +mutual + instance Neg ZZ where + negate (Pos Z) = Pos Z + negate (Pos (S n)) = NegS n + negate (NegS n) = Pos (S n) + + (-) = subZ + abs = cast . absZ + + ||| Subtract two `ZZ`s. Consider using `(-) {a=ZZ}`. + subZ : ZZ -> ZZ -> ZZ + subZ n m = plusZ n (negate m) + instance Cast ZZ Integer where cast (Pos n) = cast n diff --git a/libs/effects/Effect/Logging/Category.idr b/libs/effects/Effect/Logging/Category.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effect/Logging/Category.idr @@ -0,0 +1,184 @@ +-- ------------------------------------------------------------ [ Category.idr ] +-- Module : Category.idr +-- Copyright : (c) The Idris Community +-- License : see LICENSE +-- --------------------------------------------------------------------- [ EOH ] +||| A logging effect that allows messages to be logged using both +||| numerical levels and user specified categories. The higher the +||| logging level the grater in verbosity the logging. +||| +||| In this effect the resource we are computing over is the logging +||| level itself and the list of categories to show. +module Effect.Logging.Category + +import Effects +import public Effect.Logging.Level + +%access public + +-- -------------------------------------------------------- [ Logging Resource ] + +||| The Logging details, this is the resource that the effect is +||| defined over. +record LogRes (a : Type) where + constructor MkLogRes + getLevel : LogLevel n + getCategories : List a + +instance (Show a) => Show (LogRes a) where + show (MkLogRes l cs) = unwords ["Log Settings:", show l, show cs] + +instance Default (LogRes a) where + default = MkLogRes OFF Nil + +-- ------------------------------------------------------- [ Effect Definition ] + +||| A Logging effect to log levels and categories. +data Logging : Effect where + ||| Log a message. + ||| + ||| @lvl The logging level it should appear at. + ||| @cats The categories it should appear under. + ||| @msg The message to log. + Log : (Show a, Eq a) => + (lvl : LogLevel n) + -> (cats : List a) + -> (msg : String) + -> sig Logging () (LogRes a) + + ||| Change the logging level. + ||| + ||| @nlvl The new logging level + SetLogLvl : (Show a, Eq a) => + (nlvl : LogLevel n) -> + sig Logging () (LogRes a) (LogRes a) + + ||| Change the categories to show. + ||| + ||| @ncats The new categories. + SetLogCats : (Show a, Eq a) => + (ncats : List a) -> + sig Logging () (LogRes a) (LogRes a) + + ||| Initialise the logging. + ||| + ||| @nlvl The new logging level. + ||| @ncats The categories to show. + InitLogger : (Show a, Eq a) => + (nlvl : LogLevel n) -> + (ncats : List a) -> + sig Logging () (LogRes a) (LogRes a) + +-- -------------------------------------------------------------- [ IO Handler ] + +instance Handler Logging IO where + handle st (SetLogLvl nlvl) k = do + let newSt = record {getLevel = nlvl} st + k () newSt + handle st (SetLogCats newcs) k = do + let newSt = record {getCategories = newcs} st + k () newSt + + handle st (InitLogger l cs) k = do + let newSt = MkLogRes l cs + k () newSt + + handle st (Log l cs' msg) k = do + case cmpLevel l (getLevel st) of + GT => k () st + otherwise => do + let res = and $ map (\x => elem x cs') (getCategories st) + let prompt = if isNil (getCategories st) + then unwords [show l, ":"] + else unwords [show l, ":", show (getCategories st), ":"] + if res || isNil (getCategories st) + then do + putStrLn $ unwords [prompt, msg] + k () st + else k () st + + +-- ------------------------------------------------------- [ Effect Descriptor ] + +||| The Logging effect. +||| +||| @a The type used to differentiate categories. +LOG : (a : Type) -> EFFECT +LOG a = MkEff (LogRes a) Logging + +-- ----------------------------------------------------------- [ Effectful API ] + +||| Change the logging level. +||| +||| @l The new logging level. +setLoglvl : (Show a, Eq a) => (l : LogLevel n) -> Eff () [LOG a] +setLoglvl l = call $ SetLogLvl l + +||| Change the categories to show. +||| +||| @cs The new categories. +setLogCats : (Show a, Eq a) => (cs : List a) -> Eff () [LOG a] +setLogCats cs = call $ SetLogCats cs + +||| Initialise the Logger. +||| +||| @l The logging level. +||| @cs The categories to show. +initLogger : (Show a, Eq a) => (l : LogLevel n) + -> (cs : List a) + -> Eff () [LOG a] +initLogger l cs = call $ InitLogger l cs + +||| Log the given message at the given level indicated by a natural number and assign it the list of categories. +||| +||| @l The logging level. +||| @cs The logging categories. +||| @m THe message to be logged. +log : (Show a, Eq a) => (l : LogLevel n) + -> (cs : List a) + -> (m : String) + -> Eff () [LOG a] +log l cs msg = call $ Log l cs msg + +||| Log the given message at the given level indicated by a natural number and assign it the list of categories. +||| +||| @l The logging level. +||| @cs The logging categories. +||| @m THe message to be logged. +logN : (Show a, Eq a) => (l : Nat) + -> {auto prf : LTE l 70} + -> (cs : List a) + -> (m : String) + -> Eff () [LOG a] +logN l cs msg = call $ Log (getProof lvl) cs msg + where + lvl : (n ** LogLevel n) + lvl = case cast {to=String} (cast {to=Int} l) of + "0" => (_ ** OFF) + "10" => (_ ** TRACE) + "20" => (_ ** DEBUG) + "30" => (_ ** INFO) + "40" => (_ ** WARN) + "50" => (_ ** FATAL) + "60" => (_ ** ERROR) + _ => (_ ** CUSTOM l) + +trace : (Show a, Eq a) => List a -> String -> Eff () [LOG a] +trace cs msg = call $ Log TRACE cs msg + +debug : (Show a, Eq a) => List a -> String -> Eff () [LOG a] +debug cs msg = call $ Log DEBUG cs msg + +info : (Show a, Eq a) => List a -> String -> Eff () [LOG a] +info cs msg = call $ Log INFO cs msg + +warn : (Show a, Eq a) => List a -> String -> Eff () [LOG a] +warn cs msg = call $ Log WARN cs msg + +fatal : (Show a, Eq a) => List a -> String -> Eff () [LOG a] +fatal cs msg = call $ Log FATAL cs msg + +error : (Show a, Eq a) => List a -> String -> Eff () [LOG a] +error cs msg = call $ Log ERROR cs msg + +-- --------------------------------------------------------------------- [ EOF ] diff --git a/libs/effects/Effect/Logging/Default.idr b/libs/effects/Effect/Logging/Default.idr --- a/libs/effects/Effect/Logging/Default.idr +++ b/libs/effects/Effect/Logging/Default.idr @@ -2,56 +2,117 @@ -- Module : Default.idr -- Copyright : (c) The Idris Community -- License : see LICENSE --- --------------------------------------------------------------------- [ EOH ] - -||| A logging effect that allows messages to be logged using both -||| numerical levels and user specified categories. The higher the -||| logging level the grater in verbosity the logging. +--------------------------------------------------------------------- [ EOH ] +||| The default logging effect that allows messages to be logged at +||| different numerical levels. The higher the number the greater in +||| verbosity the logging. ||| ||| In this effect the resource we are computing over is the logging -||| level itself and the list of categories to show. +||| level itself. ||| module Effect.Logging.Default import Effects import public Effect.Logging.Level -import Control.IOExcept -- TODO Add IOExcept Logger. +%access public -||| A Logging effect to log levels and categories. +-- ------------------------------------------------------------ [ The Resource ] + +||| The resource that the log effect is defined over. +record LogRes where + constructor MkLogRes + getLevel : LogLevel n + +instance Default LogRes where + default = MkLogRes OFF + +-- ------------------------------------------------------ [ The Logging Effect ] + +||| A Logging effect that displays a logging message to be logged at a +||| certain level. data Logging : Effect where - Log : (Eq a, Show a) => - (lvl : Nat) - -> (cats : List a) + ||| Change the logging level. + ||| + ||| @lvl The new logging level. + SetLvl : (lvl : LogLevel n) + -> sig Logging () (LogRes) (LogRes) + + ||| Log a message. + ||| + ||| @lvl The logging level it should appear at. + ||| @msg The message to log. + Log : (lvl : LogLevel n) -> (msg : String) - -> Logging () (Nat,List a) (\v => (Nat,List a)) + -> sig Logging () (LogRes) -||| The Logging effect. -||| -||| @cTy The type used to differentiate categories. -LOG : (cTy : Type) -> EFFECT -LOG a = MkEff (Nat, List a) Logging +-- -------------------------------------------------------------- [ IO Handler ] +-- For logging in the IO context instance Handler Logging IO where - handle (l,cs) (Log lvl cs' msg) k = do - case lvl <= l of - False => k () (l,cs) - True => do - let res = and $ map (\x => elem x cs') cs - let prompt = if isNil cs then "" else show cs - if res || isNil cs - then do - printLn $ unwords [show lvl, ":", prompt, ":", msg] - k () (l,cs) - else k () (l,cs) + handle st (SetLvl newLvl) k = k () (MkLogRes newLvl) + handle st (Log lvl msg) k = do + case cmpLevel lvl (getLevel st) of + GT => k () st + otherwise => do + putStrLn $ unwords [show lvl, ":", msg] + k () st -||| Log the given message at the given level and assign it the list of categories. +-- ------------------------------------------------------- [ Effect Descriptor ] + +||| A Logging Effect. +LOG : EFFECT +LOG = MkEff (LogRes) Logging + +-- ----------------------------------------------------------- [ Effectful API ] + +||| Set the logging level. ||| -||| @l The logging level. -||| @cs The logging categories. -||| @m THe message to be logged. -log : (Show a, Eq a) => (l : Nat) - -> (cs : List a) -> (m : String) -> Eff () [LOG a] -log lvl cs msg = call $ Log lvl cs msg +||| @l The new logging level. +setLogLvl : (l : LogLevel n) -> Eff () [LOG] +setLogLvl l = call $ SetLvl l + +||| Log `msg` at the given level specified as a natural number. +||| +||| @l The level to log. +||| @m The message to log. +log : (l : LogLevel n) -> (m : String) -> Eff () [LOG] +log l msg = call $ Log l msg + +||| Log `msg` at the given level specified as a natural number. +||| +||| @l The level to log. +||| @m The message to log. +logN : (l : Nat) -> {auto prf : LTE l 70} -> (m : String) -> Eff () [LOG] +logN l msg = call $ Log (getProof lvl) msg + where + lvl : (n ** LogLevel n) + lvl = case cast {to=String} (cast {to=Int} l) of + "0" => (_ ** OFF) + "10" => (_ ** TRACE) + "20" => (_ ** DEBUG) + "30" => (_ ** INFO) + "40" => (_ ** WARN) + "50" => (_ ** FATAL) + "60" => (_ ** ERROR) + _ => (_ ** CUSTOM l) + +trace : String -> Eff () [LOG] +trace msg = call $ Log TRACE msg + +debug : String -> Eff () [LOG] +debug msg = call $ Log DEBUG msg + +info : String -> Eff () [LOG] +info msg = call $ Log INFO msg + +warn : String -> Eff () [LOG] +warn msg = call $ Log WARN msg + +fatal : String -> Eff () [LOG] +fatal msg = call $ Log FATAL msg + +error : String -> Eff () [LOG] +error msg = call $ Log ERROR msg -- --------------------------------------------------------------------- [ EOF ] diff --git a/libs/effects/Effect/Logging/Level.idr b/libs/effects/Effect/Logging/Level.idr --- a/libs/effects/Effect/Logging/Level.idr +++ b/libs/effects/Effect/Logging/Level.idr @@ -1,49 +1,81 @@ --- -------------------------------------------------------------- [ Levels.idr ] --- Module : Levels.idr --- Copyright : (c) Jan de Muijnck-Hughes +-- --------------------------------------------------------------- [ Level.idr ] +-- Module : Level.idr +-- Copyright : (c) The Idris Community -- License : see LICENSE -- --------------------------------------------------------------------- [ EOH ] -||| Common aliases and definitions of Logging Levels. +||| A dependently typed logging level representation where logging +||| levels are based on a Natural number range [0,70]. +||| +||| The `LogLevel` type allows for semantic constructors to be used +||| for the majority of logging levels, with an option for custom +||| levels to be defined. +||| +||| The logging level design comes from the Log4j/Python family of +||| loggers. module Effect.Logging.Level %access public --- ---------------------------------------------- [ Nat Derived Logging Levels ] --- --- Several aliases have been defined to aide in semantic use of the --- logging levels. These aliases have come from the Log4j family of --- loggers. +%default total -||| No events will be logged. -OFF : Nat -OFF = 0 +-- ---------------------------------------------------- [ Log Level Definition ] -||| A severe error that will prevent the application from continuing. -FATAL : Nat -FATAL = 1 +||| Logging levels are natural numbers wrapped in a data type for +||| convenience. +||| +||| Several aliases have been defined to aide in semantic use of the +||| logging levels. These aliases have come from the Log4j/Python +||| family of loggers. +data LogLevel : Nat -> Type where + ||| Log No Events + OFF : LogLevel 0 -||| An error in the application, possibly recoverable. -ERROR : Nat -ERROR = 2 + ||| A fine-grained debug message, typically capturing the flow through + ||| the application. + TRACE : LogLevel 10 -||| An event that might possible lead to an error. -WARN : Nat -WARN = 3 + ||| A general debugging event. + DEBUG : LogLevel 20 -||| An event for informational purposes. -INFO : Nat -INFO = 4 + ||| An event for informational purposes. + INFO : LogLevel 30 -||| A general debugging event. -DEBUG : Nat -DEBUG = 5 + ||| An event that might possible lead to an error. + WARN : LogLevel 40 -||| A fine-grained debug message, typically capturing the flow through -||| the application. -TRACE : Nat -TRACE = 6 + ||| An error in the application, possibly recoverable. + ERROR : LogLevel 50 -||| All events should be logged. -ALL : Nat -ALL = 7 + ||| A severe error that will prevent the application from continuing. + FATAL : LogLevel 60 + + ||| All events should be logged. + ALL : LogLevel 70 + + ||| User defined logging level. + CUSTOM : (n : Nat) -> {auto prf : LTE n 70} -> LogLevel n + +instance Cast (LogLevel n) Nat where + cast {n} _ = n + +instance Show (LogLevel n) where + show OFF = "OFF" + show TRACE = "TRACE" + show DEBUG = "DEBUG" + show INFO = "INFO" + show WARN = "WARN" + show FATAL = "FATAL" + show ERROR = "ERROR" + show ALL = "ALL" + show (CUSTOM n) = unwords ["CUSTOM", show n] + +instance Eq (LogLevel n) where + (==) x y = lvlEq x y + where + lvlEq : LogLevel a -> LogLevel b -> Bool + lvlEq {a} {b} _ _ = a == b + +||| Compare to logging levels. +cmpLevel : LogLevel a -> LogLevel b -> Ordering +cmpLevel {a} {b} _ _ = compare a b -- --------------------------------------------------------------------- [ EOF ] diff --git a/libs/effects/Effect/Logging/Simple.idr b/libs/effects/Effect/Logging/Simple.idr deleted file mode 100644 --- a/libs/effects/Effect/Logging/Simple.idr +++ /dev/null @@ -1,48 +0,0 @@ --- -------------------------------------------------------------- [ Simple.idr ] --- Module : Logging.idr --- Copyright : (c) The Idris Community --- License : see LICENSE ---------------------------------------------------------------------- [ EOH ] - -||| A simple logging effect that allows messages to be logged at -||| different numerical level. The higher the number the grater in -||| verbosity the logging. -||| -||| In this effect the resource we are computing over is the logging -||| level itself. -||| -module Effect.Logging.Simple - -import Effects -import public Effect.Logging.Level - -import Control.IOExcept -- TODO Add IO Logging Handler - -||| A Logging effect that displays a logging message to be logged at a -||| certain level. -data Logging : Effect where - Log : (lvl : Nat) - -> (msg : String) - -> Logging () Nat (\v => Nat) - -||| A Logging Effect. -LOG : EFFECT -LOG = MkEff Nat Logging - --- For logging in the IO context -instance Handler Logging IO where - handle l (Log lvl msg) k = do - case lvl <= l of - False => k () l - True => do - printLn $ unwords [show lvl, ":", msg] - k () l - -||| Log `msg` at the given level. -||| -||| @l The level to log. -||| @m The message to log. -log : (l : Nat) -> (m : String) -> Eff () [LOG] -log lvl msg = call $ Log lvl msg - --- --------------------------------------------------------------------- [ EOF ] diff --git a/libs/effects/Effects.idr b/libs/effects/Effects.idr --- a/libs/effects/Effects.idr +++ b/libs/effects/Effects.idr @@ -25,7 +25,7 @@ MkEff : Type -> Effect -> EFFECT -- 'sig' gives the signature for an effect. There are four versions --- depending on whether there is no resource needed, +-- depending on whether there is no resource needed, -- no state change, a non-dependent change, -- or a dependent change. These are easily disambiguated by type. @@ -42,7 +42,7 @@ sig e r e_in e_out = e r e_in (\v => e_out) namespace DepUpdateEffect - sig : Effect -> + sig : Effect -> (ret : Type) -> (res_in : Type) -> (res_out : ret -> Type) -> Type sig e r e_in e_out = e r e_in e_out @@ -193,17 +193,17 @@ Eff : (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type Eff x es ce = {m : Type -> Type} -> EffM m x es (\_ => ce) - EffT : (m : Type -> Type) -> + EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type EffT m x es ce = EffM m x es (\_ => ce) namespace DepEff -- Dependent effects, updates dependent on result - Eff : (x : Type) -> (es : List EFFECT) + Eff : (x : Type) -> (es : List EFFECT) -> (ce : x -> List EFFECT) -> Type Eff x es ce = {m : Type -> Type} -> EffM m x es ce - EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) + EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) -> (ce : x -> List EFFECT) -> Type EffT m x es ce = EffM m x es ce @@ -269,7 +269,7 @@ eff env (liftP prf effP) k = let env' = dropEnv env prf in eff env' effP (\p', envk => k p' (rebuildEnv envk prf env)) -eff env (new (MkEff resTy newEff) res {prf=Refl} effP) k +eff env (new (MkEff resTy newEff) res {prf=Refl} effP) k = eff (res :: env) effP (\p', (val :: envk) => k p' envk) -- FIXME: -- xs is needed explicitly because otherwise the pattern binding for @@ -313,7 +313,7 @@ ||| ||| @prog The effectful program to run. %no_implicit -run : Applicative m => +run : Applicative m => (prog : EffM m a xs xs') -> {default MkDefaultEnv env : Env m xs} -> m a run prog {env} = eff env prog (\r, env => pure r) @@ -325,8 +325,8 @@ ||| ||| @prog The effectful program to run. %no_implicit -runPure : (prog : EffM id a xs xs') -> - {default MkDefaultEnv env : Env id xs} -> a +runPure : (prog : EffM Basics.id a xs xs') -> + {default MkDefaultEnv env : Env Basics.id xs} -> a runPure prog {env} = eff env prog (\r, env => r) ||| Run an effectful program in a given context `m` with a default value for the environment. @@ -346,7 +346,7 @@ ||| @env The environment to use. ||| @prog The effectful program to run. %no_implicit -runPureInit : (env : Env id xs) -> (prog : EffM id a xs xs') -> a +runPureInit : (env : Env Basics.id xs) -> (prog : EffM Basics.id a xs xs') -> a runPureInit env prog = eff env prog (\r, env => r) %no_implicit diff --git a/libs/effects/effects.ipkg b/libs/effects/effects.ipkg --- a/libs/effects/effects.ipkg +++ b/libs/effects/effects.ipkg @@ -16,5 +16,5 @@ , Effect.System , Effect.Trans , Effect.Logging.Level - , Effect.Logging.Simple , Effect.Logging.Default + , Effect.Logging.Category diff --git a/libs/prelude/Prelude.idr b/libs/prelude/Prelude.idr --- a/libs/prelude/Prelude.idr +++ b/libs/prelude/Prelude.idr @@ -27,6 +27,7 @@ import public Prelude.Show import public Prelude.Interactive import public Prelude.File +import public Prelude.Doubles import public Decidable.Equality import public Language.Reflection import public Language.Reflection.Errors @@ -134,10 +135,10 @@ total natEnumFromThen : Nat -> Nat -> Stream Nat natEnumFromThen n inc = n :: natEnumFromThen (inc + n) inc total natEnumFromTo : Nat -> Nat -> List Nat -natEnumFromTo n m = map (plus n) (natRange ((S m) - n)) +natEnumFromTo n m = map (plus n) (natRange (minus (S m) n)) total natEnumFromThenTo : Nat -> Nat -> Nat -> List Nat natEnumFromThenTo _ Z _ = [] -natEnumFromThenTo n (S inc) m = map (plus n . (* (S inc))) (natRange (S (divNatNZ (m - n) (S inc) SIsNotZ))) +natEnumFromThenTo n (S inc) m = map (plus n . (* (S inc))) (natRange (S (divNatNZ (minus m n) (S inc) SIsNotZ))) class Enum a where total pred : a -> a diff --git a/libs/prelude/Prelude/Cast.idr b/libs/prelude/Prelude/Cast.idr --- a/libs/prelude/Prelude/Cast.idr +++ b/libs/prelude/Prelude/Cast.idr @@ -3,7 +3,7 @@ import Prelude.Bool import public Builtins -||| Type class for transforming a instance of a data type to another type. +||| Type class for transforming an instance of a data type to another type. class Cast from to where ||| Perform a cast operation. ||| diff --git a/libs/prelude/Prelude/Chars.idr b/libs/prelude/Prelude/Chars.idr --- a/libs/prelude/Prelude/Chars.idr +++ b/libs/prelude/Prelude/Chars.idr @@ -7,16 +7,16 @@ import Prelude.Cast import Builtins -||| Return the ASCII representation of the character. +||| Convert the number to its ASCII equivalent. chr : Int -> Char -chr x = if (x >= 0 && x < 0x11000) +chr x = if (x >= 0 && x < 0x110000) then assert_total (prim__intToChar x) else '\0' instance Cast Int Char where cast = chr -||| Convert the number to its ASCII equivalent. +||| Return the ASCII representation of the character. ord : Char -> Int ord x = prim__charToInt x diff --git a/libs/prelude/Prelude/Classes.idr b/libs/prelude/Prelude/Classes.idr --- a/libs/prelude/Prelude/Classes.idr +++ b/libs/prelude/Prelude/Classes.idr @@ -71,6 +71,12 @@ GT == GT = True _ == _ = False +||| Compose two comparisons into the lexicographic product +thenCompare : Ordering -> Lazy Ordering -> Ordering +thenCompare LT y = LT +thenCompare EQ y = y +thenCompare GT y = GT + ||| The Ord class defines comparison operations on ordered data types. class Eq a => Ord a where compare : a -> a -> Ordering @@ -143,85 +149,78 @@ then compare xl yl else compare xr yr --- --------------------------------------------------------- [ Negatable Class ] -||| The `Neg` class defines unary negation (-). -class Neg a where - ||| The underlying implementation of unary minus. `-5` desugars to `negate (fromInteger 5)`. - negate : a -> a - -instance Neg Integer where - negate x = prim__subBigInt 0 x - -instance Neg Int where - negate x = prim__subInt 0 x - -instance Neg Float where - negate x = prim__negFloat x - -- --------------------------------------------------------- [ Numerical Class ] ||| The Num class defines basic numerical arithmetic. class Num a where (+) : a -> a -> a - (-) : a -> a -> a (*) : a -> a -> a - ||| Absolute value - abs : a -> a ||| Conversion from Integer. fromInteger : Integer -> a instance Num Integer where (+) = prim__addBigInt - (-) = prim__subBigInt (*) = prim__mulBigInt - abs x = if x < 0 then -x else x fromInteger = id instance Num Int where (+) = prim__addInt - (-) = prim__subInt (*) = prim__mulInt fromInteger = prim__truncBigInt_Int - abs x = if x < (prim__truncBigInt_Int 0) then -x else x instance Num Float where (+) = prim__addFloat - (-) = prim__subFloat (*) = prim__mulFloat - abs x = if x < (prim__toFloatBigInt 0) then -x else x fromInteger = prim__toFloatBigInt instance Num Bits8 where (+) = prim__addB8 - (-) = prim__subB8 (*) = prim__mulB8 - abs = id fromInteger = prim__truncBigInt_B8 instance Num Bits16 where (+) = prim__addB16 - (-) = prim__subB16 (*) = prim__mulB16 - abs = id fromInteger = prim__truncBigInt_B16 instance Num Bits32 where (+) = prim__addB32 - (-) = prim__subB32 (*) = prim__mulB32 - abs = id fromInteger = prim__truncBigInt_B32 instance Num Bits64 where (+) = prim__addB64 - (-) = prim__subB64 (*) = prim__mulB64 - abs = id fromInteger = prim__truncBigInt_B64 +-- --------------------------------------------------------- [ Negatable Class ] +||| The `Neg` class defines operations on numbers which can be negative. +class Num a => Neg a where + ||| The underlying implementation of unary minus. `-5` desugars to `negate (fromInteger 5)`. + negate : a -> a + (-) : a -> a -> a + ||| Absolute value + abs : a -> a + +instance Neg Integer where + negate x = prim__subBigInt 0 x + (-) = prim__subBigInt + abs x = if x < 0 then -x else x + +instance Neg Int where + negate x = prim__subInt 0 x + (-) = prim__subInt + abs x = if x < (prim__truncBigInt_Int 0) then -x else x + +instance Neg Float where + negate x = prim__negFloat x + (-) = prim__subFloat + abs x = if x < (prim__toFloatBigInt 0) then -x else x + +-- ------------------------------------------------------------ instance Eq Bits8 where x == y = intToBool (prim__eqB8 x y) diff --git a/libs/prelude/Prelude/Doubles.idr b/libs/prelude/Prelude/Doubles.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Doubles.idr @@ -0,0 +1,63 @@ +module Prelude.Doubles + +import Builtins +import Prelude.Classes + +%access public +%default total + +%include C "math.h" +%lib C "m" + +pi : Double +pi = 3.14159265358979323846 + +euler : Double +euler = 2.7182818284590452354 + +exp : Double -> Double +exp x = prim__floatExp x + +log : Double -> Double +log x = prim__floatLog x + +sin : Double -> Double +sin x = prim__floatSin x + +cos : Double -> Double +cos x = prim__floatCos x + +tan : Double -> Double +tan x = prim__floatTan x + +asin : Double -> Double +asin x = prim__floatASin x + +acos : Double -> Double +acos x = prim__floatACos x + +atan : Double -> Double +atan x = prim__floatATan x + +atan2 : Double -> Double -> Double +atan2 y x = atan (y/x) + +sinh : Double -> Double +sinh x = (exp x - exp (-x)) / 2 + +cosh : Double -> Double +cosh x = (exp x + exp (-x)) / 2 + +tanh : Double -> Double +tanh x = sinh x / cosh x + +sqrt : Double -> Double +sqrt x = prim__floatSqrt x + +floor : Double -> Double +floor x = prim__floatFloor x + +ceiling : Double -> Double +ceiling x = prim__floatCeil x + + diff --git a/libs/prelude/Prelude/List.idr b/libs/prelude/Prelude/List.idr --- a/libs/prelude/Prelude/List.idr +++ b/libs/prelude/Prelude/List.idr @@ -52,13 +52,12 @@ ||| The proof that a cons cell is non-empty IsNonEmpty : NonEmpty (x :: xs) -private -nonEmptyNil : NonEmpty [] -> Void -nonEmptyNil IsNonEmpty impossible +instance Uninhabited (NonEmpty []) where + uninhabited IsNonEmpty impossible ||| Decide whether a list is non-empty nonEmpty : (xs : List a) -> Dec (NonEmpty xs) -nonEmpty [] = No nonEmptyNil +nonEmpty [] = No absurd nonEmpty (x :: xs) = Yes IsNonEmpty ||| Satisfiable if `k` is a valid index into `xs` diff --git a/libs/prelude/Prelude/Nat.idr b/libs/prelude/Prelude/Nat.idr --- a/libs/prelude/Prelude/Nat.idr +++ b/libs/prelude/Prelude/Nat.idr @@ -180,6 +180,9 @@ toIntNat' Z x = x toIntNat' (S n) x = toIntNat' n (x + 1) +(-) : (m : Nat) -> (n : Nat) -> {auto smaller : LTE n m} -> Nat +(-) m n {smaller} = minus m n + -------------------------------------------------------------------------------- -- Type class instances -------------------------------------------------------------------------------- @@ -200,11 +203,8 @@ instance Num Nat where (+) = plus - (-) = minus (*) = mult - abs x = x - fromInteger = fromIntegerNat instance MinBound Nat where @@ -307,7 +307,7 @@ if lte centre right then centre else - mod' left (centre - (S right)) right + mod' left (minus centre (S right)) right partial modNat : Nat -> Nat -> Nat @@ -323,7 +323,7 @@ if lte centre right then Z else - S (div' left (centre - (S right)) right) + S (div' left (minus centre (S right)) right) partial divNat : Nat -> Nat -> Nat @@ -544,34 +544,34 @@ -- Minus total minusSuccSucc : (left : Nat) -> (right : Nat) -> - (S left) - (S right) = left - right + minus (S left) (S right) = minus left right minusSuccSucc left right = Refl -total minusZeroLeft : (right : Nat) -> 0 - right = Z +total minusZeroLeft : (right : Nat) -> minus 0 right = Z minusZeroLeft right = Refl -total minusZeroRight : (left : Nat) -> left - 0 = left +total minusZeroRight : (left : Nat) -> minus left 0 = left minusZeroRight Z = Refl minusZeroRight (S left) = Refl -total minusZeroN : (n : Nat) -> Z = n - n +total minusZeroN : (n : Nat) -> Z = minus n n minusZeroN Z = Refl minusZeroN (S n) = minusZeroN n -total minusOneSuccN : (n : Nat) -> S Z = (S n) - n +total minusOneSuccN : (n : Nat) -> S Z = minus (S n) n minusOneSuccN Z = Refl minusOneSuccN (S n) = minusOneSuccN n -total minusSuccOne : (n : Nat) -> S n - 1 = n +total minusSuccOne : (n : Nat) -> minus (S n) 1 = n minusSuccOne Z = Refl minusSuccOne (S n) = Refl -total minusPlusZero : (n : Nat) -> (m : Nat) -> n - (n + m) = Z +total minusPlusZero : (n : Nat) -> (m : Nat) -> minus n (n + m) = Z minusPlusZero Z m = Refl minusPlusZero (S n) m = minusPlusZero n m total minusMinusMinusPlus : (left : Nat) -> (centre : Nat) -> (right : Nat) -> - left - centre - right = left - (centre + right) + minus (minus left centre) right = minus left (centre + right) minusMinusMinusPlus Z Z right = Refl minusMinusMinusPlus (S left) Z right = Refl minusMinusMinusPlus Z (S centre) right = Refl @@ -581,7 +581,7 @@ Refl total plusMinusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) -> - (left + right) - (left + right') = right - right' + minus (left + right) (left + right') = minus right right' plusMinusLeftCancel Z right right' = Refl plusMinusLeftCancel (S left) right right' = let inductiveHypothesis = plusMinusLeftCancel left right right' in @@ -589,7 +589,7 @@ Refl total multDistributesOverMinusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) -> - (left - centre) * right = (left * right) - (centre * right) + (minus left centre) * right = minus (left * right) (centre * right) multDistributesOverMinusLeft Z Z right = Refl multDistributesOverMinusLeft (S left) Z right = rewrite (minusZeroRight (plus right (mult left right))) in Refl @@ -601,7 +601,7 @@ Refl total multDistributesOverMinusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) -> - left * (centre - right) = (left * centre) - (left * right) + left * (minus centre right) = minus (left * centre) (left * right) multDistributesOverMinusRight left centre right = rewrite multCommutative left (minus centre right) in rewrite multDistributesOverMinusLeft centre right left in @@ -658,7 +658,7 @@ predSucc n = Refl total minusSuccPred : (left : Nat) -> (right : Nat) -> - left - (S right) = pred (left - right) + minus left (S right) = pred (minus left right) minusSuccPred Z right = Refl minusSuccPred (S left) Z = rewrite minusZeroRight left in Refl diff --git a/libs/prelude/Prelude/Strings.idr b/libs/prelude/Prelude/Strings.idr --- a/libs/prelude/Prelude/Strings.idr +++ b/libs/prelude/Prelude/Strings.idr @@ -308,12 +308,15 @@ length = fromInteger . prim__zextInt_BigInt . prim_lenString ||| Returns a substring of a given string -||| @index The (zero based) index of the string to extract. If this is -||| beyond the end of the String, the function returns the empty string. -||| @len The desired length of the substring. Truncated if this exceeds -||| the length of the input. -substr : (index : Nat) -> (len : Nat) -> String -> String -substr i len = pack . List.take len . drop i . unpack +||| +||| @ index The (zero based) index of the string to extract. If this is +||| beyond the end of the string, the function returns the empty +||| string. +||| @ len The desired length of the substring. Truncated if this exceeds +||| the length of the input. +||| @ subject The string to return a portion of +substr : (index : Nat) -> (len : Nat) -> (subject : String) -> String +substr i len subject = prim__strSubstr (cast i) (cast len) subject ||| Lowercases all characters in the string. ||| diff --git a/libs/prelude/prelude.ipkg b/libs/prelude/prelude.ipkg --- a/libs/prelude/prelude.ipkg +++ b/libs/prelude/prelude.ipkg @@ -9,7 +9,7 @@ Prelude.Strings, Prelude.Chars, Prelude.Show, Prelude.Functor, Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream, Prelude.Uninhabited, Prelude.Pairs, Prelude.Providers, - Prelude.Interactive, Prelude.File, + Prelude.Interactive, Prelude.File, Prelude.Doubles, Language.Reflection, Language.Reflection.Errors, Language.Reflection.Elab, diff --git a/man/idris.1 b/man/idris.1 new file mode 100644 --- /dev/null +++ b/man/idris.1 @@ -0,0 +1,94 @@ +.\" Manpage for Idris. +.\" Contact <> to correct errors or typos. +.TH man 1 "06 August 2014" "0.9.14.1" "Idris man page" +.SH NAME +idris -\ a general purpose pure functional programming language with dependent types. +.SH SYNOPSIS +idris [ options] [FILES] +.SH DESCRIPTION +Idris is a general purpose pure functional programming language with +dependent types. Dependent types allow types to be predicated on +values, meaning that some aspects of a program’s behaviour can be +specified precisely in the type. It is compiled, with eager +evaluation. Its features are influenced by Haskell and ML. + ++ Full dependent types with dependent pattern matching + ++ where clauses, with rule, simple case expressions + ++ pattern matching let and lambda bindings + ++ Type classes, monad comprehensions + ++ do notation, idiom brackets + ++ syntactic conveniences for lists, tuples, dependent pairs + ++ Totality checking + ++ Coinductive types + ++ Indentation significant syntax, extensible syntax + ++ Tactic based theorem proving (influenced by Coq) + ++ Cumulative universes + ++ Simple foreign function interface (to C) + ++ Hugs style interactive environment + +It is important to note that Idris is first and foremost a research tool +and project. Thus the tooling provided and resulting programs created +should not necessarily be seen as production ready nor for industrial use. + +.SH OPTIONS + --nobanner Suppress the banner + -q,--quiet Quiet verbosity + --log LEVEL Debugging log level + -o,--output FILE Specify output file + --total Require functions to be total by default + --warnpartial Warn about undeclared partial functions + --warnreach Warn about reachable but inaccessible arguments + --link Display link flags + --libdir Display library directory + --include Display the includes flags + -V,--verbose Loud verbosity + --ibcsubdir FILE Write IBC files into sub directory + -i,--idrispath ARG Add directory to the list of import paths + --build IPKG Build package + --install IPKG Install package + --clean IPKG Clean package + --mkdoc IPKG Generate IdrisDoc for package + --checkpkg IPKG Check package only + --testpkg IPKG Run tests for package + -S,--codegenonly Do no further compilation of code generator output + -c,--compileonly Compile to object files rather than an executable + --mvn Create a maven project (for Java codegen) + --codegen TARGET Select code generator: C, Java, bytecode + -e,--eval EXPR Evaluate an expression without loading the REPL + --execute Execute as idris + --exec EXPR Execute as idris + -X,--extension EXT Turn on language extension (TypeProviders or + ErrorReflection) + --target TRIPLE Select target triple (for llvm codegen) + --cpu CPU Select target CPU e.g. corei7 or cortex-m3 (for LLVM + codegen) + --color,--colour Force coloured output + --nocolor,--nocolour Disable coloured output + -v,--version Print version information + -h,--help Show this help text +.SH SEE ALSO + ++ The IDRIS web site (http://idris-lang.org/ + ++ The IRC channel #idris, on chat.freenode.net + ++ The wiki (https://github.com/idris-lang/Idris-dev/wiki/) has further user provided information, in particular: + + – https://github.com/idris-lang/Idris-dev/wiki/Manual + + – https://github.com/idris-lang/Idris-dev/wiki/Language-Features + +.SH AUTHOR +The Idris Community diff --git a/rts/idris_rts.c b/rts/idris_rts.c --- a/rts/idris_rts.c +++ b/rts/idris_rts.c @@ -594,6 +594,17 @@ return MKINT((i_int)idx); } +VAL idris_substr(VM* vm, VAL offset, VAL length, VAL str) { + char *start = idris_utf8_advance(GETSTR(str), GETINT(offset)); + char *end = idris_utf8_advance(start, GETINT(length)); + Closure* newstr = allocate(sizeof(Closure) + (end - start) +1, 0); + SETTY(newstr, STRING); + newstr -> info.str = (char*)newstr + sizeof(Closure); + memcpy(newstr -> info.str, start, end - start); + *(newstr -> info.str + (end - start) + 1) = '\0'; + return newstr; +} + VAL idris_strRev(VM* vm, VAL str) { char *xstr = GETSTR(str); Closure* cl = allocate(sizeof(Closure) + diff --git a/rts/idris_rts.h b/rts/idris_rts.h --- a/rts/idris_rts.h +++ b/rts/idris_rts.h @@ -145,6 +145,11 @@ #define GETMPTR(x) (((VAL)(x))->info.mptr->data) #define GETFLOAT(x) (((VAL)(x))->info.f) +#define GETBITS8(x) (((VAL)(x))->info.bits8) +#define GETBITS16(x) (((VAL)(x))->info.bits16) +#define GETBITS32(x) (((VAL)(x))->info.bits32) +#define GETBITS64(x) (((VAL)(x))->info.bits64) + #define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity >> 8 : (-1)) ) #define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity & 0x000000ff : (-1)) ) @@ -309,6 +314,7 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs); VAL idris_strIndex(VM* vm, VAL str, VAL i); VAL idris_strRev(VM* vm, VAL str); +VAL idris_substr(VM* vm, VAL offset, VAL length, VAL str); // system infox // used indices: diff --git a/rts/idris_utf8.c b/rts/idris_utf8.c --- a/rts/idris_utf8.c +++ b/rts/idris_utf8.c @@ -78,6 +78,32 @@ return top; } +char* idris_utf8_advance(char* str, int i) { + while (i > 0 && *str != '\0') { + // In a UTF8 single-byte char, the highest bit is 0. In the + // first byte of a multi-byte char, the highest two bits are + // 11, but the rest of the bytes start with 10. So we can + // decrement our character counter when we see something other + // than 10 at the front. + + // This is a bit of an overapproximation, as invalid multibyte + // sequences that are too long will be treated as if they are + // OK, but it's always paying attention to null-termination. + if ((*str & 0xc0) != 0x80) { + i--; + } + str++; + } + // Now we've found the first byte of the last character. Advance + // to the end of it, or the end of the string, whichever is first. + // Here, we don't risk overrunning the end of the string because + // ('\0' & 0xc0) != 0x80. + while ((*str & 0xc0) == 0x80) { str++; } + + return str; +} + + char* idris_utf8_fromChar(int x) { char* str; int bytes = 0, top = 0; diff --git a/rts/idris_utf8.h b/rts/idris_utf8.h --- a/rts/idris_utf8.h +++ b/rts/idris_utf8.h @@ -18,5 +18,7 @@ char* idris_utf8_fromChar(int x); // Reverse a UTF8 encoded string, putting the result in 'result' char* idris_utf8_rev(char* s, char* result); - +// Advance a pointer into a string by i UTF8 characters. +// Return original pointer if i <= 0. +char* idris_utf8_advance(char* str, int i); #endif diff --git a/samples/effects/ConsoleIO.idr b/samples/effects/ConsoleIO.idr new file mode 100644 --- /dev/null +++ b/samples/effects/ConsoleIO.idr @@ -0,0 +1,15 @@ +module Main + +import Effects +import Effect.StdIO +import Effect.State + +hello : { [STATE Int, STDIO] } Eff () +hello = do putStr "Name? " + putStrLn ("Hello " ++ trim !getStr ++ "!") + update (+1) + putStrLn ("I've said hello to: " ++ show !get ++ " people") + hello + +main : IO () +main = run hello diff --git a/samples/effects/Exception.idr b/samples/effects/Exception.idr new file mode 100644 --- /dev/null +++ b/samples/effects/Exception.idr @@ -0,0 +1,21 @@ +module Main + +import Effects +import Effect.Exception +import Effect.StdIO +import Control.IOExcept + +data MyErr = NotANumber | OutOfRange + +instance Show MyErr where + show NotANumber = "Not a number" + show OutOfRange = "Out of range" + +parseNumber : Int -> String -> { [EXCEPTION MyErr] } Eff Int +parseNumber num str + = if all isDigit (unpack str) + then let x = cast str in + if (x >=0 && x <= num) + then pure x + else raise OutOfRange + else raise NotANumber diff --git a/samples/effects/Random.idr b/samples/effects/Random.idr new file mode 100644 --- /dev/null +++ b/samples/effects/Random.idr @@ -0,0 +1,37 @@ +module Main + +import Effects +import Effect.Random +import Effect.Exception +import Effect.StdIO + +data MyErr = NotANumber | OutOfRange + +parseNumber : Int -> String -> { [EXCEPTION MyErr] } Eff Int +parseNumber num str + = if all isDigit (unpack str) + then let x = cast str in + if (x >=0 && x <= num) + then pure x + else raise OutOfRange + else raise NotANumber + +guess : Int -> { [STDIO] } Eff () +guess target + = do putStr "Guess: " + case run {m=Maybe} (parseNumber 100 (trim !getStr)) of + Nothing => do putStrLn "Invalid input" + guess target + Just v => case compare v target of + LT => do putStrLn "Too low" + guess target + EQ => putStrLn "You win!" + GT => do putStrLn "Too high" + guess target + +game : { [RND, STDIO] } Eff () +game = do srand 123456789 + guess (fromInteger !(rndInt 0 100)) + +main : IO () +main = run game diff --git a/samples/effects/ReadInt.idr b/samples/effects/ReadInt.idr new file mode 100644 --- /dev/null +++ b/samples/effects/ReadInt.idr @@ -0,0 +1,22 @@ +module ReadInt + +import Effects +import Effect.State +import Effect.StdIO + +readInt : { [STATE (Vect n Int), STDIO] ==> + {ok} if ok then [STATE (Vect (S n) Int), STDIO] + else [STATE (Vect n Int), STDIO] } Eff Bool +readInt = do let x = trim !getStr + case all isDigit (unpack x) of + False => pure False + True => do updateM (\xs => cast x ::xs) + pure True + +readN : (n : Nat) -> + { [STATE (Vect m Int), STDIO] ==> + [STATE (Vect (n + m) Int), STDIO] } Eff () +readN Z = pure () +readN {m} (S k) = case !readInt of + True => rewrite plusSuccRightSucc k m in readN k + False => readN (S k) diff --git a/samples/effects/Select.idr b/samples/effects/Select.idr new file mode 100644 --- /dev/null +++ b/samples/effects/Select.idr @@ -0,0 +1,17 @@ +module Main + +import Effects +import Effect.Select +import Effect.Exception + +triple : Int -> { [SELECT, EXCEPTION String] } Eff (Int, Int, Int) +triple max = do z <- select [1..max] + y <- select [1..z] + x <- select [1..y] + if (x * x + y * y == z * z) + then pure (x, y, z) + else raise "No triple" + +main : IO () +main = do print $ the (Maybe _) $ run (triple 100) + print $ the (List _) $ run (triple 100) diff --git a/samples/effects/TreeTag-noeff.idr b/samples/effects/TreeTag-noeff.idr new file mode 100644 --- /dev/null +++ b/samples/effects/TreeTag-noeff.idr @@ -0,0 +1,21 @@ + +data BTree a = Leaf + | Node (BTree a) a (BTree a) + +testTree : BTree String +testTree = Node (Node Leaf "Jim" Leaf) + "Fred" + (Node (Node Leaf "Alice" Leaf) + "Sheila" + (Node Leaf "Bob" Leaf)) + +treeTagAux : (i : Int) -> BTree a -> (Int, BTree (Int, a)) +treeTagAux i Leaf = (i, Leaf) +treeTagAux i (Node l x r) + = let (i', l') = treeTagAux i l in + let x' = (i', x) in + let (i'', r') = treeTagAux (i' + 1) r in + (i'', Node l' x' r') + +treeTag : (i : Int) -> BTree a -> BTree (Int, a) +treeTag i x = snd (treeTagAux i x) diff --git a/samples/effects/TreeTag.idr b/samples/effects/TreeTag.idr new file mode 100644 --- /dev/null +++ b/samples/effects/TreeTag.idr @@ -0,0 +1,40 @@ +module Main + +import Effects +import Effect.State + +data BTree a = Leaf + | Node (BTree a) a (BTree a) + +instance Show a => Show (BTree a) where + show Leaf = "[]" + show (Node l x r) = "[" ++ show l ++ " " + ++ show x ++ " " + ++ show r ++ "]" + +testTree : BTree String +testTree = Node (Node Leaf "Jim" Leaf) + "Fred" + (Node (Node Leaf "Alice" Leaf) + "Sheila" + (Node Leaf "Bob" Leaf)) + +treeTagAux : BTree a -> { [STATE Int] } Eff (BTree (Int, a)) +treeTagAux Leaf = return Leaf +treeTagAux (Node l x r) + = do l' <- treeTagAux l + i <- get + put (i + 1) + r' <- treeTagAux r + return (Node l' (i, x) r') + +treeTag : (i : Int) -> BTree a -> BTree (Int, a) +treeTag i x = runPure (do put i + treeTagAux x) + +treeTagIO : (i : Int) -> BTree a -> IO (BTree (Int, a)) +treeTagIO i x = run (do put i + treeTagAux x) + +main : IO () +main = print (treeTag 1 testTree) diff --git a/samples/effects/TreeTagCount.idr b/samples/effects/TreeTagCount.idr new file mode 100644 --- /dev/null +++ b/samples/effects/TreeTagCount.idr @@ -0,0 +1,29 @@ +import Effects +import Effect.State +import Effect.StdIO + +data BTree a = Leaf + | Node (BTree a) a (BTree a) + +testTree : BTree String +testTree = Node (Node Leaf "Jim" Leaf) + "Fred" + (Node (Node Leaf "Alice" Leaf) + "Sheila" + (Node Leaf "Bob" Leaf)) + +treeTagAux : BTree a -> { ['Tag ::: STATE Int, + 'Leaves ::: STATE Int] } Eff (BTree (Int, a)) +treeTagAux Leaf = do 'Leaves :- update (+1) + pure Leaf +treeTagAux (Node l x r) + = do l' <- treeTagAux l + i <- 'Tag :- get + 'Tag :- put (i + 1) + r' <- treeTagAux r + pure (Node l' (i, x) r') + +treeTag : (i : Int) -> BTree a -> (BTree (Int, a), Int) +treeTag i x = runPureInit ['Tag := i, 'Leaves := 0] + (do x' <- treeTagAux x + pure (x', !('Leaves :- get))) diff --git a/samples/effects/hworld.idr b/samples/effects/hworld.idr new file mode 100644 --- /dev/null +++ b/samples/effects/hworld.idr @@ -0,0 +1,10 @@ +module Main + +import Effects +import Effect.StdIO + +hello : { [STDIO] } Eff () +hello = putStrLn "Hello world!" + +main : IO () +main = run hello diff --git a/samples/effects/vadd.idr b/samples/effects/vadd.idr new file mode 100644 --- /dev/null +++ b/samples/effects/vadd.idr @@ -0,0 +1,41 @@ +module Main + +import Effects +import Effect.Exception +import Effect.StdIO + +parseNumber : String -> { [EXCEPTION String] } Eff Int +parseNumber str + = if all (\x => isDigit x || x == '-') (unpack str) + then pure (cast str) + else raise "Not a number" + +vadd : Vect n Int -> Vect n Int -> Vect n Int +vadd [] [] = [] +vadd (x :: xs) (y :: ys) = x + y :: vadd xs ys + +vadd_check : Vect n Int -> Vect m Int -> + { [EXCEPTION String] } Eff (Vect m Int) +vadd_check {n} {m} xs ys with (decEq n m) + vadd_check {n} {m=n} xs ys | (Yes Refl) = pure (vadd xs ys) + vadd_check {n} {m} xs ys | (No _) = raise "Length mismatch" + +read_vec : { [STDIO] } Eff (p ** Vect p Int) +read_vec = do putStr "Number (-1 when done): " + case run {m=Maybe} (parseNumber (trim !getStr)) of + Nothing => do putStrLn "Input error" + read_vec + Just v => if (v /= -1) + then do (_ ** xs) <- read_vec + pure (_ ** v :: xs) + else pure (_ ** []) + +do_vadd : { [STDIO, EXCEPTION String] } Eff () +do_vadd = do putStrLn "Vector 1" + (_ ** xs) <- read_vec + putStrLn "Vector 2" + (_ ** ys) <- read_vec + putStrLn (show !(vadd_check xs ys)) + +main : IO () +main = run do_vadd diff --git a/samples/misc/binary.idr b/samples/misc/binary.idr new file mode 100644 --- /dev/null +++ b/samples/misc/binary.idr @@ -0,0 +1,94 @@ +module main + +data Bit : Nat -> Type where + b0 : Bit 0 + b1 : Bit 1 + +instance Show (Bit n) where + show b0 = "0" + show b1 = "1" + +infixl 5 # + +data Binary : (width : Nat) -> (value : Nat) -> Type where + zero : Binary Z Z + (#) : Binary w v -> Bit bit -> Binary (S w) (bit + 2 * v) + +instance Show (Binary w k) where + show zero = "" + show (bin # bit) = show bin ++ show bit + +pattern syntax bitpair [x] [y] = (_ ** (_ ** (x, y, _))) +term syntax bitpair [x] [y] = (_ ** (_ ** (x, y, Refl))) + +addBit : Bit x -> Bit y -> Bit c -> + (bx ** (by ** (Bit bx, Bit by, c + x + y = by + 2 * bx))) +addBit b0 b0 b0 = bitpair b0 b0 +addBit b0 b0 b1 = bitpair b0 b1 +addBit b0 b1 b0 = bitpair b0 b1 +addBit b0 b1 b1 = bitpair b1 b0 +addBit b1 b0 b0 = bitpair b0 b1 +addBit b1 b0 b1 = bitpair b1 b0 +addBit b1 b1 b0 = bitpair b1 b0 +addBit b1 b1 b1 = bitpair b1 b1 + +adc : Binary w x -> Binary w y -> Bit c -> Binary (S w) (c + x + y) +adc zero zero carry ?= zero # carry +adc (numx # bx) (numy # by) carry + ?= let (bitpair carry0 lsb) = addBit bx by carry in + adc numx numy carry0 # lsb + +main : IO () +main = do let n1 = zero # b1 # b0 # b1 # b0 + let n2 = zero # b1 # b1 # b1 # b0 + print (adc n1 n2 b0) + + + + + + + + + +---------- Proofs ---------- + +-- There is almost certainly an easier proof. I don't care, for now :) + +main.adc_lemma_2 = proof { + intro c,w,v,bit0,num0; + intro b0,v1,bit1,num1,b1; + intro bc,x,x1,bx,bx1,prf; + intro; + rewrite sym (plusZeroRightNeutral v); + rewrite sym (plusZeroRightNeutral v1); + rewrite sym (plusAssociative (plus c (plus bit0 (plus v v))) bit1 (plus v1 v1)); + rewrite (plusAssociative c (plus bit0 (plus v v)) bit1); + rewrite (plusAssociative bit0 (plus v v) bit1); + rewrite sym (plusCommutative (plus v v) bit1); + rewrite sym (plusAssociative c bit0 (plus bit1 (plus v v))); + rewrite sym (plusAssociative (plus c bit0) bit1 (plus v v)); + rewrite sym prf; + rewrite sym (plusZeroRightNeutral x); + rewrite plusAssociative x1 (plus x x) (plus v v); + rewrite plusAssociative x x (plus v v); + rewrite sym (plusAssociative x v v); + rewrite plusCommutative v (plus x v); + rewrite sym (plusAssociative x v (plus x v)); + rewrite plusAssociative x1 (plus (plus x v) (plus x v)) (plus v1 v1); + rewrite plusAssociative (plus x v) (plus x v) (plus v1 v1); + rewrite plusAssociative x v (plus v1 v1); + rewrite sym (plusAssociative v v1 v1); + rewrite sym (plusAssociative x (plus v v1) v1); + rewrite sym (plusAssociative x v v1); + rewrite sym (plusCommutative (plus (plus x v) v1) v1); + rewrite plusZeroRightNeutral (plus (plus x v) v1); + rewrite sym (plusAssociative (plus x v) v1 (plus (plus (plus x v) v1) Z)); + trivial; +} + +main.adc_lemma_1 = proof { + intros; + rewrite sym (plusZeroRightNeutral c) ; + trivial; +} diff --git a/samples/misc/interp-alt.idr b/samples/misc/interp-alt.idr new file mode 100644 --- /dev/null +++ b/samples/misc/interp-alt.idr @@ -0,0 +1,81 @@ +module main + +data Ty = TyInt | TyBool| TyFun Ty Ty + +interpTy : Ty -> Type +interpTy TyInt = Int +interpTy TyBool = Bool +interpTy (TyFun s t) = interpTy s -> interpTy t + +using (G : Vect n Ty) + + data Env : Vect n Ty -> Type where + Nil : Env Nil + (::) : interpTy a -> Env G -> Env (a :: G) + +-- data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where +-- stop : HasType FZ (t :: G) t +-- pop : HasType k G t -> HasType (FS k) (u :: G) t + + lookup : (i:Fin n) -> Env G -> interpTy (index i G) + lookup FZ (x :: xs) = x + lookup (FS i) (x :: xs) = lookup i xs + + data Expr : Vect n Ty -> Ty -> Type where + Var : (i : Fin n) -> Expr G (index i G) + Val : (x : Int) -> Expr G TyInt + Lam : Expr (a :: G) t -> Expr G (TyFun a t) + App : Expr G (TyFun a t) -> Expr G a -> Expr G t + Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> + Expr G c + If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a + Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b + + interp : Env G -> {static} Expr G t -> interpTy t + interp env (Var i) = lookup i env + interp env (Val x) = x + interp env (Lam sc) = \x => interp (x :: env) sc + interp env (App f s) = (interp env f) (interp env s) + interp env (Op op x y) = op (interp env x) (interp env y) + interp env (If x t e) = if (interp env x) then (interp env t) else (interp env e) + interp env (Bind v f) = interp env (f (interp env v)) + + eId : Expr G (TyFun TyInt TyInt) + eId = Lam (Var FZ) + + eTEST : Expr G (TyFun TyInt (TyFun TyInt TyInt)) + eTEST = Lam (Lam (Var (FS FZ))) + + eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt)) + eAdd = Lam (Lam (Op prim__addInt (Var FZ) (Var (FS FZ)))) + +-- eDouble : Expr G (TyFun TyInt TyInt) +-- eDouble = Lam (App (App (Lam (Lam (Op' (+) (Var FZ) (Var (FS FZ))))) (Var FZ)) (Var FZ)) + + eDouble : Expr G (TyFun TyInt TyInt) + eDouble = Lam (App (App eAdd (Var FZ)) (Var FZ)) + + app : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t + app = \f, a => App f a + + eFac : Expr G (TyFun TyInt TyInt) + eFac = Lam (If (Op (==) (Var FZ) (Val 0)) + (Val 1) (Op (*) (app eFac (Op (-) (Var FZ) (Val 1))) (Var FZ))) + + -- Exercise elaborator: Complicated way of doing \x y => x*4 + y*2 + + eProg : Expr G (TyFun TyInt (TyFun TyInt TyInt)) + eProg = Lam (Lam (Bind (App eDouble (Var (FS FZ))) + (\x => Bind (App eDouble (Var FZ)) + (\y => Bind (App eDouble (Val x)) + (\z => App (App eAdd (Val y)) (Val z)))))) + +test : Int +test = interp [] eProg 2 2 + +testFac : Int +testFac = interp [] eFac 4 + +main : IO () +main = do printLn test + printLn testFac diff --git a/samples/misc/interp.idr b/samples/misc/interp.idr new file mode 100644 --- /dev/null +++ b/samples/misc/interp.idr @@ -0,0 +1,91 @@ +module Main + +data Ty = TyInt | TyBool | TyFun Ty Ty + +interpTy : Ty -> Type +interpTy TyInt = Int +interpTy TyBool = Bool +interpTy (TyFun s t) = interpTy s -> interpTy t + +using (G : Vect n Ty) + + data Env : Vect n Ty -> Type where + Nil : Env Nil + (::) : interpTy a -> Env G -> Env (a :: G) + + data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where + stop : HasType FZ (t :: G) t + pop : HasType k G t -> HasType (FS k) (u :: G) t + + lookup : HasType i G t -> Env G -> interpTy t + lookup stop (x :: xs) = x + lookup (pop k) (x :: xs) = lookup k xs + + data Expr : Vect n Ty -> Ty -> Type where + Var : HasType i G t -> Expr G t + Val : (x : Int) -> Expr G TyInt + Lam : Expr (a :: G) t -> Expr G (TyFun a t) + App : Expr G (TyFun a t) -> Expr G a -> Expr G t + Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> + Expr G c + If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a + Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b + + dsl expr + lambda = Lam + variable = Var + index_first = stop + index_next = pop + + (<*>) : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t + (<*>) = \f, a => App f a + + pure : Expr G a -> Expr G a + pure = id + + syntax IF [x] THEN [t] ELSE [e] = If x t e + + (==) : Expr G TyInt -> Expr G TyInt -> Expr G TyBool + (==) = Op (==) + + (<) : Expr G TyInt -> Expr G TyInt -> Expr G TyBool + (<) = Op (<) + + instance Num (Expr G TyInt) where + (+) x y = Op (+) x y + (-) x y = Op (-) x y + (*) x y = Op (*) x y + + abs x = IF (x < 0) THEN (-x) ELSE x + + fromInteger = Val . fromInteger + + interp : Env G -> {static} Expr G t -> interpTy t + interp env (Var i) = lookup i env + interp env (Val x) = x + interp env (Lam sc) = \x => interp (x :: env) sc + interp env (App f s) = (interp env f) (interp env s) + interp env (Op op x y) = op (interp env x) (interp env y) + interp env (If x t e) = if (interp env x) then (interp env t) else (interp env e) + interp env (Bind v f) = interp env (f (interp env v)) + + eId : Expr G (TyFun TyInt TyInt) + eId = expr (\x => x) + + eTEST : Expr G (TyFun TyInt (TyFun TyInt TyInt)) + eTEST = expr (\x, y => y) + + eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt)) + eAdd = expr (\x, y => Op (+) x y) + + eDouble : Expr G (TyFun TyInt TyInt) + eDouble = expr (\x => App (App eAdd x) (Var stop)) + + eFac : Expr G (TyFun TyInt TyInt) + eFac = expr (\x => IF x == 0 THEN 1 ELSE [| eFac (x - 1) |] * x) + +testFac : Int +testFac = interp [] eFac 4 + +main : IO () +main = printLn testFac diff --git a/samples/misc/javaffi.idr b/samples/misc/javaffi.idr new file mode 100644 --- /dev/null +++ b/samples/misc/javaffi.idr @@ -0,0 +1,12 @@ +module Main + +%include Java "com.google.common.math.IntMath" +%lib Java "com.google.guava:guava:14.0" + +binom : Int -> Int -> IO Int +binom n k = mkForeign (FFun "IntMath.binomial" [FInt, FInt] FInt) n k + +main : IO () +main = do print "The number of possibilities in lotto is 49 choose 6:" + res <- binom 49 6 + printLn res diff --git a/samples/misc/named_instance.lidr b/samples/misc/named_instance.lidr new file mode 100644 --- /dev/null +++ b/samples/misc/named_instance.lidr @@ -0,0 +1,36 @@ +> module MyOrd + +An alternative Ord instance for Nats, with an explicit name "myord" +for the dictionary: + +> instance [myord] Ord Nat where +> compare O (S n) = GT +> compare (S n) O = LT +> compare O O = EQ + +The @{name} syntax below gives an explicit dictionary for the compare function. +Here, we're telling it to use the "myord" dictionary. Otherwise, it'd just +use the default (unnamed) instance. Note that there can only be one unnamed +instance --- they must not overlap. + +> compare (S x) (S y) = compare @{myord} x y + +> foo : List Nat +> foo = [1,4,2,8,3,7,5,6] + +Sort foo using the default comparison operator: + +> test1 : List Nat +> test1 = sort foo + +-- which gives [1,2,3,4,5,6,7,8] + +Sort foo using the alternative instance. No need for 'sortBy' and other +such functions. Hoorah! + +> test2 : List Nat +> test2 = sort @{myord} foo + +-- which gives [8,7,6,5,4,3,2,1] + + diff --git a/samples/misc/reflection.idr b/samples/misc/reflection.idr new file mode 100644 --- /dev/null +++ b/samples/misc/reflection.idr @@ -0,0 +1,151 @@ +module ReflectionExamples + +import Language.Reflection + +||| The reflected term for (\ x => reverse "bba") +reflectVal : TT +reflectVal = ?valPrf + +||| intEq for the integers 3 and 3 +applyTac1 : Int +applyTac1 = ?tacPrf1 + +||| intEq for the integers 3 and 42 +applyTac0 : Int +applyTac0 = ?tacPrf0 + +||| intEq for the two arguments +applyTacDyn : Int -> Int -> Int +applyTacDyn x y = ?tacPrfDyn + +||| Restored version for RConstant (I 42) +fill : Int +fill = ?fillPrf + +||| The type (TTName, TT) computed from its reflected raw rep. +envTuple : Type +envTuple = ?envTuplePrf + +||| The type List (TTName, TT) computed from its reflected raw rep. +envList : List (TTName, TT) +envList = ?envListPrf + +||| Reflected raw rep. for the type (TTName, TT) +tupleType : Raw +tupleType = RApp (RApp (Var (UN "Pair")) + (Var (NS (UN "TTName") ["Reflection", "Language"]))) + (Var (NS (UN "TT") ["Reflection", "Language"])) + +||| Reflected raw rep for the type List (TTName, TT) +mkTuple : Raw +mkTuple = RApp (RApp (Var (UN "MkPair")) + (Var (NS (UN "TTName") ["Reflection", "Language"]))) + (Var (NS (UN "TT") ["Reflection", "Language"])) + +||| Reflected raw rep for Prelude.List.Nil +nil : Raw +nil = (Var (NS (UN "Nil") ["List", "Prelude"])) + +||| Reflected raw rep for Prelude.List.:: +cons : Raw +cons = (Var (NS (UN "::") ["List", "Prelude"])) + +||| 1 if the two arguments are equal, 0 otherwise +||| This function is chosen as simple as possible for +||| demo purposes. +intEq : Int -> Int -> Int +intEq x y = case x == y of + True => 1 + False => 0 + +||| A tactic script to run intEq on two let-bound or introduced +||| arguments of the current (otherwise empty) proof context +firstEq : List (TTName, Binder TT) -> TT -> Tactic +firstEq ((_, (Let _ y))::(_, (Let _ x))::(_, Let _ f)::Nil) _ = Exact (App (App f x) y) +firstEq ((y, Lam yt)::(x, Lam xt)::(_, Let _ f)::Nil) _ = Exact (App (App f (P (Bound) x xt)) (P Bound y yt)) +firstEq xs _ = Exact (TConst (I 0)) + +||| Skip 1 argument of the proof context and return the second one which +||| has to be introduced. Used for the tactical dispatch example, which +||| will push dispatch, as first env agrument. +innerTac : List (TTName, Binder TT) -> TT -> Tactic +innerTac (_::(x, Lam xt)::_) _ = Exact (P Bound x xt) + +||| Returns the reflected representation of innerTac +innerTacTT : TT +innerTacTT = ?innerTacTTPrf + +||| Dispatch to the reflected rep. of innerTac +dispatch : List (TTName, Binder TT) -> TT -> Tactic +dispatch xs _ = ApplyTactic (innerTacTT) + +||| Call dispatch which will then dispatch to innerTac. +tacticalDispatch : Int -> Int +tacticalDispatch = ?tacticalDispatchPrf + +||| A tactic to get the representation of its goal +studyGoalTac : List (TTName, Binder TT) -> TT -> Tactic +studyGoalTac _ goal = Reflect goal + +||| Returns the representation of its goal, TT +||| (so this is reflect on the type TT) +studyGoal : TT +studyGoal = ?studyGoalPrf + +---------- Proofs ---------- + +ReflectionExamples.studyGoalPrf = proof { + applyTactic studyGoalTac; +} + +ReflectionExamples.envTuplePrf = proof { + let x = tupleType; + fill x; +} + +ReflectionExamples.envListPrf = proof { + let x : Raw = RApp nil tupleType; + fill x; +} + + +ReflectionExamples.valPrf = proof { + let x : (List String -> String) = (\ x => reverse "bba"); + reflect x; +} + + +ReflectionExamples.tacPrf1 = proof { + let f : (Int -> Int -> Int) = intEq; + let x : Int = 3; + let y : Int = 3; + applyTactic firstEq; +} + +ReflectionExamples.tacPrf0 = proof { + let f : (Int -> Int -> Int) = intEq; + let x : Int = 3; + let y : Int = 42; + applyTactic firstEq; +} + +ReflectionExamples.tacPrfDyn = proof { + let f : (Int -> Int -> Int) = intEq; + intros; + applyTactic firstEq; +} + +ReflectionExamples.fillPrf = proof { + let x : Raw = RConstant (I 42); + fill x; +} + +ReflectionExamples.innerTacTTPrf = proof { + reflect innerTac; +} + +ReflectionExamples.tacticalDispatchPrf = proof { + intros; + applyTactic dispatch; +} + diff --git a/samples/tutorial/binary.idr b/samples/tutorial/binary.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/binary.idr @@ -0,0 +1,61 @@ +module Main + +data Binary : Nat -> Type where + bEnd : Binary Z + bO : Binary n -> Binary (n + n) + bI : Binary n -> Binary (S (n + n)) + +instance Show (Binary n) where + show (bO x) = show x ++ "0" + show (bI x) = show x ++ "1" + show bEnd = "" + +data Parity : Nat -> Type where + Even : Parity (n + n) + Odd : Parity (S (n + n)) + +parity : (n:Nat) -> Parity n +parity Z = Even {n=Z} +parity (S Z) = Odd {n=Z} +parity (S (S k)) with (parity k) + parity (S (S (j + j))) | Even ?= Even {n=S j} + parity (S (S (S (j + j)))) | Odd ?= Odd {n=S j} + +natToBin : (n:Nat) -> Binary n +natToBin Z = bEnd +natToBin (S k) with (parity k) + natToBin (S (j + j)) | Even = bI (natToBin j) + natToBin (S (S (j + j))) | Odd ?= bO (natToBin (S j)) + +intToNat : Int -> Nat +intToNat 0 = Z +intToNat x = if (x>0) then (S (intToNat (x-1))) else Z + +main : IO () +main = do putStr "Enter a number: " + x <- getLine + print (natToBin (fromInteger (cast x))) + +---------- Proofs ---------- + +Main.natToBin_lemma_1 = proof + intros + rewrite plusSuccRightSucc j j + rewrite sym (plusSuccRightSucc j j) + trivial + + +parity_lemma_1 = proof + intros + rewrite sym (plusSuccRightSucc j j) + trivial + + +parity_lemma_2 = proof { + intro; + intro; + rewrite sym (plusSuccRightSucc j j); + trivial; +} + + diff --git a/samples/tutorial/bmain.idr b/samples/tutorial/bmain.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/bmain.idr @@ -0,0 +1,8 @@ +module Main + +import btree + +main : IO () +main = do let t = toTree [1,8,2,7,9,3] + print (btree.toList t) + diff --git a/samples/tutorial/btree.idr b/samples/tutorial/btree.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/btree.idr @@ -0,0 +1,18 @@ +module btree + +data BTree a = Leaf + | Node (BTree a) a (BTree a) + +insert : Ord a => a -> BTree a -> BTree a +insert x Leaf = Node Leaf x Leaf +insert x (Node l v r) = if (x < v) then (Node (insert x l) v r) + else (Node l v (insert x r)) + +toList : BTree a -> List a +toList Leaf = [] +toList (Node l v r) = btree.toList l ++ (v :: btree.toList r) + +toTree : Ord a => List a -> BTree a +toTree [] = Leaf +toTree (x :: xs) = insert x (toTree xs) + diff --git a/samples/tutorial/btreemod.idr b/samples/tutorial/btreemod.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/btreemod.idr @@ -0,0 +1,20 @@ +module btree + +abstract data BTree a = Leaf + | Node (BTree a) a (BTree a) + +abstract +insert : Ord a => a -> BTree a -> BTree a +insert x Leaf = Node Leaf x Leaf +insert x (Node l v r) = if (x < v) then (Node (insert x l) v r) + else (Node l v (insert x r)) + +abstract +toList : BTree a -> List a +toList Leaf = [] +toList (Node l v r) = btree.toList l ++ (v :: btree.toList r) + +abstract +toTree : Ord a => List a -> BTree a +toTree [] = Leaf +toTree (x :: xs) = insert x (toTree xs) diff --git a/samples/tutorial/classes.idr b/samples/tutorial/classes.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/classes.idr @@ -0,0 +1,10 @@ +m_add : Maybe Int -> Maybe Int -> Maybe Int +m_add x y = do x' <- x -- Extract value from x + y' <- y -- Extract value from y + return (x' + y') -- Add them + +m_add' : Maybe Int -> Maybe Int -> Maybe Int +m_add' x y = [ x' + y' | x' <- x, y' <- y ] + +sortAndShow : (Ord a, Show a) => List a -> String +sortAndShow xs = show (sort xs) diff --git a/samples/tutorial/foo.idr b/samples/tutorial/foo.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/foo.idr @@ -0,0 +1,10 @@ +module foo + +namespace x + test : Int -> Int + test x = x * 2 + +namespace y + test : String -> String + test x = x ++ x + diff --git a/samples/tutorial/hello.idr b/samples/tutorial/hello.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/hello.idr @@ -0,0 +1,5 @@ +module Main + +main : IO () +main = putStrLn "Hello world" + diff --git a/samples/tutorial/idiom.idr b/samples/tutorial/idiom.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/idiom.idr @@ -0,0 +1,38 @@ +module idiom + +data Expr = Var String + | Val Int + | Add Expr Expr + +data Eval : Type -> Type where + MkEval : (List (String, Int) -> Maybe a) -> Eval a + +fetch : String -> Eval Int +fetch x = MkEval fetchVal where + fetchVal : List (String, Int) -> Maybe Int + fetchVal [] = Nothing + fetchVal ((v, val) :: xs) = if (x == v) then (Just val) else (fetchVal xs) + +instance Functor Eval where + map f (MkEval g) = MkEval (\e => map f (g e)) + +instance Applicative Eval where + pure x = MkEval (\e => Just x) + + (<*>) (MkEval f) (MkEval g) = MkEval (\x => app (f x) (g x)) where + app : Maybe (a -> b) -> Maybe a -> Maybe b + app (Just fx) (Just gx) = Just (fx gx) + app _ _ = Nothing + +eval : Expr -> Eval Int +eval (Var x) = fetch x +eval (Val x) = [| x |] +eval (Add x y) = [| eval x + eval y |] + +runEval : List (String, Int) -> Expr -> Maybe Int +runEval env e = case eval e of + MkEval envFn => envFn env + +m_add' : Maybe Int -> Maybe Int -> Maybe Int +m_add' x y = [| x + y |] + diff --git a/samples/tutorial/interp.idr b/samples/tutorial/interp.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/interp.idr @@ -0,0 +1,71 @@ +module Main + +import Data.Vect +import Data.Fin + +data Ty = TyInt | TyBool| TyFun Ty Ty + +interpTy : Ty -> Type +interpTy TyInt = Int +interpTy TyBool = Bool +interpTy (TyFun s t) = interpTy s -> interpTy t + +using (G : Vect n Ty) + + data Env : Vect n Ty -> Type where + Nil : Env Nil + (::) : interpTy a -> Env G -> Env (a :: G) + + data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where + Stop : HasType FZ (t :: G) t + Pop : HasType k G t -> HasType (FS k) (u :: G) t + + lookup : HasType i G t -> Env G -> interpTy t + lookup Stop (x :: xs) = x + lookup (Pop k) (x :: xs) = lookup k xs + + data Expr : Vect n Ty -> Ty -> Type where + Var : HasType i G t -> Expr G t + Val : (x : Int) -> Expr G TyInt + Lam : Expr (a :: G) t -> Expr G (TyFun a t) + App : Expr G (TyFun a t) -> Expr G a -> Expr G t + Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> + Expr G c + If : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a + + interp : Env G -> [static] (e : Expr G t) -> interpTy t + interp env (Var i) = lookup i env + interp env (Val x) = x + interp env (Lam sc) = \x => interp (x :: env) sc + interp env (App f s) = interp env f (interp env s) + interp env (Op op x y) = op (interp env x) (interp env y) + interp env (If x t e) = if interp env x then interp env t + else interp env e + + eId : Expr G (TyFun TyInt TyInt) + eId = Lam (Var Stop) + + eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt)) + eAdd = Lam (Lam (Op (+) (Var Stop) (Var (Pop Stop)))) + + eEq : Expr G (TyFun TyInt (TyFun TyInt TyBool)) + eEq = Lam (Lam (Op (==) (Var Stop) (Var (Pop Stop)))) + + eDouble : Expr G (TyFun TyInt TyInt) + eDouble = Lam (App (App eAdd (Var Stop)) (Var Stop)) + + fact : Expr G (TyFun TyInt TyInt) + fact = Lam (If (Op (==) (Var Stop) (Val 0)) + (Val 1) (Op (*) (App fact (Op (-) (Var Stop) (Val 1))) (Var Stop))) + +testFac : Int +testFac = interp [] fact 4 + +-- unitTestFac : so (interp [] fact 4 == 24) +-- unitTestFac = oh + +main : IO () +main = do putStr "Enter a number: " + x <- getLine + print (interp [] fact (cast x)) + diff --git a/samples/tutorial/letbind.idr b/samples/tutorial/letbind.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/letbind.idr @@ -0,0 +1,16 @@ +module letbind + +mirror : List a -> List a +mirror xs = let xs' = reverse xs in + xs ++ xs' + +data Person = MkPerson String Int + +showPerson : Person -> String +showPerson p = let MkPerson name age = p in + name ++ " is " ++ show age ++ " years old" + +splitAt : Char -> String -> (String, String) +splitAt c x = case break (== c) x of + (x, y) => (x, strTail y) + diff --git a/samples/tutorial/prims.idr b/samples/tutorial/prims.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/prims.idr @@ -0,0 +1,14 @@ +module prims + +x : Int +x = 42 + +foo : String +foo = "Sausage machine" + +bar : Char +bar = 'Z' + +quux : Bool +quux = False + diff --git a/samples/tutorial/theorems.idr b/samples/tutorial/theorems.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/theorems.idr @@ -0,0 +1,57 @@ + +fiveIsFive : 5 = 5 +fiveIsFive = Refl + +twoPlusTwo : 2 + 2 = 4 +twoPlusTwo = Refl + +total disjoint : (n : Nat) -> Z = S n -> Void +disjoint n p = replace {P = disjointTy} p () + where + disjointTy : Nat -> Type + disjointTy Z = () + disjointTy (S k) = Void + +total acyclic : (n : Nat) -> n = S n -> Void +acyclic Z p = disjoint _ p +acyclic (S k) p = acyclic k (succInjective _ _ p) + +empty1 : Void +empty1 = hd [] where + hd : List a -> a + hd (x :: xs) = x + +empty2 : Void +empty2 = empty2 + +plusReduces : (n:Nat) -> plus Z n = n +plusReduces n = Refl + +plusReducesZ : (n:Nat) -> n = plus n Z +plusReducesZ Z = Refl +plusReducesZ (S k) = cong (plusReducesZ k) + +plusReducesS : (n:Nat) -> (m:Nat) -> S (plus n m) = plus n (S m) +plusReducesS Z m = Refl +plusReducesS (S k) m = cong (plusReducesS k m) + +plusReducesZ' : (n:Nat) -> n = plus n Z +plusReducesZ' Z = ?plusredZ_Z +plusReducesZ' (S k) = let ih = plusReducesZ' k in + ?plusredZ_S + + +---------- Proofs ---------- + +plusredZ_S = proof { + intro; + intro; + rewrite ih; + trivial; +} + +plusredZ_Z = proof { + compute; + trivial; +} + diff --git a/samples/tutorial/universe.idr b/samples/tutorial/universe.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/universe.idr @@ -0,0 +1,7 @@ +myid : (a : Type) -> a -> a +myid _ x = x + +idid : (a : Type) -> a -> a +idid = myid _ myid + + diff --git a/samples/tutorial/usefultypes.idr b/samples/tutorial/usefultypes.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/usefultypes.idr @@ -0,0 +1,20 @@ + +intVec : Vect 5 Int +intVec = [1, 2, 3, 4, 5] + +double : Int -> Int +double x = x * 2 + +vec : (n ** Vect n Int) +vec = (_ ** [3, 4]) + +list_lookup : Nat -> List a -> Maybe a +list_lookup _ Nil = Nothing +list_lookup Z (x :: xs) = Just x +list_lookup (S k) (x :: xs) = list_lookup k xs + +lookup_default : Nat -> List a -> a -> a +lookup_default i xs def = case list_lookup i xs of + Nothing => def + Just x => x + diff --git a/samples/tutorial/vbroken.idr b/samples/tutorial/vbroken.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/vbroken.idr @@ -0,0 +1,10 @@ +module Vect + +data Vect : Nat -> Type -> Type where + Nil : Vect Z a + (::) : a -> Vect k a -> Vect (S k) a + +(++) : Vect n a -> Vect m a -> Vect (n + m) a +(++) Nil ys = ys +(++) (x :: xs) ys = x :: xs ++ xs -- BROKEN + diff --git a/samples/tutorial/views.idr b/samples/tutorial/views.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/views.idr @@ -0,0 +1,37 @@ +module views + +data Parity : Nat -> Type where + Even : Parity (n + n) + Odd : Parity (S (n + n)) + +parity : (n:Nat) -> Parity n +parity Z = Even {n=Z} +parity (S Z) = Odd {n=Z} +parity (S (S k)) with (parity k) + parity (S (S (j + j))) | Even ?= Even {n=S j} + parity (S (S (S (j + j)))) | Odd ?= Odd {n=S j} + +natToBin : Nat -> List Bool +natToBin Z = Nil +natToBin k with (parity k) + natToBin (j + j) | Even = False :: natToBin j + natToBin (S (j + j)) | Odd = True :: natToBin j + + +---------- Proofs ---------- + +views.parity_lemma_2 = proof { + intro; + intro; + rewrite sym (plusSuccRightSucc j j); + trivial; +} + +views.parity_lemma_1 = proof { + intro; + intro; + rewrite sym (plusSuccRightSucc j j); + trivial; +} + + diff --git a/samples/tutorial/viewsbroken.idr b/samples/tutorial/viewsbroken.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/viewsbroken.idr @@ -0,0 +1,12 @@ + +data Parity : Nat -> Type where + Even : Parity (n + n) + Odd : Parity (S (n + n)) + +parity : (n:Nat) -> Parity n +parity Z = Even {n=Z} +parity (S Z) = Odd {n=Z} +parity (S (S k)) with (parity k) + parity (S (S (j + j))) | Even = Even {n=S j} + parity (S (S (S (j + j)))) | Odd = Odd {n=S j} + diff --git a/samples/tutorial/wheres.idr b/samples/tutorial/wheres.idr new file mode 100644 --- /dev/null +++ b/samples/tutorial/wheres.idr @@ -0,0 +1,14 @@ +module wheres + +even : Nat -> Bool +even Z = True +even (S k) = odd k where + odd Z = False + odd (S k) = even k + +test : List Nat +test = [c (S 1), c Z, d (S Z)] + where c x = 42 + x + d y = c (y + 1 + z y) + where z w = y + w + diff --git a/src/IRTS/CodegenC.hs b/src/IRTS/CodegenC.hs --- a/src/IRTS/CodegenC.hs +++ b/src/IRTS/CodegenC.hs @@ -259,6 +259,10 @@ where intConsts ((I _, _ ) : _) = True intConsts ((Ch _, _ ) : _) = True + intConsts ((B8 _, _ ) : _) = True + intConsts ((B16 _, _ ) : _) = True + intConsts ((B32 _, _ ) : _) = True + intConsts ((B64 _, _ ) : _) = True intConsts _ = False bigintConsts ((BI _, _ ) : _) = True @@ -279,7 +283,18 @@ iCase v (Ch b, bc) = indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n" ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n" - + iCase v (B8 w, bc) = + indent i ++ "if (GETBITS8(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n" + ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n" + iCase v (B16 w, bc) = + indent i ++ "if (GETBITS16(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n" + ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n" + iCase v (B32 w, bc) = + indent i ++ "if (GETBITS32(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n" + ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n" + iCase v (B64 w, bc) = + indent i ++ "if (GETBITS64(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n" + ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n" showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n" ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n" @@ -544,6 +559,7 @@ doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")" doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")" doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")" +doOp v LStrSubstr [x,y,z] = v ++ "idris_substr(vm, " ++ creg x ++ "," ++ creg y ++ "," ++ creg z ++ ")" doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" diff --git a/src/IRTS/CodegenJavaScript.hs b/src/IRTS/CodegenJavaScript.hs --- a/src/IRTS/CodegenJavaScript.hs +++ b/src/IRTS/CodegenJavaScript.hs @@ -1140,6 +1140,15 @@ JSNum (JSInt 1), JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1)) ] + | LStrSubstr <- op + , (offset:length:string:_) <- args = + let off = translateReg offset + len = translateReg length + str = translateReg string + in JSApp (JSProj str "substr") [ + jsCall "Math.max" [JSNum (JSInt 0), off], + jsCall "Math.max" [JSNum (JSInt 0), len] + ] | LSystemInfo <- op , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg] diff --git a/src/IRTS/Compiler.hs b/src/IRTS/Compiler.hs --- a/src/IRTS/Compiler.hs +++ b/src/IRTS/Compiler.hs @@ -44,8 +44,7 @@ import System.Environment import System.FilePath ((), addTrailingPathSeparator) --- | Given a 'main' term to compiler, return the IRs which can be used to --- generate code. +-- | Compile to simplified forms and return CodegenInfo compile :: Codegen -> FilePath -> Maybe Term -> Idris CodegenInfo compile codegen f mtm = do checkMVs -- check for undefined metavariables @@ -74,7 +73,7 @@ Just _ -> False let defs = defsIn ++ maindef - -- iputStrLn $ showSep "\n" (map show defs) + -- Inlined top level LDecl made here let defsInlined = inlineAll defs let defsUniq = map (allocUnique (addAlist defsInlined emptyContext)) @@ -90,7 +89,7 @@ let defuns = inline defuns_in logLvl 5 $ show defuns logLvl 1 "Resolving variables for CG" - -- iputStrLn $ showSep "\n" (map show (toAlist defuns)) + let checked = simplifyDefs defuns (toAlist defuns) outty <- outputTy dumpCases <- getDumpCases @@ -109,13 +108,6 @@ hdrs impdirs objs libs flags NONE c (toAlist defuns) tagged iface exports --- runIO $ case codegen of --- ViaC -> codegenC cginfo --- ViaJava -> codegenJava cginfo --- ViaJavaScript -> codegenJavaScript cginfo --- ViaNode -> codegenNode cginfo --- ViaLLVM -> codegenLLVM cginfo --- Bytecode -> dumpBC c f Error e -> ierror e where checkMVs = do i <- getIState case map fst (idris_metavars i) \\ primDefs of @@ -125,9 +117,6 @@ case idris_totcheckfail i of [] -> return () ((fc, msg):fs) -> ierror . At fc . Msg $ "Cannot compile:\n " ++ msg - inDir d h = do let f = d h - ex <- doesFileExist f - if ex then return f else return h generate :: Codegen -> FilePath -> CodegenInfo -> IO () generate codegen mainmod ir @@ -135,7 +124,7 @@ -- Built-in code generators (FIXME: lift these out!) Via "c" -> codegenC ir -- Any external code generator - Via cg -> do let cmd = "idris-" ++ cg + Via cg -> do let cmd = "idris-codegen-" ++ cg args = [mainmod, "-o", outputFile ir] ++ compilerFlags ir exit <- rawSystem cmd args when (exit /= ExitSuccess) $ @@ -485,75 +474,6 @@ deNS n = n doForeign vs env xs = ifail "Badly formed foreign function call" -{- - - | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn - = case getFTypes fgnArgTys of - Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args) - Just tys -> do - args' <- mapM (irTerm vs env) (init args) - return $ LForeign LANG_C (mkIty' ret) fgnName (zip tys args') - - | otherwise = ifail "Badly formed foreign function call" - where - getFTypes :: TT Name -> Maybe [FType] - getFTypes tm = case unApply tm of - -- nil : {a : Type} -> List a - (nil, [_]) -> Just [] - -- cons : {a : Type} -> a -> List a -> List a - (cons, [_, ty, xs]) -> (mkIty' ty :) <$> getFTypes xs - _ -> Nothing - - mkIty' (P _ (UN ty) _) = mkIty (str ty) - mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _)) - | fi == txt "FIntT" - = mkIntIty (str intTy) - - mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _))) - | ff == txt "FFunction" - , fa == txt "FAny" - , io == txt "IO" - = FFunctionIO - - mkIty' (App (App (P _ (UN ff) _) _) _) - | ff == txt "FFunction" - = FFunction - - mkIty' _ = FAny - - -- would be better if these FInt types were evaluated at compile time - -- TODO: add %eval directive for such things - -- Issue #1742 on the issue tracker. - -- https://github.com/idris-lang/Idris-dev/issues/1742 - mkIty "FFloat" = FArith ATFloat - mkIty "FInt" = mkIntIty "ITNative" - mkIty "FChar" = mkIntIty "ITChar" - mkIty "FByte" = mkIntIty "IT8" - mkIty "FShort" = mkIntIty "IT16" - mkIty "FLong" = mkIntIty "IT64" - mkIty "FBits8" = mkIntIty "IT8" - mkIty "FBits16" = mkIntIty "IT16" - mkIty "FBits32" = mkIntIty "IT32" - mkIty "FBits64" = mkIntIty "IT64" - mkIty "FString" = FString - mkIty "FPtr" = FPtr - mkIty "FManagedPtr" = FManagedPtr - mkIty "FUnit" = FUnit - mkIty "FFunction" = FFunction - mkIty "FFunctionIO" = FFunctionIO - mkIty "FBits8x16" = FArith (ATInt (ITVec IT8 16)) - mkIty "FBits16x8" = FArith (ATInt (ITVec IT16 8)) - mkIty "FBits32x4" = FArith (ATInt (ITVec IT32 4)) - mkIty "FBits64x2" = FArith (ATInt (ITVec IT64 2)) - mkIty x = error $ "Unknown type " ++ x - - mkIntIty "ITNative" = FArith (ATInt ITNative) - mkIntIty "ITChar" = FArith (ATInt ITChar) - mkIntIty "IT8" = FArith (ATInt (ITFixed IT8)) - mkIntIty "IT16" = FArith (ATInt (ITFixed IT16)) - mkIntIty "IT32" = FArith (ATInt (ITFixed IT32)) - mkIntIty "IT64" = FArith (ATInt (ITFixed IT64)) --} - irTree :: [Name] -> SC -> Idris LExp irTree args tree = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree @@ -685,6 +605,10 @@ matchable (BI _) = True matchable (Ch _) = True matchable (Str _) = True + matchable (B8 _) = True + matchable (B16 _) = True + matchable (B32 _) = True + matchable (B64 _) = True matchable _ = False matchableTy (AType (ATInt ITNative)) = True diff --git a/src/IRTS/Lang.hs b/src/IRTS/Lang.hs --- a/src/IRTS/Lang.hs +++ b/src/IRTS/Lang.hs @@ -74,7 +74,7 @@ | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan | LFSqrt | LFFloor | LFCeil | LFNegate - | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev + | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev | LStrSubstr | LReadStr | LWriteStr -- system info diff --git a/src/Idris/AbsSyntax.hs b/src/Idris/AbsSyntax.hs --- a/src/Idris/AbsSyntax.hs +++ b/src/Idris/AbsSyntax.hs @@ -31,6 +31,8 @@ import qualified Data.Set as S import Data.Word (Word) +import Data.Generics.Uniplate.Data (descend, descendM) + import Debug.Trace import System.IO.Error(isUserError, ioeGetErrorString, tryIOError) @@ -200,7 +202,7 @@ where findCoercions t [] = [] findCoercions t (n : ns) = let ps = case lookupTy n (tt_ctxt i) of - [ty'] -> case unApply (getRetTy ty') of + [ty'] -> case unApply (getRetTy (normalise (tt_ctxt i) [] ty')) of (t', _) -> if t == t' then [n] else [] _ -> [] in @@ -397,6 +399,10 @@ _ -> i putIState $ ist { idris_classes = addDef n i' (idris_classes ist) } +addRecord :: Name -> RecordInfo -> Idris () +addRecord n ri = do ist <- getIState + putIState $ ist { idris_records = addDef n ri (idris_records ist) } + addAutoHint :: Name -> Name -> Idris () addAutoHint n hint = do ist <- getIState @@ -796,6 +802,18 @@ let opt' = opts { opt_evaltypes = n } putIState $ i { idris_options = opt' } +getDesugarNats :: Idris Bool +getDesugarNats = do i <- getIState + let opts = idris_options i + return (opt_desugarnats opts) + + +setDesugarNats :: Bool -> Idris () +setDesugarNats n = do i <- getIState + let opts = idris_options i + let opt' = opts { opt_desugarnats = n } + putIState $ i { idris_options = opt' } + setQuiet :: Bool -> Idris () setQuiet q = do i <- getIState let opts = idris_options i @@ -976,7 +994,7 @@ [Name] -> -- all names [Name] -> -- names with no declaration PTerm -> PTerm -expandParams dec ps ns infs tm = en tm +expandParams dec ps ns infs tm = en 0 tm where -- if we shadow a name (say in a lambda binding) that is used in a call to -- a lifted function, we need access to both names - once in the scope of the @@ -988,78 +1006,85 @@ mkShadow (MN i n) = MN (i+1) n mkShadow (NS x s) = NS (mkShadow x) s - en (PLam fc n nfc t s) + en :: Int -- ^ The quotation level - only transform terms that are used, not terms + -- that are merely mentioned. + -> PTerm -> PTerm + en 0 (PLam fc n nfc t s) | n `elem` (map fst ps ++ ns) = let n' = mkShadow n in - PLam fc n' nfc (en t) (en (shadow n n' s)) - | otherwise = PLam fc n nfc (en t) (en s) - en (PPi p n nfc t s) + PLam fc n' nfc (en 0 t) (en 0 (shadow n n' s)) + | otherwise = PLam fc n nfc (en 0 t) (en 0 s) + en 0 (PPi p n nfc t s) | n `elem` (map fst ps ++ ns) = let n' = mkShadow n in -- TODO THINK SHADOWING TacImp? - PPi (enTacImp p) n' nfc (en t) (en (shadow n n' s)) - | otherwise = PPi (enTacImp p) n nfc (en t) (en s) - en (PLet fc n nfc ty v s) + PPi (enTacImp 0 p) n' nfc (en 0 t) (en 0 (shadow n n' s)) + | otherwise = PPi (enTacImp 0 p) n nfc (en 0 t) (en 0 s) + en 0 (PLet fc n nfc ty v s) | n `elem` (map fst ps ++ ns) = let n' = mkShadow n in - PLet fc n' nfc (en ty) (en v) (en (shadow n n' s)) - | otherwise = PLet fc n nfc (en ty) (en v) (en s) + PLet fc n' nfc (en 0 ty) (en 0 v) (en 0 (shadow n n' s)) + | otherwise = PLet fc n nfc (en 0 ty) (en 0 v) (en 0 s) -- FIXME: Should only do this in a type signature! - en (PDPair f hls p (PRef f' fcs n) t r) + en 0 (PDPair f hls p (PRef f' fcs n) t r) | n `elem` (map fst ps ++ ns) && t /= Placeholder = let n' = mkShadow n in - PDPair f hls p (PRef f' fcs n') (en t) (en (shadow n n' r)) - en (PRewrite f l r g) = PRewrite f (en l) (en r) (fmap en g) - en (PTyped l r) = PTyped (en l) (en r) - en (PPair f hls p l r) = PPair f hls p (en l) (en r) - en (PDPair f hls p l t r) = PDPair f hls p (en l) (en t) (en r) - en (PAlternative ns a as) = PAlternative ns a (map en as) - en (PHidden t) = PHidden (en t) - en (PUnifyLog t) = PUnifyLog (en t) - en (PDisamb ds t) = PDisamb ds (en t) - en (PNoImplicits t) = PNoImplicits (en t) - en (PDoBlock ds) = PDoBlock (map (fmap en) ds) - en (PProof ts) = PProof (map (fmap en) ts) - en (PTactics ts) = PTactics (map (fmap en) ts) + PDPair f hls p (PRef f' fcs n') (en 0 t) (en 0 (shadow n n' r)) + en 0 (PRewrite f l r g) = PRewrite f (en 0 l) (en 0 r) (fmap (en 0) g) + en 0 (PTyped l r) = PTyped (en 0 l) (en 0 r) + en 0 (PPair f hls p l r) = PPair f hls p (en 0 l) (en 0 r) + en 0 (PDPair f hls p l t r) = PDPair f hls p (en 0 l) (en 0 t) (en 0 r) + en 0 (PAlternative ns a as) = PAlternative ns a (map (en 0) as) + en 0 (PHidden t) = PHidden (en 0 t) + en 0 (PUnifyLog t) = PUnifyLog (en 0 t) + en 0 (PDisamb ds t) = PDisamb ds (en 0 t) + en 0 (PNoImplicits t) = PNoImplicits (en 0 t) + en 0 (PDoBlock ds) = PDoBlock (map (fmap (en 0)) ds) + en 0 (PProof ts) = PProof (map (fmap (en 0)) ts) + en 0 (PTactics ts) = PTactics (map (fmap (en 0)) ts) - en (PQuote (Var n)) + en 0 (PQuote (Var n)) | n `nselem` ns = PQuote (Var (dec n)) - en (PApp fc (PInferRef fc' hl n) as) + en 0 (PApp fc (PInferRef fc' hl n) as) | n `nselem` ns = PApp fc (PInferRef fc' hl (dec n)) - (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap en) as)) - en (PApp fc (PRef fc' hl n) as) + (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as)) + en 0 (PApp fc (PRef fc' hl n) as) | n `elem` infs = PApp fc (PInferRef fc' hl (dec n)) - (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap en) as)) + (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as)) | n `nselem` ns = PApp fc (PRef fc' hl (dec n)) - (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap en) as)) - en (PAppBind fc (PRef fc' hl n) as) + (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as)) + en 0 (PAppBind fc (PRef fc' hl n) as) | n `elem` infs = PAppBind fc (PInferRef fc' hl (dec n)) - (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap en) as)) + (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as)) | n `nselem` ns = PAppBind fc (PRef fc' hl (dec n)) - (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap en) as)) - en (PRef fc hl n) + (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as)) + en 0 (PRef fc hl n) | n `elem` infs = PApp fc (PInferRef fc hl (dec n)) (map (pexp . (PRef fc hl)) (map fst ps)) | n `nselem` ns = PApp fc (PRef fc hl (dec n)) (map (pexp . (PRef fc hl)) (map fst ps)) - en (PInferRef fc hl n) + en 0 (PInferRef fc hl n) | n `nselem` ns = PApp fc (PInferRef fc hl (dec n)) (map (pexp . (PRef fc hl)) (map fst ps)) - en (PApp fc f as) = PApp fc (en f) (map (fmap en) as) - en (PAppBind fc f as) = PAppBind fc (en f) (map (fmap en) as) - en (PCase fc c os) = PCase fc (en c) (map (pmap en) os) - en (PIfThenElse fc c t f) = PIfThenElse fc (en c) (en t) (en f) - en (PRunElab fc tm ns) = PRunElab fc (en tm) ns - en (PConstSugar fc tm) = PConstSugar fc (en tm) - en t = t + en 0 (PApp fc f as) = PApp fc (en 0 f) (map (fmap (en 0)) as) + en 0 (PAppBind fc f as) = PAppBind fc (en 0 f) (map (fmap (en 0)) as) + en 0 (PCase fc c os) = PCase fc (en 0 c) (map (pmap (en 0)) os) + en 0 (PIfThenElse fc c t f) = PIfThenElse fc (en 0 c) (en 0 t) (en 0 f) + en 0 (PRunElab fc tm ns) = PRunElab fc (en 0 tm) ns + en 0 (PConstSugar fc tm) = PConstSugar fc (en 0 tm) + en ql (PQuasiquote tm ty) = PQuasiquote (en (ql + 1) tm) (fmap (en ql) ty) + en ql (PUnquote tm) = PUnquote (en (ql - 1) tm) + + en ql t = descend (en ql) t + nselem x [] = False nselem x (y : xs) | nseq x y = True | otherwise = nselem x xs nseq x y = nsroot x == nsroot y - enTacImp (TacImp aos st scr) = TacImp aos st (en scr) - enTacImp other = other + enTacImp ql (TacImp aos st scr) = TacImp aos st (en ql scr) + enTacImp ql other = other expandParamsD :: Bool -> -- True = RHS only IState -> @@ -1550,103 +1575,109 @@ addImpl' :: Bool -> [Name] -> [Name] -> [Name] -> IState -> PTerm -> PTerm addImpl' inpat env infns imp_meths ist ptm - = mkUniqueNames env [] (ai False (zip env (repeat Nothing)) [] ptm) + = mkUniqueNames env [] (ai inpat False (zip env (repeat Nothing)) [] ptm) where - ai :: Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm - ai qq env ds (PRef fc fcs f) + topname = case ptm of + PRef _ _ n -> n + PApp _ (PRef _ _ n) _ -> n + _ -> sUN "" -- doesn't matter then + + ai :: Bool -> Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm + ai inpat qq env ds (PRef fc fcs f) | f `elem` infns = PInferRef fc fcs f - | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat qq imp_meths ist fc f fc ds [] - ai qq env ds (PHidden (PRef fc hl f)) - | not (f `elem` map fst env) = PHidden (handleErr $ aiFn inpat False qq imp_meths ist fc f fc ds []) - ai qq env ds (PRewrite fc l r g) - = let l' = ai qq env ds l - r' = ai qq env ds r - g' = fmap (ai qq env ds) g in + | not (f `elem` map fst env) = handleErr $ aiFn topname inpat inpat qq imp_meths ist fc f fc ds [] [] + ai inpat qq env ds (PHidden (PRef fc hl f)) + | not (f `elem` map fst env) = PHidden (handleErr $ aiFn topname inpat False qq imp_meths ist fc f fc ds [] []) + ai inpat qq env ds (PRewrite fc l r g) + = let l' = ai inpat qq env ds l + r' = ai inpat qq env ds r + g' = fmap (ai inpat qq env ds) g in PRewrite fc l' r' g' - ai qq env ds (PTyped l r) - = let l' = ai qq env ds l - r' = ai qq env ds r in + ai inpat qq env ds (PTyped l r) + = let l' = ai inpat qq env ds l + r' = ai inpat qq env ds r in PTyped l' r' - ai qq env ds (PPair fc hls p l r) - = let l' = ai qq env ds l - r' = ai qq env ds r in + ai inpat qq env ds (PPair fc hls p l r) + = let l' = ai inpat qq env ds l + r' = ai inpat qq env ds r in PPair fc hls p l' r' - ai qq env ds (PDPair fc hls p l t r) - = let l' = ai qq env ds l - t' = ai qq env ds t - r' = ai qq env ds r in + ai inpat qq env ds (PDPair fc hls p l t r) + = let l' = ai inpat qq env ds l + t' = ai inpat qq env ds t + r' = ai inpat qq env ds r in PDPair fc hls p l' t' r' - ai qq env ds (PAlternative ms a as) - = let as' = map (ai qq env ds) as in + ai inpat qq env ds (PAlternative ms a as) + = let as' = map (ai inpat qq env ds) as in PAlternative ms a as' - ai qq env _ (PDisamb ds' as) = ai qq env ds' as - ai qq env ds (PApp fc (PInferRef ffc hl f) as) - = let as' = map (fmap (ai qq env ds)) as in + ai inpat qq env _ (PDisamb ds' as) = ai inpat qq env ds' as + ai inpat qq env ds (PApp fc (PInferRef ffc hl f) as) + = let as' = map (fmap (ai inpat qq env ds)) as in PApp fc (PInferRef ffc hl f) as' - ai qq env ds (PApp fc ftm@(PRef ffc hl f) as) - | f `elem` infns = ai qq env ds (PApp fc (PInferRef ffc hl f) as) + ai inpat qq env ds (PApp fc ftm@(PRef ffc hl f) as) + | f `elem` infns = ai inpat qq env ds (PApp fc (PInferRef ffc hl f) as) | not (f `elem` map fst env) - = let as' = map (fmap (ai qq env ds)) as in - handleErr $ aiFn inpat False qq imp_meths ist fc f ffc ds as' + = let as' = map (fmap (ai inpat qq env ds)) as + asdotted' = map (fmap (ai False qq env ds)) as in + handleErr $ aiFn topname inpat False qq imp_meths ist fc f ffc ds as' asdotted' | Just (Just ty) <- lookup f env = - let as' = map (fmap (ai qq env ds)) as + let as' = map (fmap (ai inpat qq env ds)) as arity = getPArity ty in mkPApp fc arity ftm as' - ai qq env ds (PApp fc f as) - = let f' = ai qq env ds f - as' = map (fmap (ai qq env ds)) as in + ai inpat qq env ds (PApp fc f as) + = let f' = ai inpat qq env ds f + as' = map (fmap (ai inpat qq env ds)) as in mkPApp fc 1 f' as' - ai qq env ds (PCase fc c os) - = let c' = ai qq env ds c in + ai inpat qq env ds (PCase fc c os) + = let c' = ai inpat qq env ds c in -- leave os alone, because they get lifted into a new pattern match - -- definition which is passed through addImpl again with more scope + -- definition which is passed through addImpl agai inpatn with more scope -- information PCase fc c' os - ai qq env ds (PIfThenElse fc c t f) = PIfThenElse fc (ai qq env ds c) - (ai qq env ds t) - (ai qq env ds f) + ai inpat qq env ds (PIfThenElse fc c t f) = PIfThenElse fc (ai inpat qq env ds c) + (ai inpat qq env ds t) + (ai inpat qq env ds f) -- If the name in a lambda is a constructor name, do this as a 'case' -- instead (it is harmless to do so, especially since the lambda will -- be lifted anyway!) - ai qq env ds (PLam fc n nfc ty sc) + ai inpat qq env ds (PLam fc n nfc ty sc) = case lookupDef n (tt_ctxt ist) of - [] -> let ty' = ai qq env ds ty - sc' = ai qq ((n, Just ty):env) ds sc in + [] -> let ty' = ai inpat qq env ds ty + sc' = ai inpat qq ((n, Just ty):env) ds sc in PLam fc n nfc ty' sc' - _ -> ai qq env ds (PLam fc (sMN 0 "lamp") NoFC ty + _ -> ai inpat qq env ds (PLam fc (sMN 0 "lamp") NoFC ty (PCase fc (PRef fc [] (sMN 0 "lamp") ) [(PRef fc [] n, sc)])) - ai qq env ds (PLet fc n nfc ty val sc) + ai inpat qq env ds (PLet fc n nfc ty val sc) = case lookupDef n (tt_ctxt ist) of - [] -> let ty' = ai qq env ds ty - val' = ai qq env ds val - sc' = ai qq ((n, Just ty):env) ds sc in + [] -> let ty' = ai inpat qq env ds ty + val' = ai inpat qq env ds val + sc' = ai inpat qq ((n, Just ty):env) ds sc in PLet fc n nfc ty' val' sc' defs -> - ai qq env ds (PCase fc val [(PRef fc [] n, sc)]) - ai qq env ds (PPi p n nfc ty sc) - = let ty' = ai qq env ds ty + ai inpat qq env ds (PCase fc val [(PRef fc [] n, sc)]) + ai inpat qq env ds (PPi p n nfc ty sc) + = let ty' = ai inpat qq env ds ty env' = if n `elem` imp_meths then env else ((n, Just ty) : env) - sc' = ai qq env' ds sc in + sc' = ai inpat qq env' ds sc in PPi p n nfc ty' sc' - ai qq env ds (PGoal fc r n sc) - = let r' = ai qq env ds r - sc' = ai qq ((n, Nothing):env) ds sc in + ai inpat qq env ds (PGoal fc r n sc) + = let r' = ai inpat qq env ds r + sc' = ai inpat qq ((n, Nothing):env) ds sc in PGoal fc r' n sc' - ai qq env ds (PHidden tm) = PHidden (ai qq env ds tm) + ai inpat qq env ds (PHidden tm) = PHidden (ai inpat qq env ds tm) -- Don't do PProof or PTactics since implicits get added when scope is -- properly known in ElabTerm.runTac - ai qq env ds (PUnifyLog tm) = PUnifyLog (ai qq env ds tm) - ai qq env ds (PNoImplicits tm) = PNoImplicits (ai qq env ds tm) - ai qq env ds (PQuasiquote tm g) = PQuasiquote (ai True env ds tm) - (fmap (ai True env ds) g) - ai qq env ds (PUnquote tm) = PUnquote (ai False env ds tm) - ai qq env ds (PRunElab fc tm ns) = PRunElab fc (ai False env ds tm) ns - ai qq env ds (PConstSugar fc tm) = PConstSugar fc (ai qq env ds tm) - ai qq env ds tm = tm + ai inpat qq env ds (PUnifyLog tm) = PUnifyLog (ai inpat qq env ds tm) + ai inpat qq env ds (PNoImplicits tm) = PNoImplicits (ai inpat qq env ds tm) + ai inpat qq env ds (PQuasiquote tm g) = PQuasiquote (ai inpat True env ds tm) + (fmap (ai inpat True env ds) g) + ai inpat qq env ds (PUnquote tm) = PUnquote (ai inpat False env ds tm) + ai inpat qq env ds (PRunElab fc tm ns) = PRunElab fc (ai inpat False env ds tm) ns + ai inpat qq env ds (PConstSugar fc tm) = PConstSugar fc (ai inpat qq env ds tm) + ai inpat qq env ds tm = tm handleErr (Left err) = PElabError err handleErr (Right x) = x @@ -1654,14 +1685,15 @@ -- if in a pattern, and there are no arguments, and there's no possible -- names with zero explicit arguments, don't add implicits. -aiFn :: Bool -> Bool -> Bool +aiFn :: Name -> Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -- ^ function being applied -> FC -> [[T.Text]] - -> [PArg] -- ^ initial arguments + -> [PArg] -- ^ initial arguments (if in a pattern) + -> [PArg] -- ^ initial arguments (if in an expression) -> Either Err PTerm -aiFn inpat True qq imp_meths ist fc f ffc ds [] +aiFn topname inpat True qq imp_meths ist fc f ffc ds [] _ = case lookupDef f (tt_ctxt ist) of [] -> Right $ PPatvar ffc f alts -> let ialts = lookupCtxtName f (idris_implicits ist) in @@ -1669,7 +1701,7 @@ if (not (vname f) || tcname f || any (conCaf (tt_ctxt ist)) ialts) -- any constructor alts || any allImp ialts)) - then aiFn inpat False qq imp_meths ist fc f ffc ds [] -- use it as a constructor + then aiFn topname inpat False qq imp_meths ist fc f ffc ds [] [] -- use it as a constructor else Right $ PPatvar ffc f where imp (PExp _ _ _ _) = False imp _ = True @@ -1683,9 +1715,9 @@ vname (UN n) = True -- non qualified vname _ = False -aiFn inpat expat qq imp_meths ist fc f ffc ds as +aiFn topname inpat expat qq imp_meths ist fc f ffc ds as asexp | f `elem` primNames = Right $ PApp fc (PRef ffc [ffc] f) as -aiFn inpat expat qq imp_meths ist fc f ffc ds as +aiFn topname inpat expat qq imp_meths ist fc f ffc ds as asexp -- This is where namespaces get resolved by adding PAlternative = do let ns = lookupCtxtName f (idris_implicits ist) let nh = filter (\(n, _) -> notHidden n) ns @@ -1693,15 +1725,25 @@ [] -> nh x -> x case ns' of - [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f')) (insertImpl ns as) + [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f')) + (insertImpl ns (chooseArgs f' as asexp)) [] -> if f `elem` (map fst (idris_metavars ist)) then Right $ PApp fc (PRef ffc [ffc] f) as else Right $ mkPApp fc (length as) (PRef ffc [ffc] f) as alts -> Right $ PAlternative [] (ExactlyOne True) $ map (\(f', ns) -> mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f')) - (insertImpl ns as)) alts + (insertImpl ns (chooseArgs f' as asexp))) alts where + -- choose whether to treat the arguments as patterns or expressions + -- if 'f' is a defined function, treat as expression, otherwise do the default. + -- This is so any names which later go under a PHidden are treated + -- as function names rather than bound pattern variables + chooseArgs f as asexp | isConName f (tt_ctxt ist) = as + | f == topname = as + | Nothing <- lookupDefExact f (tt_ctxt ist) = as + | otherwise = asexp + -- if the name is in imp_meths, we should actually refer to the bound -- name rather than the global one after expanding implicits isImpName f f' | f `elem` imp_meths = f @@ -2081,43 +2123,46 @@ fullApp x = x shadow :: Name -> Name -> PTerm -> PTerm -shadow n n' t = sm t where - sm (PRef fc hl x) | n == x = PRef fc hl n' - sm (PLam fc x xfc t sc) | n /= x = PLam fc x xfc (sm t) (sm sc) - | otherwise = PLam fc x xfc (sm t) sc - sm (PPi p x fc t sc) | n /= x = PPi p x fc (sm t) (sm sc) - | otherwise = PPi p x fc (sm t) sc - sm (PLet fc x xfc t v sc) | n /= x = PLet fc x xfc (sm t) (sm v) (sm sc) - | otherwise = PLet fc x xfc (sm t) (sm v) sc - sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as) - sm (PAppBind f x as) = PAppBind f (sm x) (map (fmap sm) as) - sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as) - sm (PIfThenElse fc c t f) = PIfThenElse fc (sm c) (sm t) (sm f) - sm (PRewrite f x y tm) = PRewrite f (sm x) (sm y) (fmap sm tm) - sm (PTyped x y) = PTyped (sm x) (sm y) - sm (PPair f hls p x y) = PPair f hls p (sm x) (sm y) - sm (PDPair f hls p x t y) = PDPair f hls p (sm x) (sm t) (sm y) - sm (PAlternative ms a as) = PAlternative ms a (map sm as) - sm (PTactics ts) = PTactics (map (fmap sm) ts) - sm (PProof ts) = PProof (map (fmap sm) ts) - sm (PHidden x) = PHidden (sm x) - sm (PUnifyLog x) = PUnifyLog (sm x) - sm (PNoImplicits x) = PNoImplicits (sm x) - sm x = x +shadow n n' t = sm 0 t where + sm 0 (PRef fc hl x) | n == x = PRef fc hl n' + sm 0 (PLam fc x xfc t sc) | n /= x = PLam fc x xfc (sm 0 t) (sm 0 sc) + | otherwise = PLam fc x xfc (sm 0 t) sc + sm 0 (PPi p x fc t sc) | n /= x = PPi p x fc (sm 0 t) (sm 0 sc) + | otherwise = PPi p x fc (sm 0 t) sc + sm 0 (PLet fc x xfc t v sc) | n /= x = PLet fc x xfc (sm 0 t) (sm 0 v) (sm 0 sc) + | otherwise = PLet fc x xfc (sm 0 t) (sm 0 v) sc + sm 0 (PApp f x as) = PApp f (sm 0 x) (map (fmap (sm 0)) as) + sm 0 (PAppBind f x as) = PAppBind f (sm 0 x) (map (fmap (sm 0)) as) + sm 0 (PCase f x as) = PCase f (sm 0 x) (map (pmap (sm 0)) as) + sm 0 (PIfThenElse fc c t f) = PIfThenElse fc (sm 0 c) (sm 0 t) (sm 0 f) + sm 0 (PRewrite f x y tm) = PRewrite f (sm 0 x) (sm 0 y) (fmap (sm 0) tm) + sm 0 (PTyped x y) = PTyped (sm 0 x) (sm 0 y) + sm 0 (PPair f hls p x y) = PPair f hls p (sm 0 x) (sm 0 y) + sm 0 (PDPair f hls p x t y) = PDPair f hls p (sm 0 x) (sm 0 t) (sm 0 y) + sm 0 (PAlternative ms a as) = PAlternative ms a (map (sm 0) as) + sm 0 (PTactics ts) = PTactics (map (fmap (sm 0)) ts) + sm 0 (PProof ts) = PProof (map (fmap (sm 0)) ts) + sm 0 (PHidden x) = PHidden (sm 0 x) + sm 0 (PUnifyLog x) = PUnifyLog (sm 0 x) + sm 0 (PNoImplicits x) = PNoImplicits (sm 0 x) + sm 0 (PCoerced t) = PCoerced (sm 0 t) + sm ql (PQuasiquote tm ty) = PQuasiquote (sm (ql + 1) tm) (fmap (sm ql) ty) + sm ql (PUnquote tm) = PUnquote (sm (ql - 1) tm) + sm ql x = descend (sm ql) x -- | Rename any binders which are repeated (so that we don't have to mess -- about with shadowing anywhere else). mkUniqueNames :: [Name] -> [(Name, Name)] -> PTerm -> PTerm mkUniqueNames env shadows tm - = evalState (mkUniq initMap tm) (S.fromList env) where + = evalState (mkUniq 0 initMap tm) (S.fromList env) where initMap = M.fromList shadows inScope :: S.Set Name inScope = S.fromList $ boundNamesIn tm - mkUniqA nmap arg = do t' <- mkUniq nmap (getTm arg) - return (arg { getTm = t' }) + mkUniqA ql nmap arg = do t' <- mkUniq ql nmap (getTm arg) + return (arg { getTm = t' }) -- Initialise the unique name with the environment length (so we're not -- looking for too long...) @@ -2127,10 +2172,11 @@ -- FIXME: Probably ought to do this for completeness! It's fine as -- long as there are no bindings inside tactics though. - mkUniqT nmap tac = return tac + mkUniqT _ nmap tac = return tac - mkUniq :: M.Map Name Name -> PTerm -> State (S.Set Name) PTerm - mkUniq nmap (PLam fc n nfc ty sc) + mkUniq :: Int -- ^ The number of quotations that we're under + -> M.Map Name Name -> PTerm -> State (S.Set Name) PTerm + mkUniq 0 nmap (PLam fc n nfc ty sc) = do env <- get (n', sc') <- if n `S.member` env @@ -2140,10 +2186,10 @@ else return (n, sc) put (S.insert n' env) let nmap' = M.insert n n' nmap - ty' <- mkUniq nmap ty - sc'' <- mkUniq nmap' sc' + ty' <- mkUniq 0 nmap ty + sc'' <- mkUniq 0 nmap' sc' return $! PLam fc n' nfc ty' sc'' - mkUniq nmap (PPi p n fc ty sc) + mkUniq 0 nmap (PPi p n fc ty sc) = do env <- get (n', sc') <- if n `S.member` env @@ -2153,10 +2199,10 @@ else return (n, sc) put (S.insert n' env) let nmap' = M.insert n n' nmap - ty' <- mkUniq nmap ty - sc'' <- mkUniq nmap' sc' + ty' <- mkUniq 0 nmap ty + sc'' <- mkUniq 0 nmap' sc' return $! PPi p n' fc ty' sc'' - mkUniq nmap (PLet fc n nfc ty val sc) + mkUniq 0 nmap (PLet fc n nfc ty val sc) = do env <- get (n', sc') <- if n `S.member` env @@ -2166,28 +2212,28 @@ else return (n, sc) put (S.insert n' env) let nmap' = M.insert n n' nmap - ty' <- mkUniq nmap ty; val' <- mkUniq nmap val - sc'' <- mkUniq nmap' sc' + ty' <- mkUniq 0 nmap ty; val' <- mkUniq 0 nmap val + sc'' <- mkUniq 0 nmap' sc' return $! PLet fc n' nfc ty' val' sc'' - mkUniq nmap (PApp fc t args) - = do t' <- mkUniq nmap t - args' <- mapM (mkUniqA nmap) args + mkUniq 0 nmap (PApp fc t args) + = do t' <- mkUniq 0 nmap t + args' <- mapM (mkUniqA 0 nmap) args return $! PApp fc t' args' - mkUniq nmap (PAppBind fc t args) - = do t' <- mkUniq nmap t - args' <- mapM (mkUniqA nmap) args + mkUniq 0 nmap (PAppBind fc t args) + = do t' <- mkUniq 0 nmap t + args' <- mapM (mkUniqA 0 nmap) args return $! PAppBind fc t' args' - mkUniq nmap (PCase fc t alts) - = do t' <- mkUniq nmap t - alts' <- mapM (\(x,y)-> do x' <- mkUniq nmap x; y' <- mkUniq nmap y + mkUniq 0 nmap (PCase fc t alts) + = do t' <- mkUniq 0 nmap t + alts' <- mapM (\(x,y)-> do x' <- mkUniq 0 nmap x; y' <- mkUniq 0 nmap y return (x', y')) alts return $! PCase fc t' alts' - mkUniq nmap (PIfThenElse fc c t f) - = liftM3 (PIfThenElse fc) (mkUniq nmap c) (mkUniq nmap t) (mkUniq nmap f) - mkUniq nmap (PPair fc hls p l r) - = do l' <- mkUniq nmap l; r' <- mkUniq nmap r + mkUniq 0 nmap (PIfThenElse fc c t f) + = liftM3 (PIfThenElse fc) (mkUniq 0 nmap c) (mkUniq 0 nmap t) (mkUniq 0 nmap f) + mkUniq 0 nmap (PPair fc hls p l r) + = do l' <- mkUniq 0 nmap l; r' <- mkUniq 0 nmap r return $! PPair fc hls p l' r' - mkUniq nmap (PDPair fc hls p (PRef fc' hls' n) t sc) + mkUniq 0 nmap (PDPair fc hls p (PRef fc' hls' n) t sc) | t /= Placeholder = do env <- get (n', sc') <- if n `S.member` env @@ -2196,26 +2242,37 @@ else return (n, sc) put (S.insert n' env) let nmap' = M.insert n n' nmap - t' <- mkUniq nmap t - sc'' <- mkUniq nmap' sc' + t' <- mkUniq 0 nmap t + sc'' <- mkUniq 0 nmap' sc' return $! PDPair fc hls p (PRef fc' hls' n') t' sc'' - mkUniq nmap (PDPair fc hls p l t r) - = do l' <- mkUniq nmap l; t' <- mkUniq nmap t; r' <- mkUniq nmap r + mkUniq 0 nmap (PDPair fc hls p l t r) + = do l' <- mkUniq 0 nmap l; t' <- mkUniq 0 nmap t; r' <- mkUniq 0 nmap r return $! PDPair fc hls p l' t' r' - mkUniq nmap (PAlternative ns b as) + mkUniq 0 nmap (PAlternative ns b as) -- store the nmap and defer the rest until we've pruned the set -- during elaboration = return $ PAlternative (M.toList nmap ++ ns) b as - mkUniq nmap (PHidden t) = liftM PHidden (mkUniq nmap t) - mkUniq nmap (PUnifyLog t) = liftM PUnifyLog (mkUniq nmap t) - mkUniq nmap (PDisamb n t) = liftM (PDisamb n) (mkUniq nmap t) - mkUniq nmap (PNoImplicits t) = liftM PNoImplicits (mkUniq nmap t) - mkUniq nmap (PProof ts) = liftM PProof (mapM (mkUniqT nmap) ts) - mkUniq nmap (PTactics ts) = liftM PTactics (mapM (mkUniqT nmap) ts) - mkUniq nmap (PRunElab fc ts ns) = liftM (\tm -> PRunElab fc tm ns) (mkUniq nmap ts) - mkUniq nmap (PConstSugar fc tm) = liftM (PConstSugar fc) (mkUniq nmap tm) - mkUniq nmap t = return (shadowAll (M.toList nmap) t) + mkUniq 0 nmap (PHidden t) = liftM PHidden (mkUniq 0 nmap t) + mkUniq 0 nmap (PUnifyLog t) = liftM PUnifyLog (mkUniq 0 nmap t) + mkUniq 0 nmap (PDisamb n t) = liftM (PDisamb n) (mkUniq 0 nmap t) + mkUniq 0 nmap (PNoImplicits t) = liftM PNoImplicits (mkUniq 0 nmap t) + mkUniq 0 nmap (PProof ts) = liftM PProof (mapM (mkUniqT 0 nmap) ts) + mkUniq 0 nmap (PTactics ts) = liftM PTactics (mapM (mkUniqT 0 nmap) ts) + mkUniq 0 nmap (PRunElab fc ts ns) = liftM (\tm -> PRunElab fc tm ns) (mkUniq 0 nmap ts) + mkUniq 0 nmap (PConstSugar fc tm) = liftM (PConstSugar fc) (mkUniq 0 nmap tm) + mkUniq 0 nmap (PCoerced tm) = liftM PCoerced (mkUniq 0 nmap tm) + mkUniq 0 nmap t = return $ shadowAll (M.toList nmap) t where shadowAll [] t = t shadowAll ((n, n') : ns) t = shadow n n' (shadowAll ns t) + mkUniq ql nmap (PQuasiquote tm ty) = + do tm' <- mkUniq (ql + 1) nmap tm + ty' <- case ty of + Nothing -> return Nothing + Just t -> fmap Just $ mkUniq ql nmap t + return $! PQuasiquote tm' ty' + mkUniq ql nmap (PUnquote tm) = fmap PUnquote (mkUniq (ql - 1) nmap tm) + + mkUniq ql nmap tm = descendM (mkUniq ql nmap) tm + diff --git a/src/Idris/AbsSyntaxTree.hs b/src/Idris/AbsSyntaxTree.hs --- a/src/Idris/AbsSyntaxTree.hs +++ b/src/Idris/AbsSyntaxTree.hs @@ -28,7 +28,7 @@ import Data.Data (Data) import Data.Function (on) -import Data.Generics.Uniplate.Data (universe) +import Data.Generics.Uniplate.Data (universe, children) import Data.List hiding (group) import Data.Char import qualified Data.Map.Strict as M @@ -90,8 +90,9 @@ opt_autoImport :: [FilePath], -- ^ e.g. Builtins+Prelude opt_optimise :: [Optimisation], opt_printdepth :: Maybe Int, - opt_evaltypes :: Bool -- ^ normalise types in :t - } + opt_evaltypes :: Bool, -- ^ normalise types in :t + opt_desugarnats :: Bool + } deriving (Show, Eq) defaultOpts = IOption { opt_logLevel = 0 @@ -117,10 +118,12 @@ , opt_optimise = defaultOptimise , opt_printdepth = Just 5000 , opt_evaltypes = True + , opt_desugarnats = False } data PPOption = PPOption { ppopt_impl :: Bool -- ^^ whether to show implicits + , ppopt_desugarnats :: Bool , ppopt_pinames :: Bool -- ^^ whether to show names in pi bindings , ppopt_depth :: Maybe Int } deriving (Show) @@ -133,12 +136,14 @@ -- | Pretty printing options with default verbosity. defaultPPOption :: PPOption defaultPPOption = PPOption { ppopt_impl = False, + ppopt_desugarnats = False, ppopt_pinames = False, ppopt_depth = Just 200 } -- | Pretty printing options with the most verbosity. verbosePPOption :: PPOption verbosePPOption = PPOption { ppopt_impl = True, + ppopt_desugarnats = True, ppopt_pinames = True, ppopt_depth = Just 200 } @@ -147,7 +152,8 @@ ppOption opt = PPOption { ppopt_impl = opt_showimp opt, ppopt_pinames = False, - ppopt_depth = opt_printdepth opt + ppopt_depth = opt_printdepth opt, + ppopt_desugarnats = opt_desugarnats opt } -- | Get pretty printing options from an idris state record. @@ -177,6 +183,7 @@ idris_implicits :: Ctxt [PArg], idris_statics :: Ctxt [Bool], idris_classes :: Ctxt ClassInfo, + idris_records :: Ctxt RecordInfo, idris_dsls :: Ctxt DSL, idris_optimisation :: Ctxt OptInfo, idris_datatypes :: Ctxt TypeInfo, @@ -290,6 +297,7 @@ | IBCImp Name | IBCStatic Name | IBCClass Name + | IBCRecord Name | IBCInstance Bool Bool Name Name | IBCDSL Name | IBCData Name @@ -336,7 +344,7 @@ emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext - emptyContext + emptyContext emptyContext [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] [] [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] [] (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty @@ -501,6 +509,7 @@ | AutoSolve -- ^ Automatically issue "solve" tactic in interactive prover | UseConsoleWidth ConsoleWidth | DumpHighlights + | DesugarNats deriving (Show, Eq) data ElabShellCmd = EQED | EAbandon | EUndo | EProofState | EProofTerm @@ -967,7 +976,7 @@ | PNoImplicits PTerm -- ^ never run implicit converions on the term | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term]) | PUnquote PTerm -- ^ ~Term - | PQuoteName Name FC -- ^ `{n} where the FC is the precise highlighting for the name in particular + | PQuoteName Name Bool FC -- ^ `{n} where the FC is the precise highlighting for the name in particular. If the Bool is False, then it's `{{n}} and the name won't be resolved. | PRunElab FC PTerm [String] -- ^ %runElab tm - New-style proof script. Args are location, script, enclosing namespace. | PConstSugar FC PTerm -- ^ A desugared constant. The FC is a precise source location that will be used to highlight it later. deriving (Eq, Data, Typeable) @@ -1030,7 +1039,7 @@ mapPTermFC f g (PUnquote t) = PUnquote (mapPTermFC f g t) mapPTermFC f g (PRunElab fc tm ns) = PRunElab (f fc) (mapPTermFC f g tm) ns mapPTermFC f g (PConstSugar fc tm) = PConstSugar (g fc) (mapPTermFC f g tm) -mapPTermFC f g (PQuoteName n fc) = PQuoteName n (g fc) +mapPTermFC f g (PQuoteName n x fc) = PQuoteName n x (g fc) {-! dg instance Binary PTerm @@ -1257,7 +1266,7 @@ highestFC (PNoImplicits tm) = highestFC tm highestFC (PQuasiquote _ _) = Nothing highestFC (PUnquote tm) = highestFC tm -highestFC (PQuoteName _ fc) = Just fc +highestFC (PQuoteName _ _ fc) = Just fc highestFC (PRunElab fc _ _) = Just fc highestFC (PConstSugar fc _) = Just fc highestFC (PAppImpl t _) = highestFC t @@ -1277,6 +1286,12 @@ deriving instance NFData ClassInfo !-} +-- Record data +data RecordInfo = RI { record_parameters :: [(Name,PTerm)], + record_constructor :: Name, + record_projections :: [Name] } + deriving Show + -- Type inference data data TIData = TIPartial -- ^ a function with a partially defined type @@ -1645,7 +1660,7 @@ prettySe d p bnd (PPatvar fc n) = pretty n prettySe d p bnd e | Just str <- slist d p bnd e = depth d $ str - | Just n <- snat d p e = depth d $ annotate (AnnData "Nat" "") (text (show n)) + | Just n <- snat ppo d p e = depth d $ annotate (AnnData "Nat" "") (text (show n)) prettySe d p bnd (PRef fc _ n) = prettyName True (ppopt_impl ppo) bnd n prettySe d p bnd (PLam fc n nfc ty sc) = depth d . bracket p startPrec . group . align . hang 2 $ @@ -1862,7 +1877,9 @@ prettySe d p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe (decD d) p [] t <> text ")" prettySe d p bnd (PQuasiquote t (Just g)) = text "`(" <> prettySe (decD d) p [] t <+> colon <+> prettySe (decD d) p [] g <> text ")" prettySe d p bnd (PUnquote t) = text "~" <> prettySe (decD d) p bnd t - prettySe d p bnd (PQuoteName n _) = text "`{" <> prettyName True (ppopt_impl ppo) bnd n <> text "}" + prettySe d p bnd (PQuoteName n res _) = text start <> prettyName True (ppopt_impl ppo) bnd n <> text end + where start = if res then "`{" else "`{{" + end = if res then "}" else "}}" prettySe d p bnd (PRunElab _ tm _) = bracket p funcAppPrec . group . align . hang 2 $ text "%runElab" <$> @@ -1934,15 +1951,20 @@ natns = "Prelude.Nat." - snat :: Maybe Int -> Int -> PTerm -> Maybe Integer - snat (Just x) _ _ | x <= 0 = Nothing - snat d p (PRef _ _ z) - | show z == (natns++"Z") || show z == "Z" = Just 0 - snat d p (PApp _ s [PExp {getTm=n}]) - | show s == (natns++"S") || show s == "S", - Just n' <- snat (decD d) p n - = Just $ 1 + n' - snat _ _ _ = Nothing + snat :: PPOption -> Maybe Int -> Int -> PTerm -> Maybe Integer + snat ppo d p e + | ppopt_desugarnats ppo = Nothing + | otherwise = snat' d p e + where + snat' :: Maybe Int -> Int -> PTerm -> Maybe Integer + snat' (Just x) _ _ | x <= 0 = Nothing + snat' d p (PRef _ _ z) + | show z == (natns++"Z") || show z == "Z" = Just 0 + snat' d p (PApp _ s [PExp {getTm=n}]) + | show s == (natns++"S") || show s == "S", + Just n' <- snat' (decD d) p n + = Just $ 1 + n' + snat' _ _ _ = Nothing bracket outer inner doc | outer > inner = lparen <> doc <> rparen @@ -2155,160 +2177,216 @@ -- Return all names, free or globally bound, in the given term. allNamesIn :: PTerm -> [Name] -allNamesIn tm = nub $ ni [] tm +allNamesIn tm = nub $ ni 0 [] tm where -- TODO THINK added niTacImp, but is it right? - ni env (PRef _ _ n) + ni 0 env (PRef _ _ n) | not (n `elem` env) = [n] - ni env (PPatvar _ n) = [n] - ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) - ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) - ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os) - ni env (PIfThenElse _ c t f) = ni env c ++ ni env t ++ ni env f - ni env (PLam fc n _ ty sc) = ni env ty ++ ni (n:env) sc - ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc - ni env (PLet _ n _ ty val sc) = ni env ty ++ ni env val ++ ni (n:env) sc - ni env (PHidden tm) = ni env tm - ni env (PRewrite _ l r _) = ni env l ++ ni env r - ni env (PTyped l r) = ni env l ++ ni env r - ni env (PPair _ _ _ l r) = ni env l ++ ni env r - ni env (PDPair _ _ _ (PRef _ _ n) Placeholder r) = n : ni env r - ni env (PDPair _ _ _ (PRef _ _ n) t r) = ni env t ++ ni (n:env) r - ni env (PDPair _ _ _ l t r) = ni env l ++ ni env t ++ ni env r - ni env (PAlternative ns a ls) = concatMap (ni env) ls - ni env (PUnifyLog tm) = ni env tm - ni env (PDisamb _ tm) = ni env tm - ni env (PNoImplicits tm) = ni env tm - ni env _ = [] + ni 0 env (PPatvar _ n) = [n] + ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as) + ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as) + ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env) (map snd os) + ni 0 env (PIfThenElse _ c t f) = ni 0 env c ++ ni 0 env t ++ ni 0 env f + ni 0 env (PLam fc n _ ty sc) = ni 0 env ty ++ ni 0 (n:env) sc + ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc + ni 0 env (PLet _ n _ ty val sc) = ni 0 env ty ++ ni 0 env val ++ ni 0 (n:env) sc + ni 0 env (PHidden tm) = ni 0 env tm + ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r + ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r + ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r + ni 0 env (PDPair _ _ _ (PRef _ _ n) Placeholder r) = n : ni 0 env r + ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r + ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r + ni 0 env (PAlternative ns a ls) = concatMap (ni 0 env) ls + ni 0 env (PUnifyLog tm) = ni 0 env tm + ni 0 env (PDisamb _ tm) = ni 0 env tm + ni 0 env (PNoImplicits tm) = ni 0 env tm - niTacImp env (TacImp _ _ scr) = ni env scr - niTacImp _ _ = [] + ni i env (PQuasiquote tm ty) = ni (i+1) env tm ++ maybe [] (ni i env) ty + ni i env (PUnquote tm) = ni (i - 1) env tm + ni i env tm = concatMap (ni i env) (children tm) + niTacImp i env (TacImp _ _ scr) = ni i env scr + niTacImp _ _ _ = [] + + -- Return all names defined in binders in the given term boundNamesIn :: PTerm -> [Name] -boundNamesIn tm = S.toList (ni S.empty tm) +boundNamesIn tm = S.toList (ni 0 S.empty tm) where -- TODO THINK Added niTacImp, but is it right? - ni set (PApp _ f as) = niTms (ni set f) (map getTm as) - ni set (PAppBind _ f as) = niTms (ni set f) (map getTm as) - ni set (PCase _ c os) = niTms (ni set c) (map snd os) - ni set (PIfThenElse _ c t f) = niTms set [c, t, f] - ni set (PLam fc n _ ty sc) = S.insert n $ ni (ni set ty) sc - ni set (PLet fc n nfc ty val sc) = S.insert n $ ni (ni (ni set ty) val) sc - ni set (PPi p n _ ty sc) = niTacImp (S.insert n $ ni (ni set ty) sc) p - ni set (PRewrite _ l r _) = ni (ni set l) r - ni set (PTyped l r) = ni (ni set l) r - ni set (PPair _ _ _ l r) = ni (ni set l) r - ni set (PDPair _ _ _ (PRef _ _ n) t r) = ni (ni set t) r - ni set (PDPair _ _ _ l t r) = ni (ni (ni set l) t) r - ni set (PAlternative ns a as) = niTms set as - ni set (PHidden tm) = ni set tm - ni set (PUnifyLog tm) = ni set tm - ni set (PDisamb _ tm) = ni set tm - ni set (PNoImplicits tm) = ni set tm - ni set _ = set + ni :: Int -> S.Set Name -> PTerm -> S.Set Name + ni 0 set (PApp _ f as) = niTms 0 (ni 0 set f) (map getTm as) + ni 0 set (PAppBind _ f as) = niTms 0 (ni 0 set f) (map getTm as) + ni 0 set (PCase _ c os) = niTms 0 (ni 0 set c) (map snd os) + ni 0 set (PIfThenElse _ c t f) = niTms 0 set [c, t, f] + ni 0 set (PLam fc n _ ty sc) = S.insert n $ ni 0 (ni 0 set ty) sc + ni 0 set (PLet fc n nfc ty val sc) = S.insert n $ ni 0 (ni 0 (ni 0 set ty) val) sc + ni 0 set (PPi p n _ ty sc) = niTacImp 0 (S.insert n $ ni 0 (ni 0 set ty) sc) p + ni 0 set (PRewrite _ l r _) = ni 0 (ni 0 set l) r + ni 0 set (PTyped l r) = ni 0 (ni 0 set l) r + ni 0 set (PPair _ _ _ l r) = ni 0 (ni 0 set l) r + ni 0 set (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 (ni 0 set t) r + ni 0 set (PDPair _ _ _ l t r) = ni 0 (ni 0 (ni 0 set l) t) r + ni 0 set (PAlternative ns a as) = niTms 0 set as + ni 0 set (PHidden tm) = ni 0 set tm + ni 0 set (PUnifyLog tm) = ni 0 set tm + ni 0 set (PDisamb _ tm) = ni 0 set tm + ni 0 set (PNoImplicits tm) = ni 0 set tm - niTms set [] = set - niTms set (x : xs) = niTms (ni set x) xs + ni i set (PQuasiquote tm ty) = ni (i + 1) set tm `S.union` maybe S.empty (ni i set) ty + ni i set (PUnquote tm) = ni (i - 1) set tm - niTacImp set (TacImp _ _ scr) = ni set scr - niTacImp set _ = set + ni i set tm = foldr S.union set (map (ni i set) (children tm)) + niTms :: Int -> S.Set Name -> [PTerm] -> S.Set Name + niTms i set [] = set + niTms i set (x : xs) = niTms i (ni i set x) xs + + niTacImp i set (TacImp _ _ scr) = ni i set scr + niTacImp i set _ = set + -- Return names which are valid implicits in the given term (type). implicitNamesIn :: [Name] -> IState -> PTerm -> [Name] -implicitNamesIn uvars ist tm = nub $ ni [] tm +implicitNamesIn uvars ist tm + = let (imps, fns) = execState (ni 0 [] tm) ([], []) in + nub imps \\ nub fns where - ni env (PRef _ _ n) + addImp n = do (imps, fns) <- get + put (n : imps, fns) + addFn n = do (imps, fns) <- get + put (imps, n: fns) + + notCAF [] = False + notCAF (PExp _ _ _ _ : _) = True + notCAF (_ : xs) = notCAF xs + + notHidden (n, _) = case getAccessibility n of + Hidden -> False + _ -> True + + getAccessibility n + = case lookupDefAccExact n False (tt_ctxt ist) of + Just (n,t) -> t + _ -> Public + + ni 0 env (PRef _ _ n@(NS _ _)) | not (n `elem` env) - = case lookupTy n (tt_ctxt ist) of - [] -> [n] - _ -> if n `elem` uvars then [n] else [] - ni env (PApp _ f@(PRef _ _ n) as) - | n `elem` uvars = ni env f ++ concatMap (ni env) (map getTm as) - | otherwise = concatMap (ni env) (map getTm as) - ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) - ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) - ni env (PCase _ c os) = ni env c ++ + -- Never implicitly bind if there's a namespace + = addFn n + ni 0 env (PRef _ _ n) + | not (n `elem` env) && implicitable n || n `elem` uvars = addImp n + ni 0 env (PApp _ f@(PRef _ _ n) as) + | n `elem` uvars = do ni 0 env f + mapM_ (ni 0 env) (map getTm as) + | otherwise = do case lookupTy n (tt_ctxt ist) of + [] -> return () + _ -> addFn n + mapM_ (ni 0 env) (map getTm as) + ni 0 env (PApp _ f as) = do ni 0 env f + mapM_ (ni 0 env) (map getTm as) + ni 0 env (PAppBind _ f as) = do ni 0 env f + mapM_ (ni 0 env) (map getTm as) + ni 0 env (PCase _ c os) = do ni 0 env c -- names in 'os', not counting the names bound in the cases - (nub (concatMap (ni env) (map snd os)) - \\ nub (concatMap (ni env) (map fst os))) - ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f] - ni env (PLam fc n _ ty sc) = ni env ty ++ ni (n:env) sc - ni env (PPi p n _ ty sc) = ni env ty ++ ni (n:env) sc - ni env (PRewrite _ l r _) = ni env l ++ ni env r - ni env (PTyped l r) = ni env l ++ ni env r - ni env (PPair _ _ _ l r) = ni env l ++ ni env r - ni env (PDPair _ _ _ (PRef _ _ n) t r) = ni env t ++ ni (n:env) r - ni env (PDPair _ _ _ l t r) = ni env l ++ ni env t ++ ni env r - ni env (PAlternative ns a as) = concatMap (ni env) as - ni env (PHidden tm) = ni env tm - ni env (PUnifyLog tm) = ni env tm - ni env (PDisamb _ tm) = ni env tm - ni env (PNoImplicits tm) = ni env tm - ni env _ = [] + mapM_ (ni 0 env) (map snd os) + (imps, fns) <- get + put ([] ,[]) + mapM_ (ni 0 env) (map fst os) + (impsfst, _) <- get + put (nub imps \\ nub impsfst, fns) + ni 0 env (PIfThenElse _ c t f) = mapM_ (ni 0 env) [c, t, f] + ni 0 env (PLam fc n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc + ni 0 env (PPi p n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc + ni 0 env (PRewrite _ l r _) = do ni 0 env l; ni 0 env r + ni 0 env (PTyped l r) = do ni 0 env l; ni 0 env r + ni 0 env (PPair _ _ _ l r) = do ni 0 env l; ni 0 env r + ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = do ni 0 env t; ni 0 (n:env) r + ni 0 env (PDPair _ _ _ l t r) = do ni 0 env l + ni 0 env t + ni 0 env r + ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as + ni 0 env (PHidden tm) = ni 0 env tm + ni 0 env (PUnifyLog tm) = ni 0 env tm + ni 0 env (PDisamb _ tm) = ni 0 env tm + ni 0 env (PNoImplicits tm) = ni 0 env tm + ni i env (PQuasiquote tm ty) = do ni (i + 1) env tm + maybe (return ()) (ni i env) ty + ni i env (PUnquote tm) = ni (i - 1) env tm + + ni i env tm = mapM_ (ni i env) (children tm) + -- Return names which are free in the given term. namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name] -namesIn uvars ist tm = nub $ ni [] tm +namesIn uvars ist tm = nub $ ni 0 [] tm where - ni env (PRef _ _ n) + ni 0 env (PRef _ _ n) | not (n `elem` env) = case lookupTy n (tt_ctxt ist) of [] -> [n] _ -> if n `elem` (map fst uvars) then [n] else [] - ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) - ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) - ni env (PCase _ c os) = ni env c ++ + ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as) + ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as) + ni 0 env (PCase _ c os) = ni 0 env c ++ -- names in 'os', not counting the names bound in the cases - (nub (concatMap (ni env) (map snd os)) - \\ nub (concatMap (ni env) (map fst os))) - ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f] - ni env (PLam fc n nfc ty sc) = ni env ty ++ ni (n:env) sc - ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc - ni env (PRewrite _ l r _) = ni env l ++ ni env r - ni env (PTyped l r) = ni env l ++ ni env r - ni env (PPair _ _ _ l r) = ni env l ++ ni env r - ni env (PDPair _ _ _ (PRef _ _ n) t r) = ni env t ++ ni (n:env) r - ni env (PDPair _ _ _ l t r) = ni env l ++ ni env t ++ ni env r - ni env (PAlternative ns a as) = concatMap (ni env) as - ni env (PHidden tm) = ni env tm - ni env (PUnifyLog tm) = ni env tm - ni env (PDisamb _ tm) = ni env tm - ni env (PNoImplicits tm) = ni env tm - ni env _ = [] + (nub (concatMap (ni 0 env) (map snd os)) + \\ nub (concatMap (ni 0 env) (map fst os))) + ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f] + ni 0 env (PLam fc n nfc ty sc) = ni 0 env ty ++ ni 0 (n:env) sc + ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc + ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r + ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r + ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r + ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r + ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r + ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as + ni 0 env (PHidden tm) = ni 0 env tm + ni 0 env (PUnifyLog tm) = ni 0 env tm + ni 0 env (PDisamb _ tm) = ni 0 env tm + ni 0 env (PNoImplicits tm) = ni 0 env tm - niTacImp env (TacImp _ _ scr) = ni env scr - niTacImp _ _ = [] + ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty + ni i env (PUnquote tm) = ni (i - 1) env tm + ni i env tm = concatMap (ni i env) (children tm) + + niTacImp i env (TacImp _ _ scr) = ni i env scr + niTacImp _ _ _ = [] + -- Return which of the given names are used in the given term. usedNamesIn :: [Name] -> IState -> PTerm -> [Name] -usedNamesIn vars ist tm = nub $ ni [] tm +usedNamesIn vars ist tm = nub $ ni 0 [] tm where -- TODO THINK added niTacImp, but is it right? - ni env (PRef _ _ n) + ni 0 env (PRef _ _ n) | n `elem` vars && not (n `elem` env) = case lookupDefExact n (tt_ctxt ist) of Nothing -> [n] _ -> [] - ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) - ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) - ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os) - ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f] - ni env (PLam fc n _ ty sc) = ni env ty ++ ni (n:env) sc - ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc - ni env (PRewrite _ l r _) = ni env l ++ ni env r - ni env (PTyped l r) = ni env l ++ ni env r - ni env (PPair _ _ _ l r) = ni env l ++ ni env r - ni env (PDPair _ _ _ (PRef _ _ n) t r) = ni env t ++ ni (n:env) r - ni env (PDPair _ _ _ l t r) = ni env l ++ ni env t ++ ni env r - ni env (PAlternative ns a as) = concatMap (ni env) as - ni env (PHidden tm) = ni env tm - ni env (PUnifyLog tm) = ni env tm - ni env (PDisamb _ tm) = ni env tm - ni env (PNoImplicits tm) = ni env tm - ni env _ = [] + ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as) + ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as) + ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env) (map snd os) + ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f] + ni 0 env (PLam fc n _ ty sc) = ni 0 env ty ++ ni 0 (n:env) sc + ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc + ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r + ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r + ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r + ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r + ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r + ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as + ni 0 env (PHidden tm) = ni 0 env tm + ni 0 env (PUnifyLog tm) = ni 0 env tm + ni 0 env (PDisamb _ tm) = ni 0 env tm + ni 0 env (PNoImplicits tm) = ni 0 env tm - niTacImp env (TacImp _ _ scr) = ni env scr - niTacImp _ _ = [] + ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty + ni i env (PUnquote tm) = ni (i - 1) env tm + + ni i env tm = concatMap (ni i env) (children tm) + + niTacImp i env (TacImp _ _ scr) = ni i env scr + niTacImp _ _ _ = [] -- Return the list of inaccessible (= dotted) positions for a name. getErasureInfo :: IState -> Name -> [Int] diff --git a/src/Idris/Completion.hs b/src/Idris/Completion.hs --- a/src/Idris/Completion.hs +++ b/src/Idris/Completion.hs @@ -87,6 +87,7 @@ , "originalerrors" , "autosolve" , "nobanner" + , "desugarnats" ] completeConsoleWidth :: CompletionFunc Idris diff --git a/src/Idris/Core/DeepSeq.hs b/src/Idris/Core/DeepSeq.hs --- a/src/Idris/Core/DeepSeq.hs +++ b/src/Idris/Core/DeepSeq.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns, ViewPatterns #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Core.DeepSeq where @@ -15,6 +16,48 @@ rnf NErased = () rnf (SN x1) = rnf x1 `seq` () rnf (SymRef x1) = rnf x1 `seq` () + +instance NFData Context where + rnf ctxt = rnf (next_tvar ctxt) `seq` rnf (definitions ctxt) `seq` () + +-- | Forcing the contents of a context, for diagnosing and working +-- around space leaks +forceDefCtxt :: Context -> Context +forceDefCtxt (force -> !ctxt) = ctxt + +instance NFData NameOutput where + rnf TypeOutput = () + rnf FunOutput = () + rnf DataOutput = () + rnf MetavarOutput = () + rnf PostulateOutput = () + +instance NFData TextFormatting where + rnf BoldText = () + rnf ItalicText = () + rnf UnderlineText = () + +instance NFData Ordering where + rnf LT = () + rnf EQ = () + rnf GT = () + +instance NFData OutputAnnotation where + rnf (AnnName x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (AnnBoundName x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (AnnConst x1) = rnf x1 `seq` () + rnf (AnnData x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (AnnType x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (AnnKeyword) = () + rnf (AnnFC x) = rnf x `seq` () + rnf (AnnTextFmt x) = rnf x `seq` () + rnf (AnnLink x) = rnf x `seq` () + rnf (AnnTerm x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (AnnSearchResult x1) = rnf x1 `seq` () + rnf (AnnErr x1) = rnf x1 `seq` () + rnf (AnnNamespace x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (AnnQuasiquote) = () + rnf (AnnAntiquote) = () instance NFData SpecialName where rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () diff --git a/src/Idris/Core/Elaborate.hs b/src/Idris/Core/Elaborate.hs --- a/src/Idris/Core/Elaborate.hs +++ b/src/Idris/Core/Elaborate.hs @@ -309,7 +309,7 @@ return $! (instances (fst p)) -- | get auto argument names -get_autos :: Elab' aux [(Name, [Name])] +get_autos :: Elab' aux [(Name, ([FailContext], [Name]))] get_autos = do ES p _ _ <- get return $! (autos (fst p)) @@ -502,9 +502,10 @@ unifyProblems :: Elab' aux () unifyProblems = processTactic' UnifyProblems -defer :: [Name] -> Name -> Elab' aux () +defer :: [Name] -> Name -> Elab' aux Name defer ds n = do n' <- unique_hole n processTactic' (Defer ds n') + return n' deferType :: Name -> Raw -> [Name] -> Elab' aux () deferType n ty ns = processTactic' (DeferType n ty ns) diff --git a/src/Idris/Core/Evaluate.hs b/src/Idris/Core/Evaluate.hs --- a/src/Idris/Core/Evaluate.hs +++ b/src/Idris/Core/Evaluate.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns, PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} @@ -802,12 +802,14 @@ definitions :: Ctxt (Def, Accessibility, Totality, MetaInformation) } deriving Show + -- | The initial empty context initContext = MkContext 0 emptyContext + mapDefCtxt :: (Def -> Def) -> Context -> Context -mapDefCtxt f (MkContext t defs) = MkContext t (mapCtxt f' defs) - where f' (d, a, t, m) = f' (f d, a, t, m) +mapDefCtxt f (MkContext t !defs) = MkContext t (mapCtxt f' defs) + where f' (!d, a, t, m) = f' (f d, a, t, m) -- | Get the definitions from a context ctxtAlist :: Context -> [(Name, Def)] @@ -818,44 +820,44 @@ addToCtxt :: Name -> Term -> Type -> Context -> Context addToCtxt n tm ty uctxt = let ctxt = definitions uctxt - ctxt' = addDef n (Function ty tm, Public, Unchecked, EmptyMI) ctxt in + !ctxt' = addDef n (Function ty tm, Public, Unchecked, EmptyMI) ctxt in uctxt { definitions = ctxt' } setAccess :: Name -> Accessibility -> Context -> Context setAccess n a uctxt = let ctxt = definitions uctxt - ctxt' = updateDef n (\ (d, _, t, m) -> (d, a, t, m)) ctxt in + !ctxt' = updateDef n (\ (d, _, t, m) -> (d, a, t, m)) ctxt in uctxt { definitions = ctxt' } setTotal :: Name -> Totality -> Context -> Context setTotal n t uctxt = let ctxt = definitions uctxt - ctxt' = updateDef n (\ (d, a, _, m) -> (d, a, t, m)) ctxt in + !ctxt' = updateDef n (\ (d, a, _, m) -> (d, a, t, m)) ctxt in uctxt { definitions = ctxt' } setMetaInformation :: Name -> MetaInformation -> Context -> Context setMetaInformation n m uctxt = let ctxt = definitions uctxt - ctxt' = updateDef n (\ (d, a, t, _) -> (d, a, t, m)) ctxt in + !ctxt' = updateDef n (\ (d, a, t, _) -> (d, a, t, m)) ctxt in uctxt { definitions = ctxt' } addCtxtDef :: Name -> Def -> Context -> Context addCtxtDef n d c = let ctxt = definitions c - ctxt' = addDef n (d, Public, Unchecked, EmptyMI) $! ctxt in + !ctxt' = addDef n (d, Public, Unchecked, EmptyMI) $! ctxt in c { definitions = ctxt' } addTyDecl :: Name -> NameType -> Type -> Context -> Context addTyDecl n nt ty uctxt = let ctxt = definitions uctxt - ctxt' = addDef n (TyDecl nt ty, Public, Unchecked, EmptyMI) ctxt in + !ctxt' = addDef n (TyDecl nt ty, Public, Unchecked, EmptyMI) ctxt in uctxt { definitions = ctxt' } addDatatype :: Datatype Name -> Context -> Context addDatatype (Data n tag ty unique cons) uctxt = let ctxt = definitions uctxt ty' = normalise uctxt [] ty - ctxt' = addCons 0 cons (addDef n - (TyDecl (TCon tag (arity ty')) ty, Public, Unchecked, EmptyMI) ctxt) in + !ctxt' = addCons 0 cons (addDef n + (TyDecl (TCon tag (arity ty')) ty, Public, Unchecked, EmptyMI) ctxt) in uctxt { definitions = ctxt' } where addCons tag [] ctxt = ctxt diff --git a/src/Idris/Core/ProofState.hs b/src/Idris/Core/ProofState.hs --- a/src/Idris/Core/ProofState.hs +++ b/src/Idris/Core/ProofState.hs @@ -38,7 +38,7 @@ injective :: [Name], deferred :: [Name], -- ^ names we'll need to define instances :: [Name], -- ^ instance arguments (for type classes) - autos :: [(Name, [Name])], -- ^ unsolved 'auto' implicits with their holes + autos :: [(Name, ([FailContext], [Name]))], -- ^ unsolved 'auto' implicits with their holes psnames :: [Name], -- ^ Local names okay to use in proof search previous :: Maybe ProofState, -- ^ for undo context :: Context, @@ -154,7 +154,7 @@ holeName i = sMN i "hole" qshow :: Fails -> String -qshow fs = show (map (\ (x, y, hs, _, _, _, t) -> (t, x, y, hs)) fs) +qshow fs = show (map (\ (x, y, hs, env, _, _, t) -> (t, map fst env, x, y, hs)) fs) match_unify' :: Context -> Env -> (TT Name, Maybe Provenance) -> @@ -218,7 +218,7 @@ ("Trying " ++ show (topx, topy) ++ "\nNormalised " ++ show (normalise ctxt env topx, normalise ctxt env topy) ++ - " in " ++ show env ++ + " in\n" ++ show env ++ "\nHoles: " ++ show (holes ps) ++ "\nInjective: " ++ show (injective ps) ++ "\n") $ @@ -415,7 +415,7 @@ Nothing -> let hs = holes ps in ps { holes = (hs \\ [x]) ++ [x], - autos = (x, refsIn t) : autos ps } + autos = (x, (while_elaborating ps, refsIn t)) : autos ps } Just _ -> ps) return (Bind x (Hole t) sc) @@ -429,7 +429,8 @@ defer dropped n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' = do let env' = filter (\(n, t) -> n `notElem` dropped) env action (\ps -> let hs = holes ps in - ps { holes = hs \\ [x] }) + ps { usedns = n : usedns ps, + holes = hs \\ [x] }) ps <- get return (Bind n (GHole (length env') (psnames ps) (mkTy (reverse env') t)) (mkApp (P Ref n ty) (map getP (reverse env')))) @@ -904,6 +905,8 @@ getProvenance (CantUnify _ (_, lp) (_, rp) _ _ _) = (lp, rp) getProvenance _ = (Nothing, Nothing) +setReady (x, y, _, env, err, c, at) = (x, y, True, env, err, c, at) + updateProblems :: ProofState -> [(Name, TT Name)] -> Fails -> ([(Name, TT Name)], Fails) -- updateProblems ctxt [] ps inj holes = ([], ps) @@ -1009,7 +1012,7 @@ computeLet (context ps) n (getProofTerm (pterm ps)) }, "") processTactic UnifyProblems ps - = do let (ns', probs') = updateProblems ps [] (problems ps) + = do let (ns', probs') = updateProblems ps [] (map setReady (problems ps)) pterm' = updateSolved ns' (pterm ps) traceWhen (unifylog ps) ("(UnifyProblems) Dropping holes: " ++ show (map fst ns')) $ return (ps { pterm = pterm', solved = Nothing, problems = probs', @@ -1020,15 +1023,18 @@ holes = holes ps \\ (map fst ns') }, plog ps) where notIn ns (h, _) = h `notElem` map fst ns processTactic (MatchProblems all) ps - = do let (ns', probs') = matchProblems all ps [] (problems ps) + = do let (ns', probs') = matchProblems all ps [] (map setReady (problems ps)) (ns'', probs'') = matchProblems all ps ns' probs' - pterm' = updateSolved ns'' (pterm ps) - traceWhen (unifylog ps) ("(MatchProblems) Dropping holes: " ++ show (map fst ns'')) $ + pterm' = orderUpdateSolved ns'' (resetProofTerm (pterm ps)) + traceWhen (unifylog ps) ("(MatchProblems) Dropping holes: " ++ show ns'') $ return (ps { pterm = pterm', solved = Nothing, problems = probs'', previous = Just ps, plog = "", notunified = updateNotunified ns'' (notunified ps), recents = recents ps ++ map fst ns'', holes = holes ps \\ (map fst ns'') }, plog ps) + where + orderUpdateSolved [] t = t + orderUpdateSolved (n : ns) t = orderUpdateSolved ns (updateSolved [n] t) processTactic t ps = case holes ps of [] -> case t of diff --git a/src/Idris/Core/ProofTerm.hs b/src/Idris/Core/ProofTerm.hs --- a/src/Idris/Core/ProofTerm.hs +++ b/src/Idris/Core/ProofTerm.hs @@ -6,6 +6,7 @@ -} module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm, + resetProofTerm, updateSolved, updateSolvedTerm, updateSolvedTerm', bound_in, bound_in_term, refocus, updsubst, Hole, RunTactic', @@ -128,6 +129,9 @@ getProofTerm :: ProofTerm -> Term getProofTerm (PT path _ sub ups) = rebuildTerm sub (updateSolvedPath ups path) + +resetProofTerm :: ProofTerm -> ProofTerm +resetProofTerm = mkProofTerm . getProofTerm same :: Eq a => Maybe a -> a -> Bool same Nothing n = True diff --git a/src/Idris/Core/TT.hs b/src/Idris/Core/TT.hs --- a/src/Idris/Core/TT.hs +++ b/src/Idris/Core/TT.hs @@ -51,6 +51,7 @@ import Control.Applicative (Applicative (..), Alternative) import qualified Control.Applicative as A (Alternative (..)) +import Control.DeepSeq (($!!)) import Control.Monad.State.Strict import Control.Monad.Trans.Except (Except (..)) import Debug.Trace @@ -376,6 +377,21 @@ show x ++ ": " ++ show e show (Elaborating what n e) = "Elaborating " ++ what ++ show n ++ ":" ++ show e show (ProofSearchFail e) = "Proof search fail: " ++ show e + show (InfiniteUnify _ _ _) = "InfiniteUnify" + show (UnifyScope _ _ _ _) = "UnifyScope" + show (NonFunctionType _ _) = "NonFunctionType" + show (NotEquality _ _) = "NotEquality" + show (TooManyArguments _) = "TooManyArguments" + show (CantIntroduce _) = "CantIntroduce" + show (NoSuchVariable _) = "NoSuchVariable" + show (WithFnType _) = "WithFnType" + show (NoTypeDecl _) = "NoTypeDecl" + show (NotInjective _ _ _) = "NotInjective" + show (CantResolve _ _) = "CantResolve" + show (InvalidTCArg _ _) = "InvalidTCArg" + show (CantResolveAlts _) = "CantResolveAlts" + show (NoValidAlts _) = "NoValidAlts" + show (IncompleteTerm _) = "IncompleteTerm" show _ = "Error" instance Pretty Err OutputAnnotation where @@ -423,11 +439,11 @@ -- | Names are hierarchies of strings, describing scope (so no danger of -- duplicate names, but need to be careful on lookup). -data Name = UN T.Text -- ^ User-provided name - | NS Name [T.Text] -- ^ Root, namespaces - | MN Int T.Text -- ^ Machine chosen names +data Name = UN !T.Text -- ^ User-provided name + | NS !Name [T.Text] -- ^ Root, namespaces + | MN !Int !T.Text -- ^ Machine chosen names | NErased -- ^ Name of something which is never used in scope - | SN SpecialName -- ^ Decorated function names + | SN !SpecialName -- ^ Decorated function names | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation) deriving (Eq, Ord, Data, Typeable) @@ -448,7 +464,7 @@ sUN s = UN (txt s) sNS :: Name -> [String] -> Name -sNS n ss = NS n (map txt ss) +sNS n ss = NS n $!! (map txt ss) sMN :: Int -> String -> Name sMN i s = MN i (txt s) @@ -458,15 +474,15 @@ deriving instance NFData Name !-} -data SpecialName = WhereN Int Name Name - | WithN Int Name - | InstanceN Name [T.Text] - | ParentN Name T.Text - | MethodN Name - | CaseN Name - | ElimN Name - | InstanceCtorN Name - | MetaN Name Name +data SpecialName = WhereN !Int !Name !Name + | WithN !Int !Name + | InstanceN !Name [T.Text] + | ParentN !Name !T.Text + | MethodN !Name + | CaseN !Name + | ElimN !Name + | InstanceCtorN !Name + | MetaN !Name !Name deriving (Eq, Ord, Data, Typeable) {-! deriving instance Binary SpecialName diff --git a/src/Idris/Core/Unify.hs b/src/Idris/Core/Unify.hs --- a/src/Idris/Core/Unify.hs +++ b/src/Idris/Core/Unify.hs @@ -8,6 +8,7 @@ import Control.Monad import Control.Monad.State.Strict +import Data.Maybe import Data.List import Debug.Trace @@ -92,31 +93,6 @@ StateT UInfo TC [(Name, TT Name)] - -- This rule is highly dubious... it certainly produces a valid answer - -- but it scares me. However, matching is never guaranteed to give a unique - -- answer, merely a valid one, so perhaps we're okay. - -- In other words: it may vanish without warning some day :) - un names x tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a) - | (P (TCon _ _) _ _, _) <- unApply x, - holeIn env f || f `elem` holes - = let n' = uniqueName (sMN 0 "mv") (map fst env) in - checkCycle names (f, Bind n' (Lam t) x) - un names tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a) x - | (P (TCon _ _) _ _, _) <- unApply x, - holeIn env f || f `elem` holes - = let n' = uniqueName fn (map fst env) in - checkCycle names (f, Bind n' (Lam t) x) - un names x tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a) - | (P (DCon _ _ _) _ _, _) <- unApply x, - holeIn env f || f `elem` holes - = let n' = uniqueName (sMN 0 "mv") (map fst env) in - checkCycle names (f, Bind n' (Lam t) x) - un names tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a) x - | (P (DCon _ _ _) _ _, _) <- unApply x, - holeIn env f || f `elem` holes - = let n' = uniqueName fn (map fst env) in - checkCycle names (f, Bind n' (Lam t) x) - un names tx@(P _ x _) tm | tx /= tm && holeIn env x || x `elem` holes = do sc 1; checkCycle names (x, tm) @@ -346,7 +322,7 @@ un :: Bool -> [((Name, Name), TT Name)] -> TT Name -> TT Name -> StateT UInfo TC [(Name, TT Name)] - un = un' + un = un' env -- un fn names x y -- = let (xf, _) = unApply x -- (yf, _) = unApply y in @@ -354,23 +330,23 @@ -- uplus (un' fn names x y) -- (un' fn names (hnf ctxt env x) (hnf ctxt env y)) - un' :: Bool -> [((Name, Name), TT Name)] -> TT Name -> TT Name -> + un' :: Env -> Bool -> [((Name, Name), TT Name)] -> TT Name -> TT Name -> StateT UInfo TC [(Name, TT Name)] - un' fn names x y | x == y = return [] -- shortcut - un' fn names topx@(P (DCon _ _ _) x _) topy@(P (DCon _ _ _) y _) + un' env fn names x y | x == y = return [] -- shortcut + un' env fn names topx@(P (DCon _ _ _) x _) topy@(P (DCon _ _ _) y _) | x /= y = unifyFail topx topy - un' fn names topx@(P (TCon _ _) x _) topy@(P (TCon _ _) y _) + un' env fn names topx@(P (TCon _ _) x _) topy@(P (TCon _ _) y _) | x /= y = unifyFail topx topy - un' fn names topx@(P (DCon _ _ _) x _) topy@(P (TCon _ _) y _) + un' env fn names topx@(P (DCon _ _ _) x _) topy@(P (TCon _ _) y _) = unifyFail topx topy - un' fn names topx@(P (TCon _ _) x _) topy@(P (DCon _ _ _) y _) + un' env fn names topx@(P (TCon _ _) x _) topy@(P (DCon _ _ _) y _) = unifyFail topx topy - un' fn names topx@(Constant _) topy@(P (TCon _ _) y _) + un' env fn names topx@(Constant _) topy@(P (TCon _ _) y _) = unifyFail topx topy - un' fn names topx@(P (TCon _ _) x _) topy@(Constant _) + un' env fn names topx@(P (TCon _ _) x _) topy@(Constant _) = unifyFail topx topy - un' fn bnames tx@(P _ x _) ty@(P _ y _) + un' env fn bnames tx@(P _ x _) ty@(P _ y _) | (x,y) `elem` map fst bnames || x == y = do sc 1; return [] | injective tx && not (holeIn env y || y `elem` holes) = unifyTmpFail tx ty @@ -385,7 +361,7 @@ where envPos i n ((n',_):env) | n == n' = i envPos i n (_:env) = envPos (i+1) n env envPos _ _ _ = 100000 - un' fn bnames xtm@(P _ x _) tm + un' env fn bnames xtm@(P _ x _) tm | pureTerm tm, holeIn env x || x `elem` holes = do UI s f <- get -- injectivity check @@ -399,7 +375,7 @@ | pureTerm tm, not (injective xtm) && injective tm = do checkCycle bnames (x, tm) unifyTmpFail xtm tm - un' fn bnames tm ytm@(P _ y _) + un' env fn bnames tm ytm@(P _ y _) | pureTerm tm, holeIn env y || y `elem` holes = do UI s f <- get -- injectivity check @@ -413,62 +389,119 @@ | pureTerm tm, not (injective ytm) && injective tm = do checkCycle bnames (y, tm) unifyTmpFail tm ytm - un' fn bnames (V i) (P _ x _) + un' env fn bnames (V i) (P _ x _) | length bnames > i, fst ((map fst bnames)!!i) == x || snd ((map fst bnames)!!i) == x = do sc 1; return [] - un' fn bnames (P _ x _) (V i) + un' env fn bnames (P _ x _) (V i) | length bnames > i, fst ((map fst bnames)!!i) == x || snd ((map fst bnames)!!i) == x = do sc 1; return [] - un' fn names topx@(Bind n (Hole t) sc) y = unifyTmpFail topx y - un' fn names x topy@(Bind n (Hole t) sc) = unifyTmpFail x topy + un' env fn names topx@(Bind n (Hole t) sc) y = unifyTmpFail topx y + un' env fn names x topy@(Bind n (Hole t) sc) = unifyTmpFail x topy - un' fn bnames appx@(App _ _ _) appy@(App _ _ _) - = unApp fn bnames appx appy +-- Pattern unification rule + un' env fn bnames tm app@(App _ _ _) + | (P _ mv _, args) <- unApply app, + holeIn env mv || mv `elem` holes, + all rigid args, + containsOnly (mapMaybe getname args) (mapMaybe getV args) tm + -- && TODO: tm does not refer to any variables other than those + -- in 'args' + = -- trace ("PATTERN RULE SOLVE: " ++ show (mv, tm, env, bindLams args (substEnv env tm))) $ + checkCycle bnames (mv, eta [] $ bindLams args (substEnv env tm)) + where rigid (V i) = True + rigid (P _ t _) = t `elem` map fst env && + not (holeIn env t || t `elem` holes) + rigid _ = False + + getV (V i) = Just i + getV _ = Nothing + + getname (P _ n _) = Just n + getname _ = Nothing + + containsOnly args vs (V i) = i `elem` vs + containsOnly args vs (P Bound n ty) + = n `elem` args && containsOnly args vs ty + containsOnly args vs (P _ n ty) + = not (holeIn env n || n `elem` holes) + && containsOnly args vs ty + containsOnly args vs (App _ f a) + = containsOnly args vs f && containsOnly args vs a + containsOnly args vs (Bind _ b sc) + = containsOnly args vs (binderTy b) && + containsOnly args (0 : map (+1) vs) sc + containsOnly args vs _ = True + + bindLams [] tm = tm + bindLams (a : as) tm = bindLam a (bindLams as tm) + + bindLam (V i) tm = Bind (fst (env !! i)) + (Lam (binderTy (snd (env !! i)))) + tm + bindLam (P _ n ty) tm = Bind n (Lam ty) tm + bindLam _ tm = error "Can't happen [non rigid bindLam]" + + substEnv [] tm = tm + substEnv ((n, t) : env) tm + = substEnv env (substV (P Bound n (binderTy t)) tm) + + -- remove any unnecessary lambdas (helps with type class + -- resolution later). + eta ks (Bind n (Lam ty) sc) = eta ((n, ty) : ks) sc + eta ks t = rebind ks t + + rebind ((n, ty) : ks) (App _ f (P _ n' _)) + | n == n' = eta ks f + rebind ((n, ty) : ks) t = rebind ks (Bind n (Lam ty) t) + rebind _ t = t + + un' env fn bnames appx@(App _ _ _) appy@(App _ _ _) + = unApp env fn bnames appx appy -- = uplus (unApp fn bnames appx appy) -- (unifyTmpFail appx appy) -- take the whole lot - un' fn bnames x (Bind n (Lam t) (App _ y (P Bound n' _))) - | n == n' = un' False bnames x y - un' fn bnames (Bind n (Lam t) (App _ x (P Bound n' _))) y - | n == n' = un' False bnames x y - un' fn bnames x (Bind n (Lam t) (App _ y (V 0))) - = un' False bnames x y - un' fn bnames (Bind n (Lam t) (App _ x (V 0))) y - = un' False bnames x y --- un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy) --- = un' False ((x,y):bnames) sx sy --- un' fn bnames (Bind x (PVTy _) sx) (Bind y (PVTy _) sy) --- = un' False ((x,y):bnames) sx sy + un' env fn bnames x (Bind n (Lam t) (App _ y (P Bound n' _))) + | n == n' = un' env False bnames x y + un' env fn bnames (Bind n (Lam t) (App _ x (P Bound n' _))) y + | n == n' = un' env False bnames x y + un' env fn bnames x (Bind n (Lam t) (App _ y (V 0))) + = un' env False bnames x y + un' env fn bnames (Bind n (Lam t) (App _ x (V 0))) y + = un' env False bnames x y +-- un' env fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy) +-- = un' env False ((x,y):bnames) sx sy +-- un' env fn bnames (Bind x (PVTy _) sx) (Bind y (PVTy _) sy) +-- = un' env False ((x,y):bnames) sx sy -- f D unifies with t -> D. This is dubious, but it helps with type -- class resolution for type classes over functions. - un' fn bnames (App _ f x) (Bind n (Pi i t k) y) + un' env fn bnames (App _ f x) (Bind n (Pi i t k) y) | noOccurrence n y && injectiveApp f - = do ux <- un' False bnames x y - uf <- un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) + = do ux <- un' env False bnames x y + uf <- un' env False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) (Bind n (Pi i t k) (V 1))) - combine bnames ux uf + combine env bnames ux uf - un' fn bnames (Bind n (Pi i t k) y) (App _ f x) + un' env fn bnames (Bind n (Pi i t k) y) (App _ f x) | noOccurrence n y && injectiveApp f - = do ux <- un' False bnames y x - uf <- un' False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) + = do ux <- un' env False bnames y x + uf <- un' env False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) (Bind n (Pi i t k) (V 1))) f - combine bnames ux uf + combine env bnames ux uf - un' fn bnames (Bind x bx sx) (Bind y by sy) + un' env fn bnames (Bind x bx sx) (Bind y by sy) | sameBinder bx by - = do h1 <- uB bnames bx by - h2 <- un' False (((x,y),binderTy bx):bnames) sx sy - combine bnames h1 h2 + = do h1 <- uB env bnames bx by + h2 <- un' ((x, bx) : env) False (((x,y),binderTy bx):bnames) sx sy + combine env bnames h1 h2 where sameBinder (Lam _) (Lam _) = True sameBinder (Pi i _ _) (Pi i' _ _) = True sameBinder _ _ = False -- never unify holes/guesses/etc - un' fn bnames x y + un' env fn bnames x y | OK True <- convEq' ctxt holes x y = do sc 1; return [] | isUniverse x && isUniverse y = do sc 1; return [] | otherwise = do UI s f <- get @@ -480,11 +513,11 @@ else do put (UI s ((x, y, True, env, err, from, Unify) : f)) return [] -- lift $ tfail err - unApp fn bnames appx@(App _ fx ax) appy@(App _ fy ay) + unApp env fn bnames appx@(App _ fx ax) appy@(App _ fy ay) -- shortcut for the common case where we just want to check the -- arguments are correct | (injectiveApp fx && fx == fy) - = un' False bnames ax ay + = un' env False bnames ax ay | (injectiveApp fx && injectiveApp fy) || (injectiveApp fx && metavarApp fy && ax == ay) || (injectiveApp fy && metavarApp fx && ax == ay) @@ -493,18 +526,18 @@ -- fail quickly if the heads are disjoint checkHeads headx heady uplus - (do hf <- un' True bnames fx fy + (do hf <- un' env True bnames fx fy let ax' = hnormalise hf ctxt env (substNames hf ax) let ay' = hnormalise hf ctxt env (substNames hf ay) - ha <- un' False bnames ax' ay' + ha <- un' env False bnames ax' ay' sc 1 - combine bnames hf ha) - (do ha <- un' False bnames ax ay + combine env bnames hf ha) + (do ha <- un' env False bnames ax ay let fx' = hnormalise ha ctxt env (substNames ha fx) let fy' = hnormalise ha ctxt env (substNames ha fy) - hf <- un' False bnames fx' fy' + hf <- un' env False bnames fx' fy' sc 1 - combine bnames hf ha) + combine env bnames hf ha) | otherwise = unifyTmpFail appx appy where hnormalise [] _ _ t = t hnormalise ns ctxt env t = normalise ctxt env t @@ -522,8 +555,8 @@ unArgs as (x : xs) (y : ys) = do let x' = hnormalise as ctxt env (substNames as x) let y' = hnormalise as ctxt env (substNames as y) - as' <- un' False bnames x' y' - vs <- combine bnames as as' + as' <- un' env False bnames x' y' + vs <- combine env bnames as as' unArgs vs xs ys numArgs tm = let (f, args) = unApply tm in length args @@ -589,21 +622,22 @@ lift $ tfail err - uB bnames (Let tx vx) (Let ty vy) - = do h1 <- un' False bnames tx ty - h2 <- un' False bnames vx vy + uB env bnames (Let tx vx) (Let ty vy) + = do h1 <- un' env False bnames tx ty + h2 <- un' env False bnames vx vy sc 1 - combine bnames h1 h2 - uB bnames (Guess tx vx) (Guess ty vy) - = do h1 <- un' False bnames tx ty - h2 <- un' False bnames vx vy + combine env bnames h1 h2 + uB env bnames (Guess tx vx) (Guess ty vy) + = do h1 <- un' env False bnames tx ty + h2 <- un' env False bnames vx vy sc 1 - combine bnames h1 h2 - uB bnames (Lam tx) (Lam ty) = do sc 1; un' False bnames tx ty - uB bnames (Pi _ tx _) (Pi _ ty _) = do sc 1; un' False bnames tx ty - uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty - uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty - uB bnames x y = do UI s f <- get + combine env bnames h1 h2 + uB env bnames (Lam tx) (Lam ty) = do sc 1; un' env False bnames tx ty + uB env bnames (Pi _ tx _) (Pi _ ty _) = do sc 1; un' env False bnames tx ty + uB env bnames (Hole tx) (Hole ty) = un' env False bnames tx ty + uB env bnames (PVar tx) (PVar ty) = un' env False bnames tx ty + uB env bnames x y + = do UI s f <- get let r = recoverable (normalise ctxt env (binderTy x)) (normalise ctxt env (binderTy y)) let err = cantUnify from r (topx, xfrom) (topy, yfrom) @@ -638,20 +672,15 @@ App MaybeHoles (Bind y (Lam ty) (bind (i-1) ns tm)) (P Bound x ty) - combineArgs bnames args = ca [] args where - ca acc [] = return acc - ca acc (x : xs) = do x' <- combine bnames acc x - ca x' xs - - combine bnames as [] = return as - combine bnames as ((n, t) : bs) + combine env bnames as [] = return as + combine env bnames as ((n, t) : bs) = case lookup n as of - Nothing -> combine bnames (as ++ [(n,t)]) bs - Just t' -> do ns <- un' False bnames t t' + Nothing -> combine env bnames (as ++ [(n,t)]) bs + Just t' -> do ns <- un' env False bnames t t' -- make sure there's n mapping from n in ns let ns' = filter (\ (x, _) -> x/=n) ns sc 1 - combine bnames as (ns' ++ bs) + combine env bnames as (ns' ++ bs) boundVs :: Int -> Term -> [Int] boundVs i (V j) | j < i = [] @@ -719,10 +748,14 @@ | (P (DCon _ _ _) _ _, _) <- unApply f = False | (P (TCon _ _) _ _, _) <- unApply f = False | (Constant _) <- f = False + | TType _ <- f = False + | UType _ <- f = False recoverable (Bind _ (Pi _ _ _) sc) f | (P (DCon _ _ _) _ _, _) <- unApply f = False | (P (TCon _ _) _ _, _) <- unApply f = False | (Constant _) <- f = False + | TType _ <- f = False + | UType _ <- f = False recoverable (Bind _ (Lam _) sc) f = recoverable sc f recoverable f (Bind _ (Lam _) sc) = recoverable f sc recoverable x y = True diff --git a/src/Idris/Coverage.hs b/src/Idris/Coverage.hs --- a/src/Idris/Coverage.hs +++ b/src/Idris/Coverage.hs @@ -54,16 +54,16 @@ genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm] genClauses fc n xs given = do i <- getIState - let lhs_tms = map (\x -> delab' i x True True) xs + let lhs_tms = map (\x -> flattenArgs $ delab' i x True True) xs -- if a placeholder was given, don't bother generating cases for it let lhs_tms' = zipWith mergePlaceholders lhs_tms - (map (stripUnmatchable i) given) + (map (stripUnmatchable i) (map flattenArgs given)) let lhss = map pUnApply lhs_tms' let argss = transpose lhss let all_args = map (genAll i) argss logLvl 5 $ "COVERAGE of " ++ show n - logLvl 5 $ show lhss + logLvl 5 $ show (lhs_tms, lhss) logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args) logLvl 10 $ show argss ++ "\n" ++ show all_args logLvl 3 $ "Original: \n" ++ @@ -89,8 +89,12 @@ | (f, args) <- unApply term = map (\t -> delab' i t True True) args | otherwise = [] - pUnApply (PApp _ _ args) = map getTm args + pUnApply (PApp _ f args) = map getTm args pUnApply _ = [] + + flattenArgs (PApp fc (PApp _ f as) as') + = flattenArgs (PApp fc f (as ++ as')) + flattenArgs t = t -- Return whether the given clause matches none of the input clauses -- (xs) diff --git a/src/Idris/DeepSeq.hs b/src/Idris/DeepSeq.hs --- a/src/Idris/DeepSeq.hs +++ b/src/Idris/DeepSeq.hs @@ -6,6 +6,10 @@ import Idris.Docstrings import Idris.Core.TT import Idris.AbsSyntaxTree +import Idris.Colours +import IRTS.Lang (PrimFn(..)) +import IRTS.CodegenCommon (OutputType (..)) +import Util.DynamicLinker import Control.DeepSeq @@ -18,6 +22,285 @@ instance NFData CT.Options where rnf (CT.Options x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () +instance NFData ConsoleWidth where + rnf InfinitelyWide = () + rnf (ColsWide x) = rnf x `seq` () + rnf AutomaticWidth = () + +instance NFData PrimFn where + rnf (LPlus x) = rnf x `seq` () + rnf (LMinus x) = rnf x `seq` () + rnf (LTimes x) = rnf x `seq` () + rnf (LUDiv x) = rnf x `seq` () + rnf (LSDiv x) = rnf x `seq` () + rnf (LURem x) = rnf x `seq` () + rnf (LSRem x) = rnf x `seq` () + rnf (LAnd x) = rnf x `seq` () + rnf (LOr x) = rnf x `seq` () + rnf (LXOr x) = rnf x `seq` () + rnf (LCompl x) = rnf x `seq` () + rnf (LSHL x) = rnf x `seq` () + rnf (LLSHR x) = rnf x `seq` () + rnf (LASHR x) = rnf x `seq` () + rnf (LEq x) = rnf x `seq` () + rnf (LLt x) = rnf x `seq` () + rnf (LLe x) = rnf x `seq` () + rnf (LGt x) = rnf x `seq` () + rnf (LGe x) = rnf x `seq` () + rnf (LSLt x) = rnf x `seq` () + rnf (LSLe x) = rnf x `seq` () + rnf (LSGt x) = rnf x `seq` () + rnf (LSGe x) = rnf x `seq` () + rnf (LSExt x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (LZExt x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (LTrunc x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (LStrConcat) = () + rnf (LStrLt) = () + rnf (LStrEq) = () + rnf (LStrLen) = () + rnf (LIntFloat x) = rnf x `seq` () + rnf (LFloatInt x) = rnf x `seq` () + rnf (LIntStr x) = rnf x `seq` () + rnf (LStrInt x) = rnf x `seq` () + rnf (LFloatStr) = () + rnf (LStrFloat) = () + rnf (LChInt x) = rnf x `seq` () + rnf (LIntCh x) = rnf x `seq` () + rnf (LBitCast x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (LFExp) = () + rnf (LFLog) = () + rnf (LFSin) = () + rnf (LFCos) = () + rnf (LFTan) = () + rnf (LFASin) = () + rnf (LFACos) = () + rnf (LFATan) = () + rnf (LFSqrt) = () + rnf (LFFloor) = () + rnf (LFCeil) = () + rnf (LFNegate) = () + rnf (LStrHead) = () + rnf (LStrTail) = () + rnf (LStrCons) = () + rnf (LStrIndex) = () + rnf (LStrRev) = () + rnf (LStrSubstr) = () + rnf (LReadStr) = () + rnf (LWriteStr) = () + rnf (LSystemInfo) = () + rnf (LFork) = () + rnf (LPar) = () + rnf (LExternal x) = rnf x `seq` () + rnf (LNoOp) = () + +instance NFData SyntaxRules where + rnf (SyntaxRules xs) = rnf xs `seq` () + +instance NFData DynamicLib where + rnf (Lib x _) = rnf x `seq` () + + +instance NFData Opt where + rnf (Filename str) = rnf str `seq` () + rnf (Quiet) = () + rnf (NoBanner) = () + rnf (ColourREPL bool) = rnf bool `seq` () + rnf (Idemode) = () + rnf (IdemodeSocket) = () + rnf (ShowLibs) = () + rnf (ShowLibdir) = () + rnf (ShowIncs) = () + rnf (ShowPkgs) = () + rnf (NoBasePkgs) = () + rnf (NoPrelude) = () + rnf (NoBuiltins) = () + rnf (NoREPL) = () + rnf (OLogging i) = rnf i `seq` () + rnf (Output str) = rnf str `seq` () + rnf (Interface) = () + rnf (TypeCase) = () + rnf (TypeInType) = () + rnf (DefaultTotal) = () + rnf (DefaultPartial) = () + rnf (WarnPartial) = () + rnf (WarnReach) = () + rnf (EvalTypes) = () + rnf (DesugarNats) = () + rnf (NoCoverage) = () + rnf (ErrContext) = () + rnf (ShowImpl) = () + rnf (Verbose) = () + rnf (Port str) = rnf str `seq` () + rnf (IBCSubDir str) = rnf str `seq` () + rnf (ImportDir str) = rnf str `seq` () + rnf (PkgBuild str) = rnf str `seq` () + rnf (PkgInstall str) = rnf str `seq` () + rnf (PkgClean str) = rnf str `seq` () + rnf (PkgCheck str) = rnf str `seq` () + rnf (PkgREPL str) = rnf str `seq` () + rnf (PkgMkDoc str) = rnf str `seq` () + rnf (PkgTest str) = rnf str `seq` () + rnf (PkgIndex fp) = rnf fp `seq` () + rnf (WarnOnly) = () + rnf (Pkg str) = rnf str `seq` () + rnf (BCAsm str) = rnf str `seq` () + rnf (DumpDefun str) = rnf str `seq` () + rnf (DumpCases str) = rnf str `seq` () + rnf (UseCodegen cg) = rnf cg `seq` () + rnf (CodegenArgs str) = rnf str `seq` () + rnf (OutputTy ot) = rnf ot `seq` () + rnf (Extension le) = rnf le `seq` () + rnf (InterpretScript str) = rnf str `seq` () + rnf (EvalExpr str) = rnf str `seq` () + rnf (TargetTriple str) = rnf str `seq` () + rnf (TargetCPU str) = rnf str `seq` () + rnf (OptLevel i) = rnf i `seq` () + rnf (AddOpt o) = rnf o `seq` () + rnf (RemoveOpt o) = rnf o `seq` () + rnf (Client str) = rnf str `seq` () + rnf (ShowOrigErr) = () + rnf (AutoWidth) = () + rnf (AutoSolve) = () + rnf (UseConsoleWidth cw) = rnf cw `seq` () + rnf (DumpHighlights) = () + + +instance NFData TIData where + rnf TIPartial = () + rnf (TISolution xs) = rnf xs `seq` () + +instance NFData IOption where + rnf (IOption + opt_logLevel + opt_typecase + opt_typeintype + opt_coverage + opt_showimp + opt_errContext + opt_repl + opt_verbose + opt_nobanner + opt_quiet + opt_codegen + opt_outputTy + opt_ibcsubdir + opt_importdirs + opt_triple + opt_cpu + opt_cmdline + opt_origerr + opt_autoSolve + opt_autoImport + opt_optimise + opt_printdepth + opt_evaltypes + opt_desugarnats) = + rnf opt_logLevel + `seq` rnf opt_typecase + `seq` rnf opt_typeintype + `seq` rnf opt_coverage + `seq` rnf opt_showimp + `seq` rnf opt_errContext + `seq` rnf opt_repl + `seq` rnf opt_verbose + `seq` rnf opt_nobanner + `seq` rnf opt_quiet + `seq` rnf opt_codegen + `seq` rnf opt_outputTy + `seq` rnf opt_ibcsubdir + `seq` rnf opt_importdirs + `seq` rnf opt_triple + `seq` rnf opt_cpu + `seq` rnf opt_cmdline + `seq` rnf opt_origerr + `seq` rnf opt_autoSolve + `seq` rnf opt_autoImport + `seq` rnf opt_optimise + `seq` rnf opt_printdepth + `seq` rnf opt_evaltypes + `seq` rnf opt_desugarnats + `seq` () + +instance NFData LanguageExt where + rnf TypeProviders = () + rnf ErrorReflection = () + +instance NFData Optimisation where + rnf PETransform = () + +instance NFData ColourTheme where + rnf (ColourTheme keywordColour + boundVarColour + implicitColour + functionColour + typeColour + dataColour + promptColour + postulateColour) = + rnf keywordColour + `seq` rnf boundVarColour + `seq` rnf implicitColour + `seq` rnf functionColour + `seq` rnf typeColour + `seq` rnf dataColour + `seq` rnf promptColour + `seq` rnf postulateColour + `seq` () + +instance NFData IdrisColour where + rnf (IdrisColour _ x2 x3 x4 x5) = rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` () + +instance NFData OutputType where + rnf Raw = () + rnf Object = () + rnf Executable = () + rnf MavenProject = () + +instance NFData IBCWrite where + rnf (IBCFix fixDecl) = rnf fixDecl `seq` () + rnf (IBCImp name) = rnf name `seq` () + rnf (IBCStatic name) = rnf name `seq` () + rnf (IBCClass name) = rnf name `seq` () + rnf (IBCInstance b1 b2 n1 n2) = rnf b1 `seq` rnf b2 `seq` rnf n1 `seq` rnf n2 `seq` () + rnf (IBCDSL name) = rnf name `seq` () + rnf (IBCData name) = rnf name `seq` () + rnf (IBCOpt name) = rnf name `seq` () + rnf (IBCMetavar name) = rnf name `seq` () + rnf (IBCSyntax syntax) = rnf syntax `seq` () + rnf (IBCKeyword string) = rnf string `seq` () + rnf (IBCImport imp) = rnf imp `seq` () + rnf (IBCImportDir filePath) = rnf filePath `seq` () + rnf (IBCObj codegen filePath) = rnf codegen `seq` rnf filePath `seq` () + rnf (IBCLib codegen string) = rnf codegen `seq` rnf string `seq` () + rnf (IBCCGFlag codegen string) = rnf codegen `seq` rnf string `seq` () + rnf (IBCDyLib string) = rnf string `seq` () + rnf (IBCHeader codegen string) = rnf codegen `seq` rnf string `seq` () + rnf (IBCAccess name accessibility) = rnf name `seq` rnf accessibility `seq` () + rnf (IBCMetaInformation name metaInformation) = rnf name `seq` rnf metaInformation `seq` () + rnf (IBCTotal name totality) = rnf name `seq` rnf totality `seq` () + rnf (IBCFlags name fnOpts) = rnf name `seq` rnf fnOpts `seq` () + rnf (IBCFnInfo name fnInfo) = rnf name `seq` rnf fnInfo `seq` () + rnf (IBCTrans name terms) = rnf name `seq` rnf terms `seq` () + rnf (IBCErrRev terms) = rnf terms `seq` () + rnf (IBCCG name) = rnf name `seq` () + rnf (IBCDoc name) = rnf name `seq` () + rnf (IBCCoercion name) = rnf name `seq` () + rnf (IBCDef name) = rnf name `seq` () + rnf (IBCNameHint names) = rnf names `seq` () + rnf (IBCLineApp filePath int pTerm) = rnf filePath `seq` rnf int `seq` rnf pTerm `seq` () + rnf (IBCErrorHandler name) = rnf name `seq` () + rnf (IBCFunctionErrorHandler n1 n2 n3) = rnf n1 `seq` rnf n2 `seq` rnf n3 `seq` () + rnf (IBCPostulate name) = rnf name `seq` () + rnf (IBCExtern extern) = rnf extern `seq` () + rnf (IBCTotCheckErr fc string) = rnf fc `seq` rnf string `seq` () + rnf (IBCParsedRegion fc) = rnf fc `seq` () + rnf (IBCModDocs name) = rnf name `seq` () + rnf (IBCUsage usage) = rnf usage `seq` () + rnf (IBCExport name) = rnf name `seq` () + rnf (IBCAutoHint n1 n2) = rnf n1 `seq` rnf n2 `seq` () + rnf (IBCRecord x) = rnf x `seq` () + + instance NFData a => NFData (D.Block a) where rnf (D.Para lines) = rnf lines `seq` () rnf (D.Header i lines) = rnf i `seq` rnf lines `seq` () @@ -270,7 +553,7 @@ rnf (PNoImplicits x1) = rnf x1 `seq` () rnf (PQuasiquote x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PUnquote x1) = rnf x1 `seq` () - rnf (PQuoteName x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PQuoteName x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (PRunElab x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (PConstSugar x1 x2) = rnf x1 `seq` rnf x2 `seq` () @@ -346,6 +629,10 @@ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` () +instance NFData RecordInfo where + rnf (RI x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + instance NFData OptInfo where rnf (Optimise x1 x2) = rnf x1 `seq` rnf x2 `seq` () @@ -390,3 +677,18 @@ rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` () + +instance NFData OutputMode where + rnf (RawOutput x) = () -- no instance for Handle, so this is a bit wrong + rnf (IdeMode x y) = rnf x `seq` () + + +instance NFData IState where + rnf (IState x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 + x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 + x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 + x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` () `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` rnf x14 `seq` rnf x15 `seq` rnf x16 `seq` rnf x17 `seq` rnf x18 `seq` rnf x19 `seq` rnf x20 `seq` + rnf x21 `seq` rnf x22 `seq` rnf x23 `seq` rnf x24 `seq` rnf x25 `seq` rnf x26 `seq` rnf x27 `seq` rnf x28 `seq` rnf x29 `seq` rnf x30 `seq` rnf x31 `seq` rnf x32 `seq` rnf x33 `seq` rnf x34 `seq` rnf x35 `seq` rnf x36 `seq` rnf x37 `seq` rnf x38 `seq` rnf x39 `seq` rnf x40 `seq` + rnf x41 `seq` rnf x42 `seq` rnf x43 `seq` rnf x44 `seq` rnf x45 `seq` rnf x46 `seq` rnf x47 `seq` rnf x48 `seq` rnf x49 `seq` rnf x50 `seq` rnf x51 `seq` rnf x52 `seq` rnf x53 `seq` rnf x54 `seq` rnf x55 `seq` rnf x56 `seq` rnf x57 `seq` rnf x58 `seq` rnf x59 `seq` rnf x60 `seq` + rnf x61 `seq` rnf x62 `seq` rnf x63 `seq` rnf x64 `seq` rnf x65 `seq` rnf x66 `seq` rnf x67 `seq` rnf x68 `seq` rnf x69 `seq` rnf x70 `seq` rnf x71 `seq` rnf x72 `seq` rnf x73 `seq` () diff --git a/src/Idris/Delaborate.hs b/src/Idris/Delaborate.hs --- a/src/Idris/Delaborate.hs +++ b/src/Idris/Delaborate.hs @@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} -module Idris.Delaborate (annName, bugaddr, delab, delab', delabMV, delabSugared, delabTy, delabTy', fancifyAnnots, pprintDelab, pprintDelabTy, pprintErr, resugar) where +module Idris.Delaborate (annName, bugaddr, delab, delab', delabMV, delabSugared, delabTy, delabTy', fancifyAnnots, pprintDelab, pprintNoDelab, pprintDelabTy, pprintErr, resugar) where -- Convert core TT back into high level syntax, primarily for display -- purposes. @@ -226,6 +226,10 @@ pprintDelab ist tm = annotate (AnnTerm [] tm) (prettyIst ist (delabSugared ist tm)) +pprintNoDelab :: IState -> Term -> Doc OutputAnnotation +pprintNoDelab ist tm = annotate (AnnTerm [] tm) + (prettyIst ist (delab ist tm)) + -- | Pretty-print the type of some name pprintDelabTy :: IState -> Name -> Doc OutputAnnotation pprintDelabTy i n @@ -355,8 +359,11 @@ pprintErr' i (CantMatch t) = text "Can't match on" <+> annTm t (pprintTerm i (delabSugared i t)) pprintErr' i (IncompleteTerm t) - = align (cat (punctuate (comma <> space) - (map pprintIncomplete (nub $ getMissing [] [] t)))) + = let missing = getMissing [] [] t in + case missing of + [] -> text "Incomplete term" <+> annTm t (pprintTerm i (delabSugared i t)) + _ -> align (cat (punctuate (comma <> space) + (map pprintIncomplete (nub $ getMissing [] [] t)))) where pprintIncomplete (tm, arg) | expname arg diff --git a/src/Idris/Docs.hs b/src/Idris/Docs.hs --- a/src/Idris/Docs.hs +++ b/src/Idris/Docs.hs @@ -41,6 +41,10 @@ [PTerm] -- subclasses [PTerm] -- superclasses (Maybe (FunDoc' d)) -- explicit constructor + | RecordDoc Name d -- record docs + (FunDoc' d) -- data constructor docs + [FunDoc' d] -- projection docs + [(Name, PTerm, Maybe d)] -- parameters with type and doc | NamedInstanceDoc Name (FunDoc' d) -- name is class | ModDoc [String] -- Module name d @@ -209,6 +213,33 @@ then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty (showDoc ist) md) params) else hsep (punctuate comma (map (prettyName True False params' . fst) params)) +pprintDocs ist (RecordDoc n doc ctor projs params) + = nest 4 (text "Record" <+> prettyName True (ppopt_impl ppo) [] n <> + if nullDocstring doc + then empty + else line <> + renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) doc) + -- Parameters + <$> (if null params + then empty + else line <> nest 4 (text "Parameters:" <$> prettyParameters) <> line) + -- Constructor + <$> nest 4 (text "Constructor:" <$> pprintFDWithoutTotality ist False ctor) + -- Projections + <$> nest 4 (text "Projections:" <$> vsep (map (pprintFDWithoutTotality ist False) projs)) + where + ppo = ppOptionIst ist + infixes = idris_infixes ist + + pNames = [n | (n,_,_) <- params] + params' = zip pNames (repeat False) + + prettyParameters = + if any isJust [d | (_,_,d) <- params] + then vsep (map (\(n,pt,d) -> prettyParam (n,pt) <+> maybe empty (showDoc ist) d) params) + else hsep (punctuate comma (map prettyParam [(n,pt) | (n,pt,_) <- params])) + prettyParam (n,pt) = prettyName True False params' n <+> text ":" <+> pprintPTerm ppo params' [] infixes pt + pprintDocs ist (NamedInstanceDoc _cls doc) = nest 4 (text "Named instance:" <$> pprintFDWithoutTotality ist True doc) @@ -234,6 +265,8 @@ = do i <- getIState docs <- if | Just ci <- lookupCtxtExact n (idris_classes i) -> docClass n ci + | Just ri <- lookupCtxtExact n (idris_records i) + -> docRecord n ri | Just ti <- lookupCtxtExact n (idris_datatypes i) -> docData n ti | Just class_ <- classNameForInst i n @@ -295,6 +328,17 @@ = isSubclass pt isSubclass _ = False + +docRecord :: Name -> RecordInfo -> Idris Docs +docRecord n ri + = do i <- getIState + let docStrings = listToMaybe $ lookupCtxt n $ idris_docstrings i + docstr = maybe emptyDocstring fst docStrings + params = map (\(pn,pt) -> (pn, pt, docStrings >>= (lookup (nsroot pn) . snd))) + (record_parameters ri) + pdocs <- mapM docFun (record_projections ri) + ctorDocs <- docFun $ record_constructor ri + return $ RecordDoc n docstr ctorDocs pdocs params docFun :: Name -> Idris FunDoc docFun n diff --git a/src/Idris/Elab/Clause.hs b/src/Idris/Elab/Clause.hs --- a/src/Idris/Elab/Clause.hs +++ b/src/Idris/Elab/Clause.hs @@ -162,7 +162,7 @@ simpleCase tcase (UnmatchedCase "Error") reflect CompileTime fc inacc atys pdef erInfo cov <- coverage pmissing <- - if cov && not (hasDefault cs) + if cov && not (hasDefault pats_raw) then do missing <- genClauses fc n (map getLHS pdef) cs_full -- missing <- genMissing n scargs sc missing' <- filterM (checkPossible info fc True n) missing @@ -291,10 +291,20 @@ depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc) depat acc x = (acc, x) - hasDefault cs | (PClause _ _ last _ _ _ :_) <- reverse cs - , (PApp fn s args) <- last = all ((==Placeholder) . getTm) args + + getPVs (Bind x (PVar _) tm) = let (vs, tm') = getPVs tm + in (x:vs, tm') + getPVs tm = ([], tm) + + isPatVar vs (P Bound n _) = n `elem` vs + isPatVar _ _ = False + + hasDefault cs | (Right (lhs, rhs) : _) <- reverse cs + , (pvs, tm) <- getPVs (explicitNames lhs) + , (f, args) <- unApply tm = all (isPatVar pvs) args hasDefault _ = False + getLHS (_, l, _) = l simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y) @@ -491,6 +501,8 @@ = t { getTm = PRef NoFC [] n } : addP sc ts addP (Bind n _ sc) (t : ts) = t : addP sc ts addP _ ts = ts +propagateParams i ps t tm@(PApp fc ap args) + = PApp fc (propagateParams i ps t ap) args propagateParams i ps t (PRef fc hls n) = case lookupCtxt n (idris_implicits i) of [is] -> let ps' = filter (isImplicit is) ps in @@ -543,11 +555,15 @@ let fn_is = case lookupCtxt fname (idris_implicits i) of [t] -> t _ -> [] - let params = getParamsInType i [] fn_is (normalise ctxt [] fn_ty) + let norm_ty = normalise ctxt [] fn_ty + let params = getParamsInType i [] fn_is norm_ty + let tcparams = getTCParamsInType i [] fn_is norm_ty + let lhs = mkLHSapp $ stripLinear i $ stripUnmatchable i $ - propagateParams i params fn_ty (addImplPat i lhs_in) + propagateParams i params norm_ty (addImplPat i lhs_in) -- let lhs = mkLHSapp $ -- propagateParams i params fn_ty (addImplPat i lhs_in) + logLvl 10 (show (params, fn_ty) ++ " " ++ showTmImpls (addImplPat i lhs_in)) logLvl 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs) logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++ "\n" ++ show (fn_ty, fn_is)) @@ -576,7 +592,8 @@ -- If we're inferring metavariables in the type, don't recheck, -- because we're only doing this to try to work out those metavariables (clhs_c, clhsty) <- if not inf - then recheckC fc id [] lhs_tm + then recheckC_borrowing False (PEGenerated `notElem` opts) + [] fc id [] lhs_tm else return (lhs_tm, lhs_ty) let clhs = normalise ctxt [] clhs_c let borrowed = borrowedNames [] clhs @@ -634,7 +651,7 @@ (do pbinds ist lhs_tm -- proof search can use explicitly written names mapM_ addPSname (allNamesIn lhs_in) - mapM_ setinj (nub (params ++ inj)) + mapM_ setinj (nub (tcparams ++ inj)) setNextName (ElabResult _ _ is ctxt' newDecls highlights) <- errAt "right hand side of " fname @@ -678,14 +695,16 @@ logLvl 6 $ " ==> " ++ show (forget rhs') (crhs, crhsty) <- if not inf - then recheckC_borrowing True borrowed fc id [] rhs' + then recheckC_borrowing True (PEGenerated `notElem` opts) + borrowed fc id [] rhs' else return (rhs', clhsty) logLvl 6 $ " ==> " ++ showEnvDbg [] crhsty ++ " against " ++ showEnvDbg [] clhsty ctxt <- getContext let constv = next_tvar ctxt case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of - OK (_, cs) -> do addConstraints fc cs - logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs + OK (_, cs) -> when (PEGenerated `notElem` opts) $ do + addConstraints fc cs + logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs ++ "\n" ++ show (clhsty, crhsty) return () Error e -> ierror (At fc (CantUnify False (clhsty, Nothing) (crhsty, Nothing) e [] 0)) i <- getIState diff --git a/src/Idris/Elab/Record.hs b/src/Idris/Elab/Record.hs --- a/src/Idris/Elab/Record.hs +++ b/src/Idris/Elab/Record.hs @@ -64,6 +64,12 @@ _ -> PDatadecl tyn NoFC tycon [(cdoc, dconsArgDocs, dconName, NoFC, dconTy, fc, [])] elabData info rsyn doc paramDocs fc opts datadecl + -- Keep track of the record + let parameters = [(n,pt) | (n, _, _, pt) <- params] + let projections = [n | (n, _, _, _, _) <- fieldsWithName] + addRecord tyn (RI parameters dconName projections) + addIBC (IBCRecord tyn) + when (what /= ETypes) $ do logLvl 1 $ "fieldsWithName " ++ show fieldsWithName logLvl 1 $ "fieldsWIthNameAndDoc " ++ show fieldsWithNameAndDoc diff --git a/src/Idris/Elab/Term.hs b/src/Idris/Elab/Term.hs --- a/src/Idris/Elab/Term.hs +++ b/src/Idris/Elab/Term.hs @@ -91,7 +91,7 @@ ptm <- get_term resolveTC' True True 10 g fn ist) ivs - when (not pattern) $ solveAutos ist fn True + when (not pattern) $ solveAutos ist fn False tm <- get_term ctxt <- get_context @@ -104,6 +104,8 @@ "Remaining problems:\n" ++ qshow probs) $ do unify_all; matchProblems True; unifyProblems + when (not pattern) $ solveAutos ist fn True + probs <- get_probs case probs of [] -> return () @@ -269,8 +271,9 @@ hs <- get_holes -- If any of the autos use variables which have recently been solved, -- have another go at solving them now. - mapM_ (\(a, ns) -> if any (\n -> n `elem` solved) ns && head hs /= a - then solveAuto ist fn False a + mapM_ (\(a, (failc, ns)) -> + if any (\n -> n `elem` solved) ns && head hs /= a + then solveAuto ist fn False (a, failc) else return ()) as itm <- if not pattern then insertImpLam ina t else return t @@ -442,6 +445,7 @@ -- trace (show (map showHd as')) $ ty <- goal case as' of + [] -> lift $ tfail $ NoValidAlts (map showHd as) [x] -> elab' ina fc x -- If there's options, try now, and if that fails, postpone -- to later. @@ -451,25 +455,31 @@ (do movelast h delayElab 5 $ do hs <- get_holes - when (not (null hs)) $ do + when (h `elem` hs) $ do focus h as'' <- doPrune as' case as'' of [x] -> elab' ina fc x _ -> tryAll (zip (map (elab' ina fc) as'') (map showHd as''))) - where showHd (PApp _ (PRef _ _ n) _) = n + where showHd (PApp _ (PRef _ _ (UN l)) [_, _, arg]) + | l == txt "Delay" = showHd (getTm arg) + showHd (PApp _ (PRef _ _ n) _) = n showHd (PRef _ _ n) = n showHd (PApp _ h _) = showHd h showHd x = NErased -- We probably should do something better than this here doPrune as = - do hnf_compute + do compute ty <- goal - let (tc, _) = unApply ty + let (tc, _) = unApply (unDelay ty) env <- get_env return $ pruneByType env tc ist as + unDelay t | (P _ (UN l) _, [_, arg]) <- unApply t, + l == txt "Lazy'" = unDelay arg + | otherwise = t + isAmbiguous (CantResolveAlts _) = delayok isAmbiguous (Elaborating _ _ e) = isAmbiguous e @@ -492,20 +502,21 @@ solveAutos ist fn False) (trySeq' deferr xs) True elab' ina fc (PAlternative ms TryImplicit (orig : alts)) = do env <- get_env + compute ty <- goal let doelab = elab' ina fc orig tryCatch doelab (\err -> if recoverableErr err then -- trace ("NEED IMPLICIT! " ++ show orig ++ "\n" ++ - -- show alts ++ "\n" ++ - -- showQuick err) $ + -- show alts ++ "\n" ++ + -- showQuick err) $ -- Prune the coercions so that only the ones -- with the right type to fix the error will be tried! case pruneAlts err alts env of [] -> lift $ tfail err - alts' -> - try' (elab' ina fc (PAlternative [] (ExactlyOne False) alts')) + alts' -> do + try' (elab' ina fc (PAlternative ms (ExactlyOne False) alts')) (lift $ tfail err) -- take error from original if all fail True else lift $ tfail err) @@ -529,8 +540,8 @@ _ -> filter isLend alts -- special case hack for 'Borrowed' pruneAlts (ElaboratingArg _ _ _ e) alts env = pruneAlts e alts env pruneAlts (At _ e) alts env = pruneAlts e alts env - pruneAlts (NoValidAlts _) alts env = alts - pruneAlts _ alts _ = filter isLend alts + pruneAlts (NoValidAlts as) alts env = alts + pruneAlts err alts _ = filter isLend alts hasArg n env ap | isLend ap = True -- special case hack for 'Borrowed' hasArg n env (PApp _ (PRef _ _ a) _) @@ -538,7 +549,8 @@ Just ty -> let args = map snd (getArgTys (normalise (tt_ctxt ist) env ty)) in any (fnIs n) args Nothing -> False - hasArg n _ _ = False + hasArg n env (PAlternative _ _ as) = any (hasArg n env) as + hasArg n _ tm = False isLend (PApp _ (PRef _ _ l) _) = l == sNS (sUN "lend") ["Ownership"] isLend _ = False @@ -599,7 +611,6 @@ [] -> False _ -> True bindable (NS _ _) = False - bindable (UN xs) = True bindable n = implicitable n elab' ina _ f@(PInferRef fc hls n) = elab' ina (Just fc) (PApp NoFC f []) elab' ina fc' tm@(PRef fc hls n) @@ -969,7 +980,7 @@ let n' = metavarName (namespace info) n attack psns <- getPSnames - defer unique_used n' + n' <- defer unique_used n' solve highlightSource nfc (AnnName n' (Just MetavarOutput) Nothing Nothing) elab' ina fc (PProof ts) = do compute; mapM_ (runTac True ist (elabFC info) fn) ts @@ -1045,10 +1056,9 @@ let args' = filter (\(n, _) -> n `notElem` argsDropped) args - cname <- unique_hole' True (mkCaseName fn) - let cname' = mkN cname --- elab' ina fc (PMetavar cname') - attack; defer argsDropped cname'; solve + attack + cname' <- defer argsDropped (mkN (mkCaseName fn)) + solve -- if the scrutinee is one of the 'args' in env, we should -- inspect it directly, rather than adding it as a new argument @@ -1192,7 +1202,10 @@ elab' ina fc (PUnquote t) = fail "Found unquote outside of quasiquote" - elab' ina fc (PQuoteName n nfc) = + elab' ina fc (PQuoteName n False nfc) = + do fill $ reflectName n + solve + elab' ina fc (PQuoteName n True nfc) = do ctxt <- get_context env <- get_env case lookup n env of @@ -1376,7 +1389,7 @@ notImplicitable (PRef _ _ n) | [opts] <- lookupCtxt n (idris_flags ist) = NoImplicit `elem` opts - notImplicitable (PAlternative _ (ExactlyOne _) as) = any notImplicitable as + notImplicitable (PAlternative _ _ as) = any notImplicitable as -- case is tricky enough without implicit coercions! If they are needed, -- they can go in the branches separately. notImplicitable (PCase _ _ _) = True @@ -1420,9 +1433,11 @@ (PCoerced tm, _) -> tm (_, []) -> t (_, cs) -> PAlternative [] TryImplicit - (t : map (mkCoerce env t) cs) + (t : map (mkCoerce env t) cs) return t' where + mkCoerce env (PAlternative ms aty tms) n + = PAlternative ms aty (map (\t -> mkCoerce env t n) tms) mkCoerce env t n = let fc = maybe (fileFC "Coercion") id (highestFC t) in addImplBound ist (map fst env) (PApp fc (PRef fc [] n) [pexp (PCoerced t)]) @@ -1520,6 +1535,8 @@ n `elem` map fst env = Just t | otherwise = locallyBound ts getName (PRef _ _ n) = Just n + getName (PApp _ (PRef _ _ (UN l)) [_, _, arg]) -- ignore Delays + | l == txt "Delay" = getName (getTm arg) getName (PApp _ f _) = getName f getName (PHidden t) = getName t getName _ = Nothing @@ -1528,18 +1545,20 @@ pruneByType env (P _ n _) ist as -- if the goal type is polymorphic, keep everything | Nothing <- lookupTyExact n ctxt = as +-- if the goal type is a ?metavariable, keep everything + | Just _ <- lookup n (idris_metavars ist) = as | otherwise = let asV = filter (headIs True n) as as' = filter (headIs False n) as in case as' of - [] -> case asV of - [] -> as - _ -> asV + [] -> asV _ -> as' where ctxt = tt_ctxt ist headIs var f (PRef _ _ f') = typeHead var f f' + headIs var f (PApp _ (PRef _ _ (UN l)) [_, _, arg]) + | l == txt "Delay" = headIs var f (getTm arg) headIs var f (PApp _ (PRef _ _ f') _) = typeHead var f f' headIs var f (PApp _ f' _) = headIs var f f' headIs var f (PPi _ _ _ _ sc) = headIs var f sc @@ -1605,21 +1624,36 @@ "Can't find name" ++ show n -- Try again to solve auto implicits -solveAuto :: IState -> Name -> Bool -> Name -> ElabD () -solveAuto ist fn ambigok n - = do hs <- get_holes - tm <- get_term - when (n `elem` hs) $ do - focus n - g <- goal - isg <- is_guess -- if it's a guess, we're working on it recursively, so stop - when (not isg) $ - proofSearch' ist True ambigok 100 True Nothing fn [] [] +solveAuto :: IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD () +solveAuto ist fn ambigok (n, failc) + = do hs <- get_holes + when (not (null hs)) $ do + env <- get_env + g <- goal + handleError cantsolve (when (n `elem` hs) $ do + focus n + isg <- is_guess -- if it's a guess, we're working on it recursively, so stop + when (not isg) $ + proofSearch' ist True ambigok 100 True Nothing fn [] []) + (lift $ Error (addLoc failc + (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env)))) + return () + where addLoc (FailContext fc f x : prev) err + = At fc (ElaboratingArg f x + (map (\(FailContext _ f' x') -> (f', x')) prev) err) + addLoc _ err = err + cantsolve (CantSolveGoal _ _) = True + cantsolve (InternalMsg _) = True + cantsolve (At _ e) = cantsolve e + cantsolve (Elaborating _ _ e) = cantsolve e + cantsolve (ElaboratingArg _ _ _ e) = cantsolve e + cantsolve _ = False + solveAutos :: IState -> Name -> Bool -> ElabD () solveAutos ist fn ambigok = do autos <- get_autos - mapM_ (solveAuto ist fn ambigok) (map fst autos) + mapM_ (solveAuto ist fn ambigok) (map (\(n, (fc, _)) -> (n, fc)) autos) trivial' ist = trivial (elab ist toplevel ERHS [] (sMN 0 "tac")) ist @@ -2322,6 +2356,7 @@ -- TODO: argument-specific error handlers go here for ElaboratingArg handle e = do ist <- getIState logLvl 2 "Starting error reflection" + logLvl 5 (show e) let handlers = idris_errorhandlers ist applyHandlers e handlers getFnHandlers :: Name -> Name -> Idris [Name] diff --git a/src/Idris/Elab/Transform.hs b/src/Idris/Elab/Transform.hs --- a/src/Idris/Elab/Transform.hs +++ b/src/Idris/Elab/Transform.hs @@ -65,7 +65,7 @@ let lhs_ty = getInferType lhs' let newargs = pvars i lhs_tm - (clhs_tm_in, clhs_ty) <- recheckC fc id [] lhs_tm + (clhs_tm_in, clhs_ty) <- recheckC_borrowing False False [] fc id [] lhs_tm let clhs_tm = renamepats pnames clhs_tm_in logLvl 3 ("Transform LHS " ++ show clhs_tm) logLvl 3 ("Transform type " ++ show clhs_ty) @@ -86,7 +86,7 @@ processTacticDecls info newDecls sendHighlighting highlights - (crhs_tm_in, crhs_ty) <- recheckC fc id [] rhs' + (crhs_tm_in, crhs_ty) <- recheckC_borrowing False False [] fc id [] rhs' let crhs_tm = renamepats pnames crhs_tm_in logLvl 3 ("Transform RHS " ++ show crhs_tm) diff --git a/src/Idris/Elab/Type.hs b/src/Idris/Elab/Type.hs --- a/src/Idris/Elab/Type.hs +++ b/src/Idris/Elab/Type.hs @@ -64,6 +64,7 @@ let ty = addImpl (imp_methods syn) i ty' logLvl 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty' + logLvl 5 $ show "with methods " ++ show (imp_methods syn) logLvl 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty (ElabResult tyT' defer is ctxt' newDecls highlights, log) <- diff --git a/src/Idris/Elab/Utils.hs b/src/Idris/Elab/Utils.hs --- a/src/Idris/Elab/Utils.hs +++ b/src/Idris/Elab/Utils.hs @@ -16,15 +16,16 @@ import Control.Monad.State import Control.Monad import Data.List +import Data.Maybe import qualified Data.Traversable as Traversable import Debug.Trace import qualified Data.Map as Map -recheckC = recheckC_borrowing False [] +recheckC = recheckC_borrowing False True [] -recheckC_borrowing uniq_check bs fc mkerr env t +recheckC_borrowing uniq_check addConstrs bs fc mkerr env t = do -- t' <- applyOpts (forget t) (doesn't work, or speed things up...) ctxt <- getContext t' <- case safeForget t of @@ -33,8 +34,8 @@ (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs ctxt env t' t of Error e -> tfail (At fc (mkerr e)) OK x -> return x - logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs - addConstraints fc cs + logLvl 6 $ "CONSTRAINTS ADDED: " ++ show (tm, ty, cs) + when addConstrs $ addConstraints fc cs return (tm, ty) iderr :: Name -> Err -> Err @@ -211,6 +212,24 @@ flex = getFlexInType i env fix t in [x | x <- fix, not (x `elem` flex)] +getTCinj i (Bind n (Pi _ t _) sc) + = getTCinj i t ++ getTCinj i (instantiate (P Bound n t) sc) +getTCinj i ap@(App _ f a) + | (P _ n _, args) <- unApply ap, + isTCName n = mapMaybe getInjName args + | otherwise = [] + where + isTCName n = case lookupCtxtExact n (idris_classes i) of + Just _ -> True + _ -> False + getInjName t | (P _ x _, _) <- unApply t = Just x + | otherwise = Nothing +getTCinj _ _ = [] + +getTCParamsInType :: IState -> [Name] -> [PArg] -> Type -> [Name] +getTCParamsInType i env ps t = let params = getParamsInType i env ps t + tcs = nub $ getTCinj i t in + filter (flip elem tcs) params paramNames args env [] = [] paramNames args env (p : ps) | length args > p = case args!!p of diff --git a/src/Idris/Error.hs b/src/Idris/Error.hs --- a/src/Idris/Error.hs +++ b/src/Idris/Error.hs @@ -147,7 +147,7 @@ warnDisamb ist (PQuasiquote tm goal) = warnDisamb ist tm >> Foldable.mapM_ (warnDisamb ist) goal warnDisamb ist (PUnquote tm) = warnDisamb ist tm -warnDisamb ist (PQuoteName _ _) = return () +warnDisamb ist (PQuoteName _ _ _) = return () warnDisamb ist (PAs _ _ tm) = warnDisamb ist tm warnDisamb ist (PAppImpl tm _) = warnDisamb ist tm warnDisamb ist (PRunElab _ tm _) = warnDisamb ist tm diff --git a/src/Idris/IBC.hs b/src/Idris/IBC.hs --- a/src/Idris/IBC.hs +++ b/src/Idris/IBC.hs @@ -40,7 +40,7 @@ import Codec.Archive.Zip ibcVersion :: Word16 -ibcVersion = 119 +ibcVersion = 120 data IBCFile = IBCFile { ver :: Word16, sourcefile :: FilePath, @@ -50,6 +50,7 @@ ibc_fixes :: ![FixDecl], ibc_statics :: ![(Name, [Bool])], ibc_classes :: ![(Name, ClassInfo)], + ibc_records :: ![(Name, RecordInfo)], ibc_instances :: ![(Bool, Bool, Name, Name)], ibc_dsls :: ![(Name, DSL)], ibc_datatypes :: ![(Name, TypeInfo)], @@ -93,7 +94,7 @@ !-} initIBC :: IBCFile -initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] +initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] hasValidIBCVersion :: FilePath -> Idris Bool hasValidIBCVersion fp = do @@ -142,6 +143,7 @@ makeEntry "ibc_fixes" (ibc_fixes i), makeEntry "ibc_statics" (ibc_statics i), makeEntry "ibc_classes" (ibc_classes i), + makeEntry "ibc_records" (ibc_records i), makeEntry "ibc_instances" (ibc_instances i), makeEntry "ibc_dsls" (ibc_dsls i), makeEntry "ibc_datatypes" (ibc_datatypes i), @@ -234,6 +236,10 @@ = case lookupCtxtExact n (idris_classes i) of Just v -> return f { ibc_classes = (n,v): ibc_classes f } _ -> ifail "IBC write failed" +ibc i (IBCRecord n) f + = case lookupCtxtExact n (idris_records i) of + Just v -> return f { ibc_records = (n,v): ibc_records f } + _ -> ifail "IBC write failed" ibc i (IBCInstance int res n ins) f = return f { ibc_instances = (int, res, n, ins) : ibc_instances f } ibc i (IBCDSL n) f @@ -303,7 +309,7 @@ getEntry :: (Binary b, NFData b) => b -> FilePath -> Archive -> Idris b getEntry alt f a = case findEntryByPath f a of Nothing -> return alt - Just e -> return $ (force . decode . fromEntry) e + Just e -> return $! (force . decode . fromEntry) e process :: Bool -- ^ Reexporting -> Archive -> FilePath -> Idris () @@ -324,6 +330,7 @@ pFixes =<< getEntry [] "ibc_fixes" i pStatics =<< getEntry [] "ibc_statics" i pClasses =<< getEntry [] "ibc_classes" i + pRecords =<< getEntry [] "ibc_records" i pInstances =<< getEntry [] "ibc_instances" i pDSLs =<< getEntry [] "ibc_dsls" i pDatatypes =<< getEntry [] "ibc_datatypes" i @@ -442,6 +449,13 @@ = addDef n c' (idris_classes i) })) cs +pRecords :: [(Name, RecordInfo)] -> Idris () +pRecords rs = mapM_ (\ (n, r) -> + do i <- getIState + putIState (i { idris_records + = addDef n r (idris_records i) })) + rs + pInstances :: [(Bool, Bool, Name, Name)] -> Idris () pInstances cs = mapM_ (\ (i, res, n, ins) -> addInstance i res n ins) cs @@ -1660,9 +1674,10 @@ put x2 PUnquote x1 -> do putWord8 43 put x1 - PQuoteName x1 x2 -> do putWord8 44 - put x1 - put x2 + PQuoteName x1 x2 x3 -> do putWord8 44 + put x1 + put x2 + put x3 PIfThenElse x1 x2 x3 x4 -> do putWord8 45 put x1 put x2 @@ -1808,7 +1823,8 @@ return (PUnquote x1) 44 -> do x1 <- get x2 <- get - return (PQuoteName x1 x2) + x3 <- get + return (PQuoteName x1 x2 x3) 45 -> do x1 <- get x2 <- get x3 <- get @@ -2129,6 +2145,17 @@ x5 <- get x6 <- get return (CI x1 x2 x3 x4 x5 [] x6) + +instance Binary RecordInfo where + put (RI x1 x2 x3) + = do put x1 + put x2 + put x3 + get + = do x1 <- get + x2 <- get + x3 <- get + return (RI x1 x2 x3) instance Binary OptInfo where put (Optimise x1 x2) diff --git a/src/Idris/IdrisDoc.hs b/src/Idris/IdrisDoc.hs --- a/src/Idris/IdrisDoc.hs +++ b/src/Idris/IdrisDoc.hs @@ -221,6 +221,7 @@ where getFunDocs (FunDoc f) = [f] getFunDocs (DataDoc f fs) = f:fs getFunDocs (ClassDoc _ _ fs _ _ _ _ _) = fs + getFunDocs (RecordDoc _ _ f fs _) = f:fs getFunDocs (NamedInstanceDoc _ fd) = [fd] getFunDocs (ModDoc _ _) = [] types (FD _ _ args t _) = t:(map second args) @@ -594,6 +595,32 @@ in if (head n') `elem` opChars then '(':(n' ++ ")") else n' + +createOtherDoc ist (RecordDoc n doc ctor projs params) = do + H.dt ! (A.id $ toValue $ show n) $ do + H.span ! class_ "word" $ do "record"; nbsp + H.span ! class_ "name type" + ! title (toValue $ show n) + $ toHtml $ name $ nsroot n + H.span ! class_ "type" $ do nbsp ; prettyParameters + H.dd $ do + (if nullDocstring doc then Empty else Docstrings.renderHtml doc) + if not $ null params + then H.dl $ forM_ params genParam + else Empty + H.dl ! class_ "decls" $ createFunDoc ist ctor + H.dl ! class_ "decls" $ forM_ projs (createFunDoc ist) + where name (NS n ns) = show (NS (sUN $ name n) ns) + name n = let n' = show n + in if (head n') `elem` opChars + then '(':(n' ++ ")") + else n' + + genParam (name, pt, docstring) = do + H.dt $ toHtml $ show (nsroot name) + H.dd $ maybe nbsp Docstrings.renderHtml docstring + + prettyParameters = toHtml $ unwords [show $ nsroot n | (n,_,_) <- params] createOtherDoc ist (DataDoc fd@(FD n docstring args _ _) fds) = do H.dt ! (A.id $ toValue $ show n) $ do diff --git a/src/Idris/ParseExpr.hs b/src/Idris/ParseExpr.hs --- a/src/Idris/ParseExpr.hs +++ b/src/Idris/ParseExpr.hs @@ -226,7 +226,8 @@ update ns (PNoImplicits t) = PNoImplicits $ update ns t update ns (PQuasiquote tm mty) = PQuasiquote (update ns tm) (fmap (update ns) mty) update ns (PUnquote t) = PUnquote $ update ns t - update ns (PQuoteName n fc) = uncurry PQuoteName (updateB ns (n, fc)) + update ns (PQuoteName n res fc) = let (n', fc') = (updateB ns (n, fc)) + in PQuoteName n' res fc' update ns (PRunElab fc t nsp) = PRunElab fc (update ns t) nsp update ns (PConstSugar fc t) = PConstSugar fc $ update ns t -- PConstSugar probably can't contain anything substitutable, but it's hard to track @@ -736,15 +737,19 @@ -} namequote :: SyntaxInfo -> IdrisParser PTerm -namequote syn = do startFC <- symbolFC "`{" +namequote syn = do (startFC, res) <- + try (do fc <- symbolFC "`{{" + return (fc, False)) <|> + (do fc <- symbolFC "`{" + return (fc, True)) (n, nfc) <- fnName - endFC <- symbolFC "}" + endFC <- if res then symbolFC "}" else symbolFC "}}" mapM_ (uncurry highlightP) [ (startFC, AnnKeyword) , (endFC, AnnKeyword) , (spanFC startFC endFC, AnnQuasiquote) ] - return $ PQuoteName n nfc + return $ PQuoteName n res nfc "quoted name" diff --git a/src/Idris/Primitives.hs b/src/Idris/Primitives.hs --- a/src/Idris/Primitives.hs +++ b/src/Idris/Primitives.hs @@ -15,6 +15,8 @@ import Data.Function (on) import qualified Data.Vector.Unboxed as V +import Debug.Trace + data Prim = Prim { p_name :: Name, p_type :: Type, p_arity :: Int, @@ -165,6 +167,8 @@ (2, LStrIndex) partial, Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev) (1, LStrRev) total, + Prim (sUN "prim__strSubstr") (ty [AType (ATInt ITNative), AType (ATInt ITNative), StrType] StrType) 3 (p_strSubstr) + (3, LStrSubstr) total, Prim (sUN "prim__readString") (ty [WorldType] StrType) 1 (p_cantreduce) (1, LReadStr) total, -- total is okay, because we have 'WorldType' @@ -493,7 +497,7 @@ p_floatFloor = p_fPrim (fromInteger . floor) p_floatCeil = p_fPrim (fromInteger . ceiling) -p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev :: [Const] -> Maybe Const +p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev, p_strSubstr :: [Const] -> Maybe Const p_strLen [Str xs] = Just $ I (length xs) p_strLen _ = Nothing p_strHead [Str (x:xs)] = Just $ Ch x @@ -507,6 +511,9 @@ p_strCons _ = Nothing p_strRev [Str xs] = Just $ Str (reverse xs) p_strRev _ = Nothing +p_strSubstr [I offset, I length, Str input] = Just $ Str (take length (drop offset input)) +p_strSubstr _ = Nothing + p_cantreduce :: a -> Maybe b p_cantreduce _ = Nothing diff --git a/src/Idris/ProofSearch.hs b/src/Idris/ProofSearch.hs --- a/src/Idris/ProofSearch.hs +++ b/src/Idris/ProofSearch.hs @@ -165,12 +165,23 @@ if ambigok || argsok then case lookupCtxt nroot (idris_tyinfodata ist) of [TISolution ts] -> findInferredTy ts - _ -> psRec rec maxDepth [] S.empty - else do ptm <- get_term - autoArg (sUN "auto") -- not enough info in the type yet + _ -> if ambigok then psRec rec maxDepth [] S.empty + -- postpone if it fails early in elaboration + else handleError cantsolve + (psRec rec maxDepth [] S.empty) + (autoArg (sUN "auto")) + else autoArg (sUN "auto") -- not enough info in the type yet where findInferredTy (t : _) = elab (delab ist (toUN t)) + cantsolve (InternalMsg _) = True + cantsolve (CantSolveGoal _ _) = True + cantsolve (IncompleteTerm _) = True + cantsolve (At _ e) = cantsolve e + cantsolve (Elaborating _ _ e) = cantsolve e + cantsolve (ElaboratingArg _ _ _ e) = cantsolve e + cantsolve err = False + conArgsOK ty = let (f, as) = unApply ty in case f of @@ -206,7 +217,7 @@ | Constant _ <- c = not (n `elem` hs) -- if fa is a metavariable applied to anything, we're not ready to run yet. notHole hs (fa, c) - | (P _ fn _, args) <- unApply fa = fn `notElem` hs + | (P _ fn _, args@(_:_)) <- unApply fa = fn `notElem` hs notHole _ _ = True inHS hs (P _ n _) = n `elem` hs diff --git a/src/Idris/Prover.hs b/src/Idris/Prover.hs --- a/src/Idris/Prover.hs +++ b/src/Idris/Prover.hs @@ -127,9 +127,13 @@ _ -> return () elabStep :: ElabState EState -> ElabD a -> Idris (a, ElabState EState) -elabStep st e = case runStateT eCheck st of - OK (a, st') -> return (a, st') - Error a -> ierror a +elabStep st e = + case runStateT eCheck st of + OK ((a, ctxt'), ES (ps, est@EState{new_tyDecls = declTodo}) x old) -> + do setContext ctxt' + processTacticDecls toplevel declTodo + return (a, ES (ps, est {new_tyDecls = []}) x old) + Error a -> ierror a where eCheck = do res <- e matchProblems True unifyProblems @@ -138,7 +142,7 @@ [] -> do tm <- get_term ctxt <- get_context lift $ check ctxt [] (forget tm) - return res + return (res, ctxt) ((_,_,_,_,e,_,_):_) -> lift $ Error e dumpState :: IState -> [(Name, Type, Term)] -> ProofState -> Idris () @@ -264,6 +268,7 @@ undoElab prf env st [] = ifail "Nothing to undo" undoElab prf env st (h:hs) = do (prf', env', st') <- undoStep prf env st h return (prf', env', st', hs) + elabloop :: Name -> Bool -> String -> [String] -> ElabState EState -> [ElabShellHistory] -> Maybe History -> [(Name, Type, Term)] -> Idris (Term, [String]) elabloop fn d prompt prf e prev h env diff --git a/src/Idris/REPL.hs b/src/Idris/REPL.hs --- a/src/Idris/REPL.hs +++ b/src/Idris/REPL.hs @@ -327,10 +327,13 @@ reverse unused)] runIO . hPutStrLn h $ IdeMode.convSExp "return" good id runIdeModeCommand h id orig fn mods (IdeMode.LoadFile filename toline) = + -- The $!! here prevents a space leak on reloading. + -- This isn't a solution - but it's a temporary stopgap. + -- See issue #2386 do i <- getIState clearErr - putIState (orig { idris_options = idris_options i, - idris_outputmode = (IdeMode id h) }) + putIState $!! orig { idris_options = idris_options i, + idris_outputmode = (IdeMode id h) } mods <- loadInputs [filename] toline isetPrompt (mkPrompt mods) -- Report either success or failure @@ -490,12 +493,23 @@ if null underNSs && null names then iPrintError "Invalid or empty namespace" else do ist <- getIState - let msg = (IdeMode.SymbolAtom "ok", (underNSs, map (pn ist) names)) + underNs <- mapM pn names + let msg = (IdeMode.SymbolAtom "ok", (underNSs, underNs)) runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id - where pn ist = displaySpans . - renderPretty 0.9 1000 . - fmap (fancifyAnnots ist True) . - prettyName True True [] + where pn n = + do ctxt <- getContext + ist <- getIState + return $ + displaySpans . + renderPretty 0.9 1000 . + fmap (fancifyAnnots ist True) $ + prettyName True False [] n <> + case lookupTyExact n ctxt of + Just t -> + space <> colon <> space <> align (group (pprintDelab ist t)) + Nothing -> + empty + runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) = do ctxt <- getContext ist <- getIState @@ -675,17 +689,23 @@ Failure err -> do iputStrLn $ show (fixColour c err) return (Just inputs) Success (Right Reload) -> - do putIState $ orig { idris_options = idris_options i - , idris_colourTheme = idris_colourTheme i - , imported = imported i - } + -- The $!! here prevents a space leak on reloading. + -- This isn't a solution - but it's a temporary stopgap. + -- See issue #2386 + do putIState $!! orig { idris_options = idris_options i + , idris_colourTheme = idris_colourTheme i + , imported = imported i + } clearErr mods <- loadInputs inputs Nothing return (Just mods) Success (Right (Load f toline)) -> - do putIState orig { idris_options = idris_options i - , idris_colourTheme = idris_colourTheme i - } + -- The $!! here prevents a space leak on reloading. + -- This isn't a solution - but it's a temporary stopgap. + -- See issue #2386 + do putIState $!! orig { idris_options = idris_options i + , idris_colourTheme = idris_colourTheme i + } clearErr mod <- loadInputs [f] toline return (Just mod) @@ -735,9 +755,9 @@ let args = line ++ [fixName f] runIO $ rawSystem editor args clearErr - putIState $ orig { idris_options = idris_options i - , idris_colourTheme = idris_colourTheme i - } + putIState $!! orig { idris_options = idris_options i + , idris_colourTheme = idris_colourTheme i + } loadInputs [f] Nothing -- clearOrigPats iucheck @@ -788,7 +808,7 @@ logLvl 3 $ "Raw: " ++ show (tm', ty') logLvl 10 $ "Debug: " ++ showEnvDbg [] tm' let tmDoc = pprintDelab ist tm' - tyDoc = pprintDelab ist ty' + tyDoc = pprintDelab ist ty' iPrintTermWithType tmDoc tyDoc where perhapsForce tm | termSmallerThan 100 tm = force tm | otherwise = tm @@ -1246,6 +1266,9 @@ process fn (SetOpt EvalTypes) = setEvalTypes True process fn (UnsetOpt EvalTypes) = setEvalTypes False +process fn (SetOpt DesugarNats) = setDesugarNats True +process fn (UnsetOpt DesugarNats) = setDesugarNats False + process fn (SetOpt _) = iPrintError "Not a valid option" process fn (UnsetOpt _) = iPrintError "Not a valid option" process fn (SetColour ty c) = setColour ty c @@ -1499,13 +1522,13 @@ -- If it worked, load the whole thing from all the ibcs together case errSpan inew of Nothing -> - do putIState (ist { idris_tyinfodata = tidata }) + do putIState $!! ist { idris_tyinfodata = tidata } ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles))) tryLoad True (mapMaybe id ibcfiles) _ -> return () ist <- getIState - putIState (ist { idris_tyinfodata = tidata, - idris_patdefs = patdefs }) + putIState $! ist { idris_tyinfodata = tidata, + idris_patdefs = patdefs } exports <- findExports case opt getOutput opts of @@ -1549,11 +1572,15 @@ let tidata = idris_tyinfodata inew let patdefs = idris_patdefs inew ok <- noErrors - when ok $ do when (not keepstate) $ putIState ist - ist <- getIState - putIState (ist { idris_tyinfodata = tidata, - idris_patdefs = patdefs }) - tryLoad keepstate fs + when ok $ + -- The $!! here prevents a space leak on reloading. + -- This isn't a solution - but it's a temporary stopgap. + -- See issue #2386 + do when (not keepstate) $ putIState $!! ist + ist <- getIState + putIState $!! ist { idris_tyinfodata = tidata, + idris_patdefs = patdefs } + tryLoad keepstate fs ibc (IBC _ _) = True ibc _ = False diff --git a/src/Idris/REPLParser.hs b/src/Idris/REPLParser.hs --- a/src/Idris/REPLParser.hs +++ b/src/Idris/REPLParser.hs @@ -260,6 +260,7 @@ <|> do discard (P.symbol "nobanner") ; return NoBanner <|> do discard (P.symbol "warnreach"); return WarnReach <|> do discard (P.symbol "evaltypes"); return EvalTypes + <|> do discard (P.symbol "desugarnats"); return DesugarNats proofArg :: (Bool -> Int -> Name -> Command) -> String -> P.IdrisParser (Either String Command) proofArg cmd name = do diff --git a/src/Idris/Reflection.hs b/src/Idris/Reflection.hs --- a/src/Idris/Reflection.hs +++ b/src/Idris/Reflection.hs @@ -7,6 +7,7 @@ import Control.Applicative ((<$>), (<*>), pure) import Control.Monad (liftM, liftM2, liftM4) +import Control.Monad.State.Strict (lift) import Data.Maybe (catMaybes) import Data.List ((\\), findIndex) import qualified Data.Text as T @@ -21,6 +22,7 @@ initEState, pairCon, pairTy) import Idris.Delaborate (delab) + data RErasure = RErased | RNotErased deriving Show data RPlicity = RExplicit | RImplicit | RConstraint deriving Show @@ -351,6 +353,11 @@ | f == reflm "B32" = return $ c reifyTTConstApp f (Constant c@(B64 _)) | f == reflm "B64" = return $ c +reifyTTConstApp f v@(P _ _ _) = + lift . tfail . Msg $ + "Can't reify the variable " ++ + show v ++ + " as a constant, because its value is not statically known." reifyTTConstApp f arg = fail ("Unknown reflection constant: " ++ show (f, arg)) reifyArithTy :: Term -> ElabD ArithTy diff --git a/src/Pkg/Package.hs b/src/Pkg/Package.hs --- a/src/Pkg/Package.hs +++ b/src/Pkg/Package.hs @@ -5,7 +5,8 @@ import System.Directory import System.Exit import System.IO -import System.FilePath ((), addTrailingPathSeparator, takeFileName, takeDirectory, normalise) +import System.FilePath ((), addTrailingPathSeparator, takeFileName, + takeDirectory, normalise, addExtension, hasExtension) import System.Directory (createDirectoryIfMissing, copyFile) import Util.System @@ -118,7 +119,7 @@ rmIdx (pkgname pkgdesc) case execout pkgdesc of Nothing -> return () - Just s -> rmFile $ dir s + Just s -> rmExe $ dir s -- | Generate IdrisDoc for package -- TODO: Handle case where module does not contain a matching namespace @@ -231,7 +232,13 @@ rmIdx :: String -> IO () rmIdx p = do let f = pkgIndex p ex <- doesFileExist f - when ex $ rmFile f + when ex $ rmFile f + +rmExe :: String -> IO () +rmExe p = do + fn <- return $ if isWindows && not (hasExtension p) + then addExtension p ".exe" else p + rmFile fn toIBCFile (UN n) = str n ++ ".ibc" toIBCFile (NS n ns) = foldl1' () (reverse (toIBCFile n : map str ns)) diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,6 @@ +flags: {} +packages: +- '.' +extra-deps: +- cheapskate-0.1.0.4 +resolver: nightly-2015-07-24 diff --git a/test/basic009/expected b/test/basic009/expected --- a/test/basic009/expected +++ b/test/basic009/expected @@ -1,4 +1,13 @@ MAIN-PASS -Faulty.idr:6:7:When checking type of Faulty.fault: -Can't disambiguate name: A.num, B.C.num +Faulty.idr:7:7:When checking right hand side of fault: +Type mismatch between + 0 = 0 (Type of Refl) +and + num = 0 (Expected type) + +Specifically: + Type mismatch between + 0 + and + num Multiple.idr:3:1:import alias not unique: "X" diff --git a/test/basic014/basic014.idr b/test/basic014/basic014.idr new file mode 100644 --- /dev/null +++ b/test/basic014/basic014.idr @@ -0,0 +1,44 @@ +-- Test pattern unification + +import Data.Vect + +comp : {A : Type} -> {B : (a : A) -> Type} -> + {C : (a : A) -> (b : B a) -> Type} -> + (f : {a : A} -> (b : B a) -> C a b) -> + (g : (a : A) -> B a) -> + (a : A) -> C a (g a) +comp f g a = f (g a) + +add2 : Nat -> Nat +add2 = comp S S + +data Foo = MkFoo +data Bar = MkBar + +foo : Foo -> Bar + +bar : Bar -> Nat + +baz : Foo -> Nat +baz = (comp bar foo) + +comp0 : (B : Nat -> Type) -> ((n : Nat) -> B n) -> Int +comp0 _ _ = 0 + +test00 : Int +test00 = comp0 _ S + +comp2 : (B : Nat -> Type) -> + ((n : Nat) -> (y : B n) -> Int) -> Int +comp2 _ _ = 0 + +test20 : Int +test20 = comp2 _ dummy + where + dummy : (n : Nat) -> Vect n Int -> Int + dummy _ _ = 0 + +test03 : Int +test03 = comp0 _ dummy where + dummy : (n : Nat) -> Int -> Int + dummy _ = \x => x diff --git a/test/basic014/expected b/test/basic014/expected new file mode 100644 --- /dev/null +++ b/test/basic014/expected diff --git a/test/basic014/run b/test/basic014/run new file mode 100644 --- /dev/null +++ b/test/basic014/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris $@ basic014.idr --check +rm -f *.ibc diff --git a/test/basic015/basic015.idr b/test/basic015/basic015.idr new file mode 100644 --- /dev/null +++ b/test/basic015/basic015.idr @@ -0,0 +1,73 @@ +{- +data Nat = Z | S Nat + +plus : Nat -> Nat -> Nat +plus Z y = y +plus (S x) y = S (plus x y) +-} + +data Vect : Nat -> Type -> Type where + Nil : Vect Z a + (::) : a -> Vect k a -> Vect (S k) a + +%name Vect xs, ys, zs + +append : Vect n a -> Vect m a -> Vect (n + m) a +append [] ys = ys +append (x :: xs) ys = x :: append xs ys + + +zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c +zipWith f [] ys = [] +zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys + +create_empties : Vect m (Vect 0 elem) +create_empties {m = Z} = [] +create_empties {m = (S k)} = [] :: create_empties + +transpose_helper : (row : Vect m elem) -> (rest_trans : Vect m (Vect k elem)) -> + Vect m (Vect (S k) elem) +transpose_helper [] [] = [] +transpose_helper (rowval :: xs) (restrow :: ys) = (rowval :: restrow) :: transpose_helper xs ys + +transpose_vec : Vect n (Vect m elem) -> Vect m (Vect n elem) +transpose_vec [] = create_empties +transpose_vec (row :: rest) = let rest_trans = transpose_vec rest in + transpose_helper row rest_trans + + + + + + + + +------- A main program to read dimensions, generate and tranpose a vector + +instance Functor (Vect m) where + map m [] = [] + map m (x :: xs) = m x :: map m xs + +instance Show a => Show (Vect m a) where + show x = show (toList x) + where + toList : Vect m a -> List a + toList [] = [] + toList (y :: xs) = y :: toList xs + +countTo : (m : Nat) -> Vect m Int +countTo Z = [] +countTo (S k) = 0 :: map (+1) (countTo k) + +mkVect : (n, m : Nat) -> Vect n (Vect m Int) +mkVect Z m = [] +mkVect (S k) m = countTo m :: map (map (+ cast m)) (mkVect k m) + +main : IO () +main = do putStr "Rows: " + let r : Nat = 5 + putStr "Columns: " + let c : Nat = 6 + printLn (mkVect r c) + putStrLn "Transposed:" + printLn (transpose_vec (mkVect r c)) diff --git a/test/basic015/expected b/test/basic015/expected new file mode 100644 --- /dev/null +++ b/test/basic015/expected @@ -0,0 +1,3 @@ +Rows: Columns: [[0, 1, 2, 3, 4, 5], [6, 7, 8, 9, 10, 11], [12, 13, 14, 15, 16, 17], [18, 19, 20, 21, 22, 23], [24, 25, 26, 27, 28, 29]] +Transposed: +[[0, 6, 12, 18, 24], [1, 7, 13, 19, 25], [2, 8, 14, 20, 26], [3, 9, 15, 21, 27], [4, 10, 16, 22, 28], [5, 11, 17, 23, 29]] diff --git a/test/basic015/run b/test/basic015/run new file mode 100644 --- /dev/null +++ b/test/basic015/run @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +idris $@ basic015.idr -o basic015 +./basic015 +rm -f basic015 *.ibc diff --git a/test/classes001/ClassName.idr b/test/classes001/ClassName.idr --- a/test/classes001/ClassName.idr +++ b/test/classes001/ClassName.idr @@ -21,7 +21,7 @@ test1 : twiceAString 2 = "22" test1 = Refl -test2 : twiceAString @{badShow} 2 = "hejhej" +test2 : twiceAString @{ClassName.badShow} 2 = "hejhej" test2 = Refl diff --git a/test/dsl003/DSLPi.idr b/test/dsl003/DSLPi.idr --- a/test/dsl003/DSLPi.idr +++ b/test/dsl003/DSLPi.idr @@ -43,5 +43,5 @@ test3 : Spec [] test3 = ForAll INT . ForAll INT . ItHolds $ Var (FS FZ) === Var FZ -test4 : test2 = test3 +test4 : DSLPi.test2 = DSLPi.test3 test4 = Refl diff --git a/test/effects001/test021.idr b/test/effects001/test021.idr --- a/test/effects001/test021.idr +++ b/test/effects001/test021.idr @@ -23,7 +23,8 @@ testFile : FileIO () () testFile = do True <- open "testFile" Read | False => putStrLn "Error!" - putStrLn (show !readFile) + fcontents <- readFile + putStrLn (show fcontents) close putStrLn (show !(Count :- get)) diff --git a/test/effects005/categoryLogger.idr b/test/effects005/categoryLogger.idr new file mode 100644 --- /dev/null +++ b/test/effects005/categoryLogger.idr @@ -0,0 +1,23 @@ +import Effects +import Effect.Logging.Category + +func : Nat -> Eff () [LOG String] +func x = do + warn Nil $ unwords ["I do nothing with", show x] + pure () + +doubleFunc : Nat -> Eff Nat [LOG String] +doubleFunc x = do + logN 40 ["NumOPS"] $ unwords ["Doing the double with", show x ] + func x + pure (x+x) + +eMain : Eff Nat [LOG String] +eMain = do + initLogger ALL ["NumOPS"] + doubleFunc 3 + +main : IO () +main = do + x <- run eMain + printLn x diff --git a/test/effects005/defaultLogger.idr b/test/effects005/defaultLogger.idr new file mode 100644 --- /dev/null +++ b/test/effects005/defaultLogger.idr @@ -0,0 +1,14 @@ +import Effects +import Effect.Logging.Default + +doubleFunc : Nat -> Eff Nat [LOG] +doubleFunc x = do + warn $ unwords ["Doing the double with", show x ] + pure (x+x) + +main : IO () +main = do + x <- runInit [MkLogRes ALL] (doubleFunc 3) + printLn x + y <- run (doubleFunc 4) + printLn y diff --git a/test/effects005/defaultlog.idr b/test/effects005/defaultlog.idr deleted file mode 100644 --- a/test/effects005/defaultlog.idr +++ /dev/null @@ -1,18 +0,0 @@ -import Effects -import Effect.Logging.Default - -func : Nat -> Eff () [LOG String] -func x = do - log WARN Nil $ unwords ["I do nothing with", show x] - pure () - -doubleFunc : Nat -> Eff Nat [LOG String] -doubleFunc x = do - log WARN ["NumOPS"] $ unwords ["Doing the double with", show x ] - func x - pure (x+x) - -main : IO () -main = do - x <- runInit [(ALL,["NumOPS"])] (doubleFunc 3) - printLn x diff --git a/test/effects005/expected b/test/effects005/expected --- a/test/effects005/expected +++ b/test/effects005/expected @@ -1,5 +1,5 @@ -"3 : Doing the double with 3" +WARN : Doing the double with 3 6 8 -"3 : [\"NumOPS\"] : Doing the double with 3" +WARN : ["NumOPS"] : Doing the double with 3 6 diff --git a/test/effects005/run b/test/effects005/run --- a/test/effects005/run +++ b/test/effects005/run @@ -1,6 +1,6 @@ #!/usr/bin/env bash -idris $@ simplelog.idr -o simple -p effects -./simple -idris $@ defaultlog.idr -o default -p effects +idris $@ defaultLogger.idr -o default -p effects ./default -rm -f simple default *.ibc +idris $@ categoryLogger.idr -o category -p effects +./category +rm -f default category *.ibc diff --git a/test/effects005/simplelog.idr b/test/effects005/simplelog.idr deleted file mode 100644 --- a/test/effects005/simplelog.idr +++ /dev/null @@ -1,14 +0,0 @@ -import Effects -import Effect.Logging.Simple - -doubleFunc : Nat -> Eff Nat [LOG] -doubleFunc x = do - log WARN $ unwords ["Doing the double with", show x ] - pure (x+x) - -main : IO () -main = do - x <- runInit [ALL] (doubleFunc 3) - printLn x - y <- runInit [OFF] (doubleFunc 4) - printLn y diff --git a/test/error003/expected b/test/error003/expected --- a/test/error003/expected +++ b/test/error003/expected @@ -1,2 +1,2 @@ ErrorReflection.idr:68:5:When checking right hand side of bad: -DSL type error: (t(503) => t'(504)) doesn't match () +DSL type error: (t(504) => t'(503)) doesn't match () diff --git a/test/error004/expected b/test/error004/expected --- a/test/error004/expected +++ b/test/error004/expected @@ -1,6 +1,6 @@ -FunErrTest.idr:35:10:When checking right hand side of badCadr1: -When checking argument cons1 to function FunErrTest.cadr: +FunErrTest.idr:35:17:When checking right hand side of badCadr1: +When checking argument cons2 to function FunErrTest.cadr: Could not prove that [] has at least two elements. -FunErrTest.idr:38:10:When checking right hand side of badCadr2: +FunErrTest.idr:38:17:When checking right hand side of badCadr2: When checking argument cons2 to function FunErrTest.cadr: - Could not prove that tail [1] has at least two elements. + Could not prove that [] has at least two elements. diff --git a/test/meta002/Tacs.idr b/test/meta002/Tacs.idr --- a/test/meta002/Tacs.idr +++ b/test/meta002/Tacs.idr @@ -52,7 +52,46 @@ test2 : Nat test2 = %runElab triv +obvious : Elab () +obvious = do g <- goalType + case g of + `(() : Type) => + do fill `(() : ()) + solve + `((~a, ~b) : Type) => + do aH <- gensym "a" + bH <- gensym "b" + claim aH a + claim bH b + fill `(MkPair {A=~a} {B=~b} ~(Var aH) ~(Var bH)) + solve + focus aH; obvious + focus bH; obvious + `(Either ~a ~b) => + (do h <- gensym "a" + claim h a + fill `(Left {a=~a} {b=~b} ~(Var h)) + solve + focus h; obvious) <|> + -- This second h didn't work at one point - this + -- test makes sure the fix stays fixed. The + -- uniquification of binder names didn't + -- appropriately treat quotation. + (do h <- gensym "a" + claim h b + fill `(Right {a=~a} {b=~b} ~(Var h)) + solve + focus h; obvious) +easy : () +easy = %runElab obvious + + +easy2 : ((), ((), (Either () Void))) +easy2 = %runElab obvious + + + namespace STLC data Ty = UNIT | ARR Ty Ty @@ -254,3 +293,4 @@ -- Tacs.idr line 247 col 14: -- When elaborating right hand side of testElab3: -- Unifying ty and Tacs.STLC.ARR ty t would lead to infinite value + diff --git a/test/meta002/expected b/test/meta002/expected --- a/test/meta002/expected +++ b/test/meta002/expected @@ -1,3 +1,3 @@ -Tacs.idr:251:15: +Tacs.idr:290:15: When checking right hand side of testElab3: Unifying ty and ARR ty t would lead to infinite value diff --git a/test/primitives001/expected b/test/primitives001/expected --- a/test/primitives001/expected +++ b/test/primitives001/expected @@ -1,6 +1,27 @@ 8 -1 ("abc", "123") ("abc", "123") ([1, 2], [3, 4, 5]) ([1, 2], [3, 4, 5]) +ello! here's the thing +22 +0 +用的依赖类 +Idris +[] +is 是一个通用 +8 +is 是一个通用的依赖类型纯函数式编程语言，其类型系统与 Agda 以及 Epigram 相似。 +48 +Idris 是一个通用的依赖类型纯函 +18 + +0 +is is a +8 +is is a general-purpose purely functional programming language with dependent types. +85 +Idris is a general +18 + +0 diff --git a/test/primitives001/input b/test/primitives001/input new file mode 100644 --- /dev/null +++ b/test/primitives001/input @@ -0,0 +1,2 @@ +Idris 是一个通用的依赖类型纯函数式编程语言，其类型系统与 Agda 以及 Epigram 相似。 +Idris is a general-purpose purely functional programming language with dependent types. diff --git a/test/primitives001/run b/test/primitives001/run --- a/test/primitives001/run +++ b/test/primitives001/run @@ -1,4 +1,6 @@ #!/usr/bin/env bash idris $@ test005.idr -o test005 ./test005 -rm -f test005 test005.ibc +idris $@ substring.idr -o substring +./substring < input +rm -f test005 substring *.ibc diff --git a/test/primitives001/substring.idr b/test/primitives001/substring.idr new file mode 100644 --- /dev/null +++ b/test/primitives001/substring.idr @@ -0,0 +1,58 @@ +-- This is a test of the substring primitive, both in the Idris +-- evaluator and in some backend. It attempts to exercise that +-- negative indices are equivalent to 0, that it works for mixed +-- single- and multi-byte characters, and that overshooting the end +-- doesn't break things. + +-- Single byte test +foo : String +foo = "Hello! here's the thing" + +-- The first sentence of the Chinese wikipedia article on Idris (to +-- get mixed single-and-multibyte chars) +firstSentence : String +firstSentence = "Idris 是一个通用的依赖类型纯函数式编程语言，其类型系统与 Agda 以及 Epigram 相似。" + +emptyTest : prim__strSubstr 100000 14 Main.firstSentence = "" +emptyTest = Refl + +multiTest : prim__strSubstr 10 5 Main.firstSentence = "用的依赖类" +multiTest = Refl + +negative : prim__strSubstr (-10) 5 Main.firstSentence = "Idris" +negative = Refl + +negativeEnd : prim__strSubstr 0 (-1) Main.firstSentence = "" +negativeEnd = Refl + +negativeLength : prim__strSubstr 4 (-4) Main.firstSentence = "" +negativeLength = Refl + +main : IO () +main = do putStrLn $ prim__strSubstr 1 1004 foo + printLn $ length $ prim__strSubstr 1 1000 foo + printLn $ length $ prim__strSubstr 1000 2 firstSentence + putStrLn $ prim__strSubstr 10 5 firstSentence + putStrLn $ prim__strSubstr (-10) 5 firstSentence + putStrLn $ "[" ++ prim__strSubstr 0 (-1) firstSentence ++ "]" + -- Multi-byte dynamic string + input <- getLine + putStrLn $ prim__strSubstr 3 8 input + putStrLn $ show (length (prim__strSubstr 3 8 input)) + putStrLn $ prim__strSubstr 3 8000 input + putStrLn $ show (length (prim__strSubstr 3 8000 input)) + putStrLn $ prim__strSubstr (-13) 18 input + putStrLn $ show (length (prim__strSubstr (-13) 18 input)) + putStrLn $ prim__strSubstr 4 (-4) input + putStrLn $ show (length (prim__strSubstr 4 (-4) input)) + -- Single-byte dynamic string + input <- getLine + putStrLn $ prim__strSubstr 3 8 input + putStrLn $ show (length (prim__strSubstr 3 8 input)) + putStrLn $ prim__strSubstr 3 8000 input + putStrLn $ show (length (prim__strSubstr 3 8000 input)) + putStrLn $ prim__strSubstr (-13) 18 input + putStrLn $ show (length (prim__strSubstr (-13) 18 input)) + putStrLn $ prim__strSubstr 4 (-4) input + putStrLn $ show (length (prim__strSubstr 4 (-4) input)) + diff --git a/test/primitives001/test005.idr b/test/primitives001/test005.idr --- a/test/primitives001/test005.idr +++ b/test/primitives001/test005.idr @@ -8,7 +8,6 @@ main : IO () main = do printLn (abs (-8)) - printLn (abs (S Z)) printLn (span isAlpha tstr) printLn (break isDigit tstr) printLn (span (\x => x < 3) tlist) diff --git a/test/primitives002/run b/test/primitives002/run --- a/test/primitives002/run +++ b/test/primitives002/run @@ -2,8 +2,6 @@ HEAD='module Main -import Data.Floats - strtake : Nat -> String -> String strtake n str = pack (take n (unpack str)) diff --git a/test/proof003/test015.idr b/test/proof003/test015.idr --- a/test/proof003/test015.idr +++ b/test/proof003/test015.idr @@ -106,7 +106,7 @@ -- There is almost certainly an easier proof. I don't care, for now :) Main.adc_lemma_2 = proof { - intro w,v,num0,v1,num1,x,bx,x1,bx1,bit0,b0,bit1,b1,c,bc + intro v,w,num0,v1,num1,x,bx,x1,bx1,bit0,b0,bit1,b1,c,bc rewrite sym (plusZeroRightNeutral x); rewrite sym (plusZeroRightNeutral v1); rewrite sym (plusZeroRightNeutral (plus (plus x v) v1)); diff --git a/test/proofsearch001/expected b/test/proofsearch001/expected new file mode 100644 --- /dev/null +++ b/test/proofsearch001/expected diff --git a/test/proofsearch001/proofsearch001.idr b/test/proofsearch001/proofsearch001.idr new file mode 100644 --- /dev/null +++ b/test/proofsearch001/proofsearch001.idr @@ -0,0 +1,11 @@ +%default total + +class C a (f : Bool -> Bool) | a where {} +instance C Int Bool.not where {} + +foo : C Int g => {auto pf : g True = False} -> Unit +foo = () + +main : IO () +main = printLn $ foo -- {pf = Refl} + diff --git a/test/proofsearch001/run b/test/proofsearch001/run new file mode 100644 --- /dev/null +++ b/test/proofsearch001/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris $@ --check proofsearch001.idr +rm -f *.ibc diff --git a/test/proofsearch002/Process.idr b/test/proofsearch002/Process.idr new file mode 100644 --- /dev/null +++ b/test/proofsearch002/Process.idr @@ -0,0 +1,443 @@ +module Process + +import System.Concurrency.Raw +import public Data.List -- public, to get proof search machinery + +%access public + +-- Process IDs are parameterised by their interface. A request of type +-- 'iface t' will get a response of type 't' +data ProcID : (iface : Type -> Type) -> Type where + MkPID : Ptr -> ProcID iface + +data ServerID : Type where + MkServer : ProcID iface -> ServerID + +implicit MkServer' : ProcID iface -> ServerID +MkServer' = MkServer + +data Replied = YesR | NoR + +data ReqHandle = MkReqH Nat + +-- Current state of a process includes: +-- * the servers it currently has an open connection to +-- * the number of clients it currently has connected +-- * whether it has responded to a request yet + +-- Therefore, we can write process types which make clear that a process +-- cannot quit while it is talking to a server, or while it still has clients +-- expecting to communicate with it, or if it has not serviced any requests. +data ProcState : Type where + MkProcState : (servers : List ServerID) -> + (clients : Nat) -> + Replied -> + ProcState + +data Pending : ReqHandle -> List (ReqHandle, Type) -> Type -> Type where + PendingHere : Pending h ((h, t) :: hs) t + PendingThere : Pending h hs t -> Pending h ((h', t') :: hs) t + +dropPending : (hs : List (ReqHandle, Type)) -> Pending h hs ty -> + List (ReqHandle, Type) +dropPending ((h, t) :: xs) PendingHere = xs +dropPending ((h', t') :: xs) (PendingThere x) + = ((h', t') :: dropPending xs x) + +data ConnectedTo : ServerID -> ProcState -> Type where + IsConnectedTo : Elem p servers -> + ConnectedTo p (MkProcState servers c reply) + +data NoClient : ProcState -> Type where + IsNoClient : NoClient (MkProcState servers 0 reply) + +data OneClient : ProcState -> Type where + IsOneClient : OneClient (MkProcState servers (S k) reply) + +data Reply : ProcState -> Type where + IsReply : Reply (MkProcState s c YesR) + +data NoReply : ProcState -> Type where + IsNoReply : NoReply (MkProcState s c NoR) + +{-- Some useful operations on process state --} +newClient : ProcState -> ProcState +newClient (MkProcState servers clients r) + = MkProcState servers (S clients) r + +setClients : ProcState -> Nat -> ProcState +setClients (MkProcState servers clients r) k + = MkProcState servers k r + +newServer : ProcID iface -> ProcState -> ProcState +newServer p (MkProcState servers clients r) + = MkProcState (MkServer p :: servers) clients r + +dropServer : (pid : ProcID iface) -> (p : ProcState) -> + ConnectedTo (MkServer pid) p -> ProcState +dropServer pid (MkProcState servers c r) (IsConnectedTo prf) + = MkProcState (dropElem servers prf) c r + +{- +pendingReq : ProcID iface -> (h : ReqHandle) -> iface t -> + ProcState hs -> ProcState ((h, t) :: hs) +pendingReq {t} p h x (MkProcState s c r) = MkProcState s c r + +doneReq : ProcState hs -> (p : Pending h hs) -> ProcState (dropPending hs p) +doneReq (MkProcState s c r) p = MkProcState s c r +-} + +replied : ProcState -> ProcState +replied (MkProcState servers clients r) + = MkProcState servers clients YesR + +resetReplied : ProcState -> ProcState +resetReplied (MkProcState servers clients r) + = MkProcState servers clients NoR + +runningServer : Nat -> ProcState +runningServer c = MkProcState [] (S c) NoR + +doneServer : ProcState +doneServer = MkProcState [] 0 YesR + +init : List ServerID -> ProcState +init s = MkProcState s 0 NoR + +{-- Processes themselves. + +A process returns some type 'a', responds to requests on the interface +'iface', and has an input and output state. +--} +mutual + data Process : (a : Type) -> (iface : Type -> Type) -> + List (ReqHandle, Type) -> (a -> List (ReqHandle, Type)) -> + ProcState -> (a -> ProcState) -> + Type where + -- Some plumbing + Lift' : IO a -> Process a iface hs (const hs) p (const p) + Pure : a -> Process a iface hs (const hs) p (const p) + Quit : a -> Process a iface hs (const hs) p (const (resetReplied p)) + + bind : Process a iface hs hs' p p' -> + ((x : a) -> Process b iface (hs' x) hs'' (p' x) p'') -> + Process b iface hs hs'' p p'' + + Fork : Process () serveri [] (const []) (runningServer 1) (const doneServer) -> + Process (ProcID serveri) iface hs (const hs) p (\res => (newServer res p)) + Work : (worker : (pid : ProcID iface) -> Worker [pid] ()) -> + (waiter : Process t iface hs (const hs) (runningServer 1) (const doneServer)) -> + Process t iface hs (const hs) p (const p) + + Request : (r : ProcID serveri) -> (x : serveri ty) -> + {auto connected : ConnectedTo (MkServer r) p} -> + Process ReqHandle iface + hs (\h => (h, ty) :: hs) + p (const p) + + GetReply : (h : ReqHandle) -> + {auto pending : Pending h hs ty} -> + Process ty iface + hs (const (dropPending hs pending)) + p (const p) + + TimeoutRespond : (timeout : Int) -> + (def : res) -> + ({t : Type} -> (x : iface t) -> + Response (t, res) iface hs p) -> + Process res iface hs (const hs) p (const (replied p)) + + Respond : ({t : Type} -> (x : iface t) -> + Response (t, res) iface hs p) -> + Process res iface hs (const hs) p (const (replied p)) + + Connect : (r : ProcID serveri) -> + Process Bool iface + hs (const hs) + p (\ok => case ok of + True => newServer r p + False => p) + + Disconnect : (r : ProcID serveri) -> + {auto connected : ConnectedTo (MkServer r) p} -> + Process () iface + hs (const hs) + p (const (dropServer r p connected)) + + CountClients : Process Nat iface hs (const hs) p (\n => setClients p n) + + -- FIXME: The process had better be guaranteed to change the system + -- state (e.g. finish with a YesR since it starts with a NoR) because + -- then it can't be used in a Respond, so responding can't loop. + Loop : Inf (Process t iface hs hs' (resetReplied p) p') -> + Process t iface hs hs' p p' + + -- 'Running a iface' is the type of a process which is currently + -- responding to requests (i.e. knows it has at least one client connected) + -- and will not exit unless there are no clients connected + Running : Type -> (iface : Type -> Type) -> Type + Running a iface = {k : Nat} -> Process a iface [] (const []) (runningServer k) (const doneServer) + + Response : Type -> (iface : Type -> Type) -> List (ReqHandle, Type) -> + ProcState -> Type + Response a iface hs p = Process a iface hs (const hs) p (const p) + + -- 'Program a' is the type of a process which does not respond to any requests + -- and begins and ends with no connections to any server open. + Program : Type -> (iface : Type -> Type) -> Type + Program a iface = Process a iface [] (const []) (init []) (const (init [])) + + -- 'Connected s a' is the type of a process which does not respond to any + -- requests and begins and ends with connections to a given server list. + Connected : List ServerID -> Type -> Type + Connected s a = Process a (const Void) [] (const []) (init s) (const (init s)) + + -- 'Worker s a' is the type of a process which does not respond to any + -- requests, and begins with a connection to a server it is to send a + -- notification to. + Worker : List ServerID -> Type -> Type + Worker s a = Process a (const Void) [] (const []) (init s) (const (init [])) + +implicit +Lift : IO a -> Process a iface hs (const hs) p (const p) +Lift = Lift' + +%no_implicit -- helps error messages, and speeds things up a bit +%inline -- so that the productivity checker treats 'bind' as a constructor! +(>>=) : Process a iface hs hs' p p' -> + ((x : a) -> Process b iface (hs' x) hs'' (p' x) p'') -> + Process b iface hs hs'' p p'' +(>>=) = bind + +TrySend : (proc : ProcID iface) -> iface ty -> + Process (Maybe ty) iface' + hs (const hs) + (MkProcState s c r) (const (MkProcState s c r)) +TrySend pid req = do True <- Connect pid | False => Pure Nothing + h <- Request pid req + resp <- GetReply h + Disconnect pid + Pure (Just resp) + +Send : (proc : ProcID iface) -> iface ty -> + {auto prf : Elem (MkServer proc) s} -> + Process ty iface' + hs (const hs) + (MkProcState s c r) (const (MkProcState s c r)) +Send pid req = do h <- Request pid req + GetReply h + +{--- evaluator --} + +-- The evaluator keeps track of the number of client connections open, +-- and manages Connect/Disconnect requests by managing them whenever a +-- 'Respond' or 'TimeoutRespond' is encountered. + +data MessageQ : (Type -> Type) -> Type where + ConnectMsg : MessageQ iface + CloseMsg : MessageQ iface + RequestMsg : Nat -> iface t -> MessageQ iface + +data MessageR : Type -> Type where + ReplyMsg : Nat -> (ans : ty) -> MessageR ty + +data Message : (Type -> Type) -> List (ReqHandle, Type) -> Type where + MsgQuery : MessageQ iface -> Message iface hs + MsgReply : (reply : MessageR ty) -> Message iface hs + +readMsg : IO (Maybe (Ptr, Message iface hs)) +readMsg {iface} {hs} = + do if !checkMsgs + then do msg <- getMsgWithSender {a = Message iface hs} + pure (Just msg) + else pure Nothing + +readMsgTimeout : Int -> IO (Maybe (Ptr, Message iface hs)) +readMsgTimeout {iface} {hs} i = + do if !(checkMsgsTimeout i) + then do msg <- getMsgWithSender {a = Message iface hs} + pure (Just msg) + else pure Nothing + +data RespEnv : List (ReqHandle, Type) -> Type where + Nil : RespEnv [] + (::) : Maybe ty -> RespEnv hs -> RespEnv ((h, ty) :: hs) + +record EvalState (iface : Type -> Type) (hs : List (ReqHandle, Type)) where + constructor MkEvalState + queue : List (Ptr, MessageQ iface) + reply : RespEnv hs + clients : Nat + nexthandle : Nat + +lookup : Pending h hs ty -> RespEnv hs -> Maybe ty +lookup PendingHere (x :: xs) = x +lookup (PendingThere p) (x :: xs) = lookup p xs + +dropResp : (pending : Pending h hs ty) -> + RespEnv hs -> RespEnv (dropPending hs pending) +dropResp PendingHere (x :: xs) = xs +dropResp (PendingThere p) (x :: xs) = x :: dropResp p xs + +updateReplies : Pending h hs ty -> ty -> RespEnv hs -> RespEnv hs +updateReplies PendingHere msg (x :: xs) = Just msg :: xs +updateReplies (PendingThere p) msg (x :: xs) = x :: updateReplies p msg xs + +total +findPending : (h : ReqHandle) -> RespEnv hs -> Maybe (ty ** Pending h hs ty) +findPending {hs = []} k [] = Nothing +findPending {hs = ((MkReqH h, t) :: hs)} (MkReqH k) (x :: xs) with (decEq h k) + findPending {hs = ((MkReqH h, t) :: hs)} (MkReqH h) (x :: xs) | (Yes Refl) + = Just (t ** PendingHere) + findPending {hs = ((MkReqH h, t) :: hs)} (MkReqH k) (x :: xs) | (No contra) + = do (ty' ** p') <- findPending (MkReqH k) xs + Just (ty' ** PendingThere p') + +covering +updateQueue : EvalState iface hs -> IO (EvalState iface hs) +updateQueue {iface} {hs} st + = case !(readMsg {iface} {hs}) of + Nothing => pure st + Just (pid, MsgQuery msg) => + updateQueue (record { queue = queue st ++ [(pid, msg)] } st) + Just (pid, MsgReply (ReplyMsg rq ans)) => + case findPending (MkReqH rq) (reply st) of + Nothing => updateQueue {iface} {hs} st -- can't happen! + Just (ty ** pend) => + updateQueue (record { reply = updateReplies pend (believe_me ans) (reply st) } st) + +-- Keep updating the queue with incoming messages until either we get a +-- RequestMsg, or we reach a timeout. +covering +updateQueueTimeout : Int -> EvalState iface hs -> IO (EvalState iface hs) +updateQueueTimeout {iface} {hs} i st + = case !(readMsgTimeout {iface} {hs} i) of + Nothing => pure st + Just (pid, MsgQuery (RequestMsg rq msg)) => + pure (record { queue = queue st ++ [(pid, RequestMsg rq msg)] } st) + Just (pid, MsgQuery msg) => do + -- TODO: Why not update client count here too? + updateQueueTimeout i (record { queue = queue st ++ [(pid, msg)] } st) + Just (pid, MsgReply (ReplyMsg rq ans)) => + case findPending (MkReqH rq) (reply st) of + Nothing => updateQueueTimeout i {iface} {hs} st -- can't happen! + Just (ty ** pend) => + updateQueueTimeout i (record { reply = updateReplies pend (believe_me ans) (reply st) } st) + +total +removeReq : List (Ptr, MessageQ iface) -> List (Ptr, MessageQ iface) -> + Maybe (Ptr, (ty ** (Nat, iface ty)), List (Ptr, MessageQ iface)) +removeReq acc [] = Nothing +removeReq acc ((pid, RequestMsg rq m) :: xs) = Just (pid, (_ ** (rq, m)), reverse acc ++ xs) +removeReq acc (x :: xs) = removeReq (x :: acc) xs + +total +removeConn : Nat -> + List (Ptr, MessageQ iface) -> List (Ptr, MessageQ iface) -> + (Nat, List (Ptr, MessageQ iface)) +removeConn cl acc [] = (cl, reverse acc) +removeConn cl acc ((pid, ConnectMsg) :: xs) + = removeConn (cl + 1) acc xs +removeConn cl acc ((pid, CloseMsg) :: xs) + = removeConn (minus cl 1) acc xs +removeConn cl acc (x :: xs) = removeConn cl (x :: acc) xs + +-- Remove the first thing in the event list which is a request, if it +-- exists. +getRequest : EvalState iface hs -> Maybe (Ptr, (ty ** (Nat, iface ty)), EvalState iface hs) +getRequest (MkEvalState queue reply clients nh) + = do (pid, req, queue') <- removeReq [] queue + return (pid, req, MkEvalState queue' reply clients nh) + +countClients : EvalState iface hs -> (Nat, EvalState iface hs) +countClients (MkEvalState queue reply clients nh) + = let (clients', queue') = removeConn clients [] queue in + (clients', MkEvalState queue' reply clients' nh) + +-- sendResponse : Ptr -> +-- (ty -> EvalState iface hs -> IO a) -> +-- (x, ty) -> EvalState iface hs -> +-- IO a +-- sendResponse {iface} {hs} pid k (resp, val) st = do +-- sendToThread pid (MsgReply {hs} {iface} ?prf (ReplyMsg resp)) +-- k val st + +covering +eval : EvalState iface hs -> + {p : ProcState} -> {p' : ty -> ProcState} -> + Process ty iface hs hs' p p' -> + ((res : ty) -> EvalState iface (hs' res) -> IO a) -> IO a +eval st (Lift' x) k = do x' <- x + k x' st +eval st (Pure x) k = k x st +eval st (Quit x) k = k x st +eval st (bind x f) k = eval st x (\x', st' => eval st' (f x') k) + +eval st (Fork proc) k + = do ptr <- fork (eval (MkEvalState [] [] 1 0) proc (\_, _ => pure ())) + k (MkPID ptr) st + +eval st (Work proc cont) k + = do ptr <- fork (eval (MkEvalState [] [] 0 0) (proc (MkPID prim__vm)) + (\_, _ => pure ())) + eval (record { clients = clients st + 1 } st) cont k + +eval {hs} (MkEvalState q reqs c nh) (Request (MkPID pid) x) k + = do sendToThread pid (MsgQuery {hs} (RequestMsg nh x)) + k (MkReqH nh) (MkEvalState q (Nothing :: reqs) c (S nh)) + +eval {p} st (GetReply {pending} h) k + = do -- Need to keep receiving messages until there's a response + -- available + MkEvalState q reqs c nh <- updateQueue st + case lookup pending reqs of + Nothing => do checkMsgsTimeout 1 + eval {p} (MkEvalState q reqs c nh) (GetReply h) k + Just reply => + k reply (MkEvalState q (dropResp pending reqs) c nh) + +eval {iface} {hs} st (TimeoutRespond timeout def f) k + = do st' <- updateQueueTimeout timeout st + case getRequest st' of + Nothing => k def st' + Just (pid, (_ ** (rq, req)), st'') => do + eval st'' (f req) -- (sendResponse pid k) -- ?foo + -- this weirdness works around an erasure bug + -- which causes a seg fault... + (\ r, st''' => + case r of + (resp, val) => do + sendToThread pid (MsgReply {iface} {hs} (ReplyMsg rq resp)) + k val st''') + +eval {iface} {hs} st (Respond f) k + = do st' <- updateQueue st + case getRequest st' of + Nothing => eval {iface} st' (Respond f) k + Just (pid, (_ ** (rq, req)), st'') => do + eval st'' (f req) (\ (resp, val), st''' => do + sendToThread pid (MsgReply {iface} {hs} (ReplyMsg rq resp)) + k val st''') + +eval {hs} st (Connect {serveri} (MkPID pid)) k + = if pid == prim__vm then k False st else do + v <- sendToThread pid (MsgQuery {iface=serveri} {hs} + ConnectMsg) + -- TODO: Wait for ACK + k (v == 1) st + +eval {hs} st (Disconnect {serveri} (MkPID pid)) k + = do v <- sendToThread pid (MsgQuery {iface=serveri} {hs} + CloseMsg) + k () st + +eval st CountClients k + = do st' <- updateQueue st + let (cl, st'') = countClients st' + k cl st'' + +eval st (Loop x) k = eval st x k + +run : Program a iface -> IO a +run p = eval (MkEvalState [] [] 0 0) p (\res, t => pure res) + diff --git a/test/proofsearch002/expected b/test/proofsearch002/expected new file mode 100644 --- /dev/null +++ b/test/proofsearch002/expected diff --git a/test/proofsearch002/proofsearch002.idr b/test/proofsearch002/proofsearch002.idr new file mode 100644 --- /dev/null +++ b/test/proofsearch002/proofsearch002.idr @@ -0,0 +1,51 @@ +import Process + +import Data.Vect + +data Counter : Type -> Type where + GetIdle : Counter Int + Append : Vect n a -> Vect m a -> Counter $ Vect (n + m) a + +data Maths : Type -> Type where + Factorial : Nat -> Maths Nat + +count_process : Int -> Counter t -> Response (t, Int) Counter [] p +count_process x GetIdle = Pure (x, x) +count_process x (Append xs ys) = Pure (xs ++ ys, x) + +countServer : Int -> Running () Counter +countServer secs = do s' <- TimeoutRespond 1 (secs + 1) (count_process secs) + Loop (countServer s') + +mathsServer : Running () Maths +mathsServer = do Lift $ putStrLn "Serving maths!" + TimeoutRespond 5 () (\val => case val of + Factorial k => + Pure (fact k, ())) + Loop mathsServer + +instance Cast String Nat where + cast orig = cast (the Integer (cast orig)) + +-- Start up a couple of servers, send them requests +testProg1 : Program () (const Void) +testProg1 = do -- with Process do + mpid <- Fork mathsServer + cpid <- Fork (countServer 0) + putStr "Number1: " + x1 <- getLine + putStr "Number2: " + x2 <- getLine + + fac1h <- Request mpid (Factorial (cast (trim x1))) + fac2h <- Request mpid (Factorial (cast (trim x2))) + + fac2 <- GetReply fac2h -- {pending = PendingHere} + fac1 <- GetReply fac1h -- {pending = PendingHere} + + Disconnect cpid + Disconnect mpid + +main : IO () +main = run testProg1 + diff --git a/test/proofsearch002/run b/test/proofsearch002/run new file mode 100644 --- /dev/null +++ b/test/proofsearch002/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris $@ --check proofsearch002.idr +rm -f *.ibc diff --git a/test/proofsearch003/expected b/test/proofsearch003/expected new file mode 100644 --- /dev/null +++ b/test/proofsearch003/expected diff --git a/test/proofsearch003/proofsearch003.idr b/test/proofsearch003/proofsearch003.idr new file mode 100644 --- /dev/null +++ b/test/proofsearch003/proofsearch003.idr @@ -0,0 +1,34 @@ +import Data.Fin + +data Wrapper = Wrap (Fin 9) + +data Seq : Fin 9 -> Fin 9 -> Type where + Seq12 : {n : Fin 8} -> Seq (weaken n) (FS n) + Seq21 : {n : Fin 8} -> Seq (FS n) (weaken n) + +class Evil t where + value : t -> Fin 9 + +instance Evil Wrapper where + value (Wrap n) = n + +consTest : (Evil t) => (a : t) -> (b : t) -> + {auto p : Seq (value a) (value b)} -> Bool +consTest _ _ = True + +-- Fails! +test1 : Bool +test1 = consTest (Wrap 3) (Wrap 4) -- {p = ?foo} + +-- Succeeds! +test2 : Bool +test2 = consTest (Wrap 3) (Wrap 4) {p = Seq12} + +-- Succeeds! +test3 : Bool +test3 = consTest (Wrap 3) (Wrap 4) {p = (| Seq12, Seq21 |)} + +-- Fails! +-- test4 : Bool +-- test4 = consTest (Wrap 3) (Wrap 4) {p = (| Seq21, Seq12 |)} + diff --git a/test/proofsearch003/run b/test/proofsearch003/run new file mode 100644 --- /dev/null +++ b/test/proofsearch003/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris --check proofsearch003.idr +rm -f *.ibc diff --git a/test/quasiquote006/quasiquote006.idr b/test/quasiquote006/quasiquote006.idr --- a/test/quasiquote006/quasiquote006.idr +++ b/test/quasiquote006/quasiquote006.idr @@ -2,7 +2,7 @@ a : TTName a = `{Nat} -aOK : a = NS (UN "Nat") ["Nat", "Prelude"] +aOK : Main.a = NS (UN "Nat") ["Nat", "Prelude"] aOK = Refl b : TTName @@ -17,5 +17,5 @@ d : TTName d = `{List.(::)} -dOK : d = NS (UN "::") ["List", "Prelude"] +dOK : Main.d = NS (UN "::") ["List", "Prelude"] dOK = Refl diff --git a/test/reg001/reg001.idr b/test/reg001/reg001.idr --- a/test/reg001/reg001.idr +++ b/test/reg001/reg001.idr @@ -1,9 +1,179 @@ +-- Everything here should type check but at some point in the past has +-- not. + +import Data.So +import Data.Vect +import Data.Fin +import Control.Isomorphism + class Functor f => VerifiedFunctor (f : Type -> Type) where - identity : (fa : f a) -> map id fa = fa + identity : (fa : f a) -> map Basics.id fa = fa data Imp : Type where MkImp : {any : Type} -> any -> Imp testVal : Imp testVal = MkImp (apply id Z) + +zfin : Fin 1 +zfin = 0 + +data Infer = MkInf a + +foo : Infer +foo = MkInf (the (Fin 1) 0) + +isAnyBy : (alpha -> Bool) -> (n : Nat ** Vect n alpha) -> Bool +isAnyBy _ (_ ** Nil) = False +isAnyBy p (_ ** (a :: as)) = p a || isAnyBy p (_ ** as) + +filterTagP : (p : alpha -> Bool) -> + (as : Vect n alpha) -> + So (isAnyBy p (n ** as)) -> + (m : Nat ** (Vect m (a : alpha ** So (p a)), So (m > Z))) +filterTagP {n = S m} p (a :: as) q with (p a) + | True = (_ + ** + ((a ** believe_me Oh) + :: + (fst (getProof (filterTagP p as (believe_me Oh)))), + Oh + ) + ) + | False = filterTagP p as (believe_me Oh) + +vfoldl : (P : Nat -> Type) -> + ((x : Nat) -> P x -> a -> P (S x)) -> P Z + -> Vect m a -> P m +vfoldl P cons nil (x :: xs) + = vfoldl (\k => P (S k)) (\ n => cons (S n)) (cons Z nil x) xs + + +total soElim : (C : (b : Bool) -> So b -> Type) -> + C True Oh -> + (b : Bool) -> (s : So b) -> (C b s) +soElim C coh True Oh = coh + +soFalseElim : So False -> a +soFalseElim x = void (soElim C () False x) + where + C : (b : Bool) -> So b -> Type + C True s = () + C False s = Void + +soTrue : So b -> b = True +soTrue {b = False} x = soFalseElim x +soTrue {b = True} x = Refl + +class Eq alpha => ReflEqEq alpha where + reflexive_eqeq : (a : alpha) -> So (a == a) + +modifyFun : (Eq alpha) => + (alpha -> beta) -> + (alpha, beta) -> + (alpha -> beta) +modifyFun f (a, b) a' = if a' == a then b else f a' + +modifyFunLemma : (ReflEqEq alpha) => + (f : alpha -> beta) -> + (ab : (alpha, beta)) -> + modifyFun f ab (fst ab) = snd ab +modifyFunLemma f (a,b) = + rewrite soTrue (reflexive_eqeq a) in Refl + + +Matrix : Type -> Nat -> Nat -> Type +Matrix a n m = Vect n (Vect m a) + +mytranspose : Matrix a (S n) (S m) -> Matrix a (S m) (S n) +mytranspose ((x:: []) :: []) = [[x]] +mytranspose [x :: y :: xs] = [x] :: (mytranspose [y :: xs]) +mytranspose (x :: y :: xs) + = let tx = mytranspose [x] in + let ux = mytranspose (y :: xs) in zipWith (++) tx ux + +using (A : Type, B : A->Type, C : Type) + foo2 : ((x:A) -> B x -> C) -> ((x:A ** B x) -> C) + foo2 f p = f (getWitness p) (getProof p) + + +m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) -> + Maybe (Either Bool Int) +m_add x y = do x' <- x -- Extract value from x + y' <- y -- Extract value from y + case x' of + Left _ => Nothing + Right _ => Nothing + +data Ty = TyBool + +data Id a = I a + +interpTy : Ty -> Type +interpTy TyBool = Id Bool + +data Term : Ty -> Type where + TLit : Bool -> Term TyBool + TNot : Term TyBool -> Term TyBool + +map : (a -> b) -> Id a -> Id b +map f (I x) = I (f x) + +interp : Term t -> interpTy t +interp (TLit x) = I x +interp (TNot x) = map not (interp x) + +data Result str a = Success str a | Failure String + +instance Functor (Result str) where + map f (Success s x) = Success s (f x) + map f (Failure e ) = Failure e + +ParserT : (Type -> Type) -> Type -> Type -> Type +ParserT m str a = str -> m (Result str a) + +ap : Monad m => ParserT m str (a -> b) -> ParserT m str a -> + ParserT m str b +ap f x = \s => do f' <- f s + case f' of + Failure e => (pure (Failure e)) + Success s' g => x s' >>= pure . map g + +X : Nat -> Type +X t = (c : Nat ** So (c < 5)) + +column : X t -> Nat +column = getWitness + +data Action = Left | Ahead | Right + +admissible : X t -> Action -> Bool +admissible {t} x Ahead = column {t} x == 0 || column {t} x == 4 +admissible {t} x Left = column {t} x <= 2 +admissible {t} x Right = column {t} x >= 2 + + +class Set univ where + member : univ -> univ -> Type + +isSubsetOf : Set univ => univ -> univ -> Type +isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b) + +class Set univ => HasPower univ where + Powerset : (a : univ) -> + Sigma univ (\Pa => (c : univ) -> + (isSubsetOf c a) -> member c Pa) + +powerset : HasPower univ => univ -> univ +powerset {univ} a = getWitness (Powerset a) + +mapFilter : (alpha -> beta) -> + (alpha -> Bool) -> + Vect n alpha -> + (n : Nat ** Vect n beta) +mapFilter f p Nil = (_ ** Nil) +mapFilter f p (a :: as) with (p a) + | True = (_ ** (f a) :: (getProof (mapFilter f p as))) + | False = mapFilter f p as + diff --git a/test/reg005/expected b/test/reg005/expected deleted file mode 100644 --- a/test/reg005/expected +++ /dev/null diff --git a/test/reg005/reg005.idr b/test/reg005/reg005.idr deleted file mode 100644 --- a/test/reg005/reg005.idr +++ /dev/null @@ -1,12 +0,0 @@ -module reg032 - -import Data.Fin - -zfin : Fin 1 -zfin = 0 - -data Infer = MkInf a - -foo : Infer -foo = MkInf (the (Fin 1) 0) - diff --git a/test/reg005/run b/test/reg005/run deleted file mode 100644 --- a/test/reg005/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg005.idr --check -rm -f *.ibc diff --git a/test/reg009/expected b/test/reg009/expected deleted file mode 100644 --- a/test/reg009/expected +++ /dev/null diff --git a/test/reg009/reg009.lidr b/test/reg009/reg009.lidr deleted file mode 100644 --- a/test/reg009/reg009.lidr +++ /dev/null @@ -1,21 +0,0 @@ -> import Data.So -> import Data.Vect - -> isAnyBy : (alpha -> Bool) -> (n : Nat ** Vect n alpha) -> Bool -> isAnyBy _ (_ ** Nil) = False -> isAnyBy p (_ ** (a :: as)) = p a || isAnyBy p (_ ** as) - -> filterTagP : (p : alpha -> Bool) -> -> (as : Vect n alpha) -> -> So (isAnyBy p (n ** as)) -> -> (m : Nat ** (Vect m (a : alpha ** So (p a)), So (m > Z))) -> filterTagP {n = S m} p (a :: as) q with (p a) -> | True = (_ -> ** -> ((a ** believe_me Oh) -> :: -> (fst (getProof (filterTagP p as (believe_me Oh)))), -> Oh -> ) -> ) -> | False = filterTagP p as (believe_me Oh) diff --git a/test/reg009/run b/test/reg009/run deleted file mode 100644 --- a/test/reg009/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg009.lidr --check -rm -f reg009 *.ibc diff --git a/test/reg011/expected b/test/reg011/expected deleted file mode 100644 --- a/test/reg011/expected +++ /dev/null diff --git a/test/reg011/reg011.idr b/test/reg011/reg011.idr deleted file mode 100644 --- a/test/reg011/reg011.idr +++ /dev/null @@ -1,11 +0,0 @@ -import Data.Vect - -vfoldl : (P : Nat -> Type) -> - ((x : Nat) -> P x -> a -> P (S x)) -> P Z - -> Vect m a -> P m --- vfoldl P cons nil [] --- = nil -vfoldl P cons nil (x :: xs) - = vfoldl (\k => P (S k)) (\ n => cons (S n)) (cons Z nil x) xs --- vfoldl P cons nil (x :: xs) --- = vfoldl (\n => P (S n)) (\ n => cons _) (cons _ nil x) xs diff --git a/test/reg011/run b/test/reg011/run deleted file mode 100644 --- a/test/reg011/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg011.idr --check -rm -f *.ibc diff --git a/test/reg012/expected b/test/reg012/expected deleted file mode 100644 --- a/test/reg012/expected +++ /dev/null diff --git a/test/reg012/reg012.lidr b/test/reg012/reg012.lidr deleted file mode 100644 --- a/test/reg012/reg012.lidr +++ /dev/null @@ -1,36 +0,0 @@ -> import Data.So - -> total soElim : (C : (b : Bool) -> So b -> Type) -> -> C True Oh -> -> (b : Bool) -> (s : So b) -> (C b s) -> soElim C coh True Oh = coh - -> soFalseElim : So False -> a -> soFalseElim x = void (soElim C () False x) -> where -> C : (b : Bool) -> So b -> Type -> C True s = () -> C False s = Void - -> soTrue : So b -> b = True -> soTrue {b = False} x = soFalseElim x -> soTrue {b = True} x = Refl - -> class Eq alpha => ReflEqEq alpha where -> reflexive_eqeq : (a : alpha) -> So (a == a) - -> modifyFun : (Eq alpha) => -> (alpha -> beta) -> -> (alpha, beta) -> -> (alpha -> beta) -> modifyFun f (a, b) a' = if a' == a then b else f a' - -> modifyFunLemma : (ReflEqEq alpha) => -> (f : alpha -> beta) -> -> (ab : (alpha, beta)) -> -> modifyFun f ab (fst ab) = snd ab -> modifyFunLemma f (a,b) = -> rewrite soTrue (reflexive_eqeq a) in Refl - - replace {P = \ z => ifThenElse (a == a) b (f a) = ifThenElse z b (f a)} - (soTrue (reflexive_eqeq a)) Refl diff --git a/test/reg012/run b/test/reg012/run deleted file mode 100644 --- a/test/reg012/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg012.lidr --check -rm -f *.ibc diff --git a/test/reg014/expected b/test/reg014/expected deleted file mode 100644 --- a/test/reg014/expected +++ /dev/null diff --git a/test/reg014/reg014.idr b/test/reg014/reg014.idr deleted file mode 100644 --- a/test/reg014/reg014.idr +++ /dev/null @@ -1,14 +0,0 @@ -module reg014 - -import Data.Vect - -Matrix : Type -> Nat -> Nat -> Type -Matrix a n m = Vect n (Vect m a) - -mytranspose : Matrix a (S n) (S m) -> Matrix a (S m) (S n) -mytranspose ((x:: []) :: []) = [[x]] -mytranspose [x :: y :: xs] = [x] :: (mytranspose [y :: xs]) -mytranspose (x :: y :: xs) - = let tx = mytranspose [x] in - let ux = mytranspose (y :: xs) in zipWith (++) tx ux - diff --git a/test/reg014/run b/test/reg014/run deleted file mode 100644 --- a/test/reg014/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg014.idr --check -rm -f *.ibc diff --git a/test/reg015/expected b/test/reg015/expected deleted file mode 100644 --- a/test/reg015/expected +++ /dev/null diff --git a/test/reg015/reg015.idr b/test/reg015/reg015.idr deleted file mode 100644 --- a/test/reg015/reg015.idr +++ /dev/null @@ -1,3 +0,0 @@ -using (A : Type, B : A->Type, C : Type) - foo : ((x:A) -> B x -> C) -> ((x:A ** B x) -> C) - foo f p = f (getWitness p) (getProof p) diff --git a/test/reg015/run b/test/reg015/run deleted file mode 100644 --- a/test/reg015/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg015.idr --check -rm -f *.ibc diff --git a/test/reg019/expected b/test/reg019/expected deleted file mode 100644 --- a/test/reg019/expected +++ /dev/null diff --git a/test/reg019/reg019.idr b/test/reg019/reg019.idr deleted file mode 100644 --- a/test/reg019/reg019.idr +++ /dev/null @@ -1,7 +0,0 @@ -m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) -> - Maybe (Either Bool Int) -m_add x y = do x' <- x -- Extract value from x - y' <- y -- Extract value from y - case x' of - Left _ => Nothing - Right _ => Nothing diff --git a/test/reg019/run b/test/reg019/run deleted file mode 100644 --- a/test/reg019/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg019.idr --check -rm -f *.ibc diff --git a/test/reg021/expected b/test/reg021/expected deleted file mode 100644 --- a/test/reg021/expected +++ /dev/null diff --git a/test/reg021/reg021.idr b/test/reg021/reg021.idr deleted file mode 100644 --- a/test/reg021/reg021.idr +++ /dev/null @@ -1,22 +0,0 @@ -module Main - -%default total - -data Ty = TyBool - -data Id a = I a - -interpTy : Ty -> Type -interpTy TyBool = Id Bool - -data Term : Ty -> Type where - TLit : Bool -> Term TyBool - TNot : Term TyBool -> Term TyBool - -map : (a -> b) -> Id a -> Id b -map f (I x) = I (f x) - -interp : Term t -> interpTy t -interp (TLit x) = I x -interp (TNot x) = map not (interp x) - diff --git a/test/reg021/run b/test/reg021/run deleted file mode 100644 --- a/test/reg021/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg021.idr --check -rm -f *.ibc diff --git a/test/reg022/expected b/test/reg022/expected deleted file mode 100644 --- a/test/reg022/expected +++ /dev/null diff --git a/test/reg022/reg022.idr b/test/reg022/reg022.idr deleted file mode 100644 --- a/test/reg022/reg022.idr +++ /dev/null @@ -1,18 +0,0 @@ -module reg022 - -data Result str a = Success str a | Failure String - -instance Functor (Result str) where - map f (Success s x) = Success s (f x) - map f (Failure e ) = Failure e - -ParserT : (Type -> Type) -> Type -> Type -> Type -ParserT m str a = str -> m (Result str a) - -ap : Monad m => ParserT m str (a -> b) -> ParserT m str a -> - ParserT m str b -ap f x = \s => do f' <- f s - case f' of - Failure e => (pure (Failure e)) - Success s' g => x s' >>= pure . map g - diff --git a/test/reg022/run b/test/reg022/run deleted file mode 100644 --- a/test/reg022/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg022.idr --check -rm -f *.ibc diff --git a/test/reg026/expected b/test/reg026/expected deleted file mode 100644 --- a/test/reg026/expected +++ /dev/null diff --git a/test/reg026/reg026.idr b/test/reg026/reg026.idr deleted file mode 100644 --- a/test/reg026/reg026.idr +++ /dev/null @@ -1,16 +0,0 @@ -module Test - -import Data.So - -X : Nat -> Type -X t = (c : Nat ** So (c < 5)) - -column : X t -> Nat -column = getWitness - -data Action = Left | Ahead | Right - -admissible : X t -> Action -> Bool -admissible {t} x Ahead = column {t} x == 0 || column {t} x == 4 -admissible {t} x Left = column {t} x <= 2 -admissible {t} x Right = column {t} x >= 2 diff --git a/test/reg026/run b/test/reg026/run deleted file mode 100644 --- a/test/reg026/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg026.idr --check reg026 -rm -f *.ibc diff --git a/test/reg030/expected b/test/reg030/expected deleted file mode 100644 --- a/test/reg030/expected +++ /dev/null diff --git a/test/reg030/reg030.idr b/test/reg030/reg030.idr deleted file mode 100644 --- a/test/reg030/reg030.idr +++ /dev/null @@ -1,15 +0,0 @@ -import Control.Isomorphism - -class Set univ where - member : univ -> univ -> Type - -isSubsetOf : Set univ => univ -> univ -> Type -isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b) - -class Set univ => HasPower univ where - Powerset : (a : univ) -> - Sigma univ (\Pa => (c : univ) -> - (isSubsetOf c a) -> member c Pa) - -powerset : HasPower univ => univ -> univ -powerset {univ} a = getWitness (Powerset a) diff --git a/test/reg030/run b/test/reg030/run deleted file mode 100644 --- a/test/reg030/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg030.idr --check -rm -f *.ibc diff --git a/test/reg033/expected b/test/reg033/expected deleted file mode 100644 --- a/test/reg033/expected +++ /dev/null diff --git a/test/reg033/reg033.idr b/test/reg033/reg033.idr deleted file mode 100644 --- a/test/reg033/reg033.idr +++ /dev/null @@ -1,12 +0,0 @@ -import Data.Vect - -mapFilter : (alpha -> beta) -> - (alpha -> Bool) -> - Vect n alpha -> - (n : Nat ** Vect n beta) -mapFilter f p Nil = (_ ** Nil) -mapFilter f p (a :: as) with (p a) - | True = (_ ** (f a) :: (getProof (mapFilter f p as))) - | False = mapFilter f p as - - diff --git a/test/reg033/run b/test/reg033/run deleted file mode 100644 --- a/test/reg033/run +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -idris $@ reg033.idr --check -rm -f reg033 *.ibc diff --git a/test/reg041/ott.idr b/test/reg041/ott.idr --- a/test/reg041/ott.idr +++ b/test/reg041/ott.idr @@ -37,6 +37,6 @@ EQ (pi s t) f (pi s' t') g = pi s $ \x => pi s' $ \y => EQ s x s' y ~> EQ (t x) (f x) (t' y) (g y) EQ _ _ _ _ = zero -example : <| (id == id in (two ~> two)) |> +example : <| (Basics.id == Basics.id in (OTT.two ~> OTT.two)) |> example = ?prf diff --git a/test/reg047/reg047.idr b/test/reg047/reg047.idr --- a/test/reg047/reg047.idr +++ b/test/reg047/reg047.idr @@ -3,7 +3,7 @@ data TTSigma : (A : Type) -> (B : A -> Type) -> Type where sigma : (A : Type) -> (B : A -> Type) -> (a : A) -> B a -> TTSigma A B -data Nat = zero | succ Nat +data Nat = Zero | Succ Nat Id : (A : Type) -> A -> A -> Type Id A = (=) {A = A} {B = A} @@ -11,8 +11,8 @@ IdRefl : (A : Type) -> (a : A) -> Id A a a IdRefl A a = Refl {x = a} -zzz : Id Nat zero zero -zzz = IdRefl Nat zero +zzz : Id Nat Zero Zero +zzz = IdRefl Nat Zero -eep : TTSigma Nat (\ a => Id Nat a zero) -eep = sigma Nat (\ a => Id Nat a zero) zero zzz +eep : TTSigma Nat (\ a => Id Nat a Zero) +eep = sigma Nat (\ a => Id Nat a Zero) Zero zzz diff --git a/test/reg047/reg047a.idr b/test/reg047/reg047a.idr --- a/test/reg047/reg047a.idr +++ b/test/reg047/reg047a.idr @@ -3,7 +3,7 @@ data TTSigma : (A : Type) -> (B : A -> Type) -> Type where sigma : (A : Type) -> (B : A -> Type) -> (a : A) -> B a -> TTSigma A B -data MNat = zero | succ MNat +data MNat = Zero | Succ MNat Id : (A : Type) -> A -> A -> Type Id = \A,x,y => x = y -- {a = A} {b = A} @@ -11,14 +11,14 @@ IdRefl : (A : Type) -> (a : A) -> Id A a a IdRefl A a = Refl {x = a} -zzzz : Id MNat zero zero -zzzz = IdRefl MNat zero +zzzz : Id MNat Zero Zero +zzzz = IdRefl MNat Zero -eep : TTSigma MNat (\ c => Id MNat c zero) -eep = (sigma MNat (\b => Id MNat b zero) zero zzzz) +eep : TTSigma MNat (\ c => Id MNat c Zero) +eep = (sigma MNat (\b => Id MNat b Zero) Zero zzzz) -eep2 : TTSigma MNat (\ c => Id MNat c zero) -eep2 = (sigma MNat (\b => Id MNat b zero) zero (IdRefl MNat zero)) +eep2 : TTSigma MNat (\ c => Id MNat c Zero) +eep2 = (sigma MNat (\b => Id MNat b Zero) Zero (IdRefl MNat Zero)) diff --git a/test/totality010/expected b/test/totality010/expected new file mode 100644 --- /dev/null +++ b/test/totality010/expected @@ -0,0 +1,4 @@ +totality010.idr:27:1: +Main.evenNotS is not total as there are missing cases +totality010.idr:30:1: +Main.bad is possibly not total due to: Main.evenNotS diff --git a/test/totality010/run b/test/totality010/run new file mode 100644 --- /dev/null +++ b/test/totality010/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris $@ totality010.idr --nocolour --consolewidth 80 --check +rm -f *.ibc diff --git a/test/totality010/totality010.idr b/test/totality010/totality010.idr new file mode 100644 --- /dev/null +++ b/test/totality010/totality010.idr @@ -0,0 +1,31 @@ +%default total + +%default total +succNotLTE' : (LTE (S x) x) -> Void +succNotLTE' {x = Z} prf = succNotLTEzero prf +succNotLTE' {x = (S k)} (LTESucc prf) = succNotLTE' prf + +succNotLTE : Not (LTE (S x) x) +succNotLTE = succNotLTE' + +succNotLTE2 : Not (LTE (S x) x) +succNotLTE2 {x = Z} prf = succNotLTEzero prf +succNotLTE2 {x = (S k)} (LTESucc prf) = succNotLTE prf + +-- a defective even-odd definition allows me to prove bottom + +mutual + data Even : Nat -> Type where + ZeroEven : Even Z + MkEven : Odd n -> Even (S n) + MkBad : Even n -> Even (S n) + + data Odd : Nat -> Type where + MkOdd : Even n -> Odd (S n) + +evenNotS : Even n -> Not (Even (S n)) +evenNotS MkEven ZeroEven impossible + +bad : Void +bad = evenNotS ZeroEven $ MkBad ZeroEven + diff --git a/test/tutorial006/expected b/test/tutorial006/expected --- a/test/tutorial006/expected +++ b/test/tutorial006/expected @@ -1,5 +1,5 @@ tutorial006a.idr:5:23-25:When checking right hand side of vapp: -When checking argument xs to constructor Data.VectType.Vect.::: +When checking argument xs to constructor Data.Vect.::: Type mismatch between Vect (k + k) a (Type of vapp xs xs) and