packages feed

idris 0.11 → 0.11.1

raw patch · 141 files changed

+4839/−2029 lines, 141 filesdep +ieee754dep ~zip-archivesetup-changed

Dependencies added: ieee754

Dependency ranges changed: zip-archive

Files

− CHANGELOG 
@@ -1,762 +0,0 @@-New in 0.11:-============--Updated export rules-----------------------* The export rules are:-  - 'private' means that the definition is not exported at all-  - 'export' means that the top level type is exported, but not the-    definition. In the case of 'data', this means the type constructor is-    exported but not the data constructors.-  - 'public export' means that the entire definition is exported.-* By default, names are 'private'. This can be altered with an %access-  directive as before.-* Exported types can only refer to other exported names-* Publicly exported definitions can only refer to publicly exported names--Improved C FFI-----------------* Idris functions can now be passed as callbacks to C functions or wrapped-in a C function pointer.-* C function pointers can be called.-* Idris can access pointers to C globals.--Effects----------* Effects can now be given in any order in effect lists (there is no need-for the ordering to be preserved in sub lists of effects)--Elaborator reflection updates--------------------------------* Datatypes can now be defined from elaborator reflection:-  - declareDatatype adds the type constructor declaration to the context-  - defineDatatype adds the constructors to the datatype-  - To declare an inductive-recursive family, declare the types of the-    function and the type constructor before defining the pattern-match-    cases and constructors.--Minor language changes-------------------------* The '[static]' annotation is changed to '%static' to be consistent with the-  other annotations.-* Added '%auto_implicits' directive. The default is '%auto_implicits on'.-  Placing '%auto_implicits off' in a source file means that after that-  point, any implicit arguments must be bound, e.g.:-    append : {n,m,a:_} -> Vect n a -> Vect m a -> Vect (n + m) a--  Only names which are used explicitly in the type need to be bound, e.g.:-    Here  : {x, xs : _} -> Elem x (x :: xs)--  In 'Here', there is no need to bind any of the variables in the type of-  'xs' (it could be e.g. List a or Vect n a; 'a' and 'n' will still be-  implicitly bound).--  You can still implicitly bind with 'using':--    using (xs : Vect _ _)-      data Elem  : {a, n : _} -> a -> Vect n a -> Type where-           Here  : {x : _} -> Elem x (x :: xs)-           There : {x, y : _} -> Elem x xs -> Elem x (y :: xs)--  However, note that *only* names which appear in *both* the using block-  *and* the type being defined will be implicitly bound. The following will-  therefore fail because 'n' isn't implicitly bound:--    using (xs : Vect n a)-      bad : Elem x xs -> Elem x (y :: xs)-* `Sigma` has been renamed  to `DPair`.-* Accessor functions for dependent pairs have been renamed to bring them into-  line with standard accessor functions for pairs. The function `getWitness`-  is now `fst`, and `getProof` is `snd`.-* File Modes expanded: Append, ReadWriteTruncate, and ReadAppend added,-  Write is deprecated and renamed to WriteTruncate.-* C11 Extended Mode variations added to File Modes.-* More flexible holes.-  Holes can now depend on other holes in a term (such as implicit arguments-  which may be inferred from the definition of the hole).-* Programs with holes can now be compiled.-  Attempting to evaluate an expression with a hole results in a run time error.-* Dependent pairs now can be specified using a telescope-style syntax, without-  requirement of nesting, e.g. it is possible to now write the following:-    (a : Type ** n : Nat ** Vect n a)-* Idris will give a warning if an implicit is bound automatically, but would-  otherwise be a valid expressio if the name was used as a global--External Dependencies------------------------* Curses has been removed as an external dependancy.--New in 0.10:-============--* 'class' and 'instance' are now deprecated keywords. They have been-  replaced by 'interface' and 'implementation' respectively. This is to-  properly reflect their purpose.-* (/) operator moved into new Fractional interface.-* Idris' logging infrastructure has been categorised. Command line and repl-  are available. For command line the option `--logging-categories CATS`-  is used to pass in the categories. Here `CATS` is a colon separated quoted-  string containing the categories to log. The REPL command is `logcats CATS`.-  Where `CATS` is a whitespace separated list of categoriese. Default is for-  all categories to be logged.-* New flag `--listlogcats` to list logging categories.`--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.-* The previous syntax for tactic proofs and the previous interactive prover-  are now deprecated in favour of reflected elaboration. They will be removed-  at some point in the future.-* 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.-* Name binding in patterns follows the same rule as name binding for implicits-  in types: names which begin with lower case letters, not applied to any-  arguments, are treated as bound pattern variables.-* Added %deprecate directive, which gives a warning and a message when a-  deprecated name is referenced.--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.-* The (+), (-), and (*) operations on Fin have been removed.-* New Logging Effects have been added to facilitate logging of effectful-  programmes.-* Elaborator reflection is now a part of the prelude. It is no longer-  necessary to import Language.Reflection.Elab.-* The `PERF` effect allows for simple performance metrics to be collected-  from Effectful programs.-* Some constructors that never actually occurred have been removed from-  the TT and Raw reflection datatypes in Language.Reflection.-* File IO operations (for example openFile/fread/fwrite) now return-  'Either FileError ty' where the return type was previously 'ty' to indicate-  that they may fail.--Tool updates--------------* Records are now shown as records in :doc, rather than as the underlying-  datatype-* iPKG files have a new option `pkgs` which takes a comma-separated list-  of package names that the idris project depends on. This reduces bloat-  in the `opts` option with multiple package declarations.-* iPKG files now allow `executable = "your filename here"` in addition to-  the existing `executable = yourFilenameHere` style. While the unquoted-  version is limited to filenames that look like namespaced Idris identifiers-  (`your.filename.here`), the quoted version accepts any valid filename.-* Add definition command (\d in Vim, Ctrl-Alt-A in Atom, C-c C-s in Emacs) now-  adds missing clauses if there is already a definition.--Miscellaneous updates-----------------------* Disable the deprecation warnings for %elim and old-style tactic scripts-  with the --no-elim-deprecation-warnings and --no-tactic-deprecation-warnings-  flags.---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).
+ CHANGELOG.md view
@@ -0,0 +1,842 @@+# New in 0.12:++## Language updates++* `rewrite` can now be used to rewrite equalities on functions over+  dependent types+* `rewrite` can now be given an optional rewriting lemma, with the syntax+  `rewrite [rule] using [rewrite_lemma] in [scope]`.+* Experimental extended `with` syntax, which allows calling functions defined+  in a with block directly. For example:++  ```+  data SnocList : List a -> Type where+       Empty : SnocList []+       Snoc : SnocList xs -> SnocList (xs ++ [x])++  snocList : (xs : List a) -> SnocList a++  my_reverse : List a -> List a+  my_reverse xs with (snocList xs)+    my_reverse [] | Empty = []+    my_reverse (ys ++ [x]) | (Snoc p) = x :: my_reverse ys | p+  ```++    The `| p` on the right hand side means that the `with` block function will+    be called directly, so the recursive structure of `SnocList` can direct the+    recursion structure of `my_reverse`.++* Added `%fragile` directive, which gives a warning and a message when a+  fragile name is referenced. For use in detailing fragile APIs.++* The totality checker now looks under `case` blocks, rather than treating+  them as mutually defined functions with their top level function, meaning+  that it can spot more total functions.++## Library updates++* `Control.WellFounded` module removed, and added to the Prelude as+  `Prelude.WellFounded`.+* Added `Data.List.Views` with views on `List` and their covering functions.+* Added `Data.Nat.Views` with views on `Nat` and their covering functions.++## Miscellaneous updates++* The Idris man page is now installed as part of the cabal/stack build  process.++* Improved startup performance by reducing the processing of an already imported+  module that has changed accessibility.++* A limited set of command line options can be used to override+  package declared options. Overridable options are currently, logging+  level and categories, default totality check, warn reach, IBC output+  folder, and idris path. Note overriding IBC output folder, only+  affects the installation of Idris packages.++* Remove deprecated options `--ideslave` and `--ideslave-socket`. These options+  were replaced with `--ide-mode` and `--ide-mode-socket` in 0.9.17++* The code generator output type `MavenProject` was specific to the+  Java codegen and has now been deprecated, together with the+  corresponding `--mvn` option.++* Definitional equality on Double is now bit-pattern identity rather+  than IEEE's comparison operator. This prevents a bug where programs+  could distinguish between -0.0 and 0.0, but the type theory could+  not, leading to a contradiction. The new fine-grained equality+  prevents this.++## Reflection changes++* The implicit coercion from String to TTName was removed.++* Decidable equality for TTName is available.++# New in 0.11++## Updated export rules++* The export rules are:+  - 'private' means that the definition is not exported at all+  - 'export' means that the top level type is exported, but not the+    definition. In the case of 'data', this means the type constructor is+    exported but not the data constructors.+  - 'public export' means that the entire definition is exported.+* By default, names are 'private'. This can be altered with an %access directive+  as before.+* Exported types can only refer to other exported names+* Publicly exported definitions can only refer to publicly exported names++## Improved C FFI++* Idris functions can now be passed as callbacks to C functions or wrapped in a+  C function pointer.+* C function pointers can be called.+* Idris can access pointers to C globals.++## Effects++* Effects can now be given in any order in effect lists (there is no need for+  the ordering to be preserved in sub lists of effects)++## Elaborator reflection updates++* Datatypes can now be defined from elaborator reflection:+  - declareDatatype adds the type constructor declaration to the context+  - defineDatatype adds the constructors to the datatype+  - To declare an inductive-recursive family, declare the types of the function+    and the type constructor before defining the pattern-match cases and+    constructors.++## Minor language changes++* The `[static]` annotation is changed to `%static` to be consistent with the+  other annotations.+* Added `%auto_implicits` directive. The default is `%auto_implicits on`.+  Placing `%auto_implicits off` in a source file means that after that point,+  any implicit arguments must be bound, e.g.:++  ```+  append : {n,m,a:_} -> Vect n a -> Vect m a -> Vect (n + m) a+  ```++  Only names which are used explicitly in the type need to be bound, e.g.:++  ```+  Here  : {x, xs : _} -> Elem x (x :: xs)+  ```++  In `Here`, there is no need to bind any of the variables in the type of `xs`+  (it could be e.g. `List a` or `Vect n a`; `a` and `n` will still be implicitly+  bound).++  You can still implicitly bind with 'using':++   ```+    using (xs : Vect _ _)+      data Elem  : {a, n : _} -> a -> Vect n a -> Type where+           Here  : {x : _} -> Elem x (x :: xs)+           There : {x, y : _} -> Elem x xs -> Elem x (y :: xs)+   ```++  However, note that *only* names which appear in *both* the using block+  *and* the type being defined will be implicitly bound. The following will+  therefore fail because 'n' isn't implicitly bound:++  ```+    using (xs : Vect n a)+      bad : Elem x xs -> Elem x (y :: xs)+  ```++* `Sigma` has been renamed  to `DPair`.+* Accessor functions for dependent pairs have been renamed to bring them into+  line with standard accessor functions for pairs. The function `getWitness` is+  now `fst`, and `getProof` is `snd`.+* File Modes expanded: Append, ReadWriteTruncate, and ReadAppend added, Write is+  deprecated and renamed to WriteTruncate.+* C11 Extended Mode variations added to File Modes.+* More flexible holes. Holes can now depend on other holes in a term (such as+  implicit arguments which may be inferred from the definition of the hole).+* Programs with holes can now be compiled.  Attempting to evaluate an expression+  with a hole results in a run time error.+* Dependent pairs now can be specified using a telescope-style syntax, without+  requirement of nesting, e.g. it is possible to now write the following:++  ```+    (a : Type ** n : Nat ** Vect n a)+  ```++* Idris will give a warning if an implicit is bound automatically, but would+  otherwise be a valid expressio if the name was used as a global++## External Dependencies++* Curses has been removed as an external dependency.++# New in 0.10++* `class` and `instance` are now deprecated keywords. They have been replaced by+  `interface` and `implementation` respectively. This is to properly reflect+  their purpose.+* `(/)` operator moved into new Fractional interface.+* Idris' logging infrastructure has been categorised. Command line and repl are+  available. For command line the option `--logging-categories CATS` is used to+  pass in the categories. Here `CATS` is a colon separated quoted string+  containing the categories to log. The REPL command is `logcats CATS`.  Where+  `CATS` is a whitespace separated list of categoriese. Default is for all+  categories to be logged.+* New flag `--listlogcats` to list logging categories.++# 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.+* The previous syntax for tactic proofs and the previous interactive prover are+  now deprecated in favour of reflected elaboration. They will be removed at+  some point in the future.+* 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.+* Name binding in patterns follows the same rule as name binding for implicits+  in types: names which begin with lower case letters, not applied to any+  arguments, are treated as bound pattern variables.+* Added `%deprecate` directive, which gives a warning and a message when a+  deprecated name is referenced.++## 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.+* The `(+)`, `(-)`, and `(*)` operations on Fin have been removed.+* New Logging Effects have been added to facilitate logging of effectful+  programmes.+* Elaborator reflection is now a part of the prelude. It is no longer necessary+  to import `Language.Reflection.Elab`.+* The `PERF` effect allows for simple performance metrics to be collected from+  Effectful programs.+* Some constructors that never actually occurred have been removed from the `TT`+  and `Raw` reflection datatypes in Language.Reflection.+* File `IO` operations (for example openFile/fread/fwrite) now return+  `Either FileError ty` where the return type was previously `ty` to indicate+  that they may fail.++## Tool updates++* Records are now shown as records in `:doc`, rather than as the underlying+  datatype+* iPKG files have a new option `pkgs` which takes a comma-separated list of+  package names that the idris project depends on. This reduces bloat in the+  `opts` option with multiple package declarations.+* iPKG files now allow `executable = "your filename here"` in addition to the+  existing `executable = yourFilenameHere` style. While the unquoted version is+  limited to filenames that look like namespaced Idris identifiers+  (`your.filename.here`), the quoted version accepts any valid filename.+* Add definition command (`\d` in Vim, `Ctrl-Alt-A` in Atom, `C-c C-s` in Emacs)+  now adds missing clauses if there is already a definition.++## Miscellaneous updates++* Disable the deprecation warnings for %elim and old-style tactic scripts with+  the `--no-elim-deprecation-warnings` and `--no-tactic-deprecation-warnings`+  flags.++# 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++## User visible changes++* 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).
+ RELEASE-CHECKS.md view
@@ -0,0 +1,42 @@+# Release Checks++Things to be checked, or done before a release is made.++## Final Checks+++ [ ] Do the tests run to completion?++ [ ] Can samples build?++ [ ] Is `man/idris.1` up-to-date?++## Version Numbers+++ [ ] `man/idris.1`.++ [ ] `docs/conf.py`.++ [ ] `docs/listing/idris-prompt-helloworld.txt`.++ [ ] `docs/listing/idris-prompt-interp.txt`.++ [ ] `docs/listing/idris-prompt-start.txt`.++ [ ] `idris.cabal`.++## Tag Release+++ [ ] Finalise and check `CHANGELOG.md`.++ [ ] Tag the release.++## Uploads+++ [ ] Push to GITHUB.++ [ ] Upload to Hackage.++## Binaries+++ [ ] Generate Mac OS X Package.++ [ ] Prompt helpers to create:+  + [ ] Windows Binary.+  + [ ] HomeBrew Package.++## Announcements+++ [ ] Update website.++ [ ] Email Mailing list.++ [ ] Make REDDIT post.++ [ ] Tweet
Setup.hs view
@@ -9,7 +9,7 @@ import Distribution.Simple.LocalBuildInfo as L import qualified Distribution.Simple.Setup as S import qualified Distribution.Simple.Program as P-import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFile)+import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFile, notice, installOrdinaryFiles) import Distribution.Compiler import Distribution.PackageDescription import Distribution.Text@@ -228,7 +228,7 @@          where             makeBuild dir = make verbosity [ "-C", dir, "build" , "IDRIS=" ++ idrisCmd local] -      buildRTS = make verbosity (["-C", "rts", "build"] ++ +      buildRTS = make verbosity (["-C", "rts", "build"] ++                                    gmpflag (usesGMP (configFlags local)))        gmpflag False = []@@ -242,6 +242,7 @@ idrisInstall verbosity copy pkg local = unless (execOnly (configFlags local)) $ do       installStdLib       installRTS+      installManPage    where       target = datadir $ L.absoluteInstallDirs pkg local copy @@ -253,6 +254,12 @@          let target' = target </> "rts"          putStrLn $ "Installing run time system in " ++ target'          makeInstall "rts" target'++      installManPage = do+         let mandest = (mandir $ L.absoluteInstallDirs pkg local copy) ++ "/man1"+         notice verbosity $ unwords ["Copying man page to", mandest]+         installOrdinaryFiles verbosity mandest [("man", "idris.1")]+        makeInstall src target =          make verbosity [ "-C", src, "install" , "TARGET=" ++ target, "IDRIS=" ++ idrisCmd local]
idris-tutorial.pdf view

binary file changed (326385 → 326683 bytes)

idris.cabal view
@@ -1,5 +1,5 @@ Name:           idris-Version:        0.11+Version:        0.11.1 License:        BSD3 License-file:   LICENSE Author:         Edwin Brady@@ -75,13 +75,13 @@                        rts/libtest.c  Extra-doc-files:-                       CHANGELOG+                       CHANGELOG.md                        CITATION.md                        CONTRIBUTING.md                        CONTRIBUTORS                        README.md+                       RELEASE-CHECKS.md                        idris-tutorial.pdf-                       man/idris.1                        samples/effects/*.idr                        samples/misc/*.idr                        samples/misc/*.lidr@@ -91,6 +91,7 @@                        Makefile                        config.mk                        stack.yaml+                       man/idris.1                         rts/*.c                        rts/*.h@@ -113,8 +114,10 @@                        libs/base/Control/*.idr                        libs/base/Control/Monad/*.idr                        libs/base/Data/*.idr+                       libs/base/Data/Nat/*.idr                        libs/base/Data/List/*.idr                        libs/base/Data/Vect/*.idr+                       libs/base/Data/String/*.idr                        libs/base/Debug/*.idr                        libs/base/Language/Reflection/*.idr                        libs/base/Makefile@@ -325,7 +328,14 @@                        test/reg070/run                        test/reg070/*.idr                        test/reg070/expected+                       test/reg071/run+                       test/reg071/*.idr+                       test/reg071/expected+                       test/reg072/run+                       test/reg072/*.idr+                       test/reg072/expected +                        test/basic001/run                        test/basic001/*.idr                        test/basic001/expected@@ -401,6 +411,10 @@                        test/corecords002/run                        test/corecords002/expected +                       test/directives001/*.idr+                       test/directives001/run+                       test/directives001/expected+                        test/delab001/*.idr                        test/delab001/run                        test/delab001/expected@@ -459,6 +473,15 @@                        test/error005/run                        test/error005/*.idr                        test/error005/expected+                       test/error006/run+                       test/error006/*.idr+                       test/error006/expected+                       test/error007/run+                       test/error007/*.idr+                       test/error007/expected+                       test/error008/run+                       test/error008/*.idr+                       test/error008/expected                         test/ffi001/run                        test/ffi001/*.idr@@ -581,6 +604,10 @@                        test/interactive012/input                        test/interactive012/run                        test/interactive012/*.idr+                       test/interactive013/expected+                       test/interactive013/input+                       test/interactive013/run+                       test/interactive013/*.idr                         test/io001/run                        test/io001/*.idr@@ -663,6 +690,9 @@                        test/proof010/run                        test/proof010/*.idr                        test/proof010/expected+                       test/proof011/run+                       test/proof011/*.idr+                       test/proof011/expected                         test/proofsearch001/run                        test/proofsearch001/*.idr@@ -772,6 +802,12 @@                        test/totality011/run                        test/totality011/*.lidr                        test/totality011/expected+                       test/totality012/run+                       test/totality012/*.idr+                       test/totality012/expected+                       test/totality013/run+                       test/totality013/*.idr+                       test/totality013/expected                         test/tutorial001/run                        test/tutorial001/*.idr@@ -791,6 +827,10 @@                        test/tutorial006/run                        test/tutorial006/*.idr                        test/tutorial006/expected+                       test/tutorial007/run+                       test/tutorial007/*.idr+                       test/tutorial007/*.c+                       test/tutorial007/expected                         test/unique001/run                        test/unique001/*.idr@@ -802,6 +842,16 @@                        test/unique003/*.idr                        test/unique003/expected +                       test/views001/run+                       test/views001/*.idr+                       test/views001/expected+                       test/views002/run+                       test/views002/*.idr+                       test/views002/expected+                       test/views003/run+                       test/views003/*.idr+                       test/views003/expected+                        test/docs001/run                        test/docs001/input                        test/docs001/*.idr@@ -902,6 +952,7 @@                 , Idris.Elab.Value                 , Idris.Elab.Term                 , Idris.Elab.Quasiquote+                , Idris.Elab.Rewrite                  , Idris.REPL.Browse @@ -1000,6 +1051,7 @@                 , filepath < 1.5                 , fingertree >= 0.1 && < 0.2                 , haskeline >= 0.7 && < 0.8+                , ieee754 >= 0.7 && < 0.8                 , mtl >= 2.1 && < 2.3                 , network < 2.7                 , optparse-applicative >= 0.11 && < 0.13@@ -1018,7 +1070,7 @@                 , utf8-string < 1.1                 , vector < 0.12                 , vector-binary-instances < 0.3-                , zip-archive > 0.2.3.5 && < 0.2.4+                , zip-archive > 0.2.3.5 && < 0.4                 , safe                 , fsnotify < 2.2                 , async < 2.2
libs/base/Data/Bits.idr view
@@ -3,6 +3,7 @@ import Data.Fin  %default total+%access export  public export nextPow2 : Nat -> Nat@@ -28,7 +29,7 @@ bitsUsed n = 8 * (2 `power` n)  %assert_total-natToBits' : machineTy n -> Nat -> machineTy n+natToBits' : %static {n : Nat} -> machineTy n -> Nat -> machineTy n natToBits' a Z = a natToBits' {n=n} a x with (n)  -- it seems I have to manually recover the value of n here, instead of being able to reference it@@ -37,14 +38,14 @@  natToBits' a (S x') | S (S Z)     = natToBits' {n=2} (prim__addB32 a (prim__truncInt_B32 1)) x'  natToBits' a (S x') | S (S (S _)) = natToBits' {n=3} (prim__addB64 a (prim__truncInt_B64 1)) x' -natToBits : Nat -> machineTy n+natToBits : %static {n : Nat} -> Nat -> machineTy n natToBits {n=n} x with (n)     | Z           = natToBits' {n=0} (prim__truncInt_B8  0) x     | S Z         = natToBits' {n=1} (prim__truncInt_B16 0) x     | S (S Z)     = natToBits' {n=2} (prim__truncInt_B32 0) x     | S (S (S _)) = natToBits' {n=3} (prim__truncInt_B64 0) x -getPad : Nat -> machineTy n+getPad : %static {n : Nat} -> Nat -> machineTy n getPad n = natToBits (minus (bitsUsed (nextBytes n)) n)  public export@@ -92,83 +93,69 @@     where       pad = getPad {n=3} n --- TODO: This (and all the other functions along these lings) is public export--- because it is used by public export things. Do they really need to be+-- TODO: This (and all the other functions along these lings) is -- because it is used by things. Do they really need to be -- public export, or is export good enough?-public export-shiftLeft' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)+shiftLeft' : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) shiftLeft' {n=n} x c with (nextBytes n)     | Z = pad8' n prim__shlB8 x c     | S Z = pad16' n prim__shlB16 x c     | S (S Z) = pad32' n prim__shlB32 x c     | S (S (S _)) = pad64' n prim__shlB64 x c -public export-shiftLeft : Bits n -> Bits n -> Bits n+shiftLeft : %static {n : Nat} -> Bits n -> Bits n -> Bits n shiftLeft (MkBits x) (MkBits y) = MkBits (shiftLeft' x y) -public export-shiftRightLogical' : machineTy n -> machineTy n -> machineTy n+shiftRightLogical' : %static {n : Nat} -> machineTy n -> machineTy n -> machineTy n shiftRightLogical' {n=n} x c with (n)     | Z = prim__lshrB8 x c     | S Z = prim__lshrB16 x c     | S (S Z) = prim__lshrB32 x c     | S (S (S _)) = prim__lshrB64 x c -public export-shiftRightLogical : Bits n -> Bits n -> Bits n+shiftRightLogical : %static {n : Nat} -> Bits n -> Bits n -> Bits n shiftRightLogical {n} (MkBits x) (MkBits y)     = MkBits {n} (shiftRightLogical' {n=nextBytes n} x y) -public export-shiftRightArithmetic' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)+shiftRightArithmetic' : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) shiftRightArithmetic' {n=n} x c with (nextBytes n)     | Z = pad8' n prim__ashrB8 x c     | S Z = pad16' n prim__ashrB16 x c     | S (S Z) = pad32' n prim__ashrB32 x c     | S (S (S _)) = pad64' n prim__ashrB64 x c -public export-shiftRightArithmetic : Bits n -> Bits n -> Bits n+shiftRightArithmetic : %static {n : Nat} -> Bits n -> Bits n -> Bits n shiftRightArithmetic (MkBits x) (MkBits y) = MkBits (shiftRightArithmetic' x y) -public export-and' : machineTy n -> machineTy n -> machineTy n+and' : %static {n : Nat} -> machineTy n -> machineTy n -> machineTy n and' {n=n} x y with (n)     | Z = prim__andB8 x y     | S Z = prim__andB16 x y     | S (S Z) = prim__andB32 x y     | S (S (S _)) = prim__andB64 x y -public export-and : Bits n -> Bits n -> Bits n+and : %static {n : Nat} -> Bits n -> Bits n -> Bits n and {n} (MkBits x) (MkBits y) = MkBits (and' {n=nextBytes n} x y) -public export-or' : machineTy n -> machineTy n -> machineTy n+or' : %static {n : Nat} -> machineTy n -> machineTy n -> machineTy n or' {n=n} x y with (n)     | Z = prim__orB8 x y     | S Z = prim__orB16 x y     | S (S Z) = prim__orB32 x y     | S (S (S _)) = prim__orB64 x y -public export-or : Bits n -> Bits n -> Bits n+or : %static {n : Nat} -> Bits n -> Bits n -> Bits n or {n} (MkBits x) (MkBits y) = MkBits (or' {n=nextBytes n} x y) -public export-xor' : machineTy n -> machineTy n -> machineTy n+xor' : %static {n : Nat} -> machineTy n -> machineTy n -> machineTy n xor' {n=n} x y with (n)     | Z = prim__xorB8 x y     | S Z = prim__xorB16 x y     | S (S Z) = prim__xorB32 x y     | S (S (S _)) = prim__xorB64 x y -public export-xor : Bits n -> Bits n -> Bits n+xor : %static {n : Nat} -> Bits n -> Bits n -> Bits n xor {n} (MkBits x) (MkBits y) = MkBits {n} (xor' {n=nextBytes n} x y) -public export plus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) plus' {n=n} x y with (nextBytes n)     | Z = pad8 n prim__addB8 x y@@ -176,11 +163,9 @@     | S (S Z) = pad32 n prim__addB32 x y     | S (S (S _)) = pad64 n prim__addB64 x y -public export-plus : Bits n -> Bits n -> Bits n+plus : %static {n : Nat} -> Bits n -> Bits n -> Bits n plus (MkBits x) (MkBits y) = MkBits (plus' x y) -public export minus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) minus' {n=n} x y with (nextBytes n)     | Z = pad8 n prim__subB8 x y@@ -188,11 +173,9 @@     | S (S Z) = pad32 n prim__subB32 x y     | S (S (S _)) = pad64 n prim__subB64 x y -public export-minus : Bits n -> Bits n -> Bits n+minus : %static {n : Nat} -> Bits n -> Bits n -> Bits n minus (MkBits x) (MkBits y) = MkBits (minus' x y) -public export times' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) times' {n=n} x y with (nextBytes n)     | Z = pad8 n prim__mulB8 x y@@ -200,12 +183,10 @@     | S (S Z) = pad32 n prim__mulB32 x y     | S (S (S _)) = pad64 n prim__mulB64 x y -public export-times : Bits n -> Bits n -> Bits n+times : %static {n : Nat} -> Bits n -> Bits n -> Bits n times (MkBits x) (MkBits y) = MkBits (times' x y)  partial-public export sdiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) sdiv' {n=n} x y with (nextBytes n)     | Z = prim__sdivB8 x y@@ -213,88 +194,85 @@     | S (S Z) = prim__sdivB32 x y     | S (S (S _)) = prim__sdivB64 x y -public export partial-sdiv : Bits n -> Bits n -> Bits n+partial+sdiv : %static {n : Nat} -> Bits n -> Bits n -> Bits n sdiv (MkBits x) (MkBits y) = MkBits (sdiv' x y)  partial-public export-udiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)+udiv' : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) udiv' {n=n} x y with (nextBytes n)     | Z = prim__udivB8 x y     | S Z = prim__udivB16 x y     | S (S Z) = prim__udivB32 x y     | S (S (S _)) = prim__udivB64 x y -public export partial-udiv : Bits n -> Bits n -> Bits n+partial+udiv : %static {n : Nat} -> Bits n -> Bits n -> Bits n udiv (MkBits x) (MkBits y) = MkBits (udiv' x y) -public export partial-srem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)+partial+srem' : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) srem' {n=n} x y with (nextBytes n)     | Z = prim__sremB8 x y     | S Z = prim__sremB16 x y     | S (S Z) = prim__sremB32 x y     | S (S (S _)) = prim__sremB64 x y -public export partial-srem : Bits n -> Bits n -> Bits n+partial+srem : %static {n : Nat} -> Bits n -> Bits n -> Bits n srem (MkBits x) (MkBits y) = MkBits (srem' x y) -public export partial-urem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)+partial+urem' : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) urem' {n=n} x y with (nextBytes n)     | Z = prim__uremB8 x y     | S Z = prim__uremB16 x y     | S (S Z) = prim__uremB32 x y     | S (S (S _)) = prim__uremB64 x y -public export partial-urem : Bits n -> Bits n -> Bits n+partial+urem : %static {n : Nat} -> Bits n -> Bits n -> Bits n urem (MkBits x) (MkBits y) = MkBits (urem' x y)  -- TODO: Proofy comparisons via postulates-lt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int+lt : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int lt {n=n} x y with (nextBytes n)     | Z = prim__ltB8 x y     | S Z = prim__ltB16 x y     | S (S Z) = prim__ltB32 x y     | S (S (S _)) = prim__ltB64 x y -lte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int+lte : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int lte {n=n} x y with (nextBytes n)     | Z = prim__lteB8 x y     | S Z = prim__lteB16 x y     | S (S Z) = prim__lteB32 x y     | S (S (S _)) = prim__lteB64 x y -eq : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int+eq : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int eq {n=n} x y with (nextBytes n)     | Z = prim__eqB8 x y     | S Z = prim__eqB16 x y     | S (S Z) = prim__eqB32 x y     | S (S (S _)) = prim__eqB64 x y -gte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int+gte : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int gte {n=n} x y with (nextBytes n)     | Z = prim__gteB8 x y     | S Z = prim__gteB16 x y     | S (S Z) = prim__gteB32 x y     | S (S (S _)) = prim__gteB64 x y -gt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int+gt : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int gt {n=n} x y with (nextBytes n)     | Z = prim__gtB8 x y     | S Z = prim__gtB16 x y     | S (S Z) = prim__gtB32 x y     | S (S (S _)) = prim__gtB64 x y -public export implementation Eq (Bits n) where     (MkBits x) == (MkBits y) = boolOp eq x y -public export implementation Ord (Bits n) where     (MkBits x) < (MkBits y) = boolOp lt x y     (MkBits x) <= (MkBits y) = boolOp lte x y@@ -307,8 +285,7 @@              then EQ              else GT -public export-complement' : machineTy (nextBytes n) -> machineTy (nextBytes n)+complement' : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) complement' {n=n} x with (nextBytes n)     | Z = let pad = getPad {n=0} n in           prim__complB8 (x `prim__shlB8` pad) `prim__lshrB8` pad@@ -319,13 +296,12 @@     | S (S (S _)) = let pad = getPad {n=3} n in                     prim__complB64 (x `prim__shlB64` pad) `prim__lshrB64` pad -public export-complement : Bits n -> Bits n+complement : %static {n : Nat} -> Bits n -> Bits n complement (MkBits x) = MkBits (complement' x)  -- TODO: Prove-public export %assert_total -- can't verify coverage of with block-zext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m))+%assert_total -- can't verify coverage of with block+zext' : %static {n : Nat} -> %static {m : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))     | (Z, Z) = believe_me x     | (Z, S Z) = believe_me (prim__zextB8_B16 (believe_me x))@@ -338,12 +314,11 @@     | (S (S Z), S (S (S _))) = believe_me (prim__zextB32_B64 (believe_me x))     | (S (S (S _)), S (S (S _))) = believe_me x -public export-zeroExtend : Bits n -> Bits (n+m)+zeroExtend : %static {n : Nat} -> %static {m : Nat} -> Bits n -> Bits (n+m) zeroExtend (MkBits x) = MkBits (zext' x) -public export %assert_total-intToBits' : Integer -> machineTy (nextBytes n)+%assert_total+intToBits' : %static {n : Nat} -> Integer -> machineTy (nextBytes n) intToBits' {n=n} x with (nextBytes n)     | Z = let pad = getPad {n=0} n in           prim__lshrB8 (prim__shlB8 (prim__truncBigInt_B8 x) pad) pad@@ -354,28 +329,24 @@     | S (S (S _)) = let pad = getPad {n=3} n in                     prim__lshrB64 (prim__shlB64 (prim__truncBigInt_B64 x) pad) pad -public export-intToBits : Integer -> Bits n+intToBits : %static {n : Nat} -> Integer -> Bits n intToBits n = MkBits (intToBits' n)  implementation Cast Integer (Bits n) where     cast = intToBits -public export-bitsToInt' : machineTy (nextBytes n) -> Integer+bitsToInt' : %static {n : Nat} -> machineTy (nextBytes n) -> Integer bitsToInt' {n=n} x with (nextBytes n)     | Z = prim__zextB8_BigInt x     | S Z = prim__zextB16_BigInt x     | S (S Z) = prim__zextB32_BigInt x     | S (S (S _)) = prim__zextB64_BigInt x -public export-bitsToInt : Bits n -> Integer+bitsToInt : %static {n : Nat} -> Bits n -> Integer bitsToInt (MkBits x) = bitsToInt' x  -- Zero out the high bits of a truncated bitstring-public export-zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n)+zeroUnused : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0)  --implementation Cast Nat (Bits n) where@@ -383,7 +354,7 @@  -- TODO: Prove %assert_total -- can't verify coverage of with block-sext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m))+sext' : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) sext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))     | (Z, Z) = let pad = getPad {n=0} n in                believe_me (prim__ashrB8 (prim__shlB8 (believe_me x) pad) pad)@@ -412,13 +383,12 @@     | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in                                    believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad) ---public export---signExtend : Bits n -> Bits (n+m)+----signExtend : Bits n -> Bits (n+m) --signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x))  -- TODO: Prove-public export %assert_total -- can't verify coverage of with block-trunc' : machineTy (nextBytes (m+n)) -> machineTy (nextBytes n)+%assert_total -- can't verify coverage of with block+trunc' : %static {m : Nat} -> %static {n : Nat} -> machineTy (nextBytes (m+n)) -> machineTy (nextBytes n) trunc' {m=m} {n=n} x with (nextBytes n, nextBytes (m+n))     | (Z, Z) = believe_me x     | (Z, S Z) = believe_me (prim__truncB16_B8 (believe_me x))@@ -431,31 +401,26 @@     | (S (S Z), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x))     | (S (S (S _)), S (S (S _))) = believe_me x -public export-truncate : Bits (m+n) -> Bits n+truncate : %static {m : Nat} -> %static {n : Nat} -> Bits (m+n) -> Bits n truncate (MkBits x) = MkBits (zeroUnused (trunc' x)) -public export-bitAt : Fin n -> Bits n+bitAt : %static {n : Nat} -> Fin n -> Bits n bitAt n = intToBits 1 `shiftLeft` intToBits (cast n) -public export-getBit : Fin n -> Bits n -> Bool+getBit : %static {n : Nat} -> Fin n -> Bits n -> Bool getBit n x = (x `and` (bitAt n)) /= intToBits 0 -public export-setBit : Fin n -> Bits n -> Bits n+setBit : %static {n : Nat} -> Fin n -> Bits n -> Bits n setBit n x = x `or` (bitAt n) -public export-unsetBit : Fin n -> Bits n -> Bits n+unsetBit : %static {n : Nat} -> Fin n -> Bits n -> Bits n unsetBit n x = x `and` complement (bitAt n) -bitsToStr : Bits n -> String+bitsToStr : %static {n : Nat} -> Bits n -> String bitsToStr x = pack (helper last x)     where       %assert_total-      helper : Fin (S n) -> Bits n -> List Char+      helper : %static {n : Nat} -> Fin (S n) -> Bits n -> List Char       helper FZ _ = []       helper (FS x) b = (if getBit x b then '1' else '0') :: helper (weaken x) b
+ libs/base/Data/List/Views.idr view
@@ -0,0 +1,229 @@+module Data.List.Views++import Data.List+import Data.Nat.Views++lengthSuc : (xs : List a) -> (y : a) -> (ys : List a) ->+            length (xs ++ (y :: ys)) = S (length (xs ++ ys))+lengthSuc [] _ _ = Refl+lengthSuc (x :: xs) y ys = cong (lengthSuc xs y ys)++lengthLT : (xs : List a) -> (ys : List a) -> +           LTE (length xs) (length (ys ++ xs))+lengthLT xs [] = lteRefl+lengthLT xs (x :: ys) = lteSuccRight (lengthLT _ _)++smallerLeft : (ys : List a) -> (y : a) -> (zs : List a) -> +              LTE (S (S (length ys))) (S (length (ys ++ (y :: zs))))+smallerLeft [] y zs = LTESucc (LTESucc LTEZero)+smallerLeft (z :: ys) y zs = LTESucc (smallerLeft ys _ _)++smallerRight : (ys : List a) -> (zs : List a) -> +               LTE (S (S (length zs))) (S (length (ys ++ (y :: zs))))+smallerRight {y} ys zs = rewrite lengthSuc ys y zs in +                                 (LTESucc (LTESucc (lengthLT _ _)))++||| View for splitting a list in half, non-recursively+public export+data Split : List a -> Type where+     SplitNil : Split []+     SplitOne : Split [x]+     SplitPair : {x, y : a} -> {xs, ys : List a} -> -- Explicit, don't erae+                 Split (x :: xs ++ y :: ys)++splitHelp : (head : a) ->+            (xs : List a) -> +            (counter : List a) -> Split (head :: xs)+splitHelp head [] counter = SplitOne+splitHelp head (x :: xs) [] = SplitPair {xs = []} {ys = xs}+splitHelp head (x :: xs) [y] = SplitPair {xs = []} {ys = xs}+splitHelp head (x :: xs) (_ :: _ :: ys) +    = case splitHelp head xs ys of+           SplitOne => SplitPair {xs = []} {ys = []}+           SplitPair {xs} {ys} => SplitPair {xs = (x :: xs)} {ys = ys}++||| Covering function for the `Split` view+||| Constructs the view in linear time+export+split : (xs : List a) -> Split xs+split [] = SplitNil+split (x :: xs) = splitHelp x xs xs++||| View for splitting a list in half, recursively+|||+||| This allows us to define recursive functions which repeatedly split lists+||| in half, with base cases for the empty and singleton lists.+public export+data SplitRec : List a -> Type where+     SplitRecNil : SplitRec []+     SplitRecOne : {x : a} -> SplitRec [x]+     SplitRecPair : {lefts, rights : List a} -> -- Explicit, don't erase+                    (lrec : Lazy (SplitRec lefts)) -> +                    (rrec : Lazy (SplitRec rights)) -> SplitRec (lefts ++ rights)++total+splitRecFix : (xs : List a) -> ((ys : List a) -> smaller ys xs -> SplitRec ys) -> +              SplitRec xs+splitRecFix xs srec with (split xs)+  splitRecFix [] srec | SplitNil = SplitRecNil+  splitRecFix [x] srec | SplitOne = SplitRecOne+  splitRecFix (x :: (ys ++ (y :: zs))) srec | SplitPair +      = let left = srec (x :: ys) (smallerLeft ys y zs)+            right = srec (y :: zs) (smallerRight ys zs) in+            SplitRecPair left right++||| Covering function for the `SplitRec` view+||| Constructs the view in O(n lg n)+export total+splitRec : (xs : List a) -> SplitRec xs+splitRec xs = accInd splitRecFix xs (smallerAcc xs)++||| View for traversing a list backwards+public export+data SnocList : List a -> Type where+     Empty : SnocList []+     Snoc : {x : a} -> {xs : List a} -> -- Explicit, so don't erase+            (rec : SnocList xs) -> SnocList (xs ++ [x])++snocListHelp : SnocList xs -> (ys : List a) -> SnocList (xs ++ ys)+snocListHelp {xs} x [] = rewrite appendNilRightNeutral xs in x+snocListHelp {xs} x (y :: ys) +   = rewrite appendAssociative xs [y] ys in snocListHelp (Snoc x) ys++||| Covering function for the `SnocList` view+||| Constructs the view in linear time+export+snocList : (xs : List a) -> SnocList xs+snocList xs = snocListHelp Empty xs++||| View for recursively filtering a list by a predicate, applied to the+||| first item in each recursively filtered list+public export+data Filtered : (a -> a -> Bool) -> List a -> Type where+     FNil : Filtered p []+     FRec : (lrec : Lazy (Filtered p (filter (\y => p y x) xs))) -> +            (rrec : Lazy (Filtered p (filter (\y => not (p y x)) xs))) ->+            Filtered p (x :: xs)++filteredLOK : (p : a -> a -> Bool) -> (x : a) -> (xs : List a) -> smaller (filter (\y => p y x) xs) (x :: xs)+filteredLOK p x xs = LTESucc (filterSmaller xs)++filteredROK : (p : a -> a -> Bool) -> (x : a) -> (xs : List a) -> smaller (filter (\y => not (p y x)) xs) (x :: xs)+filteredROK p x xs = LTESucc (filterSmaller xs)++||| Covering function for the `Filtered` view+||| Constructs the view in O(n lg n)+export+filtered : (p : a -> a -> Bool) -> (xs : List a) -> Filtered p xs+filtered p inp with (smallerAcc inp)+  filtered p [] | with_pat = FNil+  filtered p (x :: xs) | (Access xsrec) +      =  FRec (filtered p (filter (\y => p y x) xs) | xsrec _ (filteredLOK p x xs))+              (filtered p (filter (\y => not (p y x)) xs) | xsrec _ (filteredROK p x xs))++lenImpossible : (n = Z) -> (n = ((S k) + right)) -> Void+lenImpossible {n = Z} _ Refl impossible+lenImpossible {n = (S _)} Refl _ impossible++total+lsplit : (xs : List a) ->+         (n : Nat) -> (n = length xs) ->+         (left, right : Nat) -> (n = left + right) ->+         (ls : List a ** rs : List a ** +               (length ls = left, length rs = right, xs = ls ++ rs))+lsplit xs n prf Z right prf1 = ([] ** xs ** (Refl, rewrite sym prf in prf1, Refl))+lsplit [] n prf (S k) right prf1 = void $ lenImpossible prf prf1+lsplit (x :: xs) (S k) prf (S l) right prf1 +     = let (lsrec' ** rsrec' ** (lprf, rprf, recprf)) +                = lsplit xs k (succInjective _ _ prf) l right (succInjective _ _ prf1) in+           (x :: lsrec' ** rsrec' ** (eqSucc _ _ lprf, rprf, rewrite recprf in Refl))+lsplit (_ :: _) Z Refl (S _) _ _ impossible++||| Proof that two numbers differ by at most one+public export+data Balanced : Nat -> Nat -> Type where+     BalancedZ : Balanced Z Z+     BalancedL : Balanced (S Z) Z+     BalancedRec : Balanced n m -> Balanced (S n) (S m)++||| View of a list split into two halves+|||+||| The lengths of the lists are guaranteed to differ by at most one+public export+data SplitBalanced : List a -> Type where+     MkSplitBal : {xs, ys : List a} ->+                  Balanced (length xs) (length ys) -> SplitBalanced (xs ++ ys)++mkBalancedL : n = S x -> m = x -> Balanced n m+mkBalancedL {m = Z} Refl Refl = BalancedL+mkBalancedL {m = (S k)} Refl Refl = BalancedRec (mkBalancedL Refl Refl)++mkBalanced : n = x -> m = x -> Balanced n m+mkBalanced {n = Z} Refl Refl = BalancedZ+mkBalanced {n = (S _)} {m = Z} Refl Refl impossible+mkBalanced {n = (S k)} {m = (S k)} Refl Refl = BalancedRec (mkBalanced Refl Refl)++splitBalancedLen : (xs : List a) -> (n : Nat) -> (n = length xs) -> SplitBalanced xs+splitBalancedLen xs n prf with (half n)+  splitBalancedLen xs (S (x + x)) prf | HalfOdd +      = let (xs' ** ys' ** (lprf, rprf, apprf)) =+              lsplit xs (S (x + x)) prf (S x) x Refl in+              rewrite apprf in (MkSplitBal (mkBalancedL lprf rprf))+  splitBalancedLen xs (x + x) prf | HalfEven +      = let (xs' ** ys' ** (lprf, rprf, apprf)) =+              lsplit xs (x + x) prf x x Refl in+              rewrite apprf in (MkSplitBal (mkBalanced lprf rprf))++||| Covering function for the `SplitBalanced`+|||+||| Constructs the view in linear time+export+splitBalanced : (xs : List a) -> SplitBalanced xs+splitBalanced xs = splitBalancedLen xs (length xs) Refl+  +||| The `VList` view allows us to recurse on the middle of a list,+||| inspecting the front and back elements simultaneously.+public export+data VList : List a -> Type where+     VNil : VList []+     VOne : VList [x]+     VCons : {x : a} -> {y : a} -> {xs : List a} -> +             (rec : VList xs) -> VList (x :: xs ++ [y])++total+balRec : (zs, xs : List a) ->+         Balanced (S (length zs)) (S (length xs)) -> +         Balanced (length zs) (length xs)+balRec zs xs (BalancedRec x) = x++lengthSnoc : (x : _) -> (xs : List a) -> length (xs ++ [x]) = S (length xs) +lengthSnoc x [] = Refl+lengthSnoc x (_ :: xs) = cong (lengthSnoc x xs)++Uninhabited (Balanced Z (S k)) where+    uninhabited BalancedZ impossible+    uninhabited BalancedL impossible+    uninhabited (BalancedRec _) impossible++toVList : (xs : List a) -> SnocList ys -> +          Balanced (length xs) (length ys) -> VList (xs ++ ys)+toVList [] Empty y = VNil+toVList [x] Empty BalancedL = VOne+toVList (z :: zs) (Snoc {xs} {x} srec) prf+    = rewrite appendAssociative zs xs [x] in+              VCons (toVList zs srec (balRec zs xs +                    (rewrite sym $ lengthSnoc x xs in prf)))+toVList [] (Snoc {xs} {x} _) prf +     = let prf' : Balanced Z (S (length xs)) = rewrite sym $ lengthSnoc x xs in prf in+           absurd prf'+      +||| Covering function for `VList`+||| Constructs the view in linear time.+export+vList : (xs : List a) -> VList xs+vList xs with (splitBalanced xs)+  vList (ys ++ zs) | (MkSplitBal prf) +        = toVList ys (snocList zs) prf+++
+ libs/base/Data/Nat/Views.idr view
@@ -0,0 +1,38 @@+module Data.Nat.Views++||| View for dividing a Nat in half+public export+data Half : Nat -> Type where+     HalfOdd : {n : Nat} -> Half (S (n + n))+     HalfEven : {n : Nat} -> Half (n + n)++||| View for dividing a Nat in half, recursively+public export+data HalfRec : Nat -> Type where+     HalfRecZ : HalfRec Z+     HalfRecEven : {n : Nat} -> (rec : Lazy (HalfRec n)) -> HalfRec (n + n)+     HalfRecOdd : {n : Nat} -> (rec : Lazy (HalfRec n)) -> HalfRec (S (n + n))++||| Covering function for the `Half` view+export+half : (n : Nat) -> Half n+half Z = HalfEven {n=0}+half (S k) with (half k)+  half (S (S (n + n))) | HalfOdd = rewrite plusSuccRightSucc (S n) n in+                                           HalfEven {n=S n}+  half (S (n + n)) | HalfEven = HalfOdd++halfRecFix : (n : Nat) -> ((m : Nat) -> LT m n -> HalfRec m) -> HalfRec n+halfRecFix Z hrec = HalfRecZ+halfRecFix (S k) hrec with (half k)+  halfRecFix (S (S (n + n))) hrec | HalfOdd +       = rewrite plusSuccRightSucc (S n) n in +                 HalfRecEven (hrec (S n) (LTESucc (LTESucc (lteAddRight _))))+  halfRecFix (S (n + n)) hrec | HalfEven +       = HalfRecOdd (hrec n (LTESucc (lteAddRight _)))++||| Covering function for the `HalfRec` view+export+halfRec : (n : Nat) -> HalfRec n+halfRec n = accInd halfRecFix n (ltAccessible n)+
libs/base/Data/String.idr view
@@ -23,10 +23,12 @@   where     parsePosTrimmed s with (strM s)       parsePosTrimmed ""             | StrNil         = Nothing+      parsePosTrimmed (strCons '+' xs) | (StrCons '+' xs) = +        map fromInteger (parseNumWithoutSign (unpack xs) 0)       parsePosTrimmed (strCons x xs) | (StrCons x xs) = -        if (x == '+') -          then map fromInteger (parseNumWithoutSign (unpack xs) 0)-          else map fromInteger (parseNumWithoutSign (unpack xs)  (cast (ord x - ord '0')))+        if (x >= '0' && x <= '9') +        then  map fromInteger (parseNumWithoutSign (unpack xs)  (cast (ord x - ord '0')))+        else Nothing   ||| Convert a number string to a Num.
+ libs/base/Data/String/Views.idr view
@@ -0,0 +1,13 @@+module Data.String.Views++||| View for traversing a String one character at a time+data StrList : String -> Type where+     SNil  : StrList ""+     SCons : (x : Char) -> (rec : StrList xs) -> StrList (strCons x xs)++||| Covering function for `StrList`+strList : (x : String) -> StrList x+strList x with (strM x)+  strList "" | StrNil = SNil+  strList (strCons y xs) | (StrCons y xs) +          = assert_total $ SCons y (strList xs)
libs/base/Data/Vect.idr view
@@ -194,6 +194,21 @@ replicate Z     x = [] replicate (S k) x = x :: replicate k x +||| Merge two ordered vectors+mergeBy : (a -> a -> Ordering) -> Vect n a -> Vect m a -> Vect (n + m) a+mergeBy order [] [] = []+mergeBy order [] (x :: xs) = x :: xs+mergeBy {n = S k} order (x :: xs) [] = rewrite plusZeroRightNeutral (S k) in  +                                               x :: xs+mergeBy {n = S k} {m = S k'} order (x :: xs) (y :: ys) +     = case order x y of+            LT => x :: mergeBy order xs (y :: ys)+            _  => rewrite sym (plusSuccRightSucc k k') in +                             y :: mergeBy order (x :: xs) ys++merge : Ord a => Vect n a -> Vect m a -> Vect (n + m) a+merge = mergeBy compare+ -------------------------------------------------------------------------------- -- Zips and unzips --------------------------------------------------------------------------------
+ libs/base/Data/Vect/Views.idr view
@@ -0,0 +1,83 @@+module Data.Vect.Views++import Data.Vect++||| View for traversing a vector backwards+public export+data SnocVect : Vect n a -> Type where+     Empty : SnocVect []+     Snoc : {x : a} -> {xs : Vect n a} ->+            (rec : SnocVect xs) -> SnocVect (xs ++ [x])++snocVectHelp : {xs : Vect n a} ->+               SnocVect xs -> (ys : Vect m a) -> SnocVect (xs ++ ys)+snocVectHelp {xs} x [] = rewrite vectNilRightNeutral xs in x+snocVectHelp {xs} x (y :: ys) +    = rewrite vectAppendAssociative xs [y] ys in +              snocVectHelp (Snoc x {x=y}) ys+                             +||| Covering function for the `SnocVect` view+||| Constructs the view in linear time+export+snocVect : (xs : Vect n a) -> SnocVect xs+snocVect xs = snocVectHelp Empty xs++||| View for splitting a vector in half, non-recursively+public export+data Split : Vect n a -> Type where+     SplitNil : Split []+     SplitOne : Split [x]+     SplitPair : {x, y : a} -> {xs : Vect n a} -> {ys : Vect m a} ->+                 Split (x :: xs ++ y :: ys)++splitHelp : (head : a) ->+            (xs : Vect n a) -> +            (counter : Vect m a) -> Split (head :: xs)+splitHelp head [] counter = SplitOne+splitHelp head (x :: xs) [] = SplitPair {xs = []} {ys = xs}+splitHelp head (x :: xs) [y] = SplitPair {xs = []} {ys = xs}+splitHelp head (x :: xs) (_ :: _ :: ys) +     = case splitHelp head xs ys of+            SplitOne => SplitPair {xs = []} {ys = []}+            SplitPair {xs} {ys} => SplitPair {xs = x :: xs} {ys}++||| Covering function for the `Split` view+||| Constructs the view in linear time+export+split : (xs : Vect n a) -> Split xs+split [] = SplitNil+split (x :: xs) = splitHelp x xs xs++||| View for splitting a vector in half, recursively+|||+||| This allows us to define recursive functions which repeatedly split vectors+||| in half, with base cases for the empty and singleton lists.+public export+data SplitRec : Vect n a -> Type where+     SplitRecNil : SplitRec []+     SplitRecOne : {x : a} -> SplitRec [x]+     SplitRecPair : {xs : Vect n a} -> +                    {ys : Vect m a} -> -- Explicit, don't erase+                    (lrec : Lazy (SplitRec xs)) -> +                    (rrec : Lazy (SplitRec ys)) -> SplitRec (xs ++ ys)++smallerPlus : LTE (S (S m)) (S (plus m (S k)))+smallerPlus {m} {k} = rewrite sym (plusSuccRightSucc m k) in +                              (LTESucc (LTESucc (lteAddRight _)))++smallerPlus' : LTE (S (S k)) (S (plus m (S k)))+smallerPlus' {m} {k} = rewrite sym (plusSuccRightSucc m k) in +                               LTESucc (LTESucc (rewrite plusCommutative m k in (lteAddRight _)))++||| Covering function for the `SplitRec` view+||| Constructs the view in O(n lg n)+export+splitRec : (xs : Vect n a) -> SplitRec xs+splitRec {n} input with (ltAccessible n)+  splitRec input | acc with (split input)+    splitRec [] | acc | SplitNil = SplitRecNil+    splitRec [x] | acc | SplitOne = SplitRecOne+    splitRec (x :: (xs ++ (y :: ys))) | (Access rec) | SplitPair +        = let left = splitRec (x :: xs) | rec _ smallerPlus+              right = splitRec (y :: ys) | rec _ smallerPlus' in+              SplitRecPair left right
libs/base/base.ipkg view
@@ -13,11 +13,13 @@            Data.Morphisms,           Data.Bits, Data.Mod2,-          Data.Fin, Data.Vect,+          Data.Fin, Data.Vect, Data.Vect.Views,           Data.HVect, Data.Vect.Quantifiers,           Data.Complex,-          Data.Erased, Data.List,+          Data.Erased, Data.List, Data.List.Views,           Data.List.Quantifiers,+          Data.Nat.Views,+          Data.String.Views,           Data.So, Data.String,            Control.Isomorphism,
libs/contrib/CFFI/Memory.idr view
@@ -19,6 +19,10 @@ toPtr (CPt p 0) = p toPtr (CPt p o) = prim__ptrOffset p o +||| Import of calloc from the C standard library.+calloc : Int -> Int -> IO Ptr+calloc nmemb size = foreign FFI_C "calloc" (Int -> Int -> IO Ptr) nmemb size+ ||| Import of malloc from the C standard library. malloc : Int -> IO Ptr malloc size = foreign FFI_C "malloc" (Int -> IO Ptr) size@@ -29,7 +33,7 @@  ||| Allocate enough memory to hold an instance of a C typr alloc : Composite -> IO CPtr-alloc t = return $ CPt !(malloc (sizeOf t)) 0+alloc t = return $ CPt !(calloc 1 (sizeOf t)) 0  ||| Free memory allocated with alloc free : CPtr -> IO ()
libs/contrib/CFFI/Types.idr view
@@ -70,9 +70,9 @@     alignOfCT I8 = 1     alignOfCT I16 = 2     alignOfCT I32 = 4-    alignOfCT I64 = prim__sizeofPtr+    alignOfCT I64 = 8     alignOfCT FLOAT = 4-    alignOfCT DOUBLE = prim__sizeofPtr+    alignOfCT DOUBLE = 8     alignOfCT PTR = prim__sizeofPtr      ||| Alignment requirement of the type
− libs/contrib/Control/WellFounded.idr 
@@ -1,83 +0,0 @@-||| Well-founded recursion.-|||-||| This is to let us implement some functions that don't have trivial-||| recursion patterns over datatypes, but instead are using some-||| other metric of size.-module Control.WellFounded--%default total-%access public export--||| Accessibility: some element `x` is accessible if all `y` such that-||| `rel y x` are themselves accessible.-|||-||| @ a the type of elements-||| @ rel a relation on a-||| @ x the acessible element-data Accessible : (rel : a -> a -> Type) -> (x : a) -> Type where-  ||| Accessibility-  |||-  ||| @ x the accessible element-  ||| @ acc' a demonstration that all smaller elements are also accessible-  Access : (acc' : (y : a) -> rel y x -> Accessible rel y) ->-           Accessible rel x--||| A relation `rel` on `a` is well-founded if all elements of `a` are-||| acessible.-|||-||| @ rel the well-founded relation-interface WellFounded (rel : a -> a -> Type) where-  wellFounded : (x : _) -> Accessible rel x---||| A recursor over accessibility.-|||-||| This allows us to recurse over the subset of some type that is-||| accessible according to some relation.-|||-||| @ rel the well-founded relation-||| @ step how to take steps on reducing arguments-||| @ z the starting point-accRec : {rel : a -> a -> Type} ->-         (step : (x : a) -> ((y : a) -> rel y x -> b) -> b) ->-         (z : a) -> Accessible rel z -> b-accRec step z (Access f) =-  step z $ \y, lt => accRec step y (f y lt)--||| An induction principle for accessibility.-|||-||| This allows us to recurse over the subset of some type that is-||| accessible according to some relation, producing a dependent type-||| as a result.-|||-||| @ rel the well-founded relation-||| @ step how to take steps on reducing arguments-||| @ z the starting point-accInd : {rel : a -> a -> Type} -> {P : a -> Type} ->-         (step : (x : a) -> ((y : a) -> rel y x -> P y) -> P x) ->-         (z : a) -> Accessible rel z -> P z-accInd step z (Access f) =-  step z $ \y, lt => accInd step y (f y lt)---||| Use well-foundedness of a relation to write terminating operations.-|||-||| @ rel a well-founded relation-wfRec : WellFounded rel =>-        (step : (x : a) -> ((y : a) -> rel y x -> b) -> b) ->-        a -> b-wfRec {rel} step x = accRec step x (wellFounded {rel} x)---||| Use well-foundedness of a relation to write proofs-|||-||| @ rel a well-founded relation-||| @ P the motive for the induction-||| @ step the induction step: take an element and its accessibility,-|||        and give back a demonstration of P for that element,-|||        potentially using accessibility-wfInd : WellFounded rel => {P : a -> Type} ->-        (step : (x : a) -> ((y : a) -> rel y x -> P y) -> P x) ->-        (x : a) -> P x-wfInd {rel} step x = accInd step x (wellFounded {rel} x)-
libs/contrib/Data/Nat/DivMod/IteratedSubtraction.idr view
@@ -5,8 +5,6 @@ import Data.Fin import Data.So -import Control.WellFounded- %default total %access public export
libs/contrib/Network/Socket.idr view
@@ -1,16 +1,18 @@--- Time to do this properly.--- Low-Level C Sockets bindings for Idris. Used by higher-level, cleverer things.--- (C) SimonJF, MIT Licensed, 2014-module IdrisNet.Socket+||| Time to do this properly.+||| Low-Level C Sockets bindings for Idris. Used by higher-level, cleverer things.+||| (C) SimonJF, MIT Licensed, 2014+module Network.Socket  %include C "idris_net.h" %include C "sys/types.h" %include C "sys/socket.h" %include C "netdb.h" -public export ByteLength : Type+public export+ByteLength : Type ByteLength = Int +export interface ToCode a where   toCode : a -> Int @@ -18,6 +20,7 @@ ||| ||| The ones that people might actually use. We're not going to need US ||| Government proprietary ones.+public export data SocketFamily =   ||| Unspecified   AF_UNSPEC |@@ -26,11 +29,13 @@   |||  IP / UDP etc. IPv6   AF_INET6 +export implementation Show SocketFamily where   show AF_UNSPEC = "AF_UNSPEC"   show AF_INET   = "AF_INET"   show AF_INET6  = "AF_INET6" +export implementation ToCode SocketFamily where   toCode AF_UNSPEC = 0   toCode AF_INET   = 2@@ -40,6 +45,7 @@ getSocketFamily i = Prelude.List.lookup i [(0, AF_UNSPEC), (2, AF_INET), (10, AF_INET6)]  ||| Socket Types.+public export data SocketType =   ||| Not a socket, used in certain operations   NotASocket |@@ -50,62 +56,74 @@   ||| Raw sockets   RawSocket +export implementation Show SocketType where   show NotASocket = "Not a socket"   show Stream     = "Stream"   show Datagram   = "Datagram"   show RawSocket  = "Raw" +export implementation ToCode SocketType where   toCode NotASocket = 0   toCode Stream     = 1   toCode Datagram   = 2   toCode RawSocket  = 3 - data RecvStructPtr = RSPtr Ptr data RecvfromStructPtr = RFPtr Ptr -export data BufPtr = BPtr Ptr-export data SockaddrPtr = SAPtr Ptr+export+data BufPtr = BPtr Ptr+export+data SockaddrPtr = SAPtr Ptr  ||| Protocol Number. ||| ||| Generally good enough to just set it to 0.+public export ProtocolNumber : Type ProtocolNumber = Int  ||| SocketError: Error thrown by a socket operation+public export SocketError : Type SocketError = Int  ||| SocketDescriptor: Native C Socket Descriptor+public export SocketDescriptor : Type SocketDescriptor = Int +public export data SocketAddress = IPv4Addr Int Int Int Int                    | IPv6Addr -- Not implemented (yet)                    | Hostname String                    | InvalidAddress -- Used when there's a parse error +export implementation Show SocketAddress where   show (IPv4Addr i1 i2 i3 i4) = concat $ Prelude.List.intersperse "." (map show [i1, i2, i3, i4])   show IPv6Addr = "NOT IMPLEMENTED YET"   show (Hostname host) = host   show InvalidAddress = "Invalid" +public export Port : Type Port = Int  ||| Backlog used within listen() call -- number of incoming calls+public export BACKLOG : Int BACKLOG = 20  -- FIXME: This *must* be pulled in from C-EAGAIN : Int +public export+EAGAIN : Int EAGAIN = 11  -- TODO: Expand to non-string payloads+export record UDPRecvData where   constructor MkUDPRecvData   remote_addr : SocketAddress@@ -113,6 +131,7 @@   recv_data : String   data_len : Int +export record UDPAddrInfo where   constructor MkUDPAddrInfo   remote_addr : SocketAddress@@ -135,15 +154,17 @@ sock_alloc bl = map BPtr $ foreign FFI_C "idrnet_malloc" (Int -> IO Ptr) bl  ||| The metadata about a socket+export record Socket where   constructor MkSocket   descriptor : SocketDescriptor   family : SocketFamily   socketType : SocketType-  protocalNumber : ProtocolNumber+  protocolNumber : ProtocolNumber  ||| Creates a UNIX socket with the given family, socket type and protocol ||| number. Returns either a socket or an error.+export socket : SocketFamily -> SocketType -> ProtocolNumber -> IO (Either SocketError Socket) socket sf st pn = do   socket_res <- foreign FFI_C "socket" (Int -> Int -> Int -> IO Int) (toCode sf) (toCode st) pn@@ -153,6 +174,7 @@     return $ Right (MkSocket socket_res sf st pn)  ||| Close a socket+export close : Socket -> IO () close sock = foreign FFI_C "close" (Int -> IO ()) (descriptor sock) @@ -163,11 +185,12 @@  ||| Binds a socket to the given socket address and port. ||| Returns 0 on success, an error code otherwise.+export bind : Socket -> (Maybe SocketAddress) -> Port -> IO Int bind sock addr port = do-  bind_res <- foreign FFI_C "idrnet_bind" +  bind_res <- foreign FFI_C "idrnet_bind"                   (Int -> Int -> Int -> String -> Int -> IO Int)-                  (descriptor sock) (toCode $ family sock) +                  (descriptor sock) (toCode $ family sock)                   (toCode $ socketType sock) (saString addr) port   if bind_res == (-1) then -- error     getErrno@@ -175,6 +198,7 @@  ||| Connects to a given address and port. ||| Returns 0 on success, and an error number on error.+export connect : Socket -> SocketAddress -> Port -> IO Int connect sock addr port = do   conn_res <- foreign FFI_C "idrnet_connect"@@ -185,6 +209,7 @@   else return 0  ||| Listens on a bound socket.+export listen : Socket -> IO Int listen sock = do   listen_res <- foreign FFI_C "listen" (Int -> Int -> IO Int)@@ -205,7 +230,6 @@         splitted : List Int         splitted = map toInt (Prelude.Strings.split (\c => c == '.') str) - ||| Retrieves a socket address from a sockaddr pointer getSockAddr : SockaddrPtr -> IO SocketAddress getSockAddr (SAPtr ptr) = do@@ -219,6 +243,7 @@     Just AF_INET6 => return IPv6Addr     Just AF_UNSPEC => return InvalidAddress) +export accept : Socket -> IO (Either SocketError (Socket, SocketAddress)) accept sock = do   -- We need a pointer to a sockaddr structure. This is then passed into@@ -233,6 +258,7 @@     sockaddr_free (SAPtr sockaddr_ptr)     return $ Right ((MkSocket accept_res fam ty p_num), sockaddr) +export send : Socket -> String -> IO (Either SocketError ByteLength) send sock dat = do   send_res <- foreign FFI_C "idrnet_send" (Int -> String -> IO Int) (descriptor sock) dat@@ -241,7 +267,6 @@   else     return $ Right send_res - freeRecvStruct : RecvStructPtr -> IO () freeRecvStruct (RSPtr p) = foreign FFI_C "idrnet_free_recv_struct" (Ptr -> IO ()) p @@ -258,7 +283,7 @@     errno <- getErrno     freeRecvStruct (RSPtr recv_struct_ptr)     return $ Left errno-  else +  else     if recv_res == 0 then do        freeRecvStruct (RSPtr recv_struct_ptr)        return $ Left 0@@ -267,7 +292,6 @@        freeRecvStruct (RSPtr recv_struct_ptr)        return $ Right (payload, recv_res) - ||| Sends the data in a given memory location sendBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength) sendBuf sock (BPtr ptr) len = do@@ -287,28 +311,26 @@  sendTo : Socket -> SocketAddress -> Port -> String -> IO (Either SocketError ByteLength) sendTo sock addr p dat = do-  sendto_res <- foreign FFI_C "idrnet_sendto" -                   (Int -> String -> String -> Int -> Int -> IO Int) +  sendto_res <- foreign FFI_C "idrnet_sendto"+                   (Int -> String -> String -> Int -> Int -> IO Int)                    (descriptor sock) dat (show addr) p (toCode $ family sock)   if sendto_res == (-1) then     map Left getErrno   else     return $ Right sendto_res - sendToBuf : Socket -> SocketAddress -> Port -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength) sendToBuf sock addr p (BPtr dat) len = do-  sendto_res <- foreign FFI_C "idrnet_sendto_buf" -                   (Int -> Ptr -> Int -> String -> Int -> Int -> IO Int) +  sendto_res <- foreign FFI_C "idrnet_sendto_buf"+                   (Int -> Ptr -> Int -> String -> Int -> Int -> IO Int)                    (descriptor sock) dat len (show addr) p (toCode $ family sock)   if sendto_res == (-1) then     map Left getErrno   else     return $ Right sendto_res - foreignGetRecvfromPayload : RecvfromStructPtr -> IO String-foreignGetRecvfromPayload (RFPtr p) +foreignGetRecvfromPayload (RFPtr p)    = foreign FFI_C "idrnet_get_recvfrom_payload" (Ptr -> IO String) p  foreignGetRecvfromAddr : RecvfromStructPtr -> IO SocketAddress@@ -316,7 +338,6 @@   sockaddr_ptr <- map SAPtr $ foreign FFI_C "idrnet_get_recvfrom_sockaddr" (Ptr -> IO Ptr) p   getSockAddr sockaddr_ptr - foreignGetRecvfromPort : RecvfromStructPtr -> IO Port foreignGetRecvfromPort (RFPtr p) = do   sockaddr_ptr <- foreign FFI_C "idrnet_get_recvfrom_sockaddr" (Ptr -> IO Ptr) p@@ -325,7 +346,7 @@  recvFrom : Socket -> ByteLength -> IO (Either SocketError (UDPAddrInfo, String, ByteLength)) recvFrom sock bl = do-  recv_ptr <- foreign FFI_C "idrnet_recvfrom" (Int -> Int -> IO Ptr) +  recv_ptr <- foreign FFI_C "idrnet_recvfrom" (Int -> Int -> IO Ptr)                 (descriptor sock) bl   let recv_ptr' = RFPtr recv_ptr   if !(nullPtr recv_ptr) then@@ -342,7 +363,6 @@       freeRecvfromStruct recv_ptr'       return $ Right (MkUDPAddrInfo addr port, payload, result) - recvFromBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError (UDPAddrInfo, ByteLength)) recvFromBuf sock (BPtr ptr) bl = do   recv_ptr <- foreign FFI_C "idrnet_recvfrom_buf" (Int -> Ptr -> Int -> IO Ptr) (descriptor sock) ptr bl@@ -359,5 +379,3 @@       addr <- foreignGetRecvfromAddr recv_ptr'       freeRecvfromStruct recv_ptr'       return $ Right (MkUDPAddrInfo addr port, result + 1)--
libs/contrib/contrib.ipkg view
@@ -8,7 +8,6 @@           Control.Algebra.NumericInstances,           Control.Isomorphism.Primitives,           Control.Partial,-          Control.WellFounded,            Classes.Verified,
libs/effects/Effects.idr view
@@ -3,6 +3,7 @@ import Language.Reflection import public Effect.Default import Data.Vect+import public Data.List  --- Effectful computations are described as algebraic data types that --- explain how an effect is interpreted in some underlying context.@@ -89,7 +90,7 @@ data SubElem : a -> List a -> Type where   Z : SubElem a (a :: as)   S : SubElem a as -> SubElem a (b :: as)-  + public export data SubList : List a -> List a -> Type where   SubNil : SubList [] xs@@ -142,13 +143,6 @@     Nil  : Env m Nil     (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs) -namespace EffElem-  public export-  data EffElem : Effect -> Type ->-                 List EFFECT -> Type where-    Here : EffElem x a (MkEff a x :: xs)-    There : EffElem x a xs -> EffElem x a (y :: xs)-     total envElem : SubElem x xs -> Env m xs -> Env m [x] envElem Z (x :: xs) = [x] envElem (S k) (x :: xs) = envElem k xs@@ -158,7 +152,7 @@ dropEnv [] SubNil = [] dropEnv [] (InList idx rest) = absurd idx dropEnv (y::ys) SubNil = []-dropEnv e@(y::ys) (InList idx rest) = +dropEnv e@(y::ys) (InList idx rest) =   let [x] = envElem idx e   in x :: dropEnv e rest @@ -191,13 +185,13 @@ rebuildEnv [] SubNil env = env rebuildEnv (x :: xs) SubNil env = env rebuildEnv [] (InList w s) env = env-rebuildEnv (x :: xs) (InList idx rest) env = replaceEnvAt x idx (rebuildEnv xs rest env) +rebuildEnv (x :: xs) (InList idx rest) env = replaceEnvAt x idx (rebuildEnv xs rest env)  -- -------------------------------------------------- [ The Effect EDSL itself ]  public export total updateResTy : (val : t) ->-              (xs : List EFFECT) -> EffElem e a xs -> e t a b ->+              (xs : List EFFECT) -> with List Elem (MkEff a e) xs -> e t a b ->               List EFFECT updateResTy {b} val (MkEff a e :: xs) Here n = (MkEff (b val) e) :: xs updateResTy     val (x :: xs)    (There p) n = x :: updateResTy val xs p n@@ -238,7 +232,7 @@      Value    : (val : a) -> EffM m a (xs val) xs      EBind    : EffM m a xs xs' ->                 ((val : a) -> EffM m b (xs' val) xs'') -> EffM m b xs xs''-     CallP    : (prf : EffElem e a xs) ->+     CallP    : (prf : with List Elem (MkEff a e) xs) ->                 (eff : e t a b) ->                 EffM m t xs (\v => updateResTy v xs prf eff) @@ -327,7 +321,7 @@ (<*>) prog v = do fn <- prog                   arg <- v                   return (fn arg)-                  + (<$>) : (a -> b) ->         EffM m a xs (\v => xs) -> EffM m b xs (\v => xs) (<$>) f v = pure f <*> v@@ -336,7 +330,7 @@        EffM m b xs (\v => xs) -> EffM m b xs (\v => xs) a *> b = do a             b-     + new : Handler e' m => (e : EFFECT) -> resTy ->       {auto prf : e = MkEff resTy e'} ->       EffM m t (e :: es) (\v => e :: es) ->@@ -346,7 +340,7 @@ -- ---------------------------------------------------------- [ an interpreter ]  private-execEff : Env m xs -> (p : EffElem e res xs) ->+execEff : Env m xs -> (p : with List Elem (MkEff res e) xs) ->           (eff : e a res resk) ->           ((v : a) -> Env m (updateResTy v xs p eff) -> m t) -> m t execEff (val :: env) Here eff' k@@ -387,7 +381,7 @@ %no_implicit call : {a, b: _} -> {e : Effect} ->        (eff : e t a b) ->-       {auto prf : EffElem e a xs} ->+       {auto prf : with List Elem (MkEff a e) xs} ->       EffM m t xs (\v => updateResTy v xs prf eff) call e {prf} = CallP prf e
libs/prelude/Builtins.idr view
@@ -87,13 +87,19 @@ (~=~) x y = (x = y)  ||| Perform substitution in a term according to some equality.-|||-||| This is used by the `rewrite` tactic and term. replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y replace Refl prf = prf +||| Perform substitution in a term according to some equality.+|||+||| Like `replace`, but with an explicit predicate, and applying the rewrite+||| in the other direction, which puts it in a form usable by the `rewrite`+||| tactic and term.+rewrite__impl : (P : a -> Type) -> x = y -> P y -> P x+rewrite__impl P Refl prf = prf+ ||| Symmetry of propositional equality-sym : {left:a} -> {right:a} -> left = right -> right = left+sym : {left:a} -> {right:b} -> left = right -> right = left sym Refl = Refl  ||| Transitivity of propositional equality
libs/prelude/Decidable/Equality.idr view
@@ -158,9 +158,11 @@ --------------------------------------------------------------------------------  implementation DecEq Int where-    decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq+    decEq x y = case x == y of -- Blocks if x or y not concrete+                     True => Yes primitiveEq +                     False => No primitiveNotEq        where primitiveEq : x = y-             primitiveEq = believe_me (Refl {x})+             primitiveEq = really_believe_me (Refl {x})              postulate primitiveNotEq : x = y -> Void  --------------------------------------------------------------------------------@@ -168,9 +170,11 @@ --------------------------------------------------------------------------------  implementation DecEq Char where-    decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq+    decEq x y = case x == y of -- Blocks if x or y not concrete+                     True => Yes primitiveEq +                     False => No primitiveNotEq        where primitiveEq : x = y-             primitiveEq = believe_me (Refl {x})+             primitiveEq = really_believe_me (Refl {x})              postulate primitiveNotEq : x = y -> Void  --------------------------------------------------------------------------------@@ -178,20 +182,23 @@ --------------------------------------------------------------------------------  implementation DecEq Integer where-    decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq+    decEq x y = case x == y of -- Blocks if x or y not concrete+                     True => Yes primitiveEq +                     False => No primitiveNotEq        where primitiveEq : x = y              primitiveEq = really_believe_me (Refl {x})              postulate primitiveNotEq : x = y -> Void - -------------------------------------------------------------------------------- -- String --------------------------------------------------------------------------------  implementation DecEq String where-    decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq+    decEq x y = case x == y of -- Blocks if x or y not concrete+                     True => Yes primitiveEq +                     False => No primitiveNotEq        where primitiveEq : x = y-             primitiveEq = believe_me (Refl {x})+             primitiveEq = really_believe_me (Refl {x})              postulate primitiveNotEq : x = y -> Void  --------------------------------------------------------------------------------@@ -199,9 +206,11 @@ --------------------------------------------------------------------------------  implementation DecEq Ptr where-    decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq+    decEq x y = case x == y of -- Blocks if x or y not concrete+                     True => Yes primitiveEq +                     False => No primitiveNotEq        where primitiveEq : x = y-             primitiveEq = believe_me (Refl {x})+             primitiveEq = really_believe_me (Refl {x})              postulate primitiveNotEq : x = y -> Void  --------------------------------------------------------------------------------@@ -209,7 +218,9 @@ --------------------------------------------------------------------------------  implementation DecEq ManagedPtr where-    decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq+    decEq x y = case x == y of -- Blocks if x or y not concrete+                     True => Yes primitiveEq +                     False => No primitiveNotEq        where primitiveEq : x = y-             primitiveEq = believe_me (Refl {x})+             primitiveEq = really_believe_me (Refl {x})              postulate primitiveNotEq : x = y -> Void
libs/prelude/Language/Reflection.idr view
@@ -8,6 +8,8 @@ import Prelude.List import Prelude.Nat import Prelude.Traversable+import Prelude.Uninhabited+import Decidable.Equality  %access public export @@ -24,9 +26,27 @@   ||| The line and column of the end of the source span   end : (Int, Int) -%name SourceLocation loc+%name SourceLocation loc, loc' +private+fileLocInj : (FileLoc fn s e = FileLoc fn' s' e') -> (fn = fn', s = s', e = e')+fileLocInj Refl = (Refl, Refl, Refl) +implementation DecEq SourceLocation where+  decEq (FileLoc f s e) (FileLoc f' s' e') with (decEq f f')+    decEq (FileLoc f s e) (FileLoc f s' e')  | Yes Refl with (decEq s s')+      decEq (FileLoc f s e) (FileLoc f s e')  | Yes Refl | Yes Refl with (decEq e e')+        decEq (FileLoc f s e) (FileLoc f s e)  | Yes Refl | Yes Refl | Yes Refl =+            Yes Refl+        decEq (FileLoc f s e) (FileLoc f s e') | Yes Refl | Yes Refl | No contra =+            No $ contra . snd . snd . fileLocInj+      decEq (FileLoc f s e) (FileLoc f s' e') | Yes Refl | No contra =+          No $ contra . fst . snd . fileLocInj+    decEq (FileLoc f s e) (FileLoc f' s' e') | No contra =+        No $ contra . fst . fileLocInj+++ mutual   data TTName =               ||| A user-provided name@@ -52,13 +72,505 @@                    | ElimN TTName                    | InstanceCtorN TTName                    | MetaN TTName TTName+  %name SpecialName sn, sn' +-- Rather  than  implement  one-off  private functions,  we  make  the+-- disjointness of  the constructors available to  all Idris programs,+-- at the cost of a bit of scrolling here. +implementation Uninhabited (UN _ = NS _ _) where+  uninhabited Refl impossible -implicit-userSuppliedName : String -> TTName-userSuppliedName = UN+implementation Uninhabited (UN _ = MN _ _) where+  uninhabited Refl impossible +implementation Uninhabited (UN _ = SN _) where+  uninhabited Refl impossible++implementation Uninhabited (NS _ _ = UN _) where+  uninhabited Refl impossible++implementation Uninhabited (NS _ _ = MN _ _) where+  uninhabited Refl impossible++implementation Uninhabited (NS _ _ = SN _) where+  uninhabited Refl impossible++implementation Uninhabited (MN _ _ = UN _) where+  uninhabited Refl impossible++implementation Uninhabited (MN _ _ = NS _ _) where+  uninhabited Refl impossible++implementation Uninhabited (MN _ _ = SN _) where+  uninhabited Refl impossible++implementation Uninhabited (SN _ = UN _) where+  uninhabited Refl impossible++implementation Uninhabited (SN _ = MN _ _) where+  uninhabited Refl impossible++implementation Uninhabited (SN _ = NS _ _) where+  uninhabited Refl impossible++implementation Uninhabited ((WhereN x n n') = (WithN y z)) where+  uninhabited Refl impossible++implementation Uninhabited ((WhereN x n n') = (InstanceN y xs)) where+  uninhabited Refl impossible++implementation Uninhabited ((WhereN x n n') = (ParentN y z)) where+  uninhabited Refl impossible++implementation Uninhabited ((WhereN x n n') = (MethodN y)) where+  uninhabited Refl impossible++implementation Uninhabited ((WhereN x n n') = (CaseN loc y)) where+  uninhabited Refl impossible++implementation Uninhabited ((WhereN x n n') = (ElimN y)) where+  uninhabited Refl impossible++implementation Uninhabited ((WhereN x n n') = (InstanceCtorN y)) where+  uninhabited Refl impossible++implementation Uninhabited ((WhereN x n n') = (MetaN y z)) where+  uninhabited Refl impossible++implementation Uninhabited ((WithN x n) = (WhereN y n' z)) where+  uninhabited Refl impossible++implementation Uninhabited ((WithN x n) = (InstanceN n' xs)) where+  uninhabited Refl impossible++implementation Uninhabited ((WithN x n) = (ParentN n' y)) where+  uninhabited Refl impossible++implementation Uninhabited ((WithN x n) = (MethodN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((WithN x n) = (CaseN loc n')) where+  uninhabited Refl impossible++implementation Uninhabited ((WithN x n) = (ElimN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((WithN x n) = (InstanceCtorN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((WithN x n) = (MetaN n' y)) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceN n xs) = (WhereN x n' y)) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceN n xs) = (WithN x n')) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceN n xs) = (ParentN n' x)) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceN n xs) = (MethodN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceN n xs) = (CaseN loc n')) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceN n xs) = (ElimN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceN n xs) = (InstanceCtorN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceN n xs) = (MetaN n' x)) where+  uninhabited Refl impossible++implementation Uninhabited ((ParentN n x) = (WhereN y n' z)) where+  uninhabited Refl impossible++implementation Uninhabited ((ParentN n x) = (WithN y n')) where+  uninhabited Refl impossible++implementation Uninhabited ((ParentN n x) = (InstanceN n' xs)) where+  uninhabited Refl impossible++implementation Uninhabited ((ParentN n x) = (MethodN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((ParentN n x) = (CaseN loc n')) where+  uninhabited Refl impossible++implementation Uninhabited ((ParentN n x) = (ElimN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((ParentN n x) = (InstanceCtorN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((ParentN n x) = (MetaN n' y)) where+  uninhabited Refl impossible++implementation Uninhabited ((MethodN n) = (WhereN x n' y)) where+  uninhabited Refl impossible++implementation Uninhabited ((MethodN n) = (WithN x n')) where+  uninhabited Refl impossible++implementation Uninhabited ((MethodN n) = (InstanceN n' xs)) where+  uninhabited Refl impossible++implementation Uninhabited ((MethodN n) = (ParentN n' x)) where+  uninhabited Refl impossible++implementation Uninhabited ((MethodN n) = (CaseN loc n')) where+  uninhabited Refl impossible++implementation Uninhabited ((MethodN n) = (ElimN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((MethodN n) = (InstanceCtorN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((MethodN n) = (MetaN n' x)) where+  uninhabited Refl impossible++implementation Uninhabited ((CaseN loc n) = (WhereN x n' y)) where+  uninhabited Refl impossible++implementation Uninhabited ((CaseN loc n) = (WithN x n')) where+  uninhabited Refl impossible++implementation Uninhabited ((CaseN loc n) = (InstanceN n' xs)) where+  uninhabited Refl impossible++implementation Uninhabited ((CaseN loc n) = (ParentN n' x)) where+  uninhabited Refl impossible++implementation Uninhabited ((CaseN loc n) = (MethodN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((CaseN loc n) = (ElimN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((CaseN loc n) = (InstanceCtorN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((CaseN loc n) = (MetaN n' x)) where+  uninhabited Refl impossible++implementation Uninhabited ((ElimN n) = (WhereN x n' y)) where+  uninhabited Refl impossible++implementation Uninhabited ((ElimN n) = (WithN x n')) where+  uninhabited Refl impossible++implementation Uninhabited ((ElimN n) = (InstanceN n' xs)) where+  uninhabited Refl impossible++implementation Uninhabited ((ElimN n) = (ParentN n' x)) where+  uninhabited Refl impossible++implementation Uninhabited ((ElimN n) = (MethodN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((ElimN n) = (CaseN loc n')) where+  uninhabited Refl impossible++implementation Uninhabited ((ElimN n) = (InstanceCtorN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((ElimN n) = (MetaN n' x)) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceCtorN n) = (WhereN x n' y)) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceCtorN n) = (WithN x n')) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceCtorN n) = (InstanceN n' xs)) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceCtorN n) = (ParentN n' x)) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceCtorN n) = (MethodN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceCtorN n) = (CaseN loc n')) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceCtorN n) = (ElimN n')) where+  uninhabited Refl impossible++implementation Uninhabited ((InstanceCtorN n) = (MetaN n' x)) where+  uninhabited Refl impossible++implementation Uninhabited ((MetaN n n') = (WhereN x y z)) where+  uninhabited Refl impossible++implementation Uninhabited ((MetaN n n') = (WithN x y)) where+  uninhabited Refl impossible++implementation Uninhabited ((MetaN n n') = (InstanceN x xs)) where+  uninhabited Refl impossible++implementation Uninhabited ((MetaN n n') = (ParentN x y)) where+  uninhabited Refl impossible++implementation Uninhabited ((MetaN n n') = (MethodN x)) where+  uninhabited Refl impossible++implementation Uninhabited ((MetaN n n') = (CaseN loc x)) where+  uninhabited Refl impossible++implementation Uninhabited ((MetaN n n') = (ElimN x)) where+  uninhabited Refl impossible++implementation Uninhabited ((MetaN n n') = (InstanceCtorN x)) where+  uninhabited Refl impossible++mutual+  private+  unInj : (UN x = UN y) -> x = y+  unInj Refl = Refl++  private+  nsInj : (NS n ns = NS n' ns') -> (n = n', ns = ns')+  nsInj Refl = (Refl, Refl)++  private+  mnInj : (MN i s = MN i' s') -> (i = i', s = s')+  mnInj Refl = (Refl, Refl)++  private+  snInj : SN sn = SN sn' -> sn = sn'+  snInj Refl = Refl++  private+  decTTNameEq : (n1, n2 : TTName) -> Dec (n1 = n2)+  decTTNameEq (UN x) (UN y) with (decEq x y)+    decTTNameEq (UN x) (UN y) | Yes prf =+        Yes (cong prf)+    decTTNameEq (UN x) (UN y) | No contra =+        No $ contra . unInj+  decTTNameEq (UN x) (NS n xs) = No absurd+  decTTNameEq (UN x) (MN y z) = No absurd+  decTTNameEq (UN x) (SN y) = No absurd+  decTTNameEq (NS n xs) (UN x) = No absurd+  decTTNameEq (NS n ns) (NS n' ns') with (decTTNameEq n n')+    decTTNameEq (NS n ns) (NS n ns')  | Yes Refl with (decEq ns ns')+      decTTNameEq (NS n ns) (NS n ns)   | Yes Refl | Yes Refl =+          Yes Refl+      decTTNameEq (NS n ns) (NS n ns')  | Yes Refl | No contra =+          No $ contra . snd . nsInj+    decTTNameEq (NS n ns) (NS n' ns') | No contra =+        No $ contra . fst . nsInj+  decTTNameEq (NS n xs) (MN x y) = No absurd+  decTTNameEq (NS n xs) (SN x) = No absurd+  decTTNameEq (MN x y) (UN z) = No absurd+  decTTNameEq (MN x y) (NS n xs) = No absurd+  decTTNameEq (MN x y) (MN z w) with (decEq x z)+    decTTNameEq (MN x y) (MN x w) | Yes Refl with (decEq y w)+      decTTNameEq (MN x y) (MN x y) | Yes Refl | Yes Refl =+          Yes Refl+      decTTNameEq (MN x y) (MN x w) | Yes Refl | No contra =+          No $ contra . snd . mnInj+    decTTNameEq (MN x y) (MN z w) | No contra =+        No $ contra . fst . mnInj+  decTTNameEq (MN x y) (SN z) = No absurd+  decTTNameEq (SN x) (UN y) = No absurd+  decTTNameEq (SN x) (NS n xs) = No absurd+  decTTNameEq (SN x) (MN y z) = No absurd+  decTTNameEq (SN x) (SN y) with (decSNEq x y)+    decTTNameEq (SN x) (SN x) | Yes Refl = Yes Refl+    decTTNameEq (SN x) (SN y) | (No contra) = No $ contra . snInj+++  private+  whereNInj : (WhereN x n n' = WhereN y z w) -> (x = y, n = z, n' = w)+  whereNInj Refl = (Refl, Refl, Refl)++  private+  withNInj : (WithN x n = WithN y n') -> (x = y, n = n')+  withNInj Refl = (Refl, Refl)++  private+  instanceNInj : (InstanceN n xs = InstanceN n' ys) -> (n = n', xs = ys)+  instanceNInj Refl = (Refl, Refl)++  private+  parentNInj : (ParentN n x = ParentN n' y) -> (n = n', x = y)+  parentNInj Refl = (Refl, Refl)++  private+  methodNInj : (MethodN n = MethodN n') -> n = n'+  methodNInj Refl = Refl++  private+  caseNInj : (CaseN loc n = CaseN loc' n') -> (loc = loc', n = n')+  caseNInj Refl = (Refl, Refl)++  private+  elimNInj : (ElimN n = ElimN n') -> n = n'+  elimNInj Refl = Refl++  private+  instanceCtorNInj : (InstanceCtorN n = InstanceCtorN n') -> n = n'+  instanceCtorNInj Refl = Refl++  private+  metaNInj : (MetaN n m = MetaN n' m') -> (n = n', m = m')+  metaNInj Refl = (Refl, Refl)++  private+  decSNEq : (n1, n2 : SpecialName) -> Dec (n1 = n2)+  decSNEq (WhereN x n n') (WhereN y z w) with (decEq x y)+    decSNEq (WhereN x n n') (WhereN x z w) | Yes Refl with (assert_total $ decTTNameEq n z)+      decSNEq (WhereN x n n') (WhereN x n w) | Yes Refl | Yes Refl with (assert_total $ decTTNameEq n' w)+        decSNEq (WhereN x n n') (WhereN x n n') | Yes Refl | Yes Refl | Yes Refl =+            Yes Refl+        decSNEq (WhereN x n n') (WhereN x n w) | Yes Refl | Yes Refl | No contra =+            No $ contra . snd . snd . whereNInj+      decSNEq (WhereN x n n') (WhereN x z w) | Yes Refl | No contra =+          No $ contra . fst . snd . whereNInj+    decSNEq (WhereN x n n') (WhereN y z w) | No contra =+        No $ contra . fst . whereNInj+  decSNEq (WhereN x n n') (WithN y z) = No absurd+  decSNEq (WhereN x n n') (InstanceN y xs) = No absurd+  decSNEq (WhereN x n n') (ParentN y z) = No absurd+  decSNEq (WhereN x n n') (MethodN y) = No absurd+  decSNEq (WhereN x n n') (CaseN loc y) = No absurd+  decSNEq (WhereN x n n') (ElimN y) = No absurd+  decSNEq (WhereN x n n') (InstanceCtorN y) = No absurd+  decSNEq (WhereN x n n') (MetaN y z) = No absurd+  decSNEq (WithN x n) (WhereN y n' z) = No absurd+  decSNEq (WithN x n) (WithN y n') with (decEq x y)+    decSNEq (WithN x n) (WithN x n') | Yes Refl  with (assert_total $ decTTNameEq n n')+      decSNEq (WithN x n) (WithN x n)  | Yes Refl  | Yes Refl =+          Yes Refl+      decSNEq (WithN x n) (WithN x n') | Yes Refl  | No contra =+          No $ contra . snd . withNInj+    decSNEq (WithN x n) (WithN y n') | No contra =+        No $ contra . fst . withNInj+  decSNEq (WithN x n) (InstanceN n' xs) = No absurd+  decSNEq (WithN x n) (ParentN n' y) = No absurd+  decSNEq (WithN x n) (MethodN n') = No absurd+  decSNEq (WithN x n) (CaseN loc n') = No absurd+  decSNEq (WithN x n) (ElimN n') = No absurd+  decSNEq (WithN x n) (InstanceCtorN n') = No absurd+  decSNEq (WithN x n) (MetaN n' y) = No absurd+  decSNEq (InstanceN n xs) (WhereN x n' y) = No absurd+  decSNEq (InstanceN n xs) (WithN x n') = No absurd+  decSNEq (InstanceN n xs) (InstanceN n' ys) with (assert_total $ decTTNameEq n n')+    decSNEq (InstanceN n xs) (InstanceN n ys)  | Yes Refl with (decEq xs ys)+      decSNEq (InstanceN n xs) (InstanceN n xs)  | Yes Refl | Yes Refl =+          Yes Refl+      decSNEq (InstanceN n xs) (InstanceN n ys)  | Yes Refl | No contra =+          No $ contra . snd . instanceNInj+    decSNEq (InstanceN n xs) (InstanceN n' ys) | No contra =+        No $ contra . fst . instanceNInj+  decSNEq (InstanceN n xs) (ParentN n' x) = No absurd+  decSNEq (InstanceN n xs) (MethodN n') = No absurd+  decSNEq (InstanceN n xs) (CaseN loc n') = No absurd+  decSNEq (InstanceN n xs) (ElimN n') = No absurd+  decSNEq (InstanceN n xs) (InstanceCtorN n') = No absurd+  decSNEq (InstanceN n xs) (MetaN n' x) = No absurd+  decSNEq (ParentN n x) (WhereN y n' z) = No absurd+  decSNEq (ParentN n x) (WithN y n') = No absurd+  decSNEq (ParentN n x) (InstanceN n' xs) = No absurd+  decSNEq (ParentN n x) (ParentN n' y) with (assert_total $ decTTNameEq n n')+    decSNEq (ParentN n x) (ParentN n y)  | Yes Refl with (decEq x y)+      decSNEq (ParentN n x) (ParentN n x) | Yes Refl | Yes Refl =+          Yes Refl+      decSNEq (ParentN n x) (ParentN n y) | Yes Refl | No contra =+          No $ contra . snd . parentNInj+    decSNEq (ParentN n x) (ParentN n' y) | No contra =+        No $ contra . fst . parentNInj+  decSNEq (ParentN n x) (MethodN n') = No absurd+  decSNEq (ParentN n x) (CaseN loc n') = No absurd+  decSNEq (ParentN n x) (ElimN n') = No absurd+  decSNEq (ParentN n x) (InstanceCtorN n') = No absurd+  decSNEq (ParentN n x) (MetaN n' y) = No absurd+  decSNEq (MethodN n) (WhereN x n' y) = No absurd+  decSNEq (MethodN n) (WithN x n') = No absurd+  decSNEq (MethodN n) (InstanceN n' xs) = No absurd+  decSNEq (MethodN n) (ParentN n' x) = No absurd+  decSNEq (MethodN n) (MethodN n') with (assert_total $ decTTNameEq n n')+    decSNEq (MethodN n) (MethodN n)  | Yes Refl =+        Yes Refl+    decSNEq (MethodN n) (MethodN n') | No contra =+        No $ contra . methodNInj+  decSNEq (MethodN n) (CaseN loc n') = No absurd+  decSNEq (MethodN n) (ElimN n') = No absurd+  decSNEq (MethodN n) (InstanceCtorN n') = No absurd+  decSNEq (MethodN n) (MetaN n' x) = No absurd+  decSNEq (CaseN loc n) (WhereN x n' y) = No absurd+  decSNEq (CaseN loc n) (WithN x n') = No absurd+  decSNEq (CaseN loc n) (InstanceN n' xs) = No absurd+  decSNEq (CaseN loc n) (ParentN n' x) = No absurd+  decSNEq (CaseN loc n) (MethodN n') = No absurd+  decSNEq (CaseN loc n) (CaseN loc' n') with (decEq loc loc')+    decSNEq (CaseN loc n) (CaseN loc n')  | Yes Refl with (assert_total $ decTTNameEq n n')+      decSNEq (CaseN loc n) (CaseN loc n)  | Yes Refl | Yes Refl =+          Yes Refl+      decSNEq (CaseN loc n) (CaseN loc n') | Yes Refl | No contra =+          No $ contra . snd . caseNInj+    decSNEq (CaseN loc n) (CaseN loc' n') | No contra =+        No $ contra . fst . caseNInj+  decSNEq (CaseN loc n) (ElimN n') = No absurd+  decSNEq (CaseN loc n) (InstanceCtorN n') = No absurd+  decSNEq (CaseN loc n) (MetaN n' x) = No absurd+  decSNEq (ElimN n) (WhereN x n' y) = No absurd+  decSNEq (ElimN n) (WithN x n') = No absurd+  decSNEq (ElimN n) (InstanceN n' xs) = No absurd+  decSNEq (ElimN n) (ParentN n' x) = No absurd+  decSNEq (ElimN n) (MethodN n') = No absurd+  decSNEq (ElimN n) (CaseN loc n') = No absurd+  decSNEq (ElimN n) (ElimN n') with (assert_total $ decTTNameEq n n')+    decSNEq (ElimN n) (ElimN n)  | Yes Refl =+        Yes Refl+    decSNEq (ElimN n) (ElimN n') | No contra =+        No $ contra . elimNInj+  decSNEq (ElimN n) (InstanceCtorN n') = No absurd+  decSNEq (ElimN n) (MetaN n' x) = No absurd+  decSNEq (InstanceCtorN n) (WhereN x n' y) = No absurd+  decSNEq (InstanceCtorN n) (WithN x n') = No absurd+  decSNEq (InstanceCtorN n) (InstanceN n' xs) = No absurd+  decSNEq (InstanceCtorN n) (ParentN n' x) = No absurd+  decSNEq (InstanceCtorN n) (MethodN n') = No absurd+  decSNEq (InstanceCtorN n) (CaseN loc n') = No absurd+  decSNEq (InstanceCtorN n) (ElimN n') = No absurd+  decSNEq (InstanceCtorN n) (InstanceCtorN n') with (assert_total $ decTTNameEq n n')+    decSNEq (InstanceCtorN n) (InstanceCtorN n)  | Yes Refl =+        Yes Refl+    decSNEq (InstanceCtorN n) (InstanceCtorN n') | No contra =+        No $ contra . instanceCtorNInj+  decSNEq (InstanceCtorN n) (MetaN n' x) = No absurd+  decSNEq (MetaN n n') (WhereN x y z) = No absurd+  decSNEq (MetaN n n') (WithN x y) = No absurd+  decSNEq (MetaN n n') (InstanceN x xs) = No absurd+  decSNEq (MetaN n n') (ParentN x y) = No absurd+  decSNEq (MetaN n n') (MethodN x) = No absurd+  decSNEq (MetaN n n') (CaseN loc x) = No absurd+  decSNEq (MetaN n n') (ElimN x) = No absurd+  decSNEq (MetaN n n') (InstanceCtorN x) = No absurd+  decSNEq (MetaN n n') (MetaN x y) with (assert_total $ decTTNameEq n x)+    decSNEq (MetaN n n') (MetaN n y) | Yes Refl with (assert_total $ decTTNameEq n' y)+      decSNEq (MetaN n n') (MetaN n n') | Yes Refl | Yes Refl =+          Yes Refl+      decSNEq (MetaN n n') (MetaN n y) | Yes Refl | No contra =+          No $ contra . snd . metaNInj+    decSNEq (MetaN n n') (MetaN x y) | No contra =+        No $ contra . fst . metaNInj+++implementation DecEq TTName where+  decEq = decTTNameEq++implementation DecEq SpecialName where+  decEq = decSNEq+ data TTUExp =             ||| Universe variable             UVar Int |@@ -430,20 +942,6 @@   quotedTy = `(String)   quote x = RConstant (Str x) -implementation Quotable NameType TT where-  quotedTy = `(NameType)-  quote Bound = `(Bound)-  quote Ref = `(Ref)-  quote (DCon x y) = `(DCon ~(quote x) ~(quote y))-  quote (TCon x y) = `(TCon ~(quote x) ~(quote y))--implementation Quotable NameType Raw where-  quotedTy = `(NameType)-  quote Bound = `(Bound)-  quote Ref = `(Ref)-  quote (DCon x y) = `(DCon ~(quote {t=Raw} x) ~(quote {t=Raw} y))-  quote (TCon x y) = `(TCon ~(quote {t=Raw} x) ~(quote {t=Raw} y))- implementation Quotable a TT => Quotable (List a) TT where   quotedTy = `(List ~(quotedTy {a}))   quote [] = `(List.Nil {elem=~(quotedTy {a})})@@ -454,6 +952,22 @@   quote [] = `(List.Nil {elem=~(quotedTy {a})})   quote (x :: xs) = `(List.(::) {elem=~(quotedTy {a})} ~(quote x) ~(quote xs)) +implementation Quotable () TT where+  quotedTy = `(Unit)+  quote () = `(MkUnit)++implementation Quotable () Raw where+  quotedTy = `(Unit)+  quote () = `(MkUnit)++implementation (Quotable a TT, Quotable b TT) => Quotable (a, b) TT where+  quotedTy = `(Pair ~(quotedTy {a=a}) ~(quotedTy {a=b}))+  quote (x, y) = `(MkPair {A=~(quotedTy {a=a})} {B=~(quotedTy {a=b})} ~(quote x) ~(quote y))++implementation (Quotable a Raw, Quotable b Raw) => Quotable (a, b) Raw where+  quotedTy = `(Pair ~(quotedTy {a=a}) ~(quotedTy {a=b}))+  quote (x, y) = `(MkPair {A=~(quotedTy {a=a})} {B=~(quotedTy {a=b})} ~(quote x) ~(quote y))+ implementation Quotable SourceLocation TT where   quotedTy = `(SourceLocation)   quote (FileLoc fn (sl, sc) (el, ec)) =@@ -510,6 +1024,16 @@     quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta))  +implementation Quotable TTUExp TT where+  quotedTy = `(TTUExp)+  quote (UVar x) = `(UVar ~(quote x))+  quote (UVal x) = `(UVal ~(quote x))++implementation Quotable TTUExp Raw where+  quotedTy = `(TTUExp)+  quote (UVar x) = `(UVar ~(quote {t=Raw} x))+  quote (UVal x) = `(UVal ~(quote {t=Raw} x))+ implementation Quotable NativeTy TT where     quotedTy = `(NativeTy)     quote IT8 = `(Reflection.IT8)@@ -584,15 +1108,19 @@   quote WorldType = `(WorldType)   quote TheWorld = `(TheWorld) -implementation Quotable TTUExp TT where-  quotedTy = `(TTUExp)-  quote (UVar x) = `(UVar ~(quote x))-  quote (UVal x) = `(UVal ~(quote x))+implementation Quotable NameType TT where+  quotedTy = `(NameType)+  quote Bound = `(Bound)+  quote Ref = `(Ref)+  quote (DCon x y) = `(DCon ~(quote x) ~(quote y))+  quote (TCon x y) = `(TCon ~(quote x) ~(quote y)) -implementation Quotable TTUExp Raw where-  quotedTy = `(TTUExp)-  quote (UVar x) = `(UVar ~(quote {t=Raw} x))-  quote (UVal x) = `(UVal ~(quote {t=Raw} x))+implementation Quotable NameType Raw where+  quotedTy = `(NameType)+  quote Bound = `(Bound)+  quote Ref = `(Ref)+  quote (DCon x y) = `(DCon ~(quote {t=Raw} x) ~(quote {t=Raw} y))+  quote (TCon x y) = `(TCon ~(quote {t=Raw} x) ~(quote {t=Raw} y))  implementation Quotable Universe TT where   quotedTy = `(Universe)@@ -633,6 +1161,38 @@     quote (PVTy x) = `(PVTy {a=TT} ~(assert_total (quote x)))  mutual+  quoteTTRaw : TT -> Raw+  quoteTTRaw (P nt n tm) = `(P ~(quote nt) ~(quote n) ~(quoteTTRaw tm))+  quoteTTRaw (V x) = `(V ~(quote x))+  quoteTTRaw (Bind n b tm) = `(Bind ~(quote n) ~(assert_total $ quoteTTBinderRaw b) ~(quoteTTRaw tm))+  quoteTTRaw (App f x) = `(App ~(quoteTTRaw f) ~(quoteTTRaw x))+  quoteTTRaw (TConst c) = `(TConst ~(quote c))+  quoteTTRaw Erased = `(Erased)+  quoteTTRaw (TType uexp) = `(TType ~(quote uexp))+  quoteTTRaw (UType u) = `(UType ~(quote u))++  quoteTTBinderRaw : Binder TT -> Raw+  quoteTTBinderRaw (Lam x) = `(Lam {a=TT} ~(quoteTTRaw x))+  quoteTTBinderRaw (Pi x k) = `(Pi {a=TT} ~(quoteTTRaw x)+                                          ~(quoteTTRaw k))+  quoteTTBinderRaw (Let x y) = `(Let {a=TT} ~(quoteTTRaw x)+                                            ~(quoteTTRaw y))+  quoteTTBinderRaw (Hole x) = `(Hole {a=TT} ~(quoteTTRaw x))+  quoteTTBinderRaw (GHole x) = `(GHole {a=TT} ~(quoteTTRaw x))+  quoteTTBinderRaw (Guess x y) = `(Guess {a=TT} ~(quoteTTRaw x)+                                                ~(quoteTTRaw y))+  quoteTTBinderRaw (PVar x) = `(PVar {a=TT} ~(quoteTTRaw x))+  quoteTTBinderRaw (PVTy x) = `(PVTy {a=TT} ~(quoteTTRaw x))++implementation Quotable TT Raw where+  quotedTy = `(TT)+  quote = quoteTTRaw++implementation Quotable (Binder TT) Raw where+  quotedTy = `(Binder TT)+  quote = quoteTTBinderRaw++mutual   quoteRawTT : Raw -> TT   quoteRawTT (Var n) = `(Var ~(quote n))   quoteRawTT (RBind n b tm) = `(RBind ~(quote n) ~(assert_total $ quoteRawBinderTT b) ~(quoteRawTT tm))@@ -694,7 +1254,45 @@   quote (RawPart tm) = `(RawPart ~(quote tm))   quote (SubReport xs) = `(SubReport ~(assert_total $ quote xs)) +implementation Quotable ErrorReportPart Raw where+  quotedTy = `(ErrorReportPart)+  quote (TextPart x) = `(TextPart ~(quote x))+  quote (NamePart n) = `(NamePart ~(quote n))+  quote (TermPart tm) = `(TermPart ~(quote tm))+  quote (RawPart tm) = `(RawPart ~(quote tm))+  quote (SubReport xs) = `(SubReport ~(assert_total $ quote xs))+ implementation Quotable Tactic TT where+  quotedTy = `(Tactic)+  quote (Try tac tac') = `(Try ~(quote tac) ~(quote tac'))+  quote (GoalType x tac) = `(GoalType ~(quote x) ~(quote tac))+  quote (Refine n) = `(Refine ~(quote n))+  quote (Claim n ty) = `(Claim ~(quote n) ~(quote ty))+  quote Unfocus = `(Unfocus)+  quote (Seq tac tac') = `(Seq ~(quote tac) ~(quote tac'))+  quote Trivial = `(Trivial)+  quote (Search x) = `(Search ~(quote x))+  quote Instance = `(Instance)+  quote Solve = `(Solve)+  quote Intros = `(Intros)+  quote (Intro n) = `(Intro ~(quote n))+  quote (ApplyTactic tm) = `(ApplyTactic ~(quote tm))+  quote (Reflect tm) = `(Reflect ~(quote tm))+  quote (ByReflection tm) = `(ByReflection ~(quote tm))+  quote (Fill tm) = `(Fill ~(quote tm))+  quote (Exact tm) = `(Exact ~(quote tm))+  quote (Focus n) = `(Focus ~(quote n))+  quote (Rewrite tm) = `(Rewrite ~(quote tm))+  quote (Induction tm) = `(Induction ~(quote tm))+  quote (Case tm) = `(Case ~(quote tm))+  quote (LetTac n tm) = `(LetTac ~(quote n) ~(quote tm))+  quote (LetTacTy n tm tm') = `(LetTacTy ~(quote n) ~(quote tm) ~(quote tm'))+  quote Compute = `(Compute)+  quote Skip = `(Skip)+  quote (Fail xs) = `(Fail ~(quote xs))+  quote SourceFC = `(SourceFC)++implementation Quotable Tactic Raw where   quotedTy = `(Tactic)   quote (Try tac tac') = `(Try ~(quote tac) ~(quote tac'))   quote (GoalType x tac) = `(GoalType ~(quote x) ~(quote tac))
libs/prelude/Language/Reflection/Elab.idr view
@@ -10,6 +10,7 @@ import Prelude.Basics import Prelude.Bool import Prelude.Functor+import Prelude.Interfaces import Prelude.List import Prelude.Maybe import Prelude.Monad@@ -629,4 +630,138 @@   export   runElab : Raw -> Elab () -> Elab (TT, TT)   runElab goal script = Prim__RecursiveElab goal script++---------------------------+-- Quotable Implementations+---------------------------++implementation Quotable Fixity TT where+  quotedTy = `(Fixity)+  quote (Infixl k) = `(Infixl ~(quote k))+  quote (Infixr k) = `(Infixr ~(quote k))+  quote (Infix  k) = `(Infix  ~(quote k))+  quote (Prefix k) = `(Prefix ~(quote k))++implementation Quotable Fixity Raw where+  quotedTy = `(Fixity)+  quote (Infixl k) = `(Infixl ~(quote k))+  quote (Infixr k) = `(Infixr ~(quote k))+  quote (Infix  k) = `(Infix  ~(quote k))+  quote (Prefix k) = `(Prefix ~(quote k))++implementation Quotable Erasure TT where+  quotedTy = `(Erasure)+  quote Erased    = `(Elab.Erased)+  quote NotErased = `(NotErased)++implementation Quotable Erasure Raw where+  quotedTy = `(Erasure)+  quote Erased    = `(Elab.Erased)+  quote NotErased = `(NotErased)++implementation Quotable Plicity TT where+  quotedTy = `(Plicity)+  quote Explicit   = `(Explicit)+  quote Implicit   = `(Implicit)+  quote Constraint = `(Constraint)++implementation Quotable Plicity Raw where+  quotedTy = `(Plicity)+  quote Explicit   = `(Explicit)+  quote Implicit   = `(Implicit)+  quote Constraint = `(Constraint)++implementation Quotable FunArg TT where+  quotedTy = `(FunArg)+  quote (MkFunArg name type plicity erasure) =+    `(MkFunArg ~(quote name) ~(quote type) ~(quote plicity) ~(quote erasure))++implementation Quotable FunArg Raw where+  quotedTy = `(FunArg)+  quote (MkFunArg name type plicity erasure) =+    `(MkFunArg ~(quote name) ~(quote type) ~(quote plicity) ~(quote erasure))++implementation Quotable TyConArg TT where+  quotedTy = `(TyConArg)+  quote (TyConParameter arg) = `(TyConParameter ~(quote arg))+  quote (TyConIndex     arg) = `(TyConIndex     ~(quote arg))++implementation Quotable TyConArg Raw where+  quotedTy = `(TyConArg)+  quote (TyConParameter arg) = `(TyConParameter ~(quote arg))+  quote (TyConIndex     arg) = `(TyConIndex     ~(quote arg))++implementation Quotable TyDecl TT where+  quotedTy = `(TyDecl)+  quote (Declare name arguments returnType) =+    `(Declare ~(quote name) ~(quote arguments) ~(quote returnType))++implementation Quotable TyDecl Raw where+  quotedTy = `(TyDecl)+  quote (Declare name arguments returnType) =+    `(Declare ~(quote name) ~(quote arguments) ~(quote returnType))++implementation (Quotable a TT) => Quotable (FunClause a) TT where+  quotedTy = `(FunClause ~(quotedTy {a}))+  quote (MkFunClause lhs rhs) =+    `(MkFunClause {a = ~(quotedTy {a})} ~(quote lhs) ~(quote rhs))+  quote (MkImpossibleClause lhs) =+    `(MkImpossibleClause {a = ~(quotedTy {a})} ~(quote lhs))++implementation (Quotable a Raw) => Quotable (FunClause a) Raw where+  quotedTy = `(FunClause ~(quotedTy {a}))+  quote (MkFunClause lhs rhs) =+    `(MkFunClause {a = ~(quotedTy {a})} ~(quote lhs) ~(quote rhs))+  quote (MkImpossibleClause lhs) =+    `(MkImpossibleClause {a = ~(quotedTy {a})} ~(quote lhs))++implementation (Quotable a TT) => Quotable (FunDefn a) TT where+  quotedTy = `(FunDefn ~(quotedTy {a}))+  quote (DefineFun name clauses) =+    `(DefineFun {a = ~(quotedTy {a})} ~(quote name) ~(quote clauses))++implementation (Quotable a Raw) => Quotable (FunDefn a) Raw where+  quotedTy = `(FunDefn ~(quotedTy {a}))+  quote (DefineFun name clauses) =+    `(DefineFun {a = ~(quotedTy {a})} ~(quote name) ~(quote clauses))++implementation Quotable ConstructorDefn TT where+  quotedTy = `(ConstructorDefn)+  quote (Constructor name arguments returnType) =+    `(Constructor ~(quote name) ~(quote arguments) ~(quote returnType))++implementation Quotable ConstructorDefn Raw where+  quotedTy = `(ConstructorDefn)+  quote (Constructor name arguments returnType) =+    `(Constructor ~(quote name) ~(quote arguments) ~(quote returnType))++implementation Quotable DataDefn TT where+  quotedTy = `(DataDefn)+  quote (DefineDatatype name constructors) =+    `(DefineDatatype ~(quote name) ~(quote constructors))++implementation Quotable DataDefn Raw where+  quotedTy = `(DataDefn)+  quote (DefineDatatype name constructors) =+    `(DefineDatatype ~(quote name) ~(quote constructors))++implementation Quotable CtorArg TT where+  quotedTy = `(CtorArg)+  quote (CtorParameter arg) = `(CtorParameter ~(quote arg))+  quote (CtorField     arg) = `(CtorField     ~(quote arg))++implementation Quotable CtorArg Raw where+  quotedTy = `(CtorArg)+  quote (CtorParameter arg) = `(CtorParameter ~(quote arg))+  quote (CtorField     arg) = `(CtorField     ~(quote arg))++implementation Quotable Datatype TT where+  quotedTy = `(Datatype)+  quote (MkDatatype name tyConArgs tyConRes constructors) =+    `(MkDatatype ~(quote name) ~(quote tyConArgs) ~(quote tyConRes) ~(quote constructors))++implementation Quotable Datatype Raw where+  quotedTy = `(Datatype)+  quote (MkDatatype name tyConArgs tyConRes constructors) =+    `(MkDatatype ~(quote name) ~(quote tyConArgs) ~(quote tyConRes) ~(quote constructors))
libs/prelude/Prelude.idr view
@@ -28,6 +28,7 @@ import public Prelude.Interactive import public Prelude.File import public Prelude.Doubles+import public Prelude.WellFounded import public Decidable.Equality import public Language.Reflection import public Language.Reflection.Elab
libs/prelude/Prelude/File.idr view
@@ -17,7 +17,6 @@ %access public export  ||| A file handle-export data File : Type where   FHandle : (p : Ptr) -> File
libs/prelude/Prelude/List.idr view
@@ -230,7 +230,7 @@ ||| @ xs the list to recurse over list : (nil : Lazy b) -> (cons : Lazy (a -> List a -> b)) -> (xs : List a) -> b list nil cons []      = nil-list nil cons (x::xs) = (Force cons) x xs+list nil cons (x::xs) = cons x xs  -------------------------------------------------------------------------------- -- Building (bigger) lists@@ -536,6 +536,14 @@   else     filter p xs +||| A filtered list is no longer than its input+filterSmaller : (xs : _) -> LTE (length (filter p xs)) (length xs)+filterSmaller [] = LTEZero+filterSmaller {p} (x :: xs) with (p x)+  filterSmaller {p = p} (x :: xs) | False = lteSuccRight (filterSmaller xs)+  filterSmaller {p = p} (x :: xs) | True = LTESucc (filterSmaller xs)++ ||| The nubBy function behaves just like nub, except it uses a user-supplied equality predicate instead of the overloaded == function. nubBy : (a -> a -> Bool) -> List a -> List a nubBy = nubBy' []@@ -761,9 +769,9 @@ mergeBy order []      right   = right mergeBy order left    []      = left mergeBy order (x::xs) (y::ys) =-  if order x y == LT-     then x :: mergeBy order xs (y::ys)-     else y :: mergeBy order (x::xs) ys+  case order x y of+       LT => x :: mergeBy order xs (y::ys)+       _  => y :: mergeBy order (x::xs) ys  ||| Merge two sorted lists using the default ordering for the type of their elements. merge : Ord a => List a -> List a -> List a
libs/prelude/Prelude/Maybe.idr view
@@ -44,7 +44,7 @@  maybe : Lazy b -> Lazy (a -> b) -> Maybe a -> b maybe n j Nothing  = n-maybe n j (Just x) = (Force j) x+maybe n j (Just x) = j x  ||| Convert a `Maybe a` value to an `a` value by providing a default `a` value ||| in the case that the `Maybe` value is `Nothing`.
libs/prelude/Prelude/Nat.idr view
@@ -141,6 +141,19 @@ lteSuccRight LTEZero     = LTEZero lteSuccRight (LTESucc x) = LTESucc (lteSuccRight x) +||| n + 1 < m implies n < m +lteSuccLeft : LTE (S n) m -> LTE n m+lteSuccLeft (LTESucc x) = lteSuccRight x++||| `LTE` is transitive+lteTransitive : LTE n m -> LTE m p -> LTE n p+lteTransitive LTEZero y = LTEZero+lteTransitive (LTESucc x) (LTESucc y) = LTESucc (lteTransitive x y)++lteAddRight : (n : Nat) -> LTE n (plus n m)+lteAddRight Z = LTEZero+lteAddRight (S k) = LTESucc (lteAddRight k)+  ||| Boolean test than one Nat is less than or equal to another total lte : Nat -> Nat -> Bool
libs/prelude/Prelude/Strings.idr view
@@ -327,8 +327,8 @@ ||| ``` toLower : String -> String toLower x with (strM x)-  strToLower ""             | StrNil = ""-  strToLower (strCons c cs) | (StrCons c cs) =+  toLower ""             | StrNil = ""+  toLower (strCons c cs) | (StrCons c cs) =     strCons (toLower c) (toLower (assert_smaller (strCons c cs) cs))  ||| Uppercases all characters in the string.@@ -338,8 +338,8 @@ ||| ``` toUpper : String -> String toUpper x with (strM x)-  strToLower ""             | StrNil = ""-  strToLower (strCons c cs) | (StrCons c cs) =+  toUpper ""             | StrNil = ""+  toUpper (strCons c cs) | (StrCons c cs) =     strCons (toUpper c) (toUpper (assert_smaller (strCons c cs) cs ))  --------------------------------------------------------------------------------
+ libs/prelude/Prelude/WellFounded.idr view
@@ -0,0 +1,112 @@+||| Well-founded recursion.+|||+||| This is to let us implement some functions that don't have trivial+||| recursion patterns over datatypes, but instead are using some+||| other metric of size.+module Prelude.WellFounded++import Prelude.Nat+import Prelude.List+import Prelude.Uninhabited++%default total+%access public export++||| Accessibility: some element `x` is accessible if all `y` such that+||| `rel y x` are themselves accessible.+|||+||| @ a the type of elements+||| @ rel a relation on a+||| @ x the acessible element+data Accessible : (rel : a -> a -> Type) -> (x : a) -> Type where+  ||| Accessibility+  |||+  ||| @ x the accessible element+  ||| @ rec a demonstration that all smaller elements are also accessible+  Access : (rec : (y : a) -> rel y x -> Accessible rel y) ->+           Accessible rel x++||| A relation `rel` on `a` is well-founded if all elements of `a` are+||| acessible.+|||+||| @ rel the well-founded relation+interface WellFounded (rel : a -> a -> Type) where+  wellFounded : (x : _) -> Accessible rel x+++||| A recursor over accessibility.+|||+||| This allows us to recurse over the subset of some type that is+||| accessible according to some relation.+|||+||| @ rel the well-founded relation+||| @ step how to take steps on reducing arguments+||| @ z the starting point+accRec : {rel : a -> a -> Type} ->+         (step : (x : a) -> ((y : a) -> rel y x -> b) -> b) ->+         (z : a) -> Accessible rel z -> b+accRec step z (Access f) =+  step z $ \y, lt => accRec step y (f y lt)++||| An induction principle for accessibility.+|||+||| This allows us to recurse over the subset of some type that is+||| accessible according to some relation, producing a dependent type+||| as a result.+|||+||| @ rel the well-founded relation+||| @ step how to take steps on reducing arguments+||| @ z the starting point+accInd : {rel : a -> a -> Type} -> {P : a -> Type} ->+         (step : (x : a) -> ((y : a) -> rel y x -> P y) -> P x) ->+         (z : a) -> Accessible rel z -> P z+accInd {P} step z (Access f) =+  step z $ \y, lt => accInd {P} step y (f y lt)+++||| Use well-foundedness of a relation to write terminating operations.+|||+||| @ rel a well-founded relation+wfRec : WellFounded rel =>+        (step : (x : a) -> ((y : a) -> rel y x -> b) -> b) ->+        a -> b+wfRec {rel} step x = accRec step x (wellFounded {rel} x)+++||| Use well-foundedness of a relation to write proofs+|||+||| @ rel a well-founded relation+||| @ P the motive for the induction+||| @ step the induction step: take an element and its accessibility,+|||        and give back a demonstration of P for that element,+|||        potentially using accessibility+wfInd : WellFounded rel => {P : a -> Type} ->+        (step : (x : a) -> ((y : a) -> rel y x -> P y) -> P x) ->+        (x : a) -> P x+wfInd {rel} step x = accInd step x (wellFounded {rel} x)++-- Some basic useful relations++||| LT is a well-founded relation on numbers+ltAccessible : (n : Nat) -> Accessible LT n+ltAccessible n = Access (\v, prf => ltAccessible' {n'=v} n prf)+  where+    ltAccessible' : (m : Nat) -> LT n' m -> Accessible LT n'+    ltAccessible' Z x = absurd x +    ltAccessible' (S k) (LTESucc x) +        = Access (\val, p => ltAccessible' k (lteTransitive p x))++-- First list is smaller than the second+smaller : List a -> List a -> Type+smaller xs ys = LT (length xs) (length ys)++||| `smaller` is a well-founded relation on lists+smallerAcc : (xs : List a) -> Accessible WellFounded.smaller xs+smallerAcc xs = Access (\v, prf => smallerAcc' {xs'=v} xs prf)+  where+    smallerAcc' : (ys : List a) -> smaller xs' ys -> Accessible smaller xs'+    smallerAcc' [] x = absurd x+    smallerAcc' (y :: ys) (LTESucc x) +       = Access (\val, p => smallerAcc' ys (lteTransitive p x))++
libs/prelude/prelude.ipkg view
@@ -10,6 +10,7 @@           Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,           Prelude.Uninhabited, Prelude.Pairs, Prelude.Providers,           Prelude.Interactive, Prelude.File, Prelude.Doubles,+          Prelude.WellFounded,            Language.Reflection, Language.Reflection.Errors, Language.Reflection.Elab,
main/Main.hs view
@@ -1,38 +1,21 @@ module Main where -import System.Console.Haskeline-import System.IO-import System.Environment-import System.Exit-import System.Directory+import System.Exit ( exitSuccess ) -import Data.Maybe-import Data.Version import Control.Monad ( when ) -import Idris.Core.TT-import Idris.Core.Typecheck-import Idris.Core.Evaluate-import Idris.Core.Constraints- import Idris.AbsSyntax-import Idris.Parser import Idris.REPL-import Idris.ElabDecls-import Idris.Primitives import Idris.Imports import Idris.Error import Idris.CmdOptions  import IRTS.System ( getLibFlags, getIdrisLibDir, getIncFlags ) -import Util.DynamicLinker-import Util.System+import Util.System ( setupBundledCC )  import Pkg.Package -import Paths_idris- -- Main program reads command line options, parses the main program, and gets -- on with the REPL. @@ -56,26 +39,26 @@                    runIO exitSuccess     case opt getPkgCheck opts of        [] -> return ()-       fs -> do runIO $ mapM_ (checkPkg (WarnOnly `elem` opts) True) fs+       fs -> do runIO $ mapM_ (checkPkg opts (WarnOnly `elem` opts) True) fs                 runIO exitSuccess     case opt getPkgClean opts of        [] -> return ()-       fs -> do runIO $ mapM_ cleanPkg fs+       fs -> do runIO $ mapM_ (cleanPkg opts) fs                 runIO exitSuccess     case opt getPkgMkDoc opts of                -- IdrisDoc        [] -> return ()-       fs -> do runIO $ mapM_ documentPkg fs+       fs -> do runIO $ mapM_ (documentPkg opts) fs                 runIO exitSuccess     case opt getPkgTest opts of        [] -> return ()-       fs -> do runIO $ mapM_ testPkg fs+       fs -> do runIO $ mapM_ (testPkg opts) fs                 runIO exitSuccess     case opt getPkg opts of        [] -> case opt getPkgREPL opts of                   [] -> idrisMain opts-                  [f] -> replPkg f+                  [f] -> replPkg opts f                   _ -> ifail "Too many packages"-       fs -> runIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs+       fs -> runIO $ mapM_ (buildPkg opts (WarnOnly `elem` opts)) fs  showver :: IO b showver = do putStrLn $ "Idris version " ++ ver@@ -97,7 +80,7 @@  -- | List idris packages installed showPkgs :: IO b-showPkgs = do mapM putStrLn =<< installedPackages+showPkgs = do mapM_ putStrLn =<< installedPackages               exitSuccess  showLoggingCats :: IO b
man/idris.1 view
@@ -1,6 +1,6 @@ .\" Manpage for Idris. .\" Contact <> to correct errors or typos.-.TH man 1 "06 August 2014" "0.9.14.1" "Idris man page"+.TH man 1 "25 March 2016" "0.11" "Idris man page" .SH NAME idris -\ a general purpose pure functional programming language with dependent types. .SH SYNOPSIS@@ -13,29 +13,17 @@ 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-++ Simple case expressions, where-clauses, with-rule++ Pattern matching let- and lambda-bindings++ Overloading via Interfaces (Type class-like), Monad comprehensions++ do-notation, idiom brackets++ Syntactic conveniences for lists, tuples, dependent pairs + Totality checking- + Coinductive types--+ Indentation significant syntax, extensible syntax-++ Indentation significant syntax, Extensible syntax + Tactic based theorem proving (influenced by Coq)- + Cumulative universes--+ Simple foreign function interface (to C)-++ Simple Foreign Function Interface + Hugs style interactive environment  It is important to note that Idris is first and foremost a research tool@@ -45,39 +33,68 @@ .SH OPTIONS   --nobanner               Suppress the banner   -q,--quiet               Quiet verbosity+  --ide-mode               Run the Idris REPL with machine-readable syntax+  --ide-mode-socket        Choose a socket for IDE mode to listen on+  --ideslave               Deprecated version of --ide-mode+  --ideslave-socket        Deprecated version of --ide-mode-socket   --log LEVEL              Debugging log level+  --logging-categories CATS+                           Colon separated logging categories. Use --listlogcats+                           to see list.+  --nobasepkgs             Do not use the given base package+  --noprelude              Do not use the given prelude+  --nobuiltins             Do not use the builtin functions+  --check                  Typecheck only, don't start the REPL   -o,--output FILE         Specify output file+  --interface              Generate interface files from ExportLists+  --typeintype             Turn off Universe checking   --total                  Require functions to be total by default   --warnpartial            Warn about undeclared partial functions   --warnreach              Warn about reachable but inaccessible arguments+  --listlogcats            Display logging categories   --link                   Display link flags+  --listlibs               Display installed libraries   --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+  -p,--package ARG         Add package as a dependency+  --port PORT              REPL TCP port   --build IPKG             Build package   --install IPKG           Install package+  --repl IPKG              Launch REPL, only for executables   --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+  --codegen TARGET         Select code generator: C, Javascript, Node and+                           bytecode are bundled with Idris+  --cg-opt ARG             Arguments to pass to code generator   -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)+  --no-partial-eval        Switch off partial evaluation, mainly for debugging+                           purposes+  --target TRIPLE          If supported the codegen will target the named triple.+  --cpu CPU                If supported the codegen will target the named CPU+                           e.g. corei7 or cortex-m3.   --color,--colour         Force coloured output   --nocolor,--nocolour     Disable coloured output+  --consolewidth WIDTH     Select console width: auto, infinite, nat+  --highlight              Emit source code highlighting+  --no-elim-deprecation-warnings+                           Disable deprecation warnings for %elim+  --no-tactic-deprecation-warnings+                           Disable deprecation warnings for the old tactic+                           sublanguage   -v,--version             Print version information   -h,--help                Show this help text+ .SH SEE ALSO  + The IDRIS web site (http://idris-lang.org/
src/IRTS/CodegenC.hs view
@@ -64,7 +64,6 @@          let cout = headers incs ++ debug dbg ++ h ++ wrappers ++ cc ++                      (if (exec == Executable) then mprog else hi)          case exec of-           MavenProject -> putStrLn ("FAILURE: output type not supported")            Raw -> writeSource out cout            _ -> do              (tmpn, tmph) <- tempfile ".c"@@ -731,7 +730,11 @@ carith (FCon i)   | i == sUN "C_IntChar" = "char"   | i == sUN "C_IntNative" = "int"-carith t = error "Can't happen: Not an exportable arithmetic type"+  | i == sUN "C_IntBits8" = "uint8_t"+  | i == sUN "C_IntBits16" = "uint16_t"+  | i == sUN "C_IntBits32" = "uint32_t"+  | i == sUN "C_IntBits64" = "uint64_t"+carith t = error $ "Can't happen: Not an exportable arithmetic type " ++ show t  cdesc (FStr s) = s cdesc s = error "Can't happen: Not a valid C name"
src/IRTS/CodegenCommon.hs view
@@ -5,7 +5,7 @@ import IRTS.Defunctionalise  data DbgLevel = NONE | DEBUG | TRACE deriving Eq-data OutputType = Raw | Object | Executable | MavenProject deriving (Eq, Show)+data OutputType = Raw | Object | Executable deriving (Eq, Show)  -- Everything which might be needed in a code generator - a CG can choose which -- level of Decls to generate code from (simplified, defunctionalised or merely@@ -26,6 +26,6 @@                                  liftDecls :: [(Name, LDecl)],                                  interfaces :: Bool,                                  exportDecls :: [ExportIFace]-                               } +                               }  type CodeGenerator = CodegenInfo -> IO ()
src/IRTS/Compiler.hs view
@@ -246,6 +246,12 @@         | r == txt "replace"         -> irTerm vs env arg +    -- 'void' doesn't have any pattern clauses and only gets called on+    -- erased things in higher order contexts (also a TMP HACK...)+    (P _ (UN r) _, _)+        | r == txt "void"+        -> return LNothing+     -- Laziness, the old way     (P _ (UN l) _, [_, arg])         | l == txt "lazy"@@ -343,7 +349,11 @@         case compare (length args) arity of              -- overapplied-            GT  -> ifail ("overapplied data constructor: " ++ show tm)+            GT  -> ifail ("overapplied data constructor: " ++ show tm +++                          "\nDEBUG INFO:\n" ++ +                          "Arity: " ++ show arity ++ "\n" +++                          "Arguments: " ++ show args ++ "\n" +++                          "Pruned arguments: " ++ show argsPruned)              -- exactly saturated             EQ  | isNewtype
src/IRTS/System.hs view
@@ -31,8 +31,10 @@  #if defined(FREEBSD) || defined(DRAGONFLY) extraLib = ["-L/usr/local/lib"]+extraInclude = ["-I/usr/local/include"] #else extraLib = []+extraInclude = [] #endif  #ifdef IDRIS_GMP@@ -47,10 +49,5 @@  getIdrisLibDir = addTrailingPathSeparator <$> overrideDataDirWith "IDRIS_LIBRARY_PATH" -#if defined(FREEBSD) || defined(DRAGONFLY)-extraInclude = ["-I/usr/local/include"]-#else-extraInclude = []-#endif getIncFlags = do dir <- getDataDir                  return $ ("-I" ++ dir </> "rts") : extraInclude
src/Idris/AbsSyntax.hs view
@@ -381,13 +381,26 @@              _ -> []  addDeprecated :: Name -> String -> Idris ()-addDeprecated n reason = do i <- getIState-                            putIState $ i { idris_deprecated = addDef n reason (idris_deprecated i) }+addDeprecated n reason = do+  i <- getIState+  putIState $ i { idris_deprecated = addDef n reason (idris_deprecated i) }  getDeprecated :: Name -> Idris (Maybe String)-getDeprecated n = do i <- getIState-                     return $ lookupCtxtExact n (idris_deprecated i)+getDeprecated n = do+  i <- getIState+  return $ lookupCtxtExact n (idris_deprecated i) ++addFragile :: Name -> String -> Idris ()+addFragile n reason = do+  i <- getIState+  putIState $ i { idris_fragile = addDef n reason (idris_fragile i) }++getFragile :: Name -> Idris (Maybe String)+getFragile n = do+  i <- getIState+  return $ lookupCtxtExact n (idris_fragile i)+ push_estack :: Name -> Bool -> Idris () push_estack n inst     = do i <- getIState@@ -658,7 +671,7 @@   = do mapM_ (\(n, (i, _, t, _, _, _)) -> updateContext (addTyDecl n nt (tidyNames S.empty t))) ns        mapM_ (\(n, _) -> when (not (n `elem` primDefs)) $ addIBC (IBCMetavar n)) ns        i <- getIState-       putIState $ i { idris_metavars = map (\(n, (i, top, _, ns, isTopLevel, isDefinable)) -> +       putIState $ i { idris_metavars = map (\(n, (i, top, _, ns, isTopLevel, isDefinable)) ->                                                   (n, (top, i, ns, isTopLevel, isDefinable))) ns ++                                             idris_metavars i }   where@@ -673,7 +686,7 @@         tidyNames used b = b  solveDeferred :: FC -> Name -> Idris ()-solveDeferred fc n +solveDeferred fc n     = do i <- getIState          case lookup n (idris_metavars i) of               Just (_, _, _, _, False) ->@@ -1134,7 +1147,7 @@        | n `elem` (map fst ps ++ ns) && t /= Placeholder            = let n' = mkShadow n in                  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 (PRewrite f by l r g) = PRewrite f by (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)@@ -1307,7 +1320,7 @@             [] -> 0 -- must be locally bound, if it's not an error...     pri (PPi _ _ _ x y) = max 5 (max (pri x) (pri y))     pri (PTrue _ _) = 0-    pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r))+    pri (PRewrite _ _ l r _) = max 1 (max (pri l) (pri r))     pri (PApp _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))     pri (PAppBind _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))     pri (PCase _ f as) = max 1 (max (pri f) (foldr (max . pri . snd) 0 as))@@ -1628,7 +1641,7 @@              put (PTacImplicit 10 l n scr Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc-    imps top env (PRewrite _ l r _)+    imps top env (PRewrite _ _ l r _)         = do (decls, ns) <- get              let isn = namesIn uvars ist l ++ namesIn uvars ist r              put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))@@ -1691,7 +1704,7 @@  addImpl' :: Bool -> [Name] -> [Name] -> [Name] -> IState -> PTerm -> PTerm addImpl' inpat env infns imp_meths ist ptm-   = mkUniqueNames env [] (ai inpat False (zip env (repeat Nothing)) [] ptm)+   = ai inpat False (zip env (repeat Nothing)) [] (mkUniqueNames env [] ptm)   where     topname = case ptm of                    PRef _ _ n -> n@@ -1701,14 +1714,14 @@     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 topname inpat inpat qq imp_meths ist fc f fc ds [] +        | 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)+    ai inpat qq env ds (PRewrite fc by 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'+         PRewrite fc by l' r' g'     ai inpat qq env ds (PTyped l r)       = let l' = ai inpat qq env ds l             r' = ai inpat qq env ds r in@@ -1742,28 +1755,46 @@       = let f' = ai inpat qq env ds f             as' = map (fmap (ai inpat qq env ds)) as in             mkPApp fc 1 f' as'+    ai inpat qq env ds (PWithApp fc f a)+      = PWithApp fc (ai inpat qq env ds f) (ai inpat qq env ds a)     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 agai inpatn with more scope-        -- information-            PCase fc c' os+        -- leave lhs alone, because they get lifted into a new pattern match+        -- definition which is passed through addImpl again+            PCase fc c' (map aiCase os)+     where+       aiCase (lhs, rhs)+            = (lhs, ai inpat qq (env ++ patnames lhs) ds rhs) +       -- Anything beginning with a lower case letter, not applied,+       -- and no namespace is a pattern variable+       patnames (PApp _ (PRef _ _ f) [])+           | implicitable f = [(f, Nothing)]+       patnames (PRef _ _ f)+           | implicitable f = [(f, Nothing)]+       patnames (PApp _ (PRef _ _ _) args)+           = concatMap patnames (map getTm args)+       patnames (PPair _ _ _ l r) = patnames l ++ patnames r+       patnames (PDPair _ _ _ l t r) = patnames l ++ patnames t ++ patnames r+       patnames (PAs _ _ t) = patnames t+       patnames (PAlternative _ _ ts) = concatMap patnames ts+       patnames _ = []++     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!)+    -- If the name in a lambda is an unapplied data constructor name, do this+    -- as a 'case' instead because we'll expect to match on it     ai inpat qq env ds (PLam fc n nfc ty sc)-      = case lookupDef n (tt_ctxt ist) of-             [] -> 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 inpat qq env ds (PLam fc (sMN 0 "lamp") NoFC ty+      = if canBeDConName n (tt_ctxt ist)+             then ai inpat qq env ds (PLam fc (sMN 0 "lamp") NoFC ty                                      (PCase fc (PRef fc [] (sMN 0 "lamp") )                                         [(PRef fc [] n, sc)]))+             else 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 inpat qq env ds (PLet fc n nfc ty val sc)       = case lookupDef n (tt_ctxt ist) of              [] -> let ty' = ai inpat qq env ds ty@@ -1835,9 +1866,9 @@           vname (UN n) = True -- non qualified           vname _ = False -aiFn topname inpat expat qq imp_meths ist fc f ffc ds as +aiFn topname inpat expat qq imp_meths ist fc f ffc ds as     | f `elem` primNames = Right $ PApp fc (PRef ffc [ffc] f) as-aiFn topname inpat expat qq imp_meths ist fc f ffc ds as +aiFn topname inpat expat qq imp_meths ist fc f ffc ds as           -- This is where namespaces get resolved by adding PAlternative      = do let ns = lookupCtxtName f (idris_implicits ist)           let nh = filter (\(n, _) -> notHidden n) ns@@ -1901,7 +1932,7 @@         case find n imps [] of             Just (tm, imps') ->               PImp p False l n tm : insImpAcc (M.insert n tm pnas) ps given imps'-            Nothing -> +            Nothing ->               PImp p True l n Placeholder :                 insImpAcc (M.insert n Placeholder pnas) ps given imps     insImpAcc pnas (PTacImplicit p l n sc' ty : ps) given imps =@@ -2125,7 +2156,7 @@         | not names && (not (isConName n (tt_ctxt i) ||                              isFnName n (tt_ctxt i)) || tm == Placeholder)             = return [(n, tm)]-    match (PRewrite _ l r _) (PRewrite _ l' r' _)+    match (PRewrite _ by l r _) (PRewrite _ by' l' r' _) | by == by'                                     = do ml <- match' l l'                                          mr <- match' r r'                                          return (ml ++ mr)@@ -2199,17 +2230,20 @@ substMatches :: [(Name, PTerm)] -> PTerm -> PTerm substMatches ms = substMatchesShadow ms [] -substMatchesShadow :: [(Name, PTerm)] -> [Name] -> PTerm -> PTerm-substMatchesShadow [] shs t = t-substMatchesShadow ((n,tm):ns) shs t-   = substMatchShadow n shs tm (substMatchesShadow ns shs t)+-- substMatchesShadow :: [(Name, PTerm)] -> [Name] -> PTerm -> PTerm+-- substMatchesShadow [] shs t = t+-- substMatchesShadow ((n,tm):ns) shs t+--    = substMatchShadow n shs tm (substMatchesShadow ns shs t)  substMatch :: Name -> PTerm -> PTerm -> PTerm substMatch n = substMatchShadow n []  substMatchShadow :: Name -> [Name] -> PTerm -> PTerm -> PTerm-substMatchShadow n shs tm t = sm shs t where-    sm xs (PRef _ _ n') | n == n' = tm+substMatchShadow n shs tm t = substMatchesShadow [(n, tm)] shs t++substMatchesShadow :: [(Name, PTerm)] -> [Name] -> PTerm -> PTerm+substMatchesShadow nmap shs t = sm shs t where+    sm xs (PRef _ _ n) | Just tm <- lookup n nmap = tm     sm xs (PLam fc x xfc t sc) = PLam fc x xfc (sm xs t) (sm xs sc)     sm xs (PPi p x fc t sc)          | x `elem` xs@@ -2220,8 +2254,8 @@     sm xs (PApp f x as) = fullApp $ PApp f (sm xs x) (map (fmap (sm xs)) as)     sm xs (PCase f x as) = PCase f (sm xs x) (map (pmap (sm xs)) as)     sm xs (PIfThenElse fc c t f) = PIfThenElse fc (sm xs c) (sm xs t) (sm xs f)-    sm xs (PRewrite f x y tm) = PRewrite f (sm xs x) (sm xs y)-                                           (fmap (sm xs) tm)+    sm xs (PRewrite f by x y tm) = PRewrite f by (sm xs x) (sm xs y)+                                                 (fmap (sm xs) tm)     sm xs (PTyped x y) = PTyped (sm xs x) (sm xs y)     sm xs (PPair f hls p x y) = PPair f hls p (sm xs x) (sm xs y)     sm xs (PDPair f hls p x t y) = PDPair f hls p (sm xs x) (sm xs t) (sm xs y)@@ -2249,11 +2283,12 @@     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 (PRewrite f by x y tm) = PRewrite f by (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 (PAlternative ms a as) +          = PAlternative (map shadowAlt 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)@@ -2264,6 +2299,10 @@     sm ql (PUnquote tm) = PUnquote (sm (ql - 1) tm)     sm ql x = descend (sm ql) x +    shadowAlt p@(x, oldn) = (update x, update oldn)+    update oldn | n == oldn = n'+                | otherwise = oldn+ -- | 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@@ -2365,7 +2404,7 @@   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+         = return $ PAlternative (ns ++ M.toList nmap) b as   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)
src/Idris/AbsSyntaxTree.hs view
@@ -59,11 +59,15 @@                         liftname :: Name -> Name,                         namespace :: Maybe [String],                         elabFC :: Maybe FC,+                        -- We may, recursively, collect transformations to+                        -- do on the rhs, e.g. rewriting recursive calls to+                        -- functions defined by 'with'+                        rhs_trans :: PTerm -> PTerm,                         rec_elabDecl :: ElabWhat -> ElabInfo -> PDecl ->                                         Idris () }  toplevel :: ElabInfo-toplevel = EInfo [] emptyContext id Nothing Nothing (\_ _ _ -> fail "Not implemented")+toplevel = EInfo [] emptyContext id Nothing Nothing id (\_ _ _ -> fail "Not implemented")  eInfoNames :: ElabInfo -> [Name] eInfoNames info = map fst (params info) ++ M.keys (inblock info)@@ -267,7 +271,8 @@     idris_parserHighlights :: [(FC, OutputAnnotation)], -- ^ Highlighting information from the parser     idris_deprecated :: Ctxt String, -- ^ Deprecated names and explanation     idris_inmodule :: S.Set Name, -- ^ Names defined in current module-    idris_ttstats :: M.Map Term (Int, Term)+    idris_ttstats :: M.Map Term (Int, Term),+    idris_fragile :: Ctxt String -- ^ Fragile names and explanation.    }  -- Required for parsers library, and therefore trifecta@@ -343,6 +348,7 @@               | IBCExport Name               | IBCAutoHint Name Name               | IBCDeprecate Name String+              | IBCFragile Name String   deriving Show  -- | The initial state for the compiler@@ -357,7 +363,7 @@                    [] [] Nothing [] Nothing [] [] Nothing Nothing emptyContext Private False [] Nothing [] []                    (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty                    AutomaticWidth S.empty S.empty [] Nothing Nothing [] [] M.empty [] [] []-                   emptyContext S.empty M.empty+                   emptyContext S.empty M.empty emptyContext   -- | The monad for the main REPL - reading and processing files and updating@@ -754,22 +760,23 @@ !-}  -- | The set of source directives-data Directive = DLib Codegen String |-                 DLink Codegen String |-                 DFlag Codegen String |-                 DInclude Codegen String |-                 DHide Name |-                 DFreeze Name |-                 DAccess Accessibility |-                 DDefault Bool |-                 DLogging Integer |-                 DDynamicLibs [String] |-                 DNameHint Name FC [(Name, FC)] |-                 DErrorHandlers Name FC Name FC [(Name, FC)] |-                 DLanguage LanguageExt |-                 DDeprecate Name String |-                 DAutoImplicits Bool |-                 DUsed FC Name Name+data Directive = DLib Codegen String+               | DLink Codegen String+               | DFlag Codegen String+               | DInclude Codegen String+               | DHide Name+               | DFreeze Name+               | DAccess Accessibility+               | DDefault Bool+               | DLogging Integer+               | DDynamicLibs [String]+               | DNameHint Name FC [(Name, FC)]+               | DErrorHandlers Name FC Name FC [(Name, FC)]+               | DLanguage LanguageExt+               | DDeprecate Name String+               | DFragile Name String+               | DAutoImplicits Bool+               | DUsed FC Name Name  -- | A set of instructions for things that need to happen in IState -- after a term elaboration when there's been reflected elaboration.@@ -1012,6 +1019,7 @@            | PLet FC Name FC PTerm PTerm PTerm -- ^ A let binding (second FC is precise name location)            | PTyped PTerm PTerm -- ^ Term with explicit type            | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x+           | PWithApp FC PTerm PTerm -- ^ Application plus a 'with' argument            | PAppImpl PTerm [ImplicitInfo] -- ^ Implicit argument application (introduced during elaboration only)            | PAppBind FC PTerm [PArg] -- ^ implicitly bound application            | PMatchApp FC Name -- ^ Make an application by type matching@@ -1019,7 +1027,9 @@            | PCase FC PTerm [(PTerm, PTerm)] -- ^ A case expression. Args are source location, scrutinee, and a list of pattern/RHS pairs            | PTrue FC PunInfo -- ^ Unit type..?            | PResolveTC FC -- ^ Solve this dictionary by type class resolution-           | PRewrite FC PTerm PTerm (Maybe PTerm) -- ^ "rewrite" syntax, with optional result type+           | PRewrite FC (Maybe Name) PTerm PTerm (Maybe PTerm)+                  -- ^ "rewrite" syntax, with optional rewriting function+                  -- and optional result type            | PPair FC [FC] PunInfo PTerm PTerm -- ^ A pair (a, b) and whether it's a product type or a pair (solved by elaboration). The list of FCs is its punctuation.            | PDPair FC [FC] PunInfo PTerm PTerm PTerm -- ^ A dependent pair (tm : a ** b) and whether it's a sigma type or a pair that inhabits one (solved by elaboration). The [FC] is its punctuation.            | PAs FC Name PTerm -- ^ @-pattern, valid LHS only@@ -1067,6 +1077,7 @@ mapPTermFC f g (PLet fc n fc' t1 t2 t3)       = PLet (f fc) n (g fc') (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3) mapPTermFC f g (PTyped t1 t2)                 = PTyped (mapPTermFC f g t1) (mapPTermFC f g t2) mapPTermFC f g (PApp fc t args)               = PApp (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)+mapPTermFC f g (PWithApp fc t arg)            = PWithApp (f fc) (mapPTermFC f g t) (mapPTermFC f g arg) mapPTermFC f g (PAppImpl t1 impls)            = PAppImpl (mapPTermFC f g t1) impls mapPTermFC f g (PAppBind fc t args)           = PAppBind (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args) mapPTermFC f g (PMatchApp fc n)               = PMatchApp (f fc) n@@ -1074,7 +1085,7 @@ mapPTermFC f g (PCase fc t cases)             = PCase (f fc) (mapPTermFC f g t) (map (\(l,r) -> (mapPTermFC f g l, mapPTermFC f g r)) cases) mapPTermFC f g (PTrue fc info)                = PTrue (f fc) info mapPTermFC f g (PResolveTC fc)                = PResolveTC (f fc)-mapPTermFC f g (PRewrite fc t1 t2 t3)         = PRewrite (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (fmap (mapPTermFC f g) t3)+mapPTermFC f g (PRewrite fc by t1 t2 t3)      = PRewrite (f fc) by (mapPTermFC f g t1) (mapPTermFC f g t2) (fmap (mapPTermFC f g) t3) mapPTermFC f g (PPair fc hls info t1 t2)      = PPair (f fc) (map g hls) info (mapPTermFC f g t1) (mapPTermFC f g t2) mapPTermFC f g (PDPair fc hls info t1 t2 t3)  = PDPair (f fc) (map g hls) info (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3) mapPTermFC f g (PAs fc n t)                   = PAs (f fc) n (mapPTermFC f g t)@@ -1119,8 +1130,9 @@   mpt (PLam fc n nfc t s)     = PLam fc n nfc (mapPT f t) (mapPT f s)   mpt (PPi p n nfc t s)       = PPi p n nfc (mapPT f t) (mapPT f s)   mpt (PLet fc n nfc ty v s)  = PLet fc n nfc (mapPT f ty) (mapPT f v) (mapPT f s)-  mpt (PRewrite fc t s g)     = PRewrite fc (mapPT f t) (mapPT f s) (fmap (mapPT f) g)+  mpt (PRewrite fc by t s g)  = PRewrite fc by (mapPT f t) (mapPT f s) (fmap (mapPT f) g)   mpt (PApp fc t as)          = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)+  mpt (PWithApp fc t a)       = PWithApp fc (mapPT f t) (mapPT f a)   mpt (PAppBind fc t as)      = PAppBind fc (mapPT f t) (map (fmap (mapPT f)) as)   mpt (PCase fc c os)         = PCase fc (mapPT f c) (map (pmap (mapPT f)) os)   mpt (PIfThenElse fc c t e)  = PIfThenElse fc (mapPT f c) (mapPT f t) (mapPT f e)@@ -1295,7 +1307,7 @@ highestFC (PIfThenElse fc _ _ _)  = Just fc highestFC (PTrue fc _)            = Just fc highestFC (PResolveTC fc)         = Just fc-highestFC (PRewrite fc _ _ _)     = Just fc+highestFC (PRewrite fc _ _ _ _)   = Just fc highestFC (PPair fc _ _ _ _)      = Just fc highestFC (PDPair fc _ _ _ _ _)   = Just fc highestFC (PAs fc _ _)            = Just fc@@ -1515,14 +1527,15 @@                         mut_nesting :: Int,                         dsl_info :: DSL,                         syn_in_quasiquote :: Int,-                        syn_toplevel :: Bool }+                        syn_toplevel :: Bool,+                        withAppAllowed :: Bool }     deriving Show {-! deriving instance NFData SyntaxInfo deriving instance Binary SyntaxInfo !-} -defaultSyntax = Syn [] [] [] [] [] id False False Nothing 0 initDSL 0 True+defaultSyntax = Syn [] [] [] [] [] id False False Nothing 0 initDSL 0 True True  expandNS :: SyntaxInfo -> Name -> Name expandNS syn n@(NS _ _) = n@@ -1840,6 +1853,7 @@             if null shownArgs               then fp               else fp <+> align (vsep (map (prettyArgS d bnd) shownArgs))+    prettySe d p bnd (PWithApp _ f a) = prettySe d p bnd f <+> text "|" <+> prettySe d p bnd a     prettySe d p bnd (PCase _ scr cases) =       align $ kwd "case" <+> prettySe (decD d) startPrec bnd scr <+> kwd "of" <$>       depth d (indent 2 (vsep (map ppcase cases)))@@ -1873,9 +1887,14 @@     prettySe d p bnd (PTrue _ IsType)     = annName unitTy $ text "()"     prettySe d p bnd (PTrue _ IsTerm)     = annName unitCon $ text "()"     prettySe d p bnd (PTrue _ TypeOrTerm) = text "()"-    prettySe d p bnd (PRewrite _ l r _)   =+    prettySe d p bnd (PRewrite _ by l r _)   =       depth d . bracket p startPrec $-      text "rewrite" <+> prettySe (decD d) (startPrec + 1) bnd l <+> text "in" <+> prettySe (decD d) startPrec bnd r+      text "rewrite" <+> prettySe (decD d) (startPrec + 1) bnd l+      <+> (case by of+               Nothing -> empty+               Just fn -> text "using" <+>+                              prettyName True (ppopt_impl ppo) bnd fn) <+>+          text "in" <+> prettySe (decD d) startPrec bnd r     prettySe d p bnd (PTyped l r) =       lparen <> prettySe (decD d) startPrec bnd l <+> colon <+> prettySe (decD d) startPrec bnd r <> rparen     prettySe d p bnd pair@(PPair _ _ pun _ _) -- flatten tuples to the right, like parser@@ -2238,7 +2257,7 @@   size (PIfThenElse fc c t f)         = 1 + sum (map size [c, t, f])   size (PTrue fc _)                   = 1   size (PResolveTC fc)                = 1-  size (PRewrite fc left right _)     = 1 + size left + size right+  size (PRewrite fc by left right _)  = 1 + size left + size right   size (PPair fc _ _ left right)      = 1 + size left + size right   size (PDPair fs _ _ left ty right)  = 1 + size left + size ty + size right   size (PAlternative _ a alts)        = 1 + size alts@@ -2279,13 +2298,13 @@     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 (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 (PAlternative ns a ls)   = map snd ns ++ 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@@ -2310,7 +2329,7 @@     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 (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@@ -2386,7 +2405,7 @@     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 (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@@ -2423,7 +2442,7 @@     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 (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@@ -2458,7 +2477,7 @@     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 (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
src/Idris/CaseSplit.hs view
@@ -157,13 +157,25 @@         patvars _ = []  mergePat :: IState -> PTerm -> PTerm -> Maybe Name -> State MergeState PTerm+mergePat ist orig new t =+    do -- collect user names for name map, by matching user pattern against+       -- the generated pattern+       case matchClause ist orig new of+            Left _ -> return ()+            Right ns -> mapM_ addNameMap ns+       mergePat' ist orig new t+  where+    addNameMap (n, PRef fc _ n') = do ms <- get+                                      put (ms { namemap = ((n', n) : namemap ms) })+    addNameMap _ = return ()+ -- If any names are unified, make sure they stay unified. Always prefer -- user provided name (first pattern)-mergePat ist (PPatvar fc n) new t-  = mergePat ist (PRef fc [] n) new t-mergePat ist old (PPatvar fc n) t-  = mergePat ist old (PRef fc [] n) t-mergePat ist orig@(PRef fc _ n) new@(PRef _ _ n') t+mergePat' ist (PPatvar fc n) new t+  = mergePat' ist (PRef fc [] n) new t+mergePat' ist old (PPatvar fc n) t+  = mergePat' ist old (PRef fc [] n) t+mergePat' ist orig@(PRef fc _ n) new@(PRef _ _ n') t   | isDConName n' (tt_ctxt ist) = do addUpdate n new                                      return new   | otherwise@@ -173,20 +185,20 @@                            return (PRef fc [] x)               Nothing -> do put (ms { namemap = ((n', n) : namemap ms) })                             return (PRef fc [] n)-mergePat ist (PApp _ _ args) (PApp fc f args') t+mergePat' ist (PApp _ _ args) (PApp fc f args') t       = do newArgs <- zipWithM mergeArg args (zip args' (argTys ist f))            return (PApp fc f newArgs)    where mergeArg x (y, t)-              = do tm' <- mergePat ist (getTm x) (getTm y) t+              = do tm' <- mergePat' ist (getTm x) (getTm y) t                    case x of                         (PImp _ _ _ _ _) ->                              return (y { machine_inf = machine_inf x,                                          getTm = tm' })                         _ -> return (y { getTm = tm' })-mergePat ist (PRef fc _ n) tm ty = do tm <- tidy ist tm ty-                                      addUpdate n tm-                                      return tm-mergePat ist x y t = return y+mergePat' ist (PRef fc _ n) tm ty = do tm <- tidy ist tm ty+                                       addUpdate n tm+                                       return tm+mergePat' ist x y t = return y  mergeUserImpl :: PTerm -> PTerm -> PTerm mergeUserImpl x y = x@@ -337,8 +349,8 @@     updatePat start n tm (c:rest) = c : updatePat (not ((isAlphaNum c) || c == '_')) n tm rest      addBrackets tm | ' ' `elem` tm-                   , not (isPrefixOf "(" tm)-                   , not (isSuffixOf ")" tm) = "(" ++ tm ++ ")"+                   , not (isPrefixOf "(" tm && isSuffixOf ")" tm) +                       = "(" ++ tm ++ ")"                    | otherwise = tm
src/Idris/CmdOptions.hs view
@@ -28,7 +28,7 @@                           )                   return $ preProcOpts opts []                where-                 idrisHeader = PP.hsep [PP.text "Idris version", PP.text ver, PP.text ", (C) The Idris Community 2014"]+                 idrisHeader = PP.hsep [PP.text "Idris version", PP.text ver, PP.text ", (C) The Idris Community 2016"]                  idrisProgDesc = PP.vsep [PP.empty,                                           PP.text "Idris is a general purpose pure functional programming language with dependent",                                           PP.text "types. Dependent types allow types to be predicated on values, meaning that",@@ -37,19 +37,19 @@                                           PP.text "and ML.",                                           PP.empty,                                           PP.vsep $ map (\x -> PP.indent 4 (PP.text x)) [-                                            "+ 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"+                                              "+ Full dependent types with dependent pattern matching",+                                              "+ Simple case expressions, where-clauses, with-rule",+                                              "+ Pattern matching let- and lambda-bindings",+                                              "+ Overloading via Interfaces (Type class-like), 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",+                                              "+ Hugs style interactive environment"                                             ]]                  idrisFooter = PP.vsep [PP.text "It is important to note that Idris is first and foremost a research tool",                                         PP.text "and project. Thus the tooling provided and resulting programs created",@@ -76,14 +76,15 @@  parseFlags :: Parser [Opt] parseFlags = many $-  flag' NoBanner (long "nobanner" <> help "Suppress the banner")-  <|> flag' Quiet (short 'q' <> long "quiet" <> help "Quiet verbosity")+      flag' NoBanner (long "nobanner" <> help "Suppress the banner")+  <|> flag' Quiet    (short 'q' <> long "quiet" <> help "Quiet verbosity")+   -- IDE Mode Specific Flags-  <|> flag' Idemode (long "ide-mode" <> help "Run the Idris REPL with machine-readable syntax")+  <|> flag' Idemode       (long "ide-mode"        <> help "Run the Idris REPL with machine-readable syntax")   <|> flag' IdemodeSocket (long "ide-mode-socket" <> help "Choose a socket for IDE mode to listen on")-  <|> flag' Idemode (long "ideslave" <> help "Deprecated version of --ide-mode") -- TODO: Remove in v0.9.18-  <|> flag' IdemodeSocket (long "ideslave-socket" <> help "Deprecated version of --ide-mode-socket") -- TODO: Remove in v0.9.18+   <|> (Client <$> strOption (long "client"))+   -- Logging Flags   <|> (OLogging <$> option auto (long "log" <> metavar "LEVEL" <> help "Debugging log level"))   <|> (OLogCats <$> option (str >>= parseLogCats)@@ -91,71 +92,100 @@                          <> metavar "CATS"                          <> help "Colon separated logging categories. Use --listlogcats to see list.")) -  -- Turn off Certain libraries.+  -- Turn off things   <|> flag' NoBasePkgs (long "nobasepkgs" <> help "Do not use the given base package")-  <|> flag' NoPrelude (long "noprelude" <> help "Do not use the given prelude")+  <|> flag' NoPrelude  (long "noprelude"  <> help "Do not use the given prelude")   <|> flag' NoBuiltins (long "nobuiltins" <> help "Do not use the builtin functions")-  <|> flag' NoREPL (long "check" <> help "Typecheck only, don't start the REPL")++  <|> flag' NoREPL     (long "check"      <> help "Typecheck only, don't start the REPL")+   <|> (Output <$> strOption (short 'o' <> long "output" <> metavar "FILE" <> help "Specify output file"))+   --   <|> flag' TypeCase (long "typecase")-  <|> flag' Interface (long "interface" <> help "Generate interface files from ExportLists")-  <|> flag' TypeInType (long "typeintype" <> help "Turn off Universe checking")-  <|> flag' DefaultTotal (long "total" <> help "Require functions to be total by default")+  <|> flag' Interface      (long "interface"   <> help "Generate interface files from ExportLists")+  <|> flag' TypeInType     (long "typeintype"  <> help "Turn off Universe checking")+  <|> flag' DefaultTotal   (long "total"       <> help "Require functions to be total by default")   <|> flag' DefaultPartial (long "partial")-  <|> flag' WarnPartial (long "warnpartial" <> help "Warn about undeclared partial functions")-  <|> flag' WarnReach (long "warnreach" <> help "Warn about reachable but inaccessible arguments")-  <|> flag' NoCoverage (long "nocoverage")-  <|> flag' ErrContext (long "errorcontext")+  <|> flag' WarnPartial    (long "warnpartial" <> help "Warn about undeclared partial functions")+  <|> flag' WarnReach      (long "warnreach"   <> help "Warn about reachable but inaccessible arguments")+  <|> flag' NoCoverage     (long "nocoverage")+  <|> flag' ErrContext     (long "errorcontext")+   -- Show things-  <|> flag' ShowLoggingCats (long "listlogcats"          <> help "Display logging categories")-  <|> flag' ShowLibs        (long "link"                 <> help "Display link flags")-  <|> flag' ShowPkgs        (long "listlibs"             <> help "Display installed libraries")-  <|> flag' ShowLibdir      (long "libdir"               <> help "Display library directory")-  <|> flag' ShowIncs        (long "include"              <> help "Display the includes flags")-  <|> flag' Verbose         (short 'V' <> long "verbose" <> help "Loud verbosity")+  <|> flag' ShowLoggingCats (long "listlogcats" <> help "Display logging categories")+  <|> flag' ShowLibs        (long "link"        <> help "Display link flags")+  <|> flag' ShowPkgs        (long "listlibs"    <> help "Display installed libraries")+  <|> flag' ShowLibdir      (long "libdir"      <> help "Display library directory")+  <|> flag' ShowIncs        (long "include"     <> help "Display the includes flags")++  <|> flag' Verbose (short 'V' <> long "verbose" <> help "Loud verbosity")+   <|> (IBCSubDir <$> strOption (long "ibcsubdir" <> metavar "FILE" <> help "Write IBC files into sub directory"))   <|> (ImportDir <$> strOption (short 'i' <> long "idrispath" <> help "Add directory to the list of import paths"))+   <|> flag' WarnOnly (long "warn")-  <|> (Pkg <$> strOption (short 'p' <> long "package" <> help "Add package as a dependency"))++  <|> (Pkg  <$> strOption (short 'p' <> long "package" <> help "Add package as a dependency"))   <|> (Port <$> strOption (long "port" <> metavar "PORT" <> help "REPL TCP port"))+   -- Package commands-  <|> (PkgBuild <$> strOption (long "build" <> metavar "IPKG" <> help "Build package"))-  <|> (PkgInstall <$> strOption (long "install" <> metavar "IPKG" <> help "Install package"))-  <|> (PkgREPL <$> strOption (long "repl" <> metavar "IPKG" <> help "Launch REPL, only for executables"))-  <|> (PkgClean <$> strOption (long "clean" <> metavar "IPKG" <> help "Clean package"))-  <|> (PkgMkDoc <$> strOption (long "mkdoc" <> metavar "IPKG" <> help "Generate IdrisDoc for package"))-  <|> (PkgCheck <$> strOption (long "checkpkg" <> metavar "IPKG" <> help "Check package only"))-  <|> (PkgTest <$> strOption (long "testpkg" <> metavar "IPKG" <> help "Run tests for package"))+  <|> (PkgBuild   <$> strOption (long "build"    <> metavar "IPKG" <> help "Build package"))+  <|> (PkgInstall <$> strOption (long "install"  <> metavar "IPKG" <> help "Install package"))+  <|> (PkgREPL    <$> strOption (long "repl"     <> metavar "IPKG" <> help "Launch REPL, only for executables"))+  <|> (PkgClean   <$> strOption (long "clean"    <> metavar "IPKG" <> help "Clean package"))+  <|> (PkgMkDoc   <$> strOption (long "mkdoc"    <> metavar "IPKG" <> help "Generate IdrisDoc for package"))+  <|> (PkgCheck   <$> strOption (long "checkpkg" <> metavar "IPKG" <> help "Check package only"))+  <|> (PkgTest    <$> strOption (long "testpkg"  <> metavar "IPKG" <> help "Run tests for package"))+   -- Misc options   <|> (BCAsm <$> strOption (long "bytecode"))-  <|> flag' (OutputTy Raw) (short 'S' <> long "codegenonly" <> help "Do no further compilation of code generator output")-  <|> flag' (OutputTy Object) (short 'c' <> long "compileonly" <> help "Compile to object files rather than an executable")-  <|> flag' (OutputTy MavenProject) (long "mvn" <> help "Create a maven project (for Java codegen)")++  <|> flag' (OutputTy Raw)          (short 'S' <> long "codegenonly" <> help "Do no further compilation of code generator output")+  <|> flag' (OutputTy Object)       (short 'c' <> long "compileonly" <> help "Compile to object files rather than an executable")+   <|> (DumpDefun <$> strOption (long "dumpdefuns"))   <|> (DumpCases <$> strOption (long "dumpcases"))-  <|> ((\s -> UseCodegen $ parseCodegen s) <$> strOption (long "codegen" <> metavar "TARGET" <> help "Select code generator: C, Javascript, Node and bytecode are bundled with Idris"))-  <|> (CodegenArgs <$> strOption (long "cg-opt" <> metavar "ARG" <> help "Arguments to pass to code generator"))++  <|> ((\s -> UseCodegen $ parseCodegen s) <$> strOption (long "codegen"+                                                       <> metavar "TARGET"+                                                       <> help "Select code generator: C, Javascript, Node and bytecode are bundled with Idris"))+  <|> (CodegenArgs <$> strOption (long "cg-opt"+                               <> metavar "ARG"+                               <> help "Arguments to pass to code generator"))+   <|> (EvalExpr <$> strOption (long "eval" <> short 'e' <> metavar "EXPR" <> help "Evaluate an expression without loading the REPL"))+   <|> flag' (InterpretScript "Main.main") (long "execute" <> help "Execute as idris")-  <|> (InterpretScript <$> strOption (long "exec" <> metavar "EXPR" <> help "Execute as idris"))-  <|> ((\s -> Extension $ getExt s) <$> strOption (long "extension" <> short 'X' <> metavar "EXT" <> help "Turn on language extension (TypeProviders or ErrorReflection)"))+  <|> (InterpretScript <$> strOption      (long "exec" <> metavar "EXPR" <> help "Execute as idris"))++  <|> ((\s -> Extension $ getExt s) <$> strOption (long "extension"+                                                <> short 'X'+                                                <> metavar "EXT"+                                                <> help "Turn on language extension (TypeProviders or ErrorReflection)"))+   -- Optimisation Levels   <|> flag' (OptLevel 3) (long "O3")   <|> flag' (OptLevel 2) (long "O2")   <|> flag' (OptLevel 1) (long "O1")   <|> flag' (OptLevel 0) (long "O0")+   <|> flag' (AddOpt PETransform) (long "partial-eval")   <|> flag' (RemoveOpt PETransform) (long "no-partial-eval" <> help "Switch off partial evaluation, mainly for debugging purposes")+   <|> (OptLevel <$> option auto (short 'O' <> long "level"))-  <|> (TargetTriple <$> strOption (long "target" <> metavar "TRIPLE" <> help "Select target triple (for llvm codegen)"))-  <|> (TargetCPU <$> strOption (long "cpu" <> metavar "CPU" <> help "Select target CPU e.g. corei7 or cortex-m3 (for LLVM codegen)"))++  <|> (TargetTriple <$> strOption (long "target" <> metavar "TRIPLE" <> help "If supported the codegen will target the named triple."))+  <|> (TargetCPU    <$> strOption (long "cpu"    <> metavar "CPU"    <> help "If supported the codegen will target the named CPU e.g. corei7 or cortex-m3"))+   -- Colour Options-  <|> flag' (ColourREPL True) (long "colour" <> long "color" <> help "Force coloured output")+  <|> flag' (ColourREPL True)  (long "colour"   <> long "color"   <> help "Force coloured output")   <|> flag' (ColourREPL False) (long "nocolour" <> long "nocolor" <> help "Disable coloured output")    <|> (UseConsoleWidth <$> option (str >>= parseConsoleWidth) (long "consolewidth" <> metavar "WIDTH" <> help "Select console width: auto, infinite, nat"))+   <|> flag' DumpHighlights (long "highlight" <> help "Emit source code highlighting")-  <|> flag' NoElimDeprecationWarnings (long "no-elim-deprecation-warnings" <> help "Disable deprecation warnings for %elim")++  <|> flag' NoElimDeprecationWarnings      (long "no-elim-deprecation-warnings"   <> help "Disable deprecation warnings for %elim")   <|> flag' NoOldTacticDeprecationWarnings (long "no-tactic-deprecation-warnings" <> help "Disable deprecation warnings for the old tactic sublanguage")    where
src/Idris/Core/CaseTree.hs view
@@ -244,7 +244,7 @@                                             _ -> True) cs)           where  sc' tc defcase phase fc []-                 = return $ CaseDef [] (UnmatchedCase "No pattern clauses") []+                 = return $ CaseDef [] (UnmatchedCase (show fc ++ ":No pattern clauses")) []  sc' tc defcase phase fc cs       = let proj       = phase == RunTime             vnames     = fstT (head cs)
src/Idris/Core/Evaluate.hs view
@@ -228,10 +228,10 @@     -- returns 'True' if the function should block     -- normal evaluation should return false     blockSimplify (CaseInfo inl always dict) n stk-       | RunTT `elem` opts+       | runtime            = if always then False                        else not (inl || dict) || elem n stk-       | Simplify `elem` opts+       | simpl            = (not (inl || dict) || elem n stk)              || (n == sUN "prim__syntactic_eq")        | otherwise = False@@ -246,11 +246,11 @@       | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty)       | otherwise          = do (u, ntimes) <- usable spec n ntimes_in-              if u then+              let red = u && (tcReducible n ctxt || spec || atRepl || runtime+                                || sUN "assert_total" `elem` stk)+              if red then                do let val = lookupDefAcc n (spec || atRepl || runtime) ctxt                   case val of-                    [(Function _ tm, _)] | sUN "assert_total" `elem` stk ->-                           ev ntimes (n:stk) True env tm                     [(Function _ tm, Public)] ->                            ev ntimes (n:stk) True env tm                     [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty@@ -370,11 +370,13 @@                             _ -> return $ unload env f args       | otherwise          = do (u, ntimes) <- usable spec n ntimes_in-              if u then+              let red = u && (tcReducible n ctxt || spec || atRepl || runtime+                                || sUN "assert_total" `elem` stk)+              if red then                  do let val = lookupDefAcc n (spec || atRepl || runtime) ctxt                     case val of                       [(CaseOp ci _ _ _ _ cd, acc)]-                           | acc == Public || acc == Hidden || sUN "assert_total" `elem` stk ->+                           | acc == Public || acc == Hidden ->                            -- unoptimised version                        let (ns, tree) = getCases cd in                          if blockSimplify ci n stk@@ -1087,6 +1089,14 @@ lookupTotalExact :: Name -> Context -> Maybe Totality lookupTotalExact n ctxt = fmap mkt $ lookupCtxtExact n (definitions ctxt)   where mkt (d, a, t, m) = t++-- Check if a name is reducible in the type checker. Partial definitions+-- are not reducible (so treated as a constant)+tcReducible :: Name -> Context -> Bool+tcReducible n ctxt = case lookupTotalExact n ctxt of+                          Nothing -> True+                          Just (Partial _) -> False+                          _ -> True  lookupMetaInformation :: Name -> Context -> [MetaInformation] lookupMetaInformation n ctxt = map mkm $ lookupCtxt n (definitions ctxt)
src/Idris/Core/TT.hs view
@@ -28,7 +28,7 @@                      TermSize(..), TextFormatting(..), TT(..),Type(..), TypeInfo(..),                      UConstraint(..), UCs(..), UExp(..), Universe(..),                      addAlist, addBinder, addDef, allTTNames, arity, bindAll,-                     bindingOf, bindTyArgs, constDocs, constIsType, deleteDefExact,+                     bindingOf, bindTyArgs, caseName, constDocs, constIsType, deleteDefExact,                      discard, emptyContext, emptyFC, explicitNames, fc_end, fc_fname,                      fc_start, fcIn, fileFC, finalise, fmapMB, forget, forgetEnv,                      freeNames, getArgTys, getRetTy, implicitable, instantiate,@@ -73,6 +73,8 @@ import Data.Binary hiding (get, put) import Foreign.Storable (sizeOf) +import Numeric.IEEE (IEEE (identicalIEEE))+ import Util.Pretty hiding (Str)  data Option = TTypeInTType@@ -370,8 +372,11 @@     show (Msg s) = s     show (InternalMsg s) = "Internal error: " ++ show s     show (CantUnify rcv l r e sc i) = "CantUnify " ++ show rcv ++ " " ++-                                         show l ++ " " ++ show r ++ " " +++                                         show l ++ " and " ++ show r ++ " " ++                                          show e ++ " in " ++ show sc ++ " " ++ show i+    show (CantConvert l r sc) = "CantConvert " +++                                         show l ++ " and " ++ show r ++ " " +++                                         " in " ++ show sc     show (CantSolveGoal g _) = "CantSolve " ++ show g     show (Inaccessible n) = show n ++ " is not an accessible pattern variable"     show (UnknownImplicit n f) = show n ++ " is not an implicit argument of " ++ show f@@ -393,7 +398,7 @@     show (NotEquality _ _) = "NotEquality"     show (TooManyArguments _) = "TooManyArguments"     show (CantIntroduce _) = "CantIntroduce"-    show (NoSuchVariable _) = "NoSuchVariable"+    show (NoSuchVariable n) = "NoSuchVariable " ++ show n     show (WithFnType _) = "WithFnType"     show (NoTypeDecl _) = "NoTypeDecl"     show (NotInjective _ _ _) = "NotInjective"@@ -478,6 +483,11 @@ sMN :: Int -> String -> Name sMN i s = MN i (txt s) +caseName (SN (CaseN _ _)) = True+caseName (NS n _) = caseName n+caseName _ = False++ {-! deriving instance Binary Name deriving instance NFData Name@@ -708,7 +718,30 @@            | AType ArithTy | StrType            | WorldType | TheWorld            | VoidType | Forgot-  deriving (Eq, Ord, Data, Typeable)+  deriving (Ord, Data, Typeable)++-- We need to compare Double using bit-pattern identity rather than+-- Haskell's Eq, which equates 0.0 and -0.0, leading to a+-- contradiction in the type theory. Bit-pattern identity will also+-- avoid similar problems for NaNs.+instance Eq Const where+  I i       == I j       = i == j+  BI i      == BI j      = i == j+  Fl i      == Fl j      = identicalIEEE i j+  Ch i      == Ch j      = i == j+  Str i     == Str j     = i == j+  B8 i      == B8 j      = i == j+  B16 i     == B16 j     = i == j+  B32 i     == B32 j     = i == j+  B64 i     == B64 j     = i == j+  AType i   == AType j   = i == j+  StrType   == StrType   = True+  WorldType == WorldType = True+  TheWorld  == TheWorld  = True+  VoidType  == VoidType  = True+  Forgot    == Forgot    = True+  _         == _         = False+ {-! deriving instance Binary Const deriving instance NFData Const@@ -1002,6 +1035,7 @@ instance TermSize (TT Name) where     termsize n (P _ n' _)        | n' == n = 1000000 -- recursive => really big+       | caseName n' = 1000000 -- case, not safe to inline for termination check        | otherwise = 1     termsize n (V _) = 1     -- for `Bind` terms, we can erroneously declare a term
src/Idris/Core/Unify.hs view
@@ -529,13 +529,19 @@                 (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' env False bnames ax' ay'+                    -- Don't normalise if we don't have to+                    ha <- uplus (un' env False bnames (substNames hf ax) +                                                      (substNames hf ay))+                                (un' env False bnames ax' ay')                     sc 1                     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' env False bnames fx' fy'+                    -- Don't normalise if we don't have to+                    hf <- uplus (un' env False bnames (substNames ha fx)+                                                      (substNames ha fy))+                                (un' env False bnames fx' fy')                     sc 1                     combine env bnames hf ha)        | otherwise = unifyTmpFail appx appy@@ -550,14 +556,6 @@             checkHeads (P (TCon _ _) x _) (P (DCon _ _ _) y _)                 = unifyFail appx appy             checkHeads _ _ = return []--            unArgs as [] [] = return as-            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' 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
src/Idris/Coverage.hs view
@@ -409,6 +409,7 @@                             do t' <- if AssertTotal `elem` opts                                         then return $ Total []                                         else calcTotality fc n pats+                               logCoverage 2 $ "Set to " ++ show t'                                setTotality n t'                                addIBC (IBCTotal n t')                                return t'@@ -458,20 +459,6 @@                               _ -> []          when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n          t <- checkTotality [] fc n-         let acc = case lookupDefAccExact n False (tt_ctxt i) of-                        Just (n, a) -> a-                        _ -> Public-         case t of-              -- if it's not total, it can't reduce, to keep-              -- typechecking decidable.-              -- So if it's currently public export, set it as-              -- export instead.-              p@(Partial _) -> do let newacc = max Frozen acc-                                  setAccessibility n newacc-                                  addIBC (IBCAccess n newacc)-                                  logCoverage 5 $ "Set to " ++ show newacc ++ ":"-                                               ++ show n ++ show p-              _ -> return ()          return t  @@ -494,7 +481,7 @@              let (args, sc) = cases_totcheck cd in                do logCoverage 2 $ "Building SCG for " ++ show n ++ " from\n"                                 ++ show pats ++ "\n" ++ show sc-                  let newscg = buildSCG' ist (rights pats) args+                  let newscg = buildSCG' ist n (rights pats) args                   logCoverage 5 $ "SCG is: " ++ show newscg                   addToCG n ( cg { scg = newscg } )            _ -> return () -- CG comes from a type declaration only@@ -513,49 +500,121 @@ delazy' all (Bind n b sc) = Bind n (fmap (delazy' all) b) (delazy' all sc) delazy' all t = t -data Guardedness = Toplevel | Unguarded | Guarded+data Guardedness = Toplevel | Unguarded | Guarded | Delayed   deriving Show -buildSCG' :: IState -> [(Term, Term)] -> [Name] -> [SCGEntry]-buildSCG' ist pats args = nub $ concatMap scgPat pats where+buildSCG' :: IState -> Name -> [(Term, Term)] -> [Name] -> [SCGEntry]+buildSCG' ist topfn pats args = nub $ concatMap scgPat pats where   scgPat (lhs, rhs) = let lhs' = delazy lhs                           rhs' = delazy rhs                           (f, pargs) = unApply (dePat lhs') in-                            findCalls Toplevel (dePat rhs') (patvars lhs') pargs+                            findCalls [] Toplevel (dePat rhs') (patvars lhs') +                                      (zip pargs [0..]) -  findCalls guarded ap@(App _ f a) pvs pargs+  findCalls cases Delayed ap@(P _ n _) pvs args+     | n == topfn = []+  findCalls cases guarded ap@(App _ f a) pvs pargs      -- under a call to "assert_total", don't do any checking, just believe      -- that it is total.      | (P _ (UN at) _, [_, _]) <- unApply ap,        at == txt "assert_total" = []-     -- under a call to "Delay LazyCodata", don't do any checking of the-     -- immediate call, as long as the call is guarded.-     -- Then check its arguments+     -- under a guarded call to "Delay LazyCodata", we are 'Delayed', so don't+     -- check under guarded constructors.      | (P _ (UN del) _, [_,_,arg]) <- unApply ap,        Guarded <- guarded,-       del == txt "Delay"-           = let (capp, args) = unApply arg in-                 concatMap (\x -> findCalls guarded x pvs pargs) args+       del == txt "Delay" +           = findCalls cases Delayed arg pvs pargs+     | (P _ n _, args) <- unApply ap,+       Delayed <- guarded,+       n == topfn -- Under a delayed recursive call to the top level function,+                  -- just check the arguments+           = concatMap (\x -> findCalls cases Unguarded x pvs pargs) args+     | (P _ n _, args) <- unApply ap,+       Delayed <- guarded,+       isConName n (tt_ctxt ist)+           = -- Still under a 'Delay' and constructor guarded, so check +             -- just the arguments to the constructor, remaining Delayed+             concatMap (\x -> findCalls cases guarded x pvs pargs) args+     | (P _ n _, args) <- unApply ap,+       caseName n && n /= topfn,+       notPartial (lookupTotalExact n (tt_ctxt ist))+       -- case block - look inside the block, as long as it was covering+       -- (i.e. not currently set at Partial) to get a more accurate size+       -- change result from the top level patterns (also to help pass+       -- information through from guarded corecursion accurately)+       = concatMap (\x -> findCalls cases Unguarded x pvs pargs) args +++             if n `notElem` cases+                then findCallsCase (n : cases) guarded n args pvs pargs+                else []      | (P _ n _, args) <- unApply ap+        -- Ordinary call, not under a delay. +        -- If n is a constructor, set 'args' as Guarded         = let nguarded = case guarded of                               Unguarded -> Unguarded-                              _ -> if isConName n (tt_ctxt ist)+                              x -> if isConName n (tt_ctxt ist)                                       then Guarded                                       else Unguarded in               mkChange n args pargs ++-                 concatMap (\x -> findCalls nguarded x pvs pargs) args-  findCalls guarded (App _ f a) pvs pargs-        = findCalls Unguarded f pvs pargs ++ findCalls Unguarded a pvs pargs-  findCalls guarded (Bind n (Let t v) e) pvs pargs-        = findCalls Unguarded t pvs pargs ++-          findCalls Unguarded v pvs pargs ++ findCalls guarded e (n : pvs) pargs-  findCalls guarded (Bind n t e) pvs pargs-        = findCalls Unguarded (binderTy t) pvs pargs ++-          findCalls guarded e (n : pvs) pargs-  findCalls guarded (P _ f _ ) pvs pargs+                 concatMap (\x -> findCalls cases nguarded x pvs pargs) args+    where notPartial (Just (Partial NotCovering)) = False+          notPartial _ = True+  findCalls cases guarded (App _ f a) pvs pargs+        = findCalls cases Unguarded f pvs pargs ++ findCalls cases Unguarded a pvs pargs+  findCalls cases guarded (Bind n (Let t v) e) pvs pargs+        = findCalls cases Unguarded t pvs pargs +++          findCalls cases Unguarded v pvs pargs ++ findCalls cases guarded e (n : pvs) pargs+  findCalls cases guarded (Bind n t e) pvs pargs+        = findCalls cases Unguarded (binderTy t) pvs pargs +++          findCalls cases guarded e (n : pvs) pargs+  findCalls cases guarded (P _ f _ ) pvs pargs       | not (f `elem` pvs) = [(f, [])]-  findCalls _ _ _ _ = []+  findCalls _ _ _ _ _ = [] +  -- Assumption is that names are preserved in the case block (shadowing+  -- dealt with by the elaborator) so we can just assume the top level names+  -- are okay for building the size change+  findCallsCase cases guarded n args pvs pargs+      = case lookupDefExact n (tt_ctxt ist) of+           Just (CaseOp _ _ _ pats _ cd) -> +                concatMap (fccPat cases pvs pargs args guarded) (rights pats)+           Nothing -> []++  fccPat cases pvs pargs args g (lhs, rhs) +      = let lhs' = delazy lhs+            rhs' = delazy rhs+            (f, pargs_case) = unApply (dePat lhs') +            -- pargs is a pair of a term, and the argument position that+            -- term appears in. If any of the arguments to the case block+            -- are also on the lhs, we also want those patterns to appear+            -- in the parg list so that we'll spot patterns which are+            -- smaller than then+            newpargs = newPArg args pargs +            -- Now need to update the rhs of the case with the names in the+            -- outer definition: In rhs', wherever we see what's in pargs_case,+            -- replace it with the corresponding thing in pargs+            csubs = zip pargs_case args+            newrhs = doCaseSubs csubs (dePat rhs')+            pargs' = pargs ++ addPArg newpargs pargs_case in+               findCalls cases g newrhs pvs pargs'+    where+      doCaseSubs [] tm = tm+      doCaseSubs ((x, x') : cs) tm +           = doCaseSubs (subIn x x' cs) (substTerm x x' tm)+      +      subIn x x' [] = []+      subIn x x' ((l, r) : cs) +          = (substTerm x x' l, substTerm x x' r) : subIn x x' cs++  addPArg (Just (t, i) : ts) (t' : ts') = (t', i) : addPArg ts ts'+  addPArg (Nothing : ts) (t' : ts') = addPArg ts ts'+  addPArg _ _ = []++  newPArg :: [Term] -> [(Term, Int)] -> [Maybe (Term, Int)]+  newPArg (t : ts) pargs = case lookup t pargs of+                                Just i -> Just (t, i) : newPArg ts pargs+                                Nothing -> Nothing : newPArg ts pargs+  newPArg [] pargs = []+   expandToArity n args      = case lookupTy n (tt_ctxt ist) of             [ty] -> expand 0 (normalise (tt_ctxt ist) [] ty) args@@ -567,21 +626,21 @@   mkChange n args pargs = [(n, expandToArity n (sizes args))]     where       sizes [] = []-      sizes (a : as) = checkSize a pargs 0 : sizes as+      sizes (a : as) = checkSize a pargs : sizes as        -- find which argument in pargs <a> is smaller than, if any-      checkSize a (p : ps) i+      checkSize a ((p, i) : ps)           | a == p = Just (i, Same)           | (P _ (UN as) _, [_,_,arg,_]) <- unApply a,             as == txt "assert_smaller" && arg == p                   = Just (i, Smaller)           | smaller Nothing a (p, Nothing) = Just (i, Smaller)-          | otherwise = checkSize a ps (i + 1)-      checkSize a [] i = Nothing+          | otherwise = checkSize a ps +      checkSize a [] = Nothing -      -- the smaller thing we find must be the same type as <a>, and-      -- not be coinductive - so carry the type of the constructor we've-      -- gone under.+      -- the smaller thing we find must be defined in the same group of mutally+      -- defined types as <a>, and not be coinductive - so carry the type of+      -- the constructor we've gone under.        smaller (Just tyn) a (t, Just tyt)          | a == t = isInductive (fst (unApply (getRetTy tyn)))@@ -601,10 +660,10 @@                        Just ty -> delazy (normalise (tt_ctxt ist) [] ty) -- must exist        isInductive (P _ nty _) (P _ nty' _) =-          let co = case lookupCtxt nty (idris_datatypes ist) of-                        [TI _ x _ _ _] -> x-                        _ -> False in-              nty == nty' && not co+          let (co, muts) = case lookupCtxt nty (idris_datatypes ist) of+                                [TI _ x _ _ muts] -> (x, muts)+                                _ -> (False, []) in+              (nty == nty' || any (== nty') muts) && not co       isInductive _ _ = False    dePat (Bind x (PVar ty) sc) = dePat (instantiate (P Bound x ty) sc)@@ -627,9 +686,10 @@                   -- thread, then the function terminates                   -- also need to checks functions called are all total                   -- (Unchecked is okay as we'll spot problems here)-                  let tot = map (checkMP ist (getArity ist n)) ms+                  let tot = map (checkMP ist n (getArity ist n)) ms                   logCoverage 4 $ "Generated " ++ show (length tot) ++ " paths"-                  logCoverage 6 $ "Paths for " ++ show n ++ " yield " ++ (show tot)+                  logCoverage 5 $ "Paths for " ++ show n ++ " yield " ++ +                       (showSep "\n" (map show (zip ms tot)))                   return (noPartial tot)        [] -> do logCoverage 5 $ "No paths for " ++ show n                 return Unchecked@@ -652,20 +712,13 @@                     _ -> [ reverse ((nextf, args) : path) ]            | otherwise = [ reverse ((nextf, args) : path) ] ---     do (nextf, args) <- cg---          if ((nextf, args) `elem` path)---             then return (reverse ((nextf, args) : path))---             else case lookupCtxt nextf (idris_callgraph ist) of---                     [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)---                     _ -> return (reverse ((nextf, args) : path))- -- If any route along the multipath leads to infinite descent, we're fine. -- Try a route beginning with every argument. --   If we reach a point we've been to before, but with a smaller value, --   that means there is an infinitely descending path from that argument. -checkMP :: IState -> Int -> MultiPath -> Totality-checkMP ist i mp = if i > 0+checkMP :: IState -> Name -> Int -> MultiPath -> Totality+checkMP ist topfn i mp = if i > 0                      then let paths = (map (tryPath 0 [] mp) [0..i-1]) in --                               trace ("Paths " ++ show paths) $                                collapse paths@@ -675,6 +728,8 @@            = let res = tryPath d path mp arg in                  trace (show mp ++ "\n" ++ show arg ++ " " ++ show res) res +    mkBig (e, d) = (e, 10000)+     tryPath :: Int -> [((SCGEntry, Int), Int)] -> MultiPath -> Int -> Totality     tryPath desc path [] _ = Total [] --     tryPath desc path ((UN "believe_me", _) : _) arg@@ -682,17 +737,18 @@     -- if we get to a constructor, it's fine as long as it's strictly positive     tryPath desc path ((f, _) : es) arg         | [TyDecl (DCon _ _ _) _] <- lookupDef f (tt_ctxt ist)-            = case lookupTotal f (tt_ctxt ist) of-                   [Total _] -> Unchecked -- okay so far-                   [Partial _] -> Partial (Other [f])-                   x -> error $ "CAN'T HAPPEN: " ++ show x ++ " for " ++ show f+            = case lookupTotalExact f (tt_ctxt ist) of+                   Just (Total _) -> Unchecked -- okay so far+                   Just (Partial _) -> Partial (Other [f])+                   x -> Unchecked -- An error elsewhere, set as Unchecked to make+                                  -- some progress         | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)             = Total []     tryPath desc path (e@(f, args) : es) arg         | e `elem` es && allNothing args = Partial (Mutual [f])     tryPath desc path (e@(f, nextargs) : es) arg         | Just d <- lookup (e, arg) path-            = if desc > 0+            = if desc - d > 0 -- Now lower than when we were last here                    then -- trace ("Descent " ++ show (desc - d) ++ " "                         --      ++ show (path, e)) $                         Total []@@ -701,21 +757,15 @@            && not (f `elem` map fst es)               = Partial (Mutual (map (fst . fst . fst) path ++ [f]))         | [Unchecked] <- lookupTotal f (tt_ctxt ist) =-            let argspos = case collapseNothing (zip nextargs [0..]) of-                               [] -> [(Nothing, 0)]-                               x -> x---               trace (show (argspos, nextargs, path)) $+            let argspos = zip nextargs [0..]                 pathres =                   do (a, pos) <- argspos                      case a of-                        Nothing -> -- don't know, but if the-                                   -- rest definitely terminates without-                                   -- any cycles with route so far,-                                   -- then we might yet be total-                            case collapse (map (tryPath 0 (((e, arg), 0):path) es)-                                          [0..length nextargs - 1]) of-                                Total _ -> return Unchecked-                                x -> return x+                        Nothing -> -- gone up, but if the+                                   -- rest definitely terminates without any+                                   -- cycles (including the path so far, which+                                   -- we take as inaccessible) the path is fine+                            return $ tryPath 0 (map mkBig (((e, arg), desc) : path)) es pos                         Just (nextarg, sc) ->                           if nextarg == arg then                             case sc of@@ -729,7 +779,7 @@                                       return (Partial Itself)                             else return Unchecked in --                   trace (show (desc, argspos, path, es, pathres)) $-                   collapse' Unchecked pathres+                   collapse pathres          | [Total a] <- lookupTotal f (tt_ctxt ist) = Total a         | [Partial _] <- lookupTotal f (tt_ctxt ist) = Partial (Other [f])@@ -739,10 +789,10 @@ allNothing xs = null (collapseNothing (zip xs [0..]))  collapseNothing :: [(Maybe a, b)] -> [(Maybe a, b)]-collapseNothing ((Nothing, _) : xs)-   = filter (\ (x, _) -> case x of-                             Nothing -> False-                             _ -> True) xs+collapseNothing ((Nothing, t) : xs)+   = (Nothing, t) : filter (\ (x, _) -> case x of+                                             Nothing -> False+                                             _ -> True) xs collapseNothing (x : xs) = x : collapseNothing xs collapseNothing [] = []
src/Idris/DSL.hs view
@@ -67,6 +67,8 @@ expandSugar dsl (PPi p n fc ty tm) = PPi p n fc (expandSugar dsl ty) (expandSugar dsl tm) expandSugar dsl (PApp fc t args) = PApp fc (expandSugar dsl t)                                         (map (fmap (expandSugar dsl)) args)+expandSugar dsl (PWithApp fc t arg) = PWithApp fc (expandSugar dsl t)+                                                  (expandSugar dsl arg) expandSugar dsl (PAppBind fc t args) = PAppBind fc (expandSugar dsl t)                                                 (map (fmap (expandSugar dsl)) args) expandSugar dsl (PCase fc s opts) = PCase fc (expandSugar dsl s)@@ -86,8 +88,8 @@ expandSugar dsl (PUnifyLog t) = PUnifyLog (expandSugar dsl t) expandSugar dsl (PDisamb ns t) = PDisamb ns (expandSugar dsl t) expandSugar dsl (PReturn fc) = dsl_return dsl-expandSugar dsl (PRewrite fc r t ty)-    = PRewrite fc r (expandSugar dsl t) ty+expandSugar dsl (PRewrite fc by r t ty)+    = PRewrite fc by r (expandSugar dsl t) ty expandSugar dsl (PGoal fc r n sc)     = PGoal fc (expandSugar dsl r) n (expandSugar dsl sc) expandSugar dsl (PDoBlock ds)@@ -140,6 +142,7 @@         | otherwise = PPi p n fc (v' i ty) (v' (i+1) sc)     v' i (PTyped l r)    = PTyped (v' i l) (v' i r)     v' i (PApp f x as)   = PApp f (v' i x) (fmap (fmap (v' i)) as)+    v' i (PWithApp f x a) = PWithApp f (v' i x) (v' i a)     v' i (PCase f t as)  = PCase f (v' i t) (fmap (pmap (v' i)) as)     v' i (PPair f hls p l r) = PPair f hls p (v' i l) (v' i r)     v' i (PDPair f hls p l t r) = PDPair f hls p (v' i l) (v' i t) (v' i r)@@ -191,6 +194,10 @@          = do t' <- db' t               args' <- mapM dbArg args               return (PApp fc t' args')+    db' (PWithApp fc t arg)+         = do t' <- db' t+              arg' <- db' arg+              return (PWithApp fc t' arg')     db' (PLam fc n nfc ty sc) = return (PLam fc n nfc ty (debind b sc))     db' (PLet fc n nfc ty v sc) = do v' <- db' v                                      return (PLet fc n nfc ty v' (debind b sc))
src/Idris/DeepSeq.hs view
@@ -258,10 +258,9 @@   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 Raw        = ()+    rnf Object     = ()     rnf Executable = ()-    rnf MavenProject = ()  instance NFData IBCWrite where     rnf (IBCFix fixDecl) = rnf fixDecl `seq` ()@@ -307,6 +306,7 @@     rnf (IBCAutoHint n1 n2) = rnf n1 `seq` rnf n2 `seq` ()     rnf (IBCDeprecate n1 n2) = rnf n1 `seq` rnf n2 `seq` ()     rnf (IBCRecord x) = rnf x `seq` ()+    rnf (IBCFragile n1 n2) = rnf n1 `seq` rnf n2 `seq` ()   instance NFData a => NFData (D.Block a) where@@ -530,14 +530,15 @@         rnf (PTyped x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PAppImpl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PApp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (PWithApp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()         rnf (PAppBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()         rnf (PMatchApp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PCase x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()         rnf (PIfThenElse x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()         rnf (PTrue x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PResolveTC x1) = rnf x1 `seq` ()-        rnf (PRewrite x1 x2 x3 x4)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+        rnf (PRewrite x1 x2 x3 x4 x5)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()         rnf (PPair x1 x2 x3 x4 x5) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` x5 `seq` ()         rnf (PDPair x1 x2 x3 x4 x5 x6)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` x6 `seq` ()@@ -681,13 +682,13 @@         rnf (UConstraint x1 x2) = rnf x1 `seq` rnf x2 `seq` ()  instance NFData SyntaxInfo where-        rnf (Syn x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)+        rnf (Syn x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14)           = 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` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` ()+                      rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` rnf x14 `seq` ()  instance NFData OutputMode where   rnf (RawOutput x) = () -- no instance for Handle, so this is a bit wrong@@ -698,8 +699,8 @@   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 x74 x75)+              x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76)      = 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` rnf x74 `seq` rnf x75 `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` rnf x74 `seq` rnf x75 `seq` rnf x76 `seq` ()
src/Idris/Directives.hs view
@@ -13,29 +13,35 @@  -- | Run the action corresponding to a directive directiveAction :: Directive -> Idris ()-directiveAction (DLib cgn lib) = do addLib cgn lib-                                    addIBC (IBCLib cgn lib)+directiveAction (DLib cgn lib) = do+  addLib cgn lib+  addIBC (IBCLib cgn lib) -directiveAction (DLink cgn obj) = do dirs <- allImportDirs-                                     o <- runIO $ findInPath dirs obj-                                     addIBC (IBCObj cgn obj) -- just name, search on loading ibc-                                     addObjectFile cgn o+directiveAction (DLink cgn obj) = do+  dirs <- allImportDirs+  o <- runIO $ findInPath dirs obj+  addIBC (IBCObj cgn obj) -- just name, search on loading ibc+  addObjectFile cgn o  directiveAction (DFlag cgn flag) = do-                                      let flags = words flag-                                      mapM_ (\f -> addIBC (IBCCGFlag cgn f)) flags-                                      mapM_ (addFlag cgn) flags--directiveAction (DInclude cgn hdr) = do addHdr cgn hdr-                                        addIBC (IBCHeader cgn hdr)+  let flags = words flag+  mapM_ (\f -> addIBC (IBCCGFlag cgn f)) flags+  mapM_ (addFlag cgn) flags -directiveAction (DHide n') = do i <- getIState-                                ns <- allNamespaces n'-                                mapM_ (\n -> do setAccessibility n Hidden-                                                addIBC (IBCAccess n Hidden)) ns+directiveAction (DInclude cgn hdr) = do+  addHdr cgn hdr+  addIBC (IBCHeader cgn hdr) -directiveAction (DFreeze n) = do setAccessibility n Frozen-                                 addIBC (IBCAccess n Frozen)+directiveAction (DHide n') = do+  ns <- allNamespaces n'+  mapM_ (\n -> do+            setAccessibility n Hidden+            addIBC (IBCAccess n Hidden)) ns+directiveAction (DFreeze n') = do+  ns <- allNamespaces n'+  mapM_ (\n -> do+            setAccessibility n Frozen+            addIBC (IBCAccess n Frozen)) ns  directiveAction (DAccess acc) = do updateIState (\i -> i { default_access = acc }) @@ -43,49 +49,58 @@  directiveAction (DLogging lvl) = setLogLevel (fromInteger lvl) -directiveAction (DDynamicLibs libs) = do added <- addDyLib libs-                                         case added of-                                             Left lib -> addIBC (IBCDyLib (lib_name lib))-                                             Right msg -> fail $ msg+directiveAction (DDynamicLibs libs) = do+  added <- addDyLib libs+  case added of+    Left lib  -> addIBC (IBCDyLib (lib_name lib))+    Right msg -> fail $ msg -directiveAction (DNameHint ty tyFC ns) = do ty' <- disambiguate ty-                                            mapM_ (addNameHint ty' . fst) ns-                                            mapM_ (\n -> addIBC (IBCNameHint (ty', fst n))) ns-                                            sendHighlighting $-                                              [(tyFC, AnnName ty' Nothing Nothing Nothing)] ++-                                              map (\(n, fc) -> (fc, AnnBoundName n False)) ns+directiveAction (DNameHint ty tyFC ns) = do+  ty' <- disambiguate ty+  mapM_ (addNameHint ty' . fst) ns+  mapM_ (\n -> addIBC (IBCNameHint (ty', fst n))) ns+  sendHighlighting $ [(tyFC, AnnName ty' Nothing Nothing Nothing)] ++ map (\(n, fc) -> (fc, AnnBoundName n False)) ns -directiveAction (DErrorHandlers fn nfc arg afc ns) =-  do fn' <- disambiguate fn-     ns' <- mapM (\(n, fc) -> do n' <- disambiguate n-                                 return (n', fc)) ns-     addFunctionErrorHandlers fn' arg (map fst ns')-     mapM_ (addIBC .-         IBCFunctionErrorHandler fn' arg . fst) ns'-     sendHighlighting $-       [(nfc, AnnName fn' Nothing Nothing Nothing),-        (afc, AnnBoundName arg False)] ++-       map (\(n, fc) -> (fc, AnnName n Nothing Nothing Nothing)) ns'+directiveAction (DErrorHandlers fn nfc arg afc ns) = do+  fn' <- disambiguate fn+  ns' <- mapM (\(n, fc) -> do+                  n' <- disambiguate n+                  return (n', fc)) ns+  addFunctionErrorHandlers fn' arg (map fst ns')+  mapM_ (addIBC . IBCFunctionErrorHandler fn' arg . fst) ns'+  sendHighlighting $+       [ (nfc, AnnName fn' Nothing Nothing Nothing)+       , (afc, AnnBoundName arg False)+       ] ++ map (\(n, fc) -> (fc, AnnName n Nothing Nothing Nothing)) ns'  directiveAction (DLanguage ext) = addLangExt ext-directiveAction (DDeprecate n reason) -    = do n' <- disambiguate n-         addDeprecated n' reason-         addIBC (IBCDeprecate n' reason)-directiveAction (DAutoImplicits b)-    = setAutoImpls b-directiveAction (DUsed fc fn arg) = addUsedName fc fn arg +directiveAction (DDeprecate n reason) = do+  n' <- disambiguate n+  addDeprecated n' reason+  addIBC (IBCDeprecate n' reason)++directiveAction (DFragile n reason) = do+  n' <- disambiguate n+  addFragile n' reason+  addIBC (IBCFragile n' reason)++directiveAction (DAutoImplicits b) = setAutoImpls b+directiveAction (DUsed fc fn arg)  = addUsedName fc fn arg+ disambiguate :: Name -> Idris Name-disambiguate n = do i <- getIState-                    case lookupCtxtName n (idris_implicits i) of-                              [(n', _)] -> return n'-                              []        -> throwError (NoSuchVariable n)-                              more      -> throwError (CantResolveAlts (map fst more))+disambiguate n = do+  i <- getIState+  case lookupCtxtName n (idris_implicits i) of+    [(n', _)] -> return n'+    []        -> throwError (NoSuchVariable n)+    more      -> throwError (CantResolveAlts (map fst more)) + allNamespaces :: Name -> Idris [Name]-allNamespaces n = do i <- getIState-                     case lookupCtxtName n (idris_implicits i) of-                              [(n', _)] -> return [n']-                              []        -> throwError (NoSuchVariable n)-                              more      -> return (map fst more)+allNamespaces n = do+  i <- getIState+  case lookupCtxtName n (idris_implicits i) of+    [(n', _)] -> return [n']+    []        -> throwError (NoSuchVariable n)+    more      -> return (map fst more)
src/Idris/Elab/Class.hs view
@@ -226,7 +226,7 @@              addIBC (IBCInstance False True conn' cfn) --              iputStrLn ("Added " ++ show (conn, cfn, ty))              return [PTy emptyDocstring [] syn fc [] cfn NoFC ty,-                     PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]+                     PClauses fc [Inlinable, Dictionary] cfn [PClause fc cfn lhs [] rhs []]]      -- | Generate a top level function which looks up a method in a given     -- dictionary (this is inlinable, always)@@ -269,23 +269,27 @@     rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns     rhsArgs [] _ = [] +    -- Add the top level constraint. Put it first - elaboration will resolve+    -- the order of the implicits if there are dependencies.+    -- Also ensure the dictionary is used for lookup of any methods that+    -- are used in the type     insertConstraint :: PTerm -> [Name] -> PTerm -> PTerm-    insertConstraint c all (PPi p@(Imp _ _ _ _ _) n fc ty sc)-                              = PPi p n fc ty (insertConstraint c all sc)-    insertConstraint c all sc = let dictN = sMN 0 "__class"-                                in  PPi (constraint { pstatic = Static })-                                        dictN NoFC c-                                        (constrainMeths (map basename all)-                                                        dictN sc)-      where-        -- After we insert the constraint into the lookup, we need to-        -- ensure that the same dictionary is used to resolve lookups-        -- to the other methods in the class+    insertConstraint c all sc +          = let dictN = sMN 0 "__class" in  +                PPi (constraint { pstatic = Static })+                    dictN NoFC c+                    (constrainMeths (map basename all)+                                    dictN sc)+     where +       -- After we insert the constraint into the lookup, we need to+       -- ensure that the same dictionary is used to resolve lookups+       -- to the other methods in the class        constrainMeths :: [Name] -> Name -> PTerm -> PTerm        constrainMeths allM dictN tm = transform (addC allM dictN) tm+         addC allM dictN m@(PRef fc hls n)-         | n `elem` allM = PApp NoFC m [pconst (PRef NoFC hls dictN)]-         | otherwise = m+          | n `elem` allM = PApp NoFC m [pconst (PRef NoFC hls dictN)]+          | otherwise = m        addC _ _ tm = tm      -- make arguments explicit and don't bind class parameters
src/Idris/Elab/Clause.hs view
@@ -317,7 +317,9 @@      getLHS (_, l, _) = l -    simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y)+    -- Simplify the left hand side of a definition, to remove any lets+    -- that may have arisen during elaboration+    simple_lhs ctxt (Right (x, y)) = Right (Idris.Core.Evaluate.simplify ctxt [] x, y)     simple_lhs ctxt t = t      simple_rt ctxt (p, x, y) = (p, x, force (uniqueBinders p@@ -619,7 +621,7 @@                                then recheckC_borrowing False (PEGenerated `notElem` opts)                                                        [] fc id [] lhs_tm                                else return (lhs_tm, lhs_ty)-        let clhs = normalise ctxt [] clhs_c+        let clhs = Idris.Core.Evaluate.simplify ctxt [] clhs_c         let borrowed = borrowedNames [] clhs          -- These are the names we're not allowed to use on the RHS, because@@ -667,7 +669,8 @@         -- Now build the RHS, using the type of the LHS as the goal.         i <- getIState -- new implicits from where block         logElab 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))-        let rhs = addImplBoundInf i (map fst newargs_all) (defs \\ decls)+        let rhs = rhs_trans info $+                   addImplBoundInf i (map fst newargs_all) (defs \\ decls)                                  (expandParams decorate newargs defs (defs \\ decls) rhs_in)         logElab 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs         ctxt <- getContext -- new context with where block added@@ -861,7 +864,7 @@         (clhs, clhsty) <- recheckC fc id [] lhs_tm         logElab 5 ("Checked " ++ show clhs)         let bargs = getPBtys (explicitNames (normalise ctxt [] lhs_tm))-        let wval = addImplBound i (map fst bargs) wval_in+        let wval = rhs_trans info $ addImplBound i (map fst bargs) wval_in         logElab 5 ("Checking " ++ showTmImpls wval)         -- Elaborate wval in this context         ((wval', defer, is, ctxt', newDecls, highlights, newGName), _) <-@@ -958,8 +961,12 @@                        withblock         logElab 3 ("with block " ++ show wb)         -- propagate totality assertion to the new definitions-        when (AssertTotal `elem` opts) $ setFlags wname [AssertTotal]-        mapM_ (rec_elabDecl info EAll info) wb+        setFlags wname [Inlinable]+        when (AssertTotal `elem` opts) $ setFlags wname [Inlinable, AssertTotal]+        i <- getIState+        let rhstrans' = updateWithTerm i mpn wname lhs (map fst bargs_pre) (map fst (bargs_post))+                             . rhs_trans info+        mapM_ (rec_elabDecl info EAll (info { rhs_trans = rhstrans' })) wb          -- rhs becomes: fname' ps_pre wval ps_post Refl         let rhs = PApp fc (PRef fc [] wname)@@ -1001,9 +1008,8 @@     getImps _ = []      mkAuxC pn wname lhs ns ns' (PClauses fc o n cs)-        | True  = do cs' <- mapM (mkAux pn wname lhs ns ns') cs+                = do cs' <- mapM (mkAux pn wname lhs ns ns') cs                      return $ PClauses fc o wname cs'-        | otherwise = ifail $ show fc ++ "with clause uses wrong function name " ++ show n     mkAuxC pn wname lhs ns ns' d = return $ d      mkAux pn wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)@@ -1034,6 +1040,8 @@     addArg (PApp fc f args) w = PApp fc f (args ++ [pexp w])     addArg (PRef fc hls f) w = PApp fc (PRef fc hls f) [pexp w] +    -- ns, arguments which don't depend on the with argument+    -- ns', arguments which do     updateLHS n pn wname mvars ns_in ns_in' (PApp fc (PRef fc' hls' n') args) w         = let ns = map (keepMvar (map fst mvars) fc') ns_in               ns' = map (keepMvar (map fst mvars) fc') ns_in' in@@ -1046,9 +1054,56 @@     updateLHS n pn wname mvars ns_in ns_in' tm w         = updateLHS n pn wname mvars ns_in ns_in' (PApp fc tm []) w +    -- Only keep a var as a pattern variable in the with block if it's+    -- matched in the top level pattern     keepMvar mvs fc v | v `elem` mvs = PRef fc [] v                       | otherwise = Placeholder +    updateWithTerm :: IState -> Maybe Name -> Name -> PTerm -> [Name] -> [Name] -> PTerm -> PTerm+    updateWithTerm ist pn wname toplhs ns_in ns_in' tm +          = mapPT updateApp tm+       where+         arity (PApp _ _ as) = length as+         arity _ = 0++         lhs_arity = arity toplhs++         updateApp wtm@(PWithApp fcw tm warg) = +              case matchClause ist toplhs tm of+                Left _ -> PElabError (Msg (show fc ++ ":with application does not match top level"))+                Right mvars -> +                   let ns = map (keepMvar (map fst mvars) fcw) ns_in+                       ns' = map (keepMvar (map fst mvars) fcw) ns_in' +                       wty = lookupTyExact wname (tt_ctxt ist)+                       res = substMatches mvars $+                          PApp fcw (PRef fcw [] wname)+                            (map pexp ns ++ pexp warg : (map pexp ns') +++                                case pn of+                                     Nothing -> []+                                     Just pnm -> [pexp (PRef fc [] pnm)]) in+                          case wty of+                               Nothing -> res -- can't happen!+                               Just ty -> addResolves ty res+         updateApp tm = tm++         addResolves ty (PApp fc f args) = PApp fc f (addResolvesArgs fc ty args)+         addResolves ty tm = tm++         -- if an argument's type is a type class, and is otherwise to+         -- be inferred, then resolve it with instance search+         -- This is something of a hack, because matching on the top level+         -- application won't find this information for us+         addResolvesArgs :: FC -> Term -> [PArg] -> [PArg]+         addResolvesArgs fc (Bind n (Pi _ ty _) sc) (a : args)+             | (P _ cn _, _) <- unApply ty,+               getTm a == Placeholder+                 = case lookupCtxtExact cn (idris_classes ist) of+                        Just _ -> a { getTm = PResolveTC fc } : addResolvesArgs fc sc args+                        Nothing -> a : addResolvesArgs fc sc args+         addResolvesArgs fc (Bind n (Pi _ ty _) sc) (a : args)+                 = a : addResolvesArgs fc sc args+         addResolvesArgs fc _ args = args+     fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs))     fullApp x = x @@ -1059,3 +1114,19 @@     split deps [] pre = (reverse pre, [])      abstract wn wv wty (n, argty) = (n, substTerm wv (P Bound wn wty) argty)++-- Apply a transformation to all RHSes and nested RHSs+mapRHS :: (PTerm -> PTerm) -> PClause -> PClause+mapRHS f (PClause fc n lhs args rhs ws) +    = PClause fc n lhs args (f rhs) (map (mapRHSdecl f) ws)+mapRHS f (PWith fc n lhs args warg prf ws)+    = PWith fc n lhs args (f warg) prf (map (mapRHSdecl f) ws)+mapRHS f (PClauseR fc args rhs ws) +    = PClauseR fc args (f rhs) (map (mapRHSdecl f) ws)+mapRHS f (PWithR fc args warg prf ws)+    = PWithR fc args (f warg) prf (map (mapRHSdecl f) ws)++mapRHSdecl :: (PTerm -> PTerm) -> PDecl -> PDecl+mapRHSdecl f (PClauses fc opt n cs) +    = PClauses fc opt n (map (mapRHS f) cs)+mapRHSdecl f t = t
src/Idris/Elab/Data.hs view
@@ -20,6 +20,7 @@  import Idris.Elab.Type import Idris.Elab.Utils+import Idris.Elab.Rewrite import Idris.Elab.Value  import Idris.Core.TT@@ -126,6 +127,9 @@          -- create a case function          when (DefaultCaseFun `elem` opts) $             evalStateT (elabCaseFun False params n t dcons info) Map.empty+         -- create a rewriting lemma+         when (n /= sUN "=") $+            elabRewriteLemma info n cty          -- Emit highlighting info          sendHighlighting $ [(nfc, AnnName n Nothing Nothing Nothing)] ++            map (\(_, _, n, nfc, _, _, _) ->
src/Idris/Elab/Instance.hs view
@@ -67,7 +67,7 @@     ist <- getIState     (n, ci) <- case lookupCtxtName n (idris_classes ist) of                   [c] -> return c-                  [] -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"+                  [] -> ifail $ show fc ++ ":" ++ show n ++ " is not an interface"                   cs -> tclift $ tfail $ At fc                            (CantResolveAlts (map fst cs))     let constraint = PApp fc (PRef fc [] n) (map pexp ps)@@ -75,7 +75,7 @@     putIState (ist { hide_list = addDef iname acc (hide_list ist) })     ist <- getIState -    let totopts = Dictionary : opts+    let totopts = Dictionary : Inlinable : opts      let emptyclass = null (class_methods ci)     when (what /= EDefns) $ do
src/Idris/Elab/Quasiquote.hs view
@@ -109,13 +109,13 @@        (t', ex2) <- extractUnquotes n t        (f', ex3) <- extractUnquotes n f        return (PIfThenElse fc c' t' f', ex1 ++ ex2 ++ ex3)-extractUnquotes n (PRewrite fc x y z)+extractUnquotes n (PRewrite fc by x y z)   = do (x', ex1) <- extractUnquotes n x        (y', ex2) <- extractUnquotes n y        case z of          Just zz -> do (z', ex3) <- extractUnquotes n zz-                       return (PRewrite fc x' y' (Just z'), ex1 ++ ex2 ++ ex3)-         Nothing -> return (PRewrite fc x' y' Nothing, ex1 ++ ex2)+                       return (PRewrite fc by x' y' (Just z'), ex1 ++ ex2 ++ ex3)+         Nothing -> return (PRewrite fc by x' y' Nothing, ex1 ++ ex2) extractUnquotes n (PPair fc hls info l r)   = do (l', ex1) <- extractUnquotes n l        (r', ex2) <- extractUnquotes n r
+ src/Idris/Elab/Rewrite.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE PatternGuards, ViewPatterns #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+module Idris.Elab.Rewrite(elabRewrite, elabRewriteLemma) where++import Idris.AbsSyntax+import Idris.AbsSyntaxTree+import Idris.Delaborate+import Idris.Error+import Idris.Core.TT+import Idris.Core.Elaborate+import Idris.Core.Evaluate+import Idris.Docstrings++import Control.Monad+import Control.Monad.State.Strict+import Data.List++import Debug.Trace++elabRewrite :: (PTerm -> ElabD ()) -> IState -> +               FC -> Maybe Name -> PTerm -> PTerm -> Maybe PTerm -> ElabD ()+-- Old version, no rewrite rule given+{-+elabRewrite elab ist fc Nothing rule sc newg+        = do attack+             tyn <- getNameFrom (sMN 0 "rty")+             claim tyn RType+             valn <- getNameFrom (sMN 0 "rval")+             claim valn (Var tyn)+             letn <- getNameFrom (sMN 0 "_rewrite_rule")+             letbind letn (Var tyn) (Var valn)+             focus valn+             elab rule+             compute+             g <- goal+             rewrite (Var letn)+             g' <- goal+             when (g == g') $ lift $ tfail (NoRewriting g)+             case newg of+                 Nothing -> elab sc+                 Just t -> doEquiv elab fc t sc+             solve+             -}+elabRewrite elab ist fc substfn_in rule sc_in newg+        = do attack+             sc <- case newg of+                      Nothing -> return sc_in+                      Just t -> do+                         letn <- getNameFrom (sMN 0 "rewrite_result")+                         return $ PLet fc letn fc t sc_in +                                       (PRef fc [] letn)+             tyn <- getNameFrom (sMN 0 "rty")+             claim tyn RType+             valn <- getNameFrom (sMN 0 "rval")+             claim valn (Var tyn)+             letn <- getNameFrom (sMN 0 "_rewrite_rule")+             letbind letn (Var tyn) (Var valn)+             focus valn+             elab rule+             compute+             g <- goal+             (tmv, rule_in) <- get_type_val (Var letn)+             env <- get_env+             let ttrule = normalise (tt_ctxt ist) env rule_in+             rname <- unique_hole (sMN 0 "replaced")+             case unApply ttrule of+                  (P _ (UN q) _, [lt, rt, l, r]) | q == txt "=" ->+                     do substfn <- findSubstFn substfn_in ist lt rt+                        let pred_tt = mkP (P Bound rname rt) l r g+                        when (g == pred_tt) $ lift $ tfail (NoRewriting g)+                        let pred = PLam fc rname fc Placeholder+                                        (delab ist pred_tt)+                        let rewrite = stripImpls $+                                        addImplBound ist (map fst env) (PApp fc (PRef fc [] substfn)+                                              [pexp pred, pexp rule, pexp sc])+--                         trace ("LHS: " ++ show l ++ "\n" +++--                                "RHS: " ++ show r ++ "\n" +++--                                "REWRITE: " ++ show rewrite ++ "\n" ++ +--                                "GOAL: " ++ show (delab ist g)) $+                        elab rewrite+                        solve+                  _ -> lift $ tfail (NotEquality tmv ttrule)+      where+        mkP :: TT Name -> -- Left term, top level+               TT Name -> TT Name -> TT Name -> TT Name+        mkP lt l r ty | l == ty = lt+        mkP lt l r (App s f a) +            = let f' = if (r /= f) then mkP lt l r f else f+                  a' = if (r /= a) then mkP lt l r a else a in+                  App s f' a'+        mkP lt l r (Bind n b sc)+             = let b' = mkPB b+                   sc' = if (r /= sc) then mkP lt l r sc else sc in+                   Bind n b' sc'+            where mkPB (Let t v) = let t' = if (r /= t) then mkP lt l r t else t+                                       v' = if (r /= v) then mkP lt l r v else v in+                                       Let t' v'+                  mkPB b = let ty = binderTy b+                               ty' = if (r /= ty) then mkP lt l r ty else ty in+                                     b { binderTy = ty' }+        mkP lt l r x = x++        -- If we're rewriting a dependent type, the rewrite type the rewrite+        -- may break the indices. +        -- So, for any function argument which can be determined by looking+        -- at the indices (i.e. any constructor guarded elsewhere in the type)+        -- replace it with a _. e.g. (++) a n m xs ys becomes (++) _ _ _ xs ys+        -- because a,n, and m are constructor guarded later in the type of ++++        -- FIXME: Currently this is an approximation which just strips+        -- implicits. This is perfectly fine for most cases, but not as+        -- general as it should be.+        stripImpls tm = mapPT phApps tm++        phApps (PApp fc f args) = PApp fc f (map removeImp args)+          where removeImp tm@(PImp{}) = tm { getTm = Placeholder }+                removeImp t = t+        phApps tm = tm+       +findSubstFn :: Maybe Name -> IState -> Type -> Type -> ElabD Name+findSubstFn Nothing ist lt rt+     | lt == rt = return (sUN "rewrite__impl")+     -- TODO: Find correct rewriting lemma, if it exists, and tidy up this+     -- error+     | (P _ lcon _, _) <- unApply lt,+       (P _ rcon _, _) <- unApply rt,+       lcon == rcon+         = case lookupTyExact (rewrite_name lcon) (tt_ctxt ist) of+                Just _ -> return (rewrite_name lcon)+                Nothing -> rewriteFail lt rt+     | otherwise = rewriteFail lt rt+  where rewriteFail lt rt = lift . tfail . +                     Msg $ "Can't rewrite heterogeneous equality on types " ++ +                           show (delab ist lt) ++ " and " ++ show (delab ist rt)++findSubstFn (Just substfn_in) ist lt rt+    = case lookupTyName substfn_in (tt_ctxt ist) of+           [(n, t)] -> return n+           [] -> lift . tfail . NoSuchVariable $ substfn_in+           more -> lift . tfail . CantResolveAlts $ map fst more++rewrite_name :: Name -> Name+rewrite_name n = sMN 0 (show n ++ "_rewrite_lemma")++data ParamInfo = Index +               | Param +               | ImplicitIndex+               | ImplicitParam+  deriving Show++getParamInfo :: Type -> [PArg] -> Int -> [Int] -> [ParamInfo]+-- Skip the top level implicits, we just need the explicit ones+getParamInfo (Bind n (Pi _ _ _) sc) (PExp{} : is) i ps+    | i `elem` ps = Param : getParamInfo sc is (i + 1) ps+    | otherwise = Index : getParamInfo sc is (i + 1) ps+getParamInfo (Bind n (Pi _ _ _) sc) (_ : is) i ps+    | i `elem` ps = ImplicitParam : getParamInfo sc is (i + 1) ps+    | otherwise = ImplicitIndex : getParamInfo sc is (i + 1) ps+getParamInfo _ _ _ _ = []++isParam Index = False+isParam Param = True+isParam ImplicitIndex = False+isParam ImplicitParam = True++-- Make a rewriting lemma for the given type constructor.+-- If it fails, fail silently (it may well fail for some very complex types.+-- We can fix this later, for now this gives us a lot more working rewrites...)+elabRewriteLemma :: ElabInfo -> Name -> Type -> Idris ()+elabRewriteLemma info n cty_in =+    do ist <- getIState+       let cty = normalise (tt_ctxt ist) [] cty_in+       let rewrite_lem = rewrite_name n+       case lookupCtxtExact n (idris_datatypes ist) of+            Nothing -> fail $ "Can't happen, elabRewriteLemma for " ++ show n+            Just ti -> do+               let imps = case lookupCtxtExact n (idris_implicits ist) of+                               Nothing -> repeat (pexp Placeholder)+                               Just is -> is +               let pinfo = getParamInfo cty imps 0 (param_pos ti)+               if all isParam pinfo+                  then return () -- no need for a lemma, = will be homogeneous+                  else idrisCatch (mkLemma info rewrite_lem n pinfo cty)+                                  (\_ -> return ())++mkLemma :: ElabInfo -> Name -> Name -> [ParamInfo] -> Type -> Idris ()+mkLemma info lemma tcon ps ty =+    do ist <- getIState+       let leftty = mkTy tcon ps (namesFrom "p" 0) (namesFrom "left" 0)+           rightty = mkTy tcon ps (namesFrom "p" 0) (namesFrom "right" 0)+           predty = bindIdxs ist ps ty (namesFrom "pred" 0) $+                        PPi expl (sMN 0 "rep") fc +                          (mkTy tcon ps (namesFrom "p" 0) (namesFrom "pred" 0))+                          (PType fc)+       let xarg = sMN 0 "x"+       let yarg = sMN 0 "y"+       let parg = sMN 0 "P"+       let eq = sMN 0 "eq"+       let prop = sMN 0 "prop"+       let lemTy = PPi impl xarg fc leftty $+                   PPi impl yarg fc rightty $+                   PPi expl parg fc predty $+                   PPi expl eq fc (PApp fc (PRef fc [] (sUN "="))+                                       [pexp (PRef fc [] xarg),+                                        pexp (PRef fc [] yarg)]) $+                   PPi expl prop fc (PApp fc (PRef fc [] parg)+                                       [pexp (PRef fc [] yarg)]) $+                       PApp fc (PRef fc [] parg) [pexp (PRef fc [] xarg)]++       let lemLHS = PApp fc (PRef fc [] lemma)+                            [pexp (PRef fc [] parg),+                             pexp (PRef fc [] (sUN "Refl")),+                             pexp (PRef fc [] prop)]++       let lemRHS = PRef fc [] prop++       -- Elaborate the type of the lemma+       rec_elabDecl info EAll info +            (PTy emptyDocstring [] defaultSyntax fc [] lemma fc lemTy) +       -- Elaborate the definition+       rec_elabDecl info EAll info+            (PClauses fc [] lemma [PClause fc lemma lemLHS [] lemRHS []])++  where+    fc = emptyFC++    namesFrom x i = sMN i x : namesFrom x (i + 1) +              +    mkTy fn pinfo ps is +         = PApp fc (PRef fc [] fn) (mkArgs pinfo ps is)++    mkArgs [] ps is = []+    mkArgs (Param : pinfo) (p : ps) is+         = pexp (PRef fc [] p) : mkArgs pinfo ps is+    mkArgs (Index : pinfo) ps (i : is)+         = pexp (PRef fc [] i) : mkArgs pinfo ps is+    mkArgs (ImplicitParam : pinfo) (p : ps) is+         = mkArgs pinfo ps is+    mkArgs (ImplicitIndex : pinfo) ps (i : is)+         = mkArgs pinfo ps is+    mkArgs _ _ _ = []++    bindIdxs ist [] ty is tm = tm+    bindIdxs ist (Param : pinfo) (Bind n (Pi _ ty _) sc) is tm +         = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm+    bindIdxs ist (Index : pinfo) (Bind n (Pi _ ty _) sc) (i : is) tm +        = PPi forall_imp i fc (delab ist ty) +               (bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm)+    bindIdxs ist (ImplicitParam : pinfo) (Bind n (Pi _ ty _) sc) is tm +        = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm+    bindIdxs ist (ImplicitIndex : pinfo) (Bind n (Pi _ ty _) sc) (i : is) tm +        = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm+    bindIdxs _ _ _ _ tm = tm++
src/Idris/Elab/Term.hs view
@@ -22,6 +22,7 @@ import Idris.ErrReverse (errReverse) import Idris.Elab.Quasiquote (extractUnquotes) import Idris.Elab.Utils+import Idris.Elab.Rewrite import Idris.Reflection import qualified Util.Pretty as U @@ -268,6 +269,8 @@                   (h: hs) -> do patvar h; mkPat                   [] -> return () +    elabRec = elabE initElabCtxt Nothing+     -- | elabE elaborates an expression, possibly wrapping implicit coercions     -- and forces/delays.  If you make a recursive call in elab', it is     -- normally correct to call elabE - the ones that don't are desugarings@@ -284,7 +287,8 @@                               then solveAuto ist fn False (a, failc)                               else return ()) as -        itm <- if not pattern then insertImpLam ina t else return t+        apt <- expandToArity t+        itm <- if not pattern then insertImpLam ina apt else return apt         ct <- insertCoerce ina itm         t' <- insertLazy ct         g <- goal@@ -298,8 +302,8 @@         --         ++ "\nproblems " ++ show ps         --         ++ "\n-----------\n") $         --trace ("ELAB " ++ show t') $-        let fc = fileFC "Force"         env <- get_env+        let fc = fileFC "Force"         handleError (forceErr t' env)             (elab' ina fc' t')             (elab' ina fc' (PApp fc (PRef fc [] (sUN "Force"))@@ -367,7 +371,7 @@             UType _ -> elab' ina (Just fc) (PRef fc [] unitTy)             _ -> elab' ina (Just fc) (PRef fc [] unitCon)     elab' ina fc (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes-       = do g <- goal; resolveTC' False False 5 g fn ist+       = do g <- goal; resolveTC False False 5 g fn elabRec ist     elab' ina fc (PResolveTC fc')         = do c <- getNameFrom (sMN 0 "__class")              instanceArg c@@ -413,14 +417,15 @@                                                  pimp (sUN "B") Placeholder False,                                                  pexp l, pexp r])     elab' ina _ (PDPair fc hls p l@(PRef nfc hl n) t r)-            = case t of-                Placeholder ->+            = case p of+                IsType -> asType+                IsTerm -> asValue+                TypeOrTerm ->                    do hnf_compute                       g <- goal                       case g of                          TType _ -> asType                          _ -> asValue-                _ -> asType          where asType = elab' ina (Just fc) (PApp fc (PRef NoFC hls sigmaTy)                                         [pexp t,                                          pexp (PLam fc n nfc Placeholder r)])@@ -474,7 +479,7 @@                      ty <- goal                      let (tc, _) = unApply (unDelay ty)                      env <- get_env-                     return $ pruneByType env tc ist as+                     return $ pruneByType env tc (unDelay ty) ist as                unDelay t | (P _ (UN l) _, [_, arg]) <- unApply t,                           l == txt "Lazy'" = unDelay arg@@ -495,10 +500,13 @@               trySeq (x : xs) = let e1 = elab' ina fc x in                                     try' e1 (trySeq' e1 xs) True               trySeq [] = fail "Nothing to try in sequence"-              trySeq' deferr [] = proofFail deferr+              trySeq' deferr [] = do deferr; unifyProblems               trySeq' deferr (x : xs)-                  = try' (do elab' ina fc x-                             solveAutos ist fn False) (trySeq' deferr xs) True+                  = try' (tryCatch (do elab' ina fc x+                                       solveAutos ist fn False+                                       unifyProblems)+                             (\_ -> trySeq' deferr []))+                         (trySeq' deferr xs) True     elab' ina fc (PAlternative ms TryImplicit (orig : alts)) = do         env <- get_env         compute@@ -716,7 +724,7 @@                                    hs <- get_holes                                    if all (\n -> n == tyn || not (n `elem` hs)) (freeNames g)                                     then handleError (tcRecoverable emode)-                                           (resolveTC' True False 10 g fn ist)+                                           (resolveTC True False 10 g fn elabRec ist)                                            (movelast n)                                     else movelast n)                          (ivs' \\ ivs)@@ -889,7 +897,7 @@                                                     hs <- get_holes                                                     if all (\n -> not (n `elem` hs)) (freeNames g)                                                      then handleError (tcRecoverable emode)-                                                              (resolveTC' False False 10 g fn ist)+                                                              (resolveTC False False 10 g fn elabRec ist)                                                               (movelast n)                                                      else movelast n)                                           (ivs' \\ ivs)@@ -994,39 +1002,8 @@         | not pattern = do mapM_ (runTac False ist fc fn) ts         | otherwise = elab' ina fc Placeholder     elab' ina fc (PElabError e) = lift $ tfail e-    elab' ina _ (PRewrite fc r sc newg)-        = do attack-             tyn <- getNameFrom (sMN 0 "rty")-             claim tyn RType-             valn <- getNameFrom (sMN 0 "rval")-             claim valn (Var tyn)-             letn <- getNameFrom (sMN 0 "_rewrite_rule")-             letbind letn (Var tyn) (Var valn)-             focus valn-             elab' ina (Just fc) r-             compute-             g <- goal-             rewrite (Var letn)-             g' <- goal-             when (g == g') $ lift $ tfail (NoRewriting g)-             case newg of-                 Nothing -> elab' ina (Just fc) sc-                 Just t -> doEquiv t sc-             solve-        where doEquiv t sc =-                do attack-                   tyn <- getNameFrom (sMN 0 "ety")-                   claim tyn RType-                   valn <- getNameFrom (sMN 0 "eqval")-                   claim valn (Var tyn)-                   letn <- getNameFrom (sMN 0 "equiv_val")-                   letbind letn (Var tyn) (Var valn)-                   focus tyn-                   elab' ina (Just fc) t-                   focus valn-                   elab' ina (Just fc) sc-                   elab' ina (Just fc) (PRef fc [] letn)-                   solve+    elab' ina mfc (PRewrite fc substfn rule sc newg)+        = elabRewrite (elab' ina mfc) ist fc substfn rule sc newg     elab' ina _ c@(PCase fc scr opts)         = do attack @@ -1406,15 +1383,22 @@     fullyElaborated (Proj t _) = fullyElaborated t     fullyElaborated _ = return () +    -- If the goal type is a "Lazy", then try elaborating via 'Delay'+    -- first. We need to do this brute force approach, rather than anything+    -- more precise, since there may be various other ambiguities to resolve+    -- first.     insertLazy :: PTerm -> ElabD PTerm     insertLazy t@(PApp _ (PRef _ _ (UN l)) _) | l == txt "Delay" = return t     insertLazy t@(PApp _ (PRef _ _ (UN l)) _) | l == txt "Force" = return t     insertLazy (PCoerced t) = return t+    -- Don't add a delay to pattern variables, since they can be forced+    -- on the rhs+    insertLazy t@(PPatvar _ _) | pattern = return t     insertLazy t =         do ty <- goal            env <- get_env            let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)-           let tries = if pattern then [t, mkDelay env t] else [mkDelay env t, t]+           let tries = [mkDelay env t, t]            case tyh of                 P _ (UN l) _ | l == txt "Lazy'"                     -> return (PAlternative [] FirstSuccess tries)@@ -1441,6 +1425,23 @@     notImplicitable (PCase _ _ _) = True     notImplicitable _ = False +    -- Elaboration works more smoothly if we expand function applications+    -- to their full arity and elaborate it all at once (better error messages+    -- in particular)+    expandToArity tm@(PApp fc f a) = do+       env <- get_env+       case fullApp tm of+            -- if f is global, leave it alone because we've already+            -- expanded it to the right arity+            PApp fc ftm@(PRef _ _ f) args | Just aty <- lookup f env ->+               do let a = length (getArgTys (normalise (tt_ctxt ist) env (binderTy aty)))+                  return (mkPApp fc a ftm args)+            _ -> return tm+    expandToArity t = return t+    +    fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs))+    fullApp x = x+     insertScopedImps fc (Bind n (Pi im@(Just i) _ _) sc) xs       | tcinstance i && not (toplevel_imp i)           = pimp n (PResolveTC fc) True : insertScopedImps fc sc xs@@ -1595,9 +1596,10 @@ -- Rule out alternatives that don't return the same type as the head of the goal -- (If there are none left as a result, do nothing) pruneByType :: Env -> Term -> -- head of the goal+               Type -> -- goal                IState -> [PTerm] -> [PTerm] -- if an alternative has a locally bound name at the head, take it-pruneByType env t c as+pruneByType env t goalty c as    | Just a <- locallyBound as = [a]   where     locallyBound [] = Nothing@@ -1613,7 +1615,7 @@     getName _ = Nothing  -- 'n' is the name at the head of the goal type-pruneByType env (P _ n _) ist as+pruneByType env (P _ n _) goalty ist as -- if the goal type is polymorphic, keep everything    | Nothing <- lookupTyExact n ctxt = as -- if the goal type is a ?metavariable, keep everything@@ -1627,6 +1629,8 @@   where     ctxt = tt_ctxt ist +    -- Get the function at the head of the alternative and see if it's+    -- a plausible match against the goal type. Keep if so.     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)@@ -1640,19 +1644,42 @@         = -- trace ("Trying " ++ show f' ++ " for " ++ show n) $           case lookupTyExact f' ctxt of                Just ty -> case unApply (getRetTy ty) of-                            (P _ ctyn _, _) | isConName ctyn ctxt -> ctyn == f+                            (P _ ctyn _, _) | isTConName ctyn ctxt && not (ctyn == f) +                                     -> False                             _ -> let ty' = normalise ctxt [] ty in+--                                    trace ("Trying " ++ show (getRetTy ty') ++ " for " ++ show goalty) $                                      case unApply (getRetTy ty') of-                                          (P _ ftyn _, _) -> ftyn == f                                           (V _, _) ->-                                            -- keep, variable---                                             trace ("Keeping " ++ show (f', ty')---                                                      ++ " for " ++ show n) $                                               isPlausible ist var env n ty-                                          _ -> False+                                          _ -> matching (getRetTy ty') goalty +-- May be useful to keep for debugging purposes for a bit:+--                                                let res = matching (getRetTy ty') goalty in+--                                                   traceWhen (not res)+--                                                     ("Rejecting " ++ show (getRetTy ty', goalty)) res                _ -> False -pruneByType _ t _ as = as+    -- If the goal is a constructor, it must match the suggested function type+    matching (P _ ctyn _) (P _ n' _) +         | isTConName n' ctxt = ctyn == n'+         | otherwise = True+    -- Variables match anything+    matching (V _) _ = True +    matching _ (V _) = True +    matching _ (P _ n _) = not (isTConName n ctxt)+    matching (P _ n _) _ = not (isTConName n ctxt)+    -- Binders are a plausible match, so keep them+    matching (Bind n _ sc) _ = True+    matching _ (Bind n _ sc) = True+    -- If we hit a function name, it's a plausible match+    matching (App _ (P _ f _) _) _ | not (isConName f ctxt) = True+    matching _ (App _ (P _ f _) _) | not (isConName f ctxt) = True+    -- Otherwise, match the rest of the structure+    matching (App _ f a) (App _ f' a') = matching f f' && matching a a'+    matching (TType _) (TType _) = True+    matching (UType _) (UType _) = True+    matching l r = l == r++pruneByType _ t _ _ as = as  -- Could the name feasibly be the return type? -- If there is a type class constraint on the return type, and no instance
src/Idris/Elab/Utils.hs view
@@ -41,6 +41,9 @@          when addConstrs $ addConstraints fc cs          mapM_ (checkDeprecated fc) (allTTNames tm)          mapM_ (checkDeprecated fc) (allTTNames ty)+         mapM_ (checkFragile fc) (allTTNames tm)+         mapM_ (checkFragile fc) (allTTNames ty)+          return (tm, ty)  checkDeprecated :: FC -> Name -> Idris ()@@ -53,6 +56,20 @@                                          "" -> Util.Pretty.empty                                          _ -> line <> text r ++checkFragile :: FC -> Name -> Idris ()+checkFragile fc n = do+  r <- getFragile n+  case r of+    Nothing -> return ()+    Just r  -> do+      iWarn fc $ text "Use of a fragile construct "+                     <> annName n+                     <> case r of+                          "" -> Util.Pretty.empty+                          _  -> line <> text r++ iderr :: Name -> Err -> Err iderr _ e = e @@ -98,8 +115,13 @@              logElab 5 $ "CASE BLOCK: " ++ show (n, d)              let opts' = nub (o ++ opts)              -- propagate totality assertion to the new definitions-             when (AssertTotal `elem` opts) $ setFlags n [AssertTotal]+             let opts' = filter propagatable opts+             setFlags n opts'              rec_elabDecl info EAll info (PClauses f opts' n ps )+  where+    propagatable AssertTotal = True+    propagatable Inlinable = True+    propagatable _ = False  -- | Check that the result of type checking matches what the programmer wrote -- (i.e. - if we inferred any arguments that the user provided, make sure@@ -319,14 +341,14 @@  -- Check that a name has the minimum required accessibility checkVisibility :: FC -> Name -> Accessibility -> Accessibility -> Name -> Idris ()-checkVisibility fc n minAcc acc ref +checkVisibility fc n minAcc acc ref     = do nvis <- getFromHideList ref          case nvis of               Nothing -> return ()-              Just acc' -> if acc' > minAcc -                              then tclift $ tfail (At fc -                                      (Msg $ show acc ++ " " ++ show n ++ -                                             " can't refer to " ++ +              Just acc' -> if acc' > minAcc+                              then tclift $ tfail (At fc+                                      (Msg $ show acc ++ " " ++ show n +++                                             " can't refer to " ++                                              show acc' ++ " " ++ show ref))                               else return () @@ -397,10 +419,10 @@         _    -> putIState ist { idris_optimisation = addDef n (Optimise [] True) opt }  displayWarnings :: EState -> Idris ()-displayWarnings est +displayWarnings est      = mapM_ displayImpWarning (implicit_warnings est)   where     displayImpWarning :: (FC, Name) -> Idris ()-    displayImpWarning (fc, n) = +    displayImpWarning (fc, n) =        iputStrLn $ show fc ++ ":WARNING: " ++ show (nsroot n) ++ " is bound as an implicit\n"                    ++ "\tDid you mean to refer to " ++ show n ++ "?"
src/Idris/Elab/Value.hs view
@@ -130,13 +130,14 @@   where     runtm t = PApp fc (PRef fc [] (sUN "run__IO"))                   [pimp (sUN "ffi") (PRef fc [] (sUN "FFI_C")) False, pexp t]-    printtm t = PApp fc (PRef fc [] (sUN "printLn"))-                  [pimp (sUN "ffi") (PRef fc [] (sUN "FFI_C")) False, pexp t]+    printtm t = PApp fc (PRef fc [] (sUN "printLn")) [pexp t]  elabREPL :: ElabInfo -> ElabMode -> PTerm -> Idris (Term, Type) elabREPL info aspat tm     = idrisCatch (elabVal info aspat tm) catchAmbig   where     catchAmbig (CantResolveAlts _)+       = elabVal info aspat (PDisamb [[txt "List"]] tm)+    catchAmbig (NoValidAlts _)        = elabVal info aspat (PDisamb [[txt "List"]] tm)     catchAmbig e = ierror e
src/Idris/ElabDecls.hs view
@@ -64,7 +64,7 @@  -- Top level elaborator info, supporting recursive elaboration recinfo :: ElabInfo-recinfo = EInfo [] emptyContext id Nothing Nothing elabDecl'+recinfo = EInfo [] emptyContext id Nothing Nothing id elabDecl'  -- | Return the elaborated term which calls 'main' elabMain :: Idris Term@@ -111,7 +111,9 @@           elabBelieveMe              = do let prim__believe_me = sUN "prim__believe_me"                   updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)-                  setTotality prim__believe_me (Partial NotCovering)+                  -- The point is that it is believed to be total, even +                  -- though it clearly isn't :)+                  setTotality prim__believe_me (Total [])                   i <- getIState                   putIState i {                       idris_scprims = (prim__believe_me, (3, LNoOp)) : idris_scprims i@@ -189,7 +191,7 @@               _ -> do mapM_ (elabDecl ETypes info) ps                       mapM_ (elabDecl EDefns info) ps          -- record mutually defined data definitions-         let datans = concatMap declared (filter isDataDecl ps)+         let datans = concatMap declared (getDataDecls ps)          mapM_ (setMutData datans) datans          logElab 1 $ "Rechecking for positivity " ++ show datans          mapM_ (\x -> do setTotality x Unchecked) datans@@ -205,6 +207,13 @@          clear_totcheck   where isDataDecl (PData _ _ _ _ _ _) = True         isDataDecl _ = False++        getDataDecls (PNamespace _ _ ds : decls)+           = getDataDecls ds ++ getDataDecls decls+        getDataDecls (d : decls) +           | isDataDecl d = d : getDataDecls decls+           | otherwise = getDataDecls decls+        getDataDecls [] = []          setMutData ns n            = do i <- getIState
src/Idris/Error.hs view
@@ -97,6 +97,7 @@ warnDisamb ist (PTyped x t) = warnDisamb ist x >> warnDisamb ist t warnDisamb ist (PApp _ t args) = warnDisamb ist t >>                                  mapM_ (warnDisamb ist . getTm) args+warnDisamb ist (PWithApp _ t a) = warnDisamb ist t >> warnDisamb ist a warnDisamb ist (PAppBind _ f args) = warnDisamb ist f >>                                      mapM_ (warnDisamb ist . getTm) args warnDisamb ist (PMatchApp _ _) = return ()@@ -105,8 +106,8 @@ warnDisamb ist (PIfThenElse _ c t f) = mapM_ (warnDisamb ist) [c, t, f] warnDisamb ist (PTrue _ _) = return () warnDisamb ist (PResolveTC _) = return ()-warnDisamb ist (PRewrite _ x y z) = warnDisamb ist x >> warnDisamb ist y >>-                                    Foldable.mapM_ (warnDisamb ist) z+warnDisamb ist (PRewrite _ _ x y z) = warnDisamb ist x >> warnDisamb ist y >>+                                      Foldable.mapM_ (warnDisamb ist) z warnDisamb ist (PPair _ _ _ x y) = warnDisamb ist x >> warnDisamb ist y warnDisamb ist (PDPair _ _ _ x y z) = warnDisamb ist x >> warnDisamb ist y >> warnDisamb ist z warnDisamb ist (PAlternative _ _ tms) = mapM_ (warnDisamb ist) tms
src/Idris/IBC.hs view
@@ -40,7 +40,7 @@ import Codec.Archive.Zip  ibcVersion :: Word16-ibcVersion = 136+ibcVersion = 138  -- When IBC is being loaded - we'll load different things (and omit different -- structures/definitions) depending on which phase we're in@@ -95,7 +95,8 @@                          ibc_deprecated :: ![(Name, String)],                          ibc_defs :: ![(Name, Def)],                          ibc_total :: ![(Name, Totality)],-                         ibc_access :: ![(Name, Accessibility)]+                         ibc_access :: ![(Name, Accessibility)],+                         ibc_fragile :: ![(Name, String)]                        }    deriving Show {-!@@ -103,7 +104,7 @@ !-}  initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] [] [] [] []+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] [] [] [] [] []  hasValidIBCVersion :: FilePath -> Idris Bool hasValidIBCVersion fp = do@@ -113,23 +114,28 @@     Right archive -> do ver <- getEntry 0 "ver" archive                         return (ver == ibcVersion) + loadIBC :: Bool -- ^ True = reexport, False = make everything private         -> IBCPhase         -> FilePath -> Idris () loadIBC reexport phase fp            = do imps <- getImported-                let redo = case lookup fp imps of-                                Nothing -> True-                                Just p -> not p && reexport-                when redo $-                  do logIBC 1 $ "Loading ibc " ++ fp ++ " " ++ show reexport-                     archiveFile <- runIO $ B.readFile fp-                     case toArchiveOrFail archiveFile of-                        Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"-                                          ++ "Please clean and rebuild it."-                        Right archive -> do process reexport phase archive fp-                                            addImported reexport fp---                                             dumpTT+                case lookup fp imps of+                    Nothing -> load True+                    Just p -> if (not p && reexport) then load False else return ()+        where+            load fullLoad = do+                    logIBC 1 $ "Loading ibc " ++ fp ++ " " ++ show reexport+                    archiveFile <- runIO $ B.readFile fp+                    case toArchiveOrFail archiveFile of+                        Left _ -> do+                            ifail $ fp  ++ " isn't loadable, it may have an old ibc format.\n"+                                        ++ "Please clean and rebuild it."+                        Right archive -> do+                            if fullLoad+                                then process reexport phase archive fp+                                else unhide phase archive+                            addImported reexport fp  -- | Load an entire package from its index file loadPkgIndex :: String -> Idris ()@@ -191,7 +197,8 @@                        makeEntry "ibc_deprecated"  (ibc_deprecated i),                        makeEntry "ibc_defs"  (ibc_defs i),                        makeEntry "ibc_total"  (ibc_total i),-                       makeEntry "ibc_access"  (ibc_access i)]+                       makeEntry "ibc_access"  (ibc_access i),+                       makeEntry "ibc_fragile" (ibc_fragile i)]  writeArchive :: FilePath -> IBCFile -> Idris () writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArchive (entries i)@@ -318,352 +325,454 @@ ibc i (IBCExport n) f = return f { ibc_exports = n : ibc_exports f } ibc i (IBCAutoHint n h) f = return f { ibc_autohints = (n, h) : ibc_autohints f } ibc i (IBCDeprecate n r) f = return f { ibc_deprecated = (n, r) : ibc_deprecated f }+ibc i (IBCFragile n r)   f = return f { ibc_fragile    = (n,r)  : ibc_fragile f }  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 +unhide :: IBCPhase -> Archive -> Idris ()+unhide phase ar = do+    processImports True phase ar+    processAccess True phase ar+ process :: Bool -- ^ Reexporting-           -> IBCPhase +           -> IBCPhase            -> Archive -> FilePath -> Idris ()-process reexp phase i fn = do-                ver <- getEntry 0 "ver" i+process reexp phase archive fn = do+                ver <- getEntry 0 "ver" archive                 when (ver /= ibcVersion) $ do                                     logIBC 1 "ibc out of date"                                     let e = if ver < ibcVersion                                             then " an earlier " else " a later "                                     ifail $ "Incompatible ibc version.\nThis library was built with"                                             ++ e ++ "version of Idris.\n" ++ "Please clean and rebuild."-                source <- getEntry "" "sourcefile" i+                source <- getEntry "" "sourcefile" archive                 srcok <- runIO $ doesFileExist source                 when srcok $ timestampOlder source fn-                pImportDirs =<< getEntry [] "ibc_importdirs" i-                pImports reexp phase =<< getEntry [] "ibc_imports" i-                pImps =<< getEntry [] "ibc_implicits" i-                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-                pOptimise =<< getEntry [] "ibc_optimise" i-                pSyntax =<< getEntry [] "ibc_syntax" i-                pKeywords =<< getEntry [] "ibc_keywords" i-                pObjs =<< getEntry [] "ibc_objs" i-                pLibs =<< getEntry [] "ibc_libs" i-                pCGFlags =<< getEntry [] "ibc_cgflags" i-                pDyLibs =<< getEntry [] "ibc_dynamic_libs" i-                pHdrs =<< getEntry [] "ibc_hdrs" i-                pPatdefs =<< getEntry [] "ibc_patdefs" i-                pFlags =<< getEntry [] "ibc_flags" i-                pFnInfo =<< getEntry [] "ibc_fninfo" i-                pTotCheckErr =<< getEntry [] "ibc_totcheckfail" i-                pCG =<< getEntry [] "ibc_cg" i-                pDocs =<< getEntry [] "ibc_docstrings" i-                pMDocs =<< getEntry [] "ibc_moduledocs" i-                pCoercions =<< getEntry [] "ibc_coercions" i-                pTrans =<< getEntry [] "ibc_transforms" i-                pErrRev =<< getEntry [] "ibc_errRev" i-                pLineApps =<< getEntry [] "ibc_lineapps" i-                pNameHints =<< getEntry [] "ibc_namehints" i-                pMetaInformation =<< getEntry [] "ibc_metainformation" i-                pErrorHandlers =<< getEntry [] "ibc_errorhandlers" i-                pFunctionErrorHandlers =<< getEntry [] "ibc_function_errorhandlers" i-                pMetavars =<< getEntry [] "ibc_metavars" i-                pPostulates =<< getEntry [] "ibc_postulates" i-                pExterns =<< getEntry [] "ibc_externs" i-                pParsedSpan =<< getEntry Nothing "ibc_parsedSpan" i-                pUsage =<< getEntry [] "ibc_usage" i-                pExports =<< getEntry [] "ibc_exports" i-                pAutoHints =<< getEntry [] "ibc_autohints" i-                pDeprecate =<< getEntry [] "ibc_deprecated" i-                pDefs reexp =<< getEntry [] "ibc_defs" i-                pTotal =<< getEntry [] "ibc_total" i-                pAccess reexp phase =<< getEntry [] "ibc_access" i+                processImportDirs archive+                processImports reexp phase archive+                processImplicits archive+                processInfix archive+                processStatics archive+                processClasses archive+                processRecords archive+                processInstances archive+                processDSLs archive+                processDatatypes  archive+                processOptimise  archive+                processSyntax archive+                processKeywords archive+                processObjectFiles archive+                processLibs archive+                processCodegenFlags archive+                processDynamicLibs archive+                processHeaders archive+                processPatternDefs archive+                processFlags archive+                processFnInfo archive+                processTotalityCheckError archive+                processCallgraph archive+                processDocs archive+                processModuleDocs archive+                processCoercions archive+                processTransforms archive+                processErrRev archive+                processLineApps archive+                processNameHints archive+                processMetaInformation archive+                processErrorHandlers archive+                processFunctionErrorHandlers archive+                processMetaVars archive+                processPostulates archive+                processExterns archive+                processParsedSpan archive+                processUsage archive+                processExports archive+                processAutoHints archive+                processDeprecate archive+                processDefs archive+                processTotal archive+                processAccess reexp phase archive+                processFragile archive  timestampOlder :: FilePath -> FilePath -> Idris ()-timestampOlder src ibc = do srct <- runIO $ getModificationTime src-                            ibct <- runIO $ getModificationTime ibc-                            if (srct > ibct)-                               then ifail $ "Needs reloading " ++ show (srct, ibct)-                               else return ()+timestampOlder src ibc = do+  srct <- runIO $ getModificationTime src+  ibct <- runIO $ getModificationTime ibc+  if (srct > ibct)+    then ifail $ unlines [ "Module needs reloading:"+                         , unwords ["\tSRC :", show src]+                         , unwords ["\tModified at:", show srct]+                         , unwords ["\tIBC :", show ibc]+                         , unwords ["\tModified at:", show ibct]+                         ]+    else return () -pPostulates :: [Name] -> Idris ()-pPostulates ns = updateIState-                    (\i -> i { idris_postulates = idris_postulates i `S.union` S.fromList ns })+processPostulates :: Archive -> Idris ()+processPostulates ar = do+    ns <- getEntry [] "ibc_postulates" ar+    updateIState (\i -> i { idris_postulates = idris_postulates i `S.union` S.fromList ns }) -pExterns :: [(Name, Int)] -> Idris ()-pExterns ns = updateIState (\i -> i{ idris_externs = idris_externs i `S.union` S.fromList ns })+processExterns :: Archive -> Idris ()+processExterns ar = do+    ns <-  getEntry [] "ibc_externs" ar+    updateIState (\i -> i{ idris_externs = idris_externs i `S.union` S.fromList ns }) -pParsedSpan :: Maybe FC -> Idris ()-pParsedSpan fc = updateIState (\i -> i { idris_parsedSpan = fc })+processParsedSpan :: Archive -> Idris ()+processParsedSpan ar = do+    fc <- getEntry Nothing "ibc_parsedSpan" ar+    updateIState (\i -> i { idris_parsedSpan = fc }) -pUsage :: [(Name, Int)] -> Idris ()-pUsage ns = updateIState (\i -> i { idris_erasureUsed = ns ++ idris_erasureUsed i })+processUsage :: Archive -> Idris ()+processUsage ar = do+    ns <- getEntry [] "ibc_usage" ar+    updateIState (\i -> i { idris_erasureUsed = ns ++ idris_erasureUsed i }) -pExports :: [Name] -> Idris ()-pExports ns = updateIState (\i -> i { idris_exports = ns ++ idris_exports i })+processExports :: Archive -> Idris ()+processExports ar = do+    ns <- getEntry [] "ibc_exports" ar+    updateIState (\i -> i { idris_exports = ns ++ idris_exports i }) -pAutoHints :: [(Name, Name)] -> Idris ()-pAutoHints ns = mapM_ (\(n,h) -> addAutoHint n h) ns+processAutoHints :: Archive -> Idris ()+processAutoHints ar = do+    ns <- getEntry [] "ibc_autohints" ar+    mapM_ (\(n,h) -> addAutoHint n h) ns -pDeprecate :: [(Name, String)] -> Idris ()-pDeprecate ns = mapM_ (\(n,reason) -> addDeprecated n reason) ns+processDeprecate :: Archive -> Idris ()+processDeprecate ar = do+    ns <-  getEntry [] "ibc_deprecated" ar+    mapM_ (\(n,reason) -> addDeprecated n reason) ns -pImportDirs :: [FilePath] -> Idris ()-pImportDirs fs = mapM_ addImportDir fs+processFragile :: Archive -> Idris ()+processFragile ar = do+    ns <- getEntry [] "ibc_fragile" ar+    mapM_ (\(n,reason) -> addFragile n reason) ns -pImports :: Bool -> IBCPhase -> [(Bool, FilePath)] -> Idris ()-pImports reexp phase fs-  = do mapM_ (\(re, f) ->-                    do i <- getIState-                       ibcsd <- valIBCSubDir i-                       ids <- allImportDirs-                       fp <- findImport ids ibcsd f+processImportDirs :: Archive -> Idris ()+processImportDirs ar = do+    fs <- getEntry [] "ibc_importdirs" ar+    mapM_ addImportDir fs++processImports :: Bool -> IBCPhase -> Archive -> Idris ()+processImports reexp phase ar = do+    fs <- getEntry [] "ibc_imports" ar+    mapM_ (\(re, f) -> do+        i <- getIState+        ibcsd <- valIBCSubDir i+        ids <- allImportDirs+        fp <- findImport ids ibcsd f --                        if (f `elem` imported i) --                         then logLvl 1 $ "Already read " ++ f-                       putIState (i { imported = f : imported i })-                       let phase' = case phase of-                                         IBC_REPL _ -> IBC_REPL False-                                         p -> p-                       case fp of-                            LIDR fn -> do-                              logIBC 1 $ "Failed at " ++ fn-                              ifail "Must be an ibc"-                            IDR fn -> do-                              logIBC 1 $ "Failed at " ++ fn-                              ifail "Must be an ibc"-                            IBC fn src -> loadIBC (reexp && re) phase' fn)-             fs+        putIState (i { imported = f : imported i })+        let phase' = case phase of+                         IBC_REPL _ -> IBC_REPL False+                         p -> p+        case fp of+            LIDR fn -> do+                logIBC 1 $ "Failed at " ++ fn+                ifail "Must be an ibc"+            IDR fn -> do+                logIBC 1 $ "Failed at " ++ fn+                ifail "Must be an ibc"+            IBC fn src -> loadIBC (reexp && re) phase' fn) fs -pImps :: [(Name, [PArg])] -> Idris ()-pImps imps = mapM_ (\ (n, imp) ->-                        do i <- getIState-                           case lookupDefAccExact n False (tt_ctxt i) of-                              Just (n, Hidden) -> return ()-                              Just (n, Private) -> return ()-                              _ -> putIState (i { idris_implicits-                                            = addDef n imp (idris_implicits i) }))-                   imps+processImplicits :: Archive -> Idris ()+processImplicits ar = do+    imps <- getEntry [] "ibc_implicits" ar+    mapM_ (\ (n, imp) -> do+        i <- getIState+        case lookupDefAccExact n False (tt_ctxt i) of+            Just (n, Hidden) -> return ()+            Just (n, Private) -> return ()+            _ -> putIState (i { idris_implicits = addDef n imp (idris_implicits i) })) imps -pFixes :: [FixDecl] -> Idris ()-pFixes f = do i <- getIState-              putIState (i { idris_infixes = sort $ f ++ idris_infixes i })+processInfix :: Archive -> Idris ()+processInfix ar = do+    f <- getEntry [] "ibc_fixes" ar+    updateIState (\i -> i { idris_infixes = sort $ f ++ idris_infixes i }) -pStatics :: [(Name, [Bool])] -> Idris ()-pStatics ss = mapM_ (\ (n, s) ->-                        do i <- getIState-                           putIState (i { idris_statics-                                           = addDef n s (idris_statics i) }))-                    ss+processStatics :: Archive -> Idris ()+processStatics ar = do+    ss <- getEntry [] "ibc_statics" ar+    mapM_ (\ (n, s) ->+        updateIState (\i -> i { idris_statics = addDef n s (idris_statics i) })) ss -pClasses :: [(Name, ClassInfo)] -> Idris ()-pClasses cs = mapM_ (\ (n, c) ->-                        do i <- getIState-                           -- Don't lose instances from previous IBCs, which-                           -- could have loaded in any order-                           let is = case lookupCtxtExact n (idris_classes i) of-                                      Just (CI _ _ _ _ _ ins _) -> ins-                                      _ -> []-                           let c' = c { class_instances =-                                          class_instances c ++ is }-                           putIState (i { idris_classes-                                           = addDef n c' (idris_classes i) }))-                    cs+processClasses :: Archive -> Idris ()+processClasses ar = do+    cs <- getEntry [] "ibc_classes" ar+    mapM_ (\ (n, c) -> do+        i <- getIState+        -- Don't lose instances from previous IBCs, which+        -- could have loaded in any order+        let is = case lookupCtxtExact n (idris_classes i) of+                    Just (CI _ _ _ _ _ ins _) -> ins+                    _ -> []+        let c' = c { class_instances = class_instances c ++ is }+        putIState (i { idris_classes = 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+processRecords :: Archive -> Idris ()+processRecords ar = do+    rs <- getEntry [] "ibc_records" ar+    mapM_ (\ (n, r) ->+        updateIState (\i -> 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+processInstances :: Archive -> Idris ()+processInstances ar = do+    cs <- getEntry [] "ibc_instances" ar+    mapM_ (\ (i, res, n, ins) -> addInstance i res n ins) cs -pDSLs :: [(Name, DSL)] -> Idris ()-pDSLs cs = mapM_ (\ (n, c) -> updateIState (\i ->+processDSLs :: Archive -> Idris ()+processDSLs ar = do+    cs <- getEntry [] "ibc_dsls" ar+    mapM_ (\ (n, c) -> updateIState (\i ->                         i { idris_dsls = addDef n c (idris_dsls i) })) cs -pDatatypes :: [(Name, TypeInfo)] -> Idris ()-pDatatypes cs = mapM_ (\ (n, c) -> updateIState (\i ->+processDatatypes :: Archive -> Idris ()+processDatatypes ar = do+    cs <- getEntry [] "ibc_datatypes" ar+    mapM_ (\ (n, c) -> updateIState (\i ->                         i { idris_datatypes = addDef n c (idris_datatypes i) })) cs -pOptimise :: [(Name, OptInfo)] -> Idris ()-pOptimise cs = mapM_ (\ (n, c) -> updateIState (\i ->+processOptimise :: Archive -> Idris ()+processOptimise ar = do+    cs <- getEntry [] "ibc_optimise" ar+    mapM_ (\ (n, c) -> updateIState (\i ->                         i { idris_optimisation = addDef n c (idris_optimisation i) })) cs -pSyntax :: [Syntax] -> Idris ()-pSyntax s = updateIState (\i -> i { syntax_rules = updateSyntaxRules s (syntax_rules i) })+processSyntax :: Archive -> Idris ()+processSyntax ar = do+    s <- getEntry [] "ibc_syntax" ar+    updateIState (\i -> i { syntax_rules = updateSyntaxRules s (syntax_rules i) }) -pKeywords :: [String] -> Idris ()-pKeywords k = updateIState (\i -> i { syntax_keywords = k ++ syntax_keywords i })+processKeywords :: Archive -> Idris ()+processKeywords ar = do+    k <- getEntry [] "ibc_keywords" ar+    updateIState (\i -> i { syntax_keywords = k ++ syntax_keywords i }) -pObjs :: [(Codegen, FilePath)] -> Idris ()-pObjs os = mapM_ (\ (cg, obj) -> do dirs <- allImportDirs-                                    o <- runIO $ findInPath dirs obj-                                    addObjectFile cg o) os+processObjectFiles :: Archive -> Idris ()+processObjectFiles ar = do+    os <- getEntry [] "ibc_objs" ar+    mapM_ (\ (cg, obj) -> do+        dirs <- allImportDirs+        o <- runIO $ findInPath dirs obj+        addObjectFile cg o) os -pLibs :: [(Codegen, String)] -> Idris ()-pLibs ls = mapM_ (uncurry addLib) ls+processLibs :: Archive -> Idris ()+processLibs ar = do+    ls <- getEntry [] "ibc_libs" ar+    mapM_ (uncurry addLib) ls -pCGFlags :: [(Codegen, String)] -> Idris ()-pCGFlags ls = mapM_ (uncurry addFlag) ls+processCodegenFlags :: Archive -> Idris ()+processCodegenFlags ar = do+    ls <- getEntry [] "ibc_cgflags" ar+    mapM_ (uncurry addFlag) ls -pDyLibs :: [String] -> Idris ()-pDyLibs ls = do res <- mapM (addDyLib . return) ls-                mapM_ checkLoad res-                return ()-    where checkLoad (Left _) = return ()-          checkLoad (Right err) = ifail err+processDynamicLibs :: Archive -> Idris ()+processDynamicLibs ar = do+        ls <- getEntry [] "ibc_dynamic_libs" ar+        res <- mapM (addDyLib . return) ls+        mapM_ checkLoad res+    where+        checkLoad (Left _) = return ()+        checkLoad (Right err) = ifail err -pHdrs :: [(Codegen, String)] -> Idris ()-pHdrs hs = mapM_ (uncurry addHdr) hs+processHeaders :: Archive -> Idris ()+processHeaders ar = do+    hs <- getEntry [] "ibc_hdrs" ar+    mapM_ (uncurry addHdr) hs -pPatdefs :: [(Name, ([([(Name, Term)], Term, Term)], [PTerm]))] -> Idris ()-pPatdefs ds = mapM_ (\ (n, d) -> updateIState (\i ->+processPatternDefs :: Archive -> Idris ()+processPatternDefs ar = do+    ds <- getEntry [] "ibc_patdefs" ar+    mapM_ (\ (n, d) -> updateIState (\i ->             i { idris_patdefs = addDef n (force d) (idris_patdefs i) })) ds -pDefs :: Bool -> [(Name, Def)] -> Idris ()-pDefs reexp ds-   = mapM_ (\ (n, d) ->-               do d' <- updateDef d-                  case d' of-                       TyDecl _ _ -> return ()-                       _ -> do logIBC 1 $ "SOLVING " ++ show n-                               solveDeferred emptyFC n-                  updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })-            ) ds-  where-    updateDef (CaseOp c t args o s cd)-      = do o' <- mapM updateOrig o-           cd' <- updateCD cd-           return $ CaseOp c t args o' s cd'-    updateDef t = return t+processDefs :: Archive -> Idris ()+processDefs ar = do+        ds <- getEntry [] "ibc_defs" ar+        mapM_ (\ (n, d) -> do+            d' <- updateDef d+            case d' of+                TyDecl _ _ -> return ()+                _ -> do+                    logIBC 1 $ "SOLVING " ++ show n+                    solveDeferred emptyFC n+            updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })) ds+    where+        updateDef (CaseOp c t args o s cd) = do+            o' <- mapM updateOrig o+            cd' <- updateCD cd+            return $ CaseOp c t args o' s cd'+        updateDef t = return t -    updateOrig (Left t) = liftM Left (update t)-    updateOrig (Right (l, r)) = do l' <- update l-                                   r' <- update r-                                   return $ Right (l', r')+        updateOrig (Left t) = liftM Left (update t)+        updateOrig (Right (l, r)) = do+            l' <- update l+            r' <- update r+            return $ Right (l', r') -    updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))-        = do c' <- updateSC c-             r' <- updateSC r-             return $ CaseDefs (cs, c') (cs, c') (cs, c') (rs, r')+        updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r)) = do+            c' <- updateSC c+            r' <- updateSC r+            return $ CaseDefs (cs, c') (cs, c') (cs, c') (rs, r') -    updateSC (Case t n alts) = do alts' <- mapM updateAlt alts-                                  return (Case t n alts')-    updateSC (ProjCase t alts) = do alts' <- mapM updateAlt alts-                                    return (ProjCase t alts')-    updateSC (STerm t) = do t' <- update t-                            return (STerm t')-    updateSC c = return c+        updateSC (Case t n alts) = do+            alts' <- mapM updateAlt alts+            return (Case t n alts')+        updateSC (ProjCase t alts) = do+            alts' <- mapM updateAlt alts+            return (ProjCase t alts')+        updateSC (STerm t) = do+            t' <- update t+            return (STerm t')+        updateSC c = return c -    updateAlt (ConCase n i ns t) = do t' <- updateSC t-                                      return (ConCase n i ns t')-    updateAlt (FnCase n ns t) = do t' <- updateSC t-                                   return (FnCase n ns t')-    updateAlt (ConstCase c t) = do t' <- updateSC t-                                   return (ConstCase c t')-    updateAlt (SucCase n t) = do t' <- updateSC t-                                 return (SucCase n t')-    updateAlt (DefaultCase t) = do t' <- updateSC t-                                   return (DefaultCase t')+        updateAlt (ConCase n i ns t) = do+            t' <- updateSC t+            return (ConCase n i ns t')+        updateAlt (FnCase n ns t) = do+            t' <- updateSC t+            return (FnCase n ns t')+        updateAlt (ConstCase c t) = do+            t' <- updateSC t+            return (ConstCase c t')+        updateAlt (SucCase n t) = do+            t' <- updateSC t+            return (SucCase n t')+        updateAlt (DefaultCase t) = do+            t' <- updateSC t+            return (DefaultCase t') -    -- We get a lot of repetition in sub terms and can save a fair chunk-    -- of memory if we make sure they're shared. addTT looks for a term-    -- and returns it if it exists already, while also keeping stats of-    -- how many times a subterm is repeated.-    update t = do tm <- addTT t-                  case tm of-                       Nothing -> update' t-                       Just t' -> return t'+        -- We get a lot of repetition in sub terms and can save a fair chunk+        -- of memory if we make sure they're shared. addTT looks for a term+        -- and returns it if it exists already, while also keeping stats of+        -- how many times a subterm is repeated.+        update t = do+            tm <- addTT t+            case tm of+                Nothing -> update' t+                Just t' -> return t' -    update' (P t n ty) = do n' <- getSymbol n-                            return $ P t n' ty-    update' (App s f a) = liftM2 (App s) (update' f) (update' a)-    update' (Bind n b sc) = do b' <- updateB b-                               sc' <- update sc-                               return $ Bind n b' sc'-      where-        updateB (Let t v) = liftM2 Let (update' t) (update' v)-        updateB b = do ty' <- update' (binderTy b)-                       return (b { binderTy = ty' })-    update' (Proj t i) = do t' <- update' t-                            return $ Proj t' i-    update' t = return t+        update' (P t n ty) = do+            n' <- getSymbol n+            return $ P t n' ty+        update' (App s f a) = liftM2 (App s) (update' f) (update' a)+        update' (Bind n b sc) = do+            b' <- updateB b+            sc' <- update sc+            return $ Bind n b' sc'+                where+                    updateB (Let t v) = liftM2 Let (update' t) (update' v)+                    updateB b = do+                        ty' <- update' (binderTy b)+                        return (b { binderTy = ty' })+        update' (Proj t i) = do+                  t' <- update' t+                  return $ Proj t' i+        update' t = return t -pDocs :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))] -> Idris ()-pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds+processDocs :: Archive -> Idris ()+processDocs ar = do+    ds <- getEntry [] "ibc_docstrings" ar+    mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds -pMDocs :: [(Name, Docstring D.DocTerm)] -> Idris ()-pMDocs ds = mapM_  (\ (n, d) -> updateIState (\i ->+processModuleDocs :: Archive -> Idris ()+processModuleDocs ar = do+    ds <- getEntry [] "ibc_moduledocs" ar+    mapM_  (\ (n, d) -> updateIState (\i ->             i { idris_moduledocs = addDef n d (idris_moduledocs i) })) ds -pAccess :: Bool -- ^ Reexporting?+processAccess :: Bool -- ^ Reexporting?            -> IBCPhase-           -> [(Name, Accessibility)] -> Idris ()-pAccess reexp phase ds-        = mapM_ (\ (n, a_in) ->-                      do let a = if reexp then a_in else Hidden-                         logIBC 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a-                         updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })+           -> Archive -> Idris ()+processAccess reexp phase ar = do+    ds <- getEntry [] "ibc_access" ar+    mapM_ (\ (n, a_in) -> do+        let a = if reexp then a_in else Hidden+        logIBC 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a+        updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) }) -                         if (not reexp) then do logIBC 1 $ "Not exporting " ++ show n-                                                setAccessibility n Hidden-                                        else logIBC 1 $ "Exporting " ++ show n-                         -- Everything should be available at the REPL from-                         -- things imported publicly-                         when (phase == IBC_REPL True) $ -                              setAccessibility n Public-                ) ds+        if (not reexp)+            then do+                logIBC 1 $ "Not exporting " ++ show n+                setAccessibility n Hidden+            else logIBC 1 $ "Exporting " ++ show n+        -- Everything should be available at the REPL from+        -- things imported publicly+        when (phase == IBC_REPL True) $ setAccessibility n Public) ds -pFlags :: [(Name, [FnOpt])] -> Idris ()-pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds+processFlags :: Archive -> Idris ()+processFlags ar = do+    ds <- getEntry [] "ibc_flags" ar+    mapM_ (\ (n, a) -> setFlags n a) ds -pFnInfo :: [(Name, FnInfo)] -> Idris ()-pFnInfo ds = mapM_ (\ (n, a) -> setFnInfo n a) ds+processFnInfo :: Archive -> Idris ()+processFnInfo ar = do+    ds <- getEntry [] "ibc_fninfo" ar+    mapM_ (\ (n, a) -> setFnInfo n a) ds -pTotal :: [(Name, Totality)] -> Idris ()-pTotal ds = mapM_ (\ (n, a) -> updateIState (\i -> i { tt_ctxt = setTotal n a (tt_ctxt i) })) ds+processTotal :: Archive -> Idris ()+processTotal ar = do+    ds <- getEntry [] "ibc_total" ar+    mapM_ (\ (n, a) -> updateIState (\i -> i { tt_ctxt = setTotal n a (tt_ctxt i) })) ds -pTotCheckErr :: [(FC, String)] -> Idris ()-pTotCheckErr es = updateIState (\i -> i { idris_totcheckfail = idris_totcheckfail i ++ es })+processTotalityCheckError :: Archive -> Idris ()+processTotalityCheckError ar = do+    es <- getEntry [] "ibc_totcheckfail" ar+    updateIState (\i -> i { idris_totcheckfail = idris_totcheckfail i ++ es }) -pCG :: [(Name, CGInfo)] -> Idris ()-pCG ds = mapM_ (\ (n, a) -> addToCG n a) ds+processCallgraph :: Archive -> Idris ()+processCallgraph ar = do+    ds <- getEntry [] "ibc_cg" ar+    mapM_ (\ (n, a) -> addToCG n a) ds -pCoercions :: [Name] -> Idris ()-pCoercions ns = mapM_ (\ n -> addCoercion n) ns+processCoercions :: Archive -> Idris ()+processCoercions ar = do+    ns <- getEntry [] "ibc_coercions" ar+    mapM_ (\ n -> addCoercion n) ns -pTrans :: [(Name, (Term, Term))] -> Idris ()-pTrans ts = mapM_ (\ (n, t) -> addTrans n t) ts+processTransforms :: Archive -> Idris ()+processTransforms ar = do+    ts <- getEntry [] "ibc_transforms" ar+    mapM_ (\ (n, t) -> addTrans n t) ts -pErrRev :: [(Term, Term)] -> Idris ()-pErrRev ts = mapM_ addErrRev ts+processErrRev :: Archive -> Idris ()+processErrRev ar = do+    ts <- getEntry [] "ibc_errRev" ar+    mapM_ addErrRev ts -pLineApps :: [(FilePath, Int, PTerm)] -> Idris ()-pLineApps ls = mapM_ (\ (f, i, t) -> addInternalApp f i t) ls+processLineApps :: Archive -> Idris ()+processLineApps ar = do+    ls <- getEntry [] "ibc_lineapps" ar+    mapM_ (\ (f, i, t) -> addInternalApp f i t) ls -pNameHints :: [(Name, Name)] -> Idris ()-pNameHints ns = mapM_ (\ (n, ty) -> addNameHint n ty) ns+processNameHints :: Archive -> Idris ()+processNameHints ar = do+    ns <- getEntry [] "ibc_namehints" ar+    mapM_ (\ (n, ty) -> addNameHint n ty) ns -pMetaInformation :: [(Name, MetaInformation)] -> Idris ()-pMetaInformation ds = mapM_ (\ (n, m) -> updateIState (\i ->+processMetaInformation :: Archive -> Idris ()+processMetaInformation ar = do+    ds <- getEntry [] "ibc_metainformation" ar+    mapM_ (\ (n, m) -> updateIState (\i ->                                i { tt_ctxt = setMetaInformation n m (tt_ctxt i) })) ds -pErrorHandlers :: [Name] -> Idris ()-pErrorHandlers ns = updateIState (\i ->-                        i { idris_errorhandlers = idris_errorhandlers i ++ ns })+processErrorHandlers :: Archive -> Idris ()+processErrorHandlers ar = do+    ns <- getEntry [] "ibc_errorhandlers" ar+    updateIState (\i -> i { idris_errorhandlers = idris_errorhandlers i ++ ns }) -pFunctionErrorHandlers :: [(Name, Name, Name)] -> Idris ()-pFunctionErrorHandlers ns =  mapM_ (\ (fn,arg,handler) ->-                                addFunctionErrorHandlers fn arg [handler]) ns+processFunctionErrorHandlers :: Archive -> Idris ()+processFunctionErrorHandlers ar = do+    ns <- getEntry [] "ibc_function_errorhandlers" ar+    mapM_ (\ (fn,arg,handler) -> addFunctionErrorHandlers fn arg [handler]) ns -pMetavars :: [(Name, (Maybe Name, Int, [Name], Bool, Bool))] -> Idris ()-pMetavars ns = updateIState (\i -> i { idris_metavars = L.reverse ns ++ idris_metavars i })+processMetaVars :: Archive -> Idris ()+processMetaVars ar = do+    ns <- getEntry [] "ibc_metavars" ar+    updateIState (\i -> i { idris_metavars = L.reverse ns ++ idris_metavars i })  ----- For Cheapskate and docstrings @@ -1461,7 +1570,7 @@                     _ -> error "Corrupted binary data for Using"  instance Binary SyntaxInfo where-        put (Syn x1 x2 x3 x4 _ _ x5 x6 _ _ x7 _ _)+        put (Syn x1 x2 x3 x4 _ _ x5 x6 _ _ x7 _ _ _)           = do put x1                put x2                put x3@@ -1477,7 +1586,7 @@                x5 <- get                x6 <- get                x7 <- get-               return (Syn x1 x2 x3 x4 [] id x5 x6 Nothing 0 x7 0 True)+               return (Syn x1 x2 x3 x4 [] id x5 x6 Nothing 0 x7 0 True True)  instance (Binary t) => Binary (PClause' t) where         put x@@ -1638,11 +1747,12 @@                                   put x2                 PResolveTC x1 -> do putWord8 15                                     put x1-                PRewrite x1 x2 x3 x4 -> do putWord8 17-                                           put x1-                                           put x2-                                           put x3-                                           put x4+                PRewrite x1 x2 x3 x4 x5 -> do putWord8 17+                                              put x1+                                              put x2+                                              put x3+                                              put x4+                                              put x5                 PPair x1 x2 x3 x4 x5 -> do putWord8 18                                            put x1                                            put x2@@ -1726,6 +1836,10 @@                 PConstSugar x1 x2 -> do putWord8 46                                         put x1                                         put x2+                PWithApp x1 x2 x3 -> do putWord8 47+                                        put x1+                                        put x2+                                        put x3          get           = do i <- getWord8@@ -1789,7 +1903,8 @@                             x2 <- get                             x3 <- get                             x4 <- get-                            return (PRewrite x1 x2 x3 x4)+                            x5 <- get+                            return (PRewrite x1 x2 x3 x4 x5)                    18 -> do x1 <- get                             x2 <- get                             x3 <- get@@ -1873,6 +1988,10 @@                    46 -> do x1 <- get                             x2 <- get                             return (PConstSugar x1 x2)+                   47 -> do x1 <- get+                            x2 <- get+                            x3 <- get+                            return (PWithApp x1 x2 x3)                    _ -> error "Corrupted binary data for PTerm"  instance Binary PAltType where
src/Idris/IdrisDoc.hs view
@@ -304,9 +304,9 @@ extractPTermNames (PCase _ p ps)     = let (ps1, ps2) = unzip ps                                        in  concatMap extract (p:(ps1 ++ ps2)) extractPTermNames (PIfThenElse _ c t f) = concatMap extract [c, t, f]-extractPTermNames (PRewrite _ a b m) | Just c <- m =+extractPTermNames (PRewrite _ _ a b m) | Just c <- m =                                        concatMap extract [a, b, c]-extractPTermNames (PRewrite _ a b _) = concatMap extract [a, b]+extractPTermNames (PRewrite _ _ a b _) = concatMap extract [a, b] extractPTermNames (PPair _ _ _ p1 p2)  = concatMap extract [p1, p2] extractPTermNames (PDPair _ _ _ a b c) = concatMap extract [a, b, c] extractPTermNames (PAlternative _ _ l) = concatMap extract l
src/Idris/Parser.hs view
@@ -535,7 +535,7 @@           flip PQuasiquote goal <$> fixBind (q + 1) rens tm         fixBind q rens (PUnquote tm) =           PUnquote <$> fixBind (q - 1) rens tm-          +         fixBind q rens x = descendM (fixBind q rens) x          gensym :: Name -> IdrisParser Name@@ -923,11 +923,11 @@                                           then [TotalFn]                                           else [] -                   (doc, argDocs) <- docstring syn +                   (doc, argDocs) <- docstring syn                    opts <- fnOpts initOpts                    acc <- accessibility                    opts' <- fnOpts opts-         +                    if kwopt then optional instanceKeyword                             else do instanceKeyword                                     return (Just ())@@ -1319,6 +1319,8 @@            |   'error_handlers' Name NameList            |   'language'       'TypeProviders'            |   'language'       'ErrorReflection'+           |   'deprecated' Name String+           |   'fragile'    Name Reason            ; @ -}@@ -1371,6 +1373,10 @@                     n <- fst <$> fnName                     alt <- option "" (fst <$> stringLiteral)                     return [PDirective (DDeprecate n alt)]+             <|> do try (lchar '%' *> reserved "fragile")+                    n <- fst <$> fnName+                    alt <- option "" (fst <$> stringLiteral)+                    return [PDirective (DFragile n alt)]              <|> do fc <- getFC                     try (lchar '%' *> reserved "used")                     fn <- fst <$> fnName
src/Idris/Parser/Data.hs view
@@ -227,7 +227,7 @@                                              let fix2 = s ++ ": " ++ ns ++ " -> Type where\n  ..."                                              let fix3 = s ++ ": " ++ ss ++ " -> Type where\n  ..."                                              fail $ fixErrorMsg "unexpected \"where\"" [fix1, fix2, fix3]-                      cons <- sepBy1 (simpleConstructor syn) (reservedOp "|")+                      cons <- sepBy1 (simpleConstructor (syn { withAppAllowed = False })) (reservedOp "|")                       terminator                       let conty = mkPApp fc (PRef fc [] tyn) (map (PRef fc []) args)                       cons' <- mapM (\ (doc, argDocs, x, xfc, cargs, cfc, fs) ->
src/Idris/Parser/Expr.hs view
@@ -74,7 +74,8 @@ -} opExpr :: SyntaxInfo -> IdrisParser PTerm opExpr syn = do i <- get-                buildExpressionParser (table (idris_infixes i)) (expr' syn)+                buildExpressionParser (table (idris_infixes i)) +                                      (expr' syn)  {- | Parses either an internally defined expression or     a user-defined one@@ -199,8 +200,8 @@       = PIfThenElse fc (update ns c) (update ns t) (update ns f)     update ns (PCase fc c opts)       = PCase fc (update ns c) (map (pmap (update ns)) opts)-    update ns (PRewrite fc eq tm mty)-      = PRewrite fc (update ns eq) (update ns tm) (fmap (update ns) mty)+    update ns (PRewrite fc by eq tm mty)+      = PRewrite fc by (update ns eq) (update ns tm) (fmap (update ns) mty)     update ns (PPair fc hls p l r) = PPair fc hls p (update ns l) (update ns r)     update ns (PDPair fc hls p l t r)       = PDPair fc hls p (update ns l) (update ns t) (update ns r)@@ -439,7 +440,7 @@ bracketed :: SyntaxInfo -> IdrisParser PTerm bracketed syn = do (FC fn (sl, sc) _) <- getFC                    lchar '(' <?> "parenthesized expression"-                   bracketed' (FC fn (sl, sc) (sl, sc+1)) syn+                   bracketed' (FC fn (sl, sc) (sl, sc+1)) (syn { withAppAllowed = True })  {- |Parses the rest of an expression in braces @@@ -572,7 +573,7 @@ @ -} alt :: SyntaxInfo -> IdrisParser PTerm-alt syn = do symbol "(|"; alts <- sepBy1 (expr' syn) (lchar ','); symbol "|)"+alt syn = do symbol "(|"; alts <- sepBy1 (expr' (syn { withAppAllowed = False })) (lchar ','); symbol "|)"              return (PAlternative [] FirstSuccess alts)  {- | Parses a possibly hidden simple expression@@ -668,9 +669,12 @@              fc <- getFC              i <- get              args <- many (do notEndApp; arg syn)+             wargs <- if withAppAllowed syn && not (inPattern syn)+                         then many (do notEndApp; reservedOp "|"; expr' syn)+                         else return []              case args of                [] -> return f-               _  -> return (flattenFromInt fc f args))+               _  -> return (withApp fc (flattenFromInt fc f args) wargs))        <?> "function application"    where     -- bit of a hack to deal with the situation where we're applying a@@ -682,6 +686,9 @@            = PApp fc (PRef fc [] (sUN "fromInteger")) (i : args)     flattenFromInt fc f args = PApp fc f args +    withApp fc tm [] = tm+    withApp fc tm (a : as) = withApp fc (PWithApp fc tm a) as+     getFromInt ((PApp _ (PRef _ _ n) [a]) : _) | n == sUN "fromInteger" = Just a     getFromInt (_ : xs) = getFromInt xs     getFromInt _ = Nothing@@ -942,12 +949,13 @@                      fc <- getFC                      prf <- expr syn                      giving <- optional (do symbol "==>"; expr' syn)+                     using <- optional (do reserved "using" +                                           (n, _) <- name +                                           return n)                      kw' <- reservedFC "in";  sc <- expr syn                      highlightP kw AnnKeyword                      highlightP kw' AnnKeyword-                     return (PRewrite fc-                             (PApp fc (PRef fc [] (sUN "sym")) [pexp prf]) sc-                               giving)+                     return (PRewrite fc using prf sc giving)                   <?> "term rewrite expression"  {- |Parses a let binding@@ -978,10 +986,12 @@                      pat <- expr' (syn { inPattern = True })                      ty <- option Placeholder (do lchar ':'; expr' syn)                      lchar '='-                     v <- expr syn+                     v <- expr (syn { withAppAllowed = isVar pat })                      ts <- option [] (do lchar '|'                                          sepBy1 (do_alt syn) (lchar '|'))                      return (fc,pat,ty,v,ts)+   where isVar (PRef _ _ _) = True+         isVar _ = False  {- | Parses a conditional expression @@@ -1227,7 +1237,7 @@                   (try . token $ do (char ']' <?> "end of list expression")                                     (FC _ _ (l', c')) <- getFC                                     return (mkNil (FC f (l, c) (l', c'))))-                   <|> (do x <- expr syn <?> "expression"+                   <|> (do x <- expr (syn { withAppAllowed = False }) <?> "expression"                            (do try (lchar '|') <?> "list comprehension"                                qs <- sepBy1 (do_ syn) (lchar ',')                                lchar ']'@@ -1306,18 +1316,18 @@    <|> try (do (i, ifc) <- name                symbol "<-"                fc <- getFC-               e <- expr syn;+               e <- expr (syn { withAppAllowed = False });                option (DoBind fc i ifc e)                       (do lchar '|'-                          ts <- sepBy1 (do_alt syn) (lchar '|')+                          ts <- sepBy1 (do_alt (syn { withAppAllowed = False })) (lchar '|')                           return (DoBindP fc (PRef ifc [ifc] i) e ts)))    <|> try (do i <- expr' syn                symbol "<-"                fc <- getFC-               e <- expr syn;+               e <- expr (syn { withAppAllowed = False });                option (DoBindP fc i e [])                       (do lchar '|'-                          ts <- sepBy1 (do_alt syn) (lchar '|')+                          ts <- sepBy1 (do_alt (syn { withAppAllowed = False })) (lchar '|')                           return (DoBindP fc i e ts)))    <|> do e <- expr syn           fc <- getFC@@ -1339,7 +1349,7 @@ idiom syn     = do symbol "[|"          fc <- getFC-         e <- expr syn+         e <- expr (syn { withAppAllowed = False })          symbol "|]"          return (PIdiom fc e)       <?> "expression in idiom brackets"
src/Idris/Parser/Ops.hs view
@@ -36,7 +36,7 @@ table :: [FixDecl] -> OperatorTable IdrisParser PTerm table fixes    = [[prefix "-" (\fc x -> PApp fc (PRef fc [fc] (sUN "negate")) [pexp x])]] ++-     toTable (reverse fixes) +++      toTable (reverse fixes) ++      [[backtick],       [binary "$" (\fc x y -> flatten $ PApp fc x [pexp y]) AssocRight],       [binary "="  (\fc x y -> PApp fc (PRef fc [fc] eqTy) [pexp x, pexp y]) AssocLeft],
src/Idris/ProofSearch.hs view
@@ -305,7 +305,7 @@         = simple_app False (tryLocalArg d locs tys n (i - 1))                 (psRec True d locs tys) "proof search local apply" -    -- Like type class resolution, but searching with constructors+    -- Like interface resolution, but searching with constructors     tryCon d locs tys n =          do ty <- goal             let imps = case lookupCtxtExact n (idris_implicits ist) of@@ -336,8 +336,8 @@          (Bind _ (Pi _ _ _) _) -> [TextPart "In particular, function types are not supported."]          _ -> [] --- | Resolve type classes. This will only pick up 'normal' instances, never--- named instances (which is enforced by 'findInstances').+-- | Resolve interfaces. This will only pick up 'normal' implementations, never+-- named implementations (which is enforced by 'findInstances'). resolveTC :: Bool -- ^ using default Int           -> Bool -- ^ allow metavariables in the goal           -> Int -- ^ depth@@ -349,7 +349,7 @@    = do hs <- get_holes         resTC' [] def hs depth top fn elab ist -resTC' tcs def topholes 0 topg fn elab ist = fail $ "Can't resolve type class"+resTC' tcs def topholes 0 topg fn elab ist = fail $ "Can't resolve interface" resTC' tcs def topholes 1 topg fn elab ist = try' (trivial elab ist) (resolveTC def False 0 topg fn elab ist) True resTC' tcs defaultOn topholes depth topg fn elab ist   = do compute@@ -465,7 +465,7 @@     solven n = replicateM_ n solve      resolve n depth-       | depth == 0 = fail $ "Can't resolve type class"+       | depth == 0 = fail $ "Can't resolve interface"        | otherwise            = do lams <- introImps                 t <- goal@@ -483,7 +483,7 @@                 solven lams -- close any implicit lambdas we introduced                 ps' <- get_probs                 when (length ps < length ps' || unrecoverable ps') $-                     fail "Can't apply type class"+                     fail "Can't apply interface" --                 traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $                 mapM_ (\ (_,n) -> do focus n                                      t' <- goal@@ -501,8 +501,8 @@        where isImp (PImp p _ _ _ _) = (True, p)              isImp arg = (False, priority arg) --- | Find the names of instances that have been designeated for--- searching (i.e. non-named instances or instances from Elab scripts)+-- | Find the names of implementations that have been designeated for+-- searching (i.e. non-named implementations or implementations from Elab scripts) findInstances :: IState -> Term -> [Name] findInstances ist t     | (P _ n _, _) <- unApply (getRetTy t)
src/Idris/REPL.hs view
@@ -2,7 +2,8 @@              PatternGuards, CPP #-}  module Idris.REPL(getClient, getPkg, getPkgCheck, getPkgClean, getPkgMkDoc,-                  getPkgREPL, getPkgTest, getPort, idris, idrisMain, loadInputs,+                  getPkgREPL, getPkgTest, getPort, getIBCSubDir,+                  idris, idrisMain, loadInputs,                   opt, runClient, runMain, ver) where  import Idris.AbsSyntax
src/Pkg/Package.hs view
@@ -17,6 +17,8 @@  import Data.List import Data.List.Split(splitOn)+import Data.Maybe(fromMaybe)+import Data.Either(partitionEithers)  import Idris.Core.TT import Idris.REPL@@ -27,6 +29,7 @@ import Idris.IBC import Idris.Output import Idris.Imports+import Idris.Error (ifail)  import Pkg.PParser @@ -39,165 +42,234 @@ -- * invoke idris on each module, with idris_opts -- * install everything into datadir/pname, if install flag is set +--  --------------------------------------------------------- [ Build Packages ]+ -- | Run the package through the idris compiler.-buildPkg :: Bool -> (Bool, FilePath) -> IO ()-buildPkg warnonly (install, fp)-     = do pkgdesc <- parseDesc fp-          dir <- getCurrentDirectory-          let idx = PkgIndex (pkgIndex (pkgname pkgdesc))-          ok <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)-          when (and ok) $-            do m_ist <- inPkgDir pkgdesc $-                          do make (makefile pkgdesc)-                             case (execout pkgdesc) of-                               Nothing -> buildMods (idx : NoREPL : Verbose : idris_opts pkgdesc)-                                                    (modules pkgdesc)-                               Just o -> do let exec = dir </> o-                                            buildMods-                                              (idx : NoREPL : Verbose : Output exec : idris_opts pkgdesc)-                                              [idris_main pkgdesc]-               case m_ist of-                    Nothing -> exitWith (ExitFailure 1)-                    Just ist -> do-                       -- Quit with error code if there was a problem-                       case errSpan ist of-                            Just _ -> exitWith (ExitFailure 1)-                            _ -> return ()-                       when install $ installPkg pkgdesc+buildPkg :: [Opt]            -- ^ Command line options+         -> Bool             -- ^ Provide Warnings+         -> (Bool, FilePath) -- ^ (Should we install, Location of iPKG file)+         -> IO ()+buildPkg copts warnonly (install, fp) = do+  pkgdesc <- parseDesc fp+  dir <- getCurrentDirectory+  let idx = PkgIndex (pkgIndex (pkgname pkgdesc))+  oks <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)+  when (and oks) $ do+    m_ist <- inPkgDir pkgdesc $ do +      make (makefile pkgdesc)+      case (execout pkgdesc) of+        Nothing -> do+          case mergeOptions copts (idx : NoREPL : Verbose : idris_opts pkgdesc) of+            Left emsg -> do+              putStrLn emsg+              exitWith (ExitFailure 1)+            Right opts -> buildMods opts (modules pkgdesc)+        Just o -> do+          let exec = dir </> o+          case mergeOptions copts (idx : NoREPL : Verbose : Output exec : idris_opts pkgdesc) of+            Left emsg -> do+              putStrLn emsg+              exitWith (ExitFailure 1)+            Right opts -> buildMods opts [idris_main pkgdesc]+    case m_ist of+      Nothing  -> exitWith (ExitFailure 1)+      Just ist -> do+        -- Quit with error code if there was a problem+        case errSpan ist of+          Just _ -> exitWith (ExitFailure 1)+          _      -> return ()+        when install $ installPkg (opt getIBCSubDir copts) pkgdesc++--  --------------------------------------------------------- [ Check Packages ]+ -- | Type check packages only -- -- This differs from build in that executables are not built, if the -- package contains an executable.-checkPkg :: Bool         -- ^ Show Warnings-            -> Bool      -- ^ quit on failure-            -> FilePath  -- ^ Path to ipkg file.-            -> IO ()-checkPkg warnonly quit fpath-  = do pkgdesc <- parseDesc fpath-       ok <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)-       when (and ok) $-         do res <- inPkgDir pkgdesc $-                     do make (makefile pkgdesc)-                        buildMods (NoREPL : Verbose : idris_opts pkgdesc)-                                  (modules pkgdesc)-            when quit $ case res of-                          Nothing -> exitWith (ExitFailure 1)-                          Just res' -> do-                            case errSpan res' of-                              Just _ -> exitWith (ExitFailure 1)-                              _ -> return ()+checkPkg :: [Opt]     -- ^ Command line Options+         -> Bool      -- ^ Show Warnings+         -> Bool      -- ^ quit on failure+         -> FilePath  -- ^ Path to ipkg file.+         -> IO ()+checkPkg copts warnonly quit fpath = do+  pkgdesc <- parseDesc fpath+  oks <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)+  when (and oks) $ do+    res <- inPkgDir pkgdesc $ do+      make (makefile pkgdesc) --- | Check a package and start a REPL-replPkg :: FilePath -> Idris ()-replPkg fp = do orig <- getIState-                runIO $ checkPkg False False fp-                pkgdesc <- runIO $ parseDesc fp -- bzzt, repetition!-                let opts = idris_opts pkgdesc-                let mod = idris_main pkgdesc-                let f = toPath (showCG mod)-                putIState orig-                dir <- runIO $ getCurrentDirectory-                runIO $ setCurrentDirectory $ dir </> sourcedir pkgdesc+      case mergeOptions copts (NoREPL : Verbose : idris_opts pkgdesc) of+        Left emsg -> do+          putStrLn emsg+          exitWith (ExitFailure 1)+        Right opts -> do+          buildMods opts (modules pkgdesc)+    when quit $ case res of+                  Nothing -> exitWith (ExitFailure 1)+                  Just res' -> do+                    case errSpan res' of+                      Just _ -> exitWith (ExitFailure 1)+                      _      -> return () -                if (f /= "")-                   then idrisMain ((Filename f) : opts)-                   else iputStrLn "Can't start REPL: no main module given"-                runIO $ setCurrentDirectory dir+--  ------------------------------------------------------------------- [ REPL ] -    where toPath n = foldl1' (</>) $ splitOn "." n+-- | Check a package and start a REPL.+--+-- This function only works with packages that have a main module.+--+replPkg :: [Opt]    -- ^ Command line Options+        -> FilePath -- ^ Path to ipkg file.+        -> Idris ()+replPkg copts fp = do+    orig <- getIState+    runIO $ checkPkg copts False False fp+    pkgdesc <- runIO $ parseDesc fp -- bzzt, repetition! +    case mergeOptions copts (idris_opts pkgdesc) of+      Left emsg  -> ifail emsg+      Right opts -> do+        let mod = idris_main pkgdesc+        let f = toPath (showCG mod)+        putIState orig+        dir <- runIO $ getCurrentDirectory+        runIO $ setCurrentDirectory $ dir </> sourcedir pkgdesc++        if (f /= "")+          then idrisMain ((Filename f) : opts)+          else iputStrLn "Can't start REPL: no main module given"+        runIO $ setCurrentDirectory dir++  where+    toPath n = foldl1' (</>) $ splitOn "." n++--  --------------------------------------------------------------- [ Cleaning ]+ -- | Clean Package build files-cleanPkg :: FilePath -- ^ Path to ipkg file.+cleanPkg :: [Opt]    -- ^ Command line options.+         -> FilePath -- ^ Path to ipkg file.          -> IO ()-cleanPkg fp-     = do pkgdesc <- parseDesc fp-          dir <- getCurrentDirectory-          inPkgDir pkgdesc $-            do clean (makefile pkgdesc)-               mapM_ rmIBC (modules pkgdesc)-               rmIdx (pkgname pkgdesc)-               case execout pkgdesc of-                    Nothing -> return ()-                    Just s -> rmExe $ dir </> s+cleanPkg copts fp = do+  pkgdesc <- parseDesc fp+  dir <- getCurrentDirectory+  inPkgDir pkgdesc $ do+    clean (makefile pkgdesc)+    mapM_ rmIBC (modules pkgdesc)+    rmIdx (pkgname pkgdesc)+    case execout pkgdesc of+      Nothing -> return ()+      Just s -> rmExe $ dir </> s +--  ------------------------------------------------------ [ Generate IdrisDoc ]++ -- | Generate IdrisDoc for package -- TODO: Handle case where module does not contain a matching namespace --       E.g. from prelude.ipkg: IO, Prelude.Chars, Builtins -- -- Issue number #1572 on the issue tracker --       https://github.com/idris-lang/Idris-dev/issues/1572-documentPkg :: FilePath -- ^ Path to .ipkg file.+documentPkg :: [Opt]    -- ^ Command line options.+            -> FilePath -- ^ Path to ipkg file.             -> IO ()-documentPkg fp =-  do pkgdesc        <- parseDesc fp-     cd             <- getCurrentDirectory-     let pkgDir      = cd </> takeDirectory fp-         outputDir   = cd </> pkgname pkgdesc ++ "_doc"-         opts        = NoREPL : Verbose : idris_opts pkgdesc-         mods        = modules pkgdesc-         fs          = map (foldl1' (</>) . splitOn "." . showCG) mods-     setCurrentDirectory $ pkgDir </> sourcedir pkgdesc-     make (makefile pkgdesc)-     setCurrentDirectory pkgDir-     let run l       = runExceptT . execStateT l-         load []     = return ()-         load (f:fs) = do loadModule f IBC_Building; load fs-         loader      = do idrisMain opts; addImportDir (sourcedir pkgdesc); load fs-     idrisInstance  <- run loader idrisInit-     setCurrentDirectory cd-     case idrisInstance of-          Left  err -> do putStrLn $ pshow idrisInit err; exitWith (ExitFailure 1)-          Right ist ->-                do docRes <- generateDocs ist mods outputDir-                   case docRes of-                        Right _  -> return ()-                        Left msg -> do putStrLn msg-                                       exitWith (ExitFailure 1)+documentPkg copts fp = do+  pkgdesc        <- parseDesc fp+  cd             <- getCurrentDirectory+  let pkgDir      = cd </> takeDirectory fp+      outputDir   = cd </> pkgname pkgdesc ++ "_doc"+      popts       = NoREPL : Verbose : idris_opts pkgdesc+      mods        = modules pkgdesc+      fs          = map (foldl1' (</>) . splitOn "." . showCG) mods+  setCurrentDirectory $ pkgDir </> sourcedir pkgdesc+  make (makefile pkgdesc)+  setCurrentDirectory pkgDir+  case mergeOptions copts popts of+    Left emsg -> do+      putStrLn emsg+      exitWith (ExitFailure 1)+    Right opts -> do+      let run l       = runExceptT . execStateT l+          load []     = return ()+          load (f:fs) = do loadModule f IBC_Building; load fs+          loader      = do+            idrisMain opts+            addImportDir (sourcedir pkgdesc)+            load fs+      idrisInstance  <- run loader idrisInit+      setCurrentDirectory cd+      case idrisInstance of+        Left  err -> do+          putStrLn $ pshow idrisInit err+          exitWith (ExitFailure 1)+        Right ist -> do+          docRes <- generateDocs ist mods outputDir+          case docRes of+            Right _  -> return ()+            Left msg -> do+              putStrLn msg+              exitWith (ExitFailure 1) +--  ------------------------------------------------------------------- [ Test ]+ -- | Build a package with a sythesized main function that runs the tests-testPkg :: FilePath -> IO ()-testPkg fp-     = do pkgdesc <- parseDesc fp-          ok <- mapM (testLib True (pkgname pkgdesc)) (libdeps pkgdesc)-          when (and ok) $-            do m_ist <- inPkgDir pkgdesc $-                          do make (makefile pkgdesc)-                             -- Get a temporary file to save the tests' source in-                             (tmpn, tmph) <- tempfile ".idr"-                             hPutStrLn tmph $-                               "module Test_______\n" ++-                               concat ["import " ++ show m ++ "\n"-                                       | m <- modules pkgdesc] ++-                               "namespace Main\n" ++-                               "  main : IO ()\n" ++-                               "  main = do " ++-                               concat [show t ++ "\n            "-                                       | t <- idris_tests pkgdesc]-                             hClose tmph-                             (tmpn', tmph') <- tempfile ""-                             hClose tmph'-                             m_ist <- idris (Filename tmpn : NoREPL : Verbose : Output tmpn' : idris_opts pkgdesc)-                             rawSystem tmpn' []-                             return m_ist-               case m_ist of-                 Nothing -> exitWith (ExitFailure 1)-                 Just ist -> do-                    -- Quit with error code if problem building-                    case errSpan ist of-                      Just _ -> exitWith (ExitFailure 1)-                      _      -> return ()+testPkg :: [Opt]     -- ^ Command line options.+        -> FilePath  -- ^ Path to ipkg file.+        -> IO ()+testPkg copts fp = do+  pkgdesc <- parseDesc fp+  ok <- mapM (testLib True (pkgname pkgdesc)) (libdeps pkgdesc)+  when (and ok) $ do+    m_ist <- inPkgDir pkgdesc $ do+      make (makefile pkgdesc)+      -- Get a temporary file to save the tests' source in+      (tmpn, tmph) <- tempfile ".idr"+      hPutStrLn tmph $+          "module Test_______\n" +++          concat ["import " ++ show m ++ "\n" | m <- modules pkgdesc]+              ++ "namespace Main\n"+              ++ "  main : IO ()\n"+              ++ "  main = do "+              ++ concat [ show t ++ "\n            "+                        | t <- idris_tests pkgdesc]+      hClose tmph+      (tmpn', tmph') <- tempfile ""+      hClose tmph'+      let popts = (Filename tmpn : NoREPL : Verbose : Output tmpn' : idris_opts pkgdesc)+      case mergeOptions copts popts of+        Left emsg -> do+          putStrLn emsg+          exitWith (ExitFailure 1)+        Right opts -> do+          m_ist <- idris opts+          rawSystem tmpn' []+          return m_ist+    case m_ist of+      Nothing  -> exitWith (ExitFailure 1)+      Just ist -> do+        -- Quit with error code if problem building+        case errSpan ist of+          Just _ -> exitWith (ExitFailure 1)+          _      -> return () +--  ----------------------------------------------------------- [ Installation ]+ -- | Install package-installPkg :: PkgDesc -> IO ()-installPkg pkgdesc-     = inPkgDir pkgdesc $-         do case (execout pkgdesc) of-              Nothing -> do mapM_ (installIBC (pkgname pkgdesc)) (modules pkgdesc)-                            installIdx (pkgname pkgdesc)-              Just o -> return () -- do nothing, keep executable locally, for noe-            mapM_ (installObj (pkgname pkgdesc)) (objs pkgdesc)+installPkg :: [String]  -- ^ Alternate install location+           -> PkgDesc   -- ^ iPKG file.+           -> IO ()+installPkg altdests pkgdesc = inPkgDir pkgdesc $ do+  d <- getTargetDir+  let destdir = case altdests of+                  []     -> d+                  (d':_) -> d'+  case (execout pkgdesc) of+    Nothing -> do+      mapM_ (installIBC destdir (pkgname pkgdesc)) (modules pkgdesc)+      installIdx destdir (pkgname pkgdesc)+    Just o -> return () -- do nothing, keep executable locally, for noe +  mapM_ (installObj destdir (pkgname pkgdesc)) (objs pkgdesc)+ -- ---------------------------------------------------------- [ Helper Methods ] -- Methods for building, testing, installing, and removal of idris -- packages.@@ -240,33 +312,34 @@ toIBCFile (UN n) = str n ++ ".ibc" toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : map str ns)) -installIBC :: String -> Name -> IO ()-installIBC p m = do let f = toIBCFile m-                    d <- getTargetDir-                    let destdir = d </> p </> getDest m-                    putStrLn $ "Installing " ++ f ++ " to " ++ destdir-                    createDirectoryIfMissing True destdir-                    copyFile f (destdir </> takeFileName f)-                    return ()-    where getDest (UN n) = ""-          getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : map str ns))+installIBC :: String -> String -> Name -> IO ()+installIBC dest p m = do+    let f = toIBCFile m+    let destdir = dest </> p </> getDest m+    putStrLn $ "Installing " ++ f ++ " to " ++ destdir+    createDirectoryIfMissing True destdir+    copyFile f (destdir </> takeFileName f)+    return ()+  where+    getDest (UN n) = ""+    getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : map str ns)) -installIdx :: String -> IO ()-installIdx p = do d <- getTargetDir-                  let f = pkgIndex p-                  let destdir = d </> p -                  putStrLn $ "Installing " ++ f ++ " to " ++ destdir-                  createDirectoryIfMissing True destdir-                  copyFile f (destdir </> takeFileName f)-                  return ()+installIdx :: String -> String -> IO ()+installIdx dest p = do+  let f = pkgIndex p+  let destdir = dest </> p+  putStrLn $ "Installing " ++ f ++ " to " ++ destdir+  createDirectoryIfMissing True destdir+  copyFile f (destdir </> takeFileName f)+  return () -installObj :: String -> String -> IO ()-installObj p o = do d <- getTargetDir-                    let destdir = addTrailingPathSeparator (d </> p)-                    putStrLn $ "Installing " ++ o ++ " to " ++ destdir-                    createDirectoryIfMissing True destdir-                    copyFile o (destdir </> takeFileName o)-                    return ()+installObj :: String -> String -> String -> IO ()+installObj dest p o = do+  let destdir = addTrailingPathSeparator (dest </> p)+  putStrLn $ "Installing " ++ o ++ " to " ++ destdir+  createDirectoryIfMissing True destdir+  copyFile o (destdir </> takeFileName o)+  return ()  #ifdef mingw32_HOST_OS mkDirCmd = "mkdir "@@ -298,5 +371,60 @@ clean Nothing = return () clean (Just s) = do rawSystem "make" ["-f", s, "clean"]                     return ()++-- | Merge an option list representing the command line options into+-- those specified for a package description.+--+-- This is not a complete union between the two options sets. First,+-- to prevent important package specified options from being+-- overwritten. Second, the semantics for this merge are not fully+-- defined.+--+-- A discussion for this is on the issue tracker:+--     https://github.com/idris-lang/Idris-dev/issues/1448+--+mergeOptions :: [Opt] -- ^ The command line options+             -> [Opt] -- ^ The package options+             -> Either String [Opt]+mergeOptions copts popts =+    case partitionEithers (map chkOpt (normaliseOpts copts)) of+      ([], copts') -> Right $ copts' ++ popts+      (es, _)      -> Left  $ genErrMsg es+  where+    normaliseOpts :: [Opt] -> [Opt]+    normaliseOpts = filter filtOpt++    filtOpt :: Opt -> Bool+    filtOpt (PkgBuild   _) = False+    filtOpt (PkgInstall _) = False+    filtOpt (PkgClean   _) = False+    filtOpt (PkgCheck   _) = False+    filtOpt (PkgREPL    _) = False+    filtOpt (PkgMkDoc   _) = False+    filtOpt (PkgTest    _) = False+    filtOpt _              = True++    chkOpt :: Opt -> Either String Opt+    chkOpt o@(OLogging _)     = Right o+    chkOpt o@(OLogCats _)     = Right o+    chkOpt o@(DefaultTotal)   = Right o+    chkOpt o@(DefaultPartial) = Right o+    chkOpt o@(WarnPartial)    = Right o+    chkOpt o@(WarnReach)      = Right o+    chkOpt o@(IBCSubDir _)    = Right o+    chkOpt o@(ImportDir _ )   = Right o+    chkOpt o@(UseCodegen _)   = Right o+    chkOpt o                  = Left (unwords ["\t", show o, "\n"])++    genErrMsg :: [String] -> String+    genErrMsg es = unlines+        [ "Not all command line options can be used to override package options."+        , "\nThe only changeable options are:"+        , "\t--log <lvl>, --total, --warnpartial, --warnreach"+        , "\t--ibcsubdir <path>, -i --idrispath <path>"+        , "\t--logging-categories <cats>"+        , "\nThe options need removing are:"+        , unlines es+        ]  -- --------------------------------------------------------------------- [ EOF ]
stack.yaml view
@@ -1,4 +1,4 @@-resolver: lts-5.9+resolver: lts-5.11  packages:   - '.'
test/Makefile view
@@ -12,7 +12,7 @@ 	@./runtest $(patsubst %.test,%,$@) -q  test_js: runtest-	@./runtest without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 ffi007 ffi008 primitives005 primitives006 opts --codegen node+	@./runtest without tutorial007 sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 ffi007 ffi008 primitives005 primitives006 views003 opts --codegen node  update: runtest 	@./runtest all -u
+ test/directives001/directives001.idr view
@@ -0,0 +1,28 @@+module directives001++%access export+++data Foo = MkFoo String++%deprecate Foo "To be replaced with `Bar`."++data Bar : Type where+    MkBar : Nat -> Nat -> Bar+++mkFoo : String -> Foo+mkFoo = MkFoo++%deprecate mkFoo "To be replaced with `mkBar`."++mkBar : Nat -> Bar+mkBar a = MkBar a a++%fragile mkBar "How `Bar`s are to be created is still being discussed, `mkBar` is subject to change."++namespace Main+  main : IO ()+  main = do+    let b = mkBar 1+    putStrLn $ "Hello World"
+ test/directives001/expected view
@@ -0,0 +1,14 @@+directives001.idr:14:7:Use of deprecated name directives001.Foo+To be replaced with `Bar`.+directives001.idr:14:7:Use of deprecated name directives001.Foo+To be replaced with `Bar`.+directives001.idr:15:7:Use of deprecated name directives001.Foo+To be replaced with `Bar`.+directives001.idr:15:7:Use of deprecated name directives001.Foo+To be replaced with `Bar`.+directives001.idr:26:8:+Use of a fragile construct directives001.mkBar+How `Bar`s are to be created is still being discussed, `mkBar` is subject to change.+directives001.idr:26:8:+Use of a fragile construct directives001.mkBar+How `Bar`s are to be created is still being discussed, `mkBar` is subject to change.
+ test/directives001/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ directives001.idr --check --nocolour++rm -f directives001 *.ibc
+ test/error006/WithPatsNoWith.idr view
@@ -0,0 +1,6 @@+module WithPatsNoWith++foo : Int -> Bool+foo 1 | 2 | 3 = True+foo _ = False+
+ test/error006/expected view
@@ -0,0 +1,2 @@+WithPatsNoWith.idr:4:5:When checking left hand side of foo:+unexpected patterns outside of "with" block
+ test/error006/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ --check --nocolour WithPatsNoWith.idr+rm -f *.ibc
+ test/error007/error007.idr view
@@ -0,0 +1,29 @@+module Main++import CFFI++string_from_c : Ptr -> IO String+string_from_c str = foreign FFI_C "make_string_2" (Ptr -> IO String) str++connection_information_struct : Composite+connection_information_struct = STRUCT [I8, PTR, PTR, PTR, I32]++send_page : (conn : Ptr) -> (text : String) -> (code : Int) -> IO Int+send_page conn page code = pure (the Int 1)++-- Error here was using the error from the 'do' block without 'Delay' applied,+-- which ended up looking very strange... elaborator should take the first+-- error (from the delayed block) when elaborating arguments which may or may+-- not need a delay+answer_to_connection : Ptr -> Ptr -> IO Int+answer_to_connection conn conn_info = do+  code_fld <- pure $ (connection_information_struct#4) conn_info+  code <- peek I32 code_fld+  answer_fld <- pure $ (connection_information_struct#1) conn_info+  answer <- peek PTR answer_fld+  if answer /= null then do+      str <- string_from_c answer+      send_page conn str code -- (prim__zextB32_Int code)+    else do+      send_page conn str (prim__zextB32_Int code)+
+ test/error007/expected view
@@ -0,0 +1,15 @@+error007.idr:26:17:+When checking right hand side of answer_to_connection with expected type+        IO Int++When checking argument code to function Main.send_page:+        Type mismatch between+                translate I32 (Type of code)+        and+                Int (Expected type)+        +        Specifically:+                Type mismatch between+                        Bits32+                and+                        Int
+ test/error007/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ --check --nocolour error007.idr -p contrib+rm -f *.ibc
+ test/error008/error008.idr view
@@ -0,0 +1,5 @@+import Data.Vect++s2 : x + sum Nil = x * fromInteger 0+s2 = Refl+
+ test/error008/error008a.idr view
@@ -0,0 +1,5 @@+import Data.Vect++s1 : Num a => {x : a} -> x + sum {a} Nil = x -- * fromInteger 0+s1 = Refl+
+ test/error008/expected view
@@ -0,0 +1,4 @@+error008.idr:3:4:When checking type of Main.s2:+Can't disambiguate name: Prelude.List.Nil, Data.Vect.Nil+error008a.idr:3:4:When checking type of Main.s1:+Can't disambiguate name: Prelude.List.Nil, Data.Vect.Nil
+ test/error008/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ --check --nocolour error008.idr+${IDRIS:-idris} $@ --check --nocolour error008a.idr+rm -f *.ibc
test/ffi004/theOtherType view
@@ -1,1 +1,1 @@-Nat+When `fromFile` reads me it will provide the default type Nat.
test/interactive001/expected view
@@ -7,7 +7,7 @@ isElem2 x (y :: ys) with (_)   isElem2 x (y :: ys) | with_pat = ?isElem2_rhs -  isElem3 x (x :: ys) | (Yes Refl) = ?isElem3_rhs_3+  isElem3 y (y :: ys) | (Yes Refl) = ?isElem3_rhs_3                [] => ?bar_1               (x :: ys) => ?bar_2
+ test/interactive013/expected view
@@ -0,0 +1,4 @@+gcd aa (aa + (S y)) (CmpLT y) = ?gcd_rhs_1+gcd bb bb CmpEQ = ?gcd_rhs_2+gcd (bb + (S x)) bb (CmpGT x) = ?gcd_rhs_3+
+ test/interactive013/input view
@@ -0,0 +1,1 @@+:cs 3 cc
+ test/interactive013/interactive013.idr view
@@ -0,0 +1,4 @@++gcd : (x : Nat) -> (y : Nat) -> CmpNat x y -> Nat+gcd aa bb cc = ?gcd_rhs+
+ test/interactive013/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} --quiet interactive013.idr < input+rm -f *.ibc
test/meta001/Finite.idr view
@@ -56,8 +56,8 @@ mkOk2Clause : TTName -> (size, i : Nat) -> (constr : (TTName, List CtorArg, Raw)) -> Elab (FunClause Raw) mkOk2Clause fn size i (n, [], Var ty) =   return $ MkFunClause (RApp (Var fn) !(mkFin size i))-                       [| (Var "Refl") `(Fin ~(quote size))-                                       !(mkFin size i) |]+                       [| (Var `{Refl}) `(Fin ~(quote size))+                                        !(mkFin size i) |] mkOk2Clause fn size i (n, _, ty) =   fail [TextPart "unsupported constructor", NamePart n]
test/meta002/AgdaStyleReflection.idr view
@@ -40,12 +40,6 @@   | Constant Const   | Ty -implementation Quotable Plicity Raw where-  quotedTy = `(Plicity)-  quote Explicit = `(Explicit)-  quote Implicit = `(Implicit)-  quote Constraint = `(Constraint)- implementation (Quotable a Raw) => Quotable (Arg a) Raw where   quotedTy = `(Arg ~(quotedTy {a=a}))   quote (MkArg plicity argValue) =
test/meta002/expected view
@@ -6,7 +6,7 @@         DPair Ty (Tm [])  Unifying ty and ARR ty t would lead to infinite value-AgdaStyleReflection.idr:321:5:+AgdaStyleReflection.idr:315:5: When checking right hand side of baz with expected type         (Nat, Void)
test/pkg001/expected view
@@ -0,0 +1,19 @@+Not all command line options can be used to override package options.++The only changeable options are:+	--log <lvl>, --total, --warnpartial, --warnreach+	--ibcsubdir <path>, -i --idrispath <path>+	--logging-categories <cats>++The options need removing are:+	 Quiet ++++Elaborating {__Infer0}+builtin+Elaborating =+builtin+Elaborating type decl Main.main[]+Elaborating clause Main.main+Rechecking for positivity []
test/pkg001/run view
@@ -1,3 +1,5 @@ #!/usr/bin/env bash ${IDRIS:-idris} $@ --build test.ipkg rm -f  *.ibc+${IDRIS:-idris} $@ --build test.ipkg --quiet+${IDRIS:-idris} $@ --build test.ipkg --logging-categories "elab" --log 1
test/primitives006/run view
@@ -3,4 +3,4 @@ ${IDRIS:-idris} $@ -o load-test load-test.idr --nocolour --warnreach ./load-test rm -f load-test *.o *.ibc-find -name \*.ibc -delete+rm -f Data/*.ibc
+ test/proof011/expected view
@@ -0,0 +1,12 @@+proof011.idr:19:9:+When checking right hand side of vassoc' with expected type+        (x :: xs) ++ ys ++ zs = ((x :: xs) ++ ys) ++ zs++rewrite did not change type x :: xs ++ ys ++ zs =+                            x :: (xs ++ ys) ++ zs+proof011a.idr:13:9:+When checking right hand side of vassoc' with expected type+        (x :: xs) ++ ys ++ zs = ((x :: xs) ++ ys) ++ zs++rewrite did not change type x :: xs ++ ys ++ zs =+                            x :: (xs ++ ys) ++ zs
+ test/proof011/proof011.idr view
@@ -0,0 +1,21 @@+import Data.Vect++vreplace : {xs : Vect n a} -> {ys : Vect m a} ->+           (P : {len : Nat} -> Vect len a -> Type) ->+           xs = ys -> P ys -> P xs+vreplace P Refl prop = prop++total+vassoc : (xs : Vect n a) -> (ys : Vect m a) -> (zs : Vect p a) ->+         xs ++ (ys ++ zs) = (xs ++ ys) ++ zs+vassoc [] ys zs = Refl+vassoc (x :: xs) ys zs +    = rewrite vassoc xs ys zs using vreplace in +              Refl+total+vassoc' : (xs : Vect n a) -> (ys : Vect m a) -> (zs : Vect p a) ->+         xs ++ (ys ++ zs) = (xs ++ ys) ++ zs+vassoc' [] ys zs = Refl+vassoc' (x :: xs) ys zs +    = rewrite vassoc xs ys xs using vreplace in +              Refl
+ test/proof011/proof011a.idr view
@@ -0,0 +1,14 @@+import Data.Vect++total+vassoc : (xs : Vect n a) -> (ys : Vect m a) -> (zs : Vect p a) ->+         xs ++ (ys ++ zs) = (xs ++ ys) ++ zs+vassoc [] ys zs = Refl+vassoc (x :: xs) ys zs +    = rewrite vassoc xs ys zs in Refl+total+vassoc' : (xs : Vect n a) -> (ys : Vect m a) -> (zs : Vect p a) ->+         xs ++ (ys ++ zs) = (xs ++ ys) ++ zs+vassoc' [] ys zs = Refl+vassoc' (x :: xs) ys zs +    = rewrite vassoc xs ys xs in Refl
+ test/proof011/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ proof011.idr --nocolour --check+${IDRIS:-idris} $@ proof011a.idr --nocolour --check+rm -f *.ibc
test/reg006/expected view
@@ -1,2 +1,2 @@ reg006.idr:17:1:-RBTree.lookup is possibly not total due to: RBTree.case block in lookup at reg006.idr:19:8+RBTree.lookup is possibly not total due to recursive path RBTree.lookup --> RBTree.lookup
test/reg006/reg006.idr view
@@ -12,7 +12,7 @@ toBlack Leaf = (_ ** (Leaf, Left Refl)) toBlack (BlackBranch k v l r) = (_ ** (BlackBranch k v l r, Left Refl)) -total+total -- Yes, but the checker can't spot it lookup : Ord k => k -> RBTree k v n Black -> Maybe v lookup k Leaf = Nothing lookup k (BlackBranch k0 v0 l r) =@@ -20,7 +20,8 @@     EQ => Just v0     LT =>       let (_ ** (t, _)) = toBlack l in-            lookup k t+            lookup k t -- The checker can't tell that 't' is always +                       -- the same size as 'l'     GT =>       let (_ ** (t, _)) = toBlack r in             lookup k t
test/reg018/expected view
@@ -1,9 +1,9 @@ reg018a.idr:16:1:-conat.minusCoNat is possibly not total due to recursive path conat.minusCoNat+conat.minusCoNat is possibly not total due to recursive path conat.minusCoNat --> conat.minusCoNat reg018a.idr:21:1: conat.loopForever is possibly not total due to: conat.minusCoNat reg018b.idr:8:1:-A.showB is possibly not total due to recursive path A.showB+A.showB is possibly not total due to recursive path A.showB --> A.showB reg018b.idr:11:1: A.B implementation of Prelude.Show.Show is possibly not total due to: A.showB reg018c.idr:21:1:
+ test/reg071/expected view
+ test/reg071/reg071.idr view
@@ -0,0 +1,19 @@+mutual+  data Odd : Type where+       MkOdd : Even -> Odd++  data Even : Type where+       MkEven : Odd -> Even +       EvenZ : Even++mutual+  total+  countEven : Even -> Nat+  countEven (MkEven x) = countOdd x+  countEven EvenZ = Z++  total+  countOdd : Odd -> Nat+  countOdd (MkOdd x) = S (countEven x)+  +
+ test/reg071/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ reg071.idr --check+rm -f *.ibc
+ test/reg072/DoubleEquality.idr view
@@ -0,0 +1,5 @@+module DoubleEquality++oops : Void+oops = the ((False = True) -> Void) (\Refl impossible) $ cong {f = (>0) . (1/)} $ the (-0.0 = 0.0) Refl+
+ test/reg072/expected view
@@ -0,0 +1,15 @@+DoubleEquality.idr:4:87:+When checking right hand side of oops with expected type+        Void++When checking argument value to function Prelude.Basics.the:+        Type mismatch between+                x = x (Type of Refl)+        and+                negate 0.0 = 0.0 (Expected type)+        +        Specifically:+                Type mismatch between+                        -0.0+                and+                        0.0
+ test/reg072/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ DoubleEquality.idr --check+rm -f *.ibc
test/tactics001/Tactics.idr view
@@ -18,15 +18,15 @@ plusZeroRightNeutralNew : (n : Nat) -> plus n 0 = n plusZeroRightNeutralNew Z = Refl plusZeroRightNeutralNew (S k) =-  %runElab (do rewriteWith `(sym $ plusZeroRightNeutralNew ~(Var "k"))-               fill $ refl `(Nat : Type) `(S ~(Var (UN "k")))+  %runElab (do rewriteWith `(sym $ plusZeroRightNeutralNew ~(Var `{k}))+               fill $ refl `(Nat : Type) `(S ~(Var `{k}))                solve)  plusSuccRightSuccNew : (j, k : Nat) -> plus j (S k) = S (plus j k) plusSuccRightSuccNew Z k = Refl plusSuccRightSuccNew (S j) k =-  %runElab (do rewriteWith `(sym $ plusSuccRightSuccNew ~(Var "j") ~(Var (UN "k")))-               fill $ refl `(Nat : Type) `(S (S (plus ~(Var (UN "j")) ~(Var (UN "k")))))+  %runElab (do rewriteWith `(sym $ plusSuccRightSuccNew ~(Var `{j}) ~(Var `{k}))+               fill $ refl `(Nat : Type) `(S (S (plus ~(Var `{j}) ~(Var `{k}))))                solve)  -- Test that side effects in new tactics work
test/totality004/totality004a.idr view
@@ -22,4 +22,3 @@  main : IO () main = printLn (take 10 (process doubleInt (countStream 1)))-
test/totality009/TestLambdaPossible.idr view
@@ -11,3 +11,4 @@ wrongPossible' : Nool True -> Bool wrongPossible' x = case x of                         Flase impossible+
+ test/totality009/TestLambdaPossible2.idr view
@@ -0,0 +1,16 @@+||| Some functions that should be non-total+module TestLambdaPossible++data Nool : Bool -> Type where+  Flase : Nool False+  Ture : Nool True++total+wrongPossible : Nool True -> Bool+wrongPossible = (\Flase impossible)++total+wrongPossible' : Nool True -> Bool+wrongPossible' x = case x of+                        Flase impossible+
test/totality009/expected view
@@ -6,3 +6,5 @@ TestLambdaPossible.idr:9:1:Warning - TestLambdaPossible.wrongPossible is possibly not total due to: TestLambdaPossible.case block in wrongPossible at TestLambdaPossible.idr:9:25 TestLambdaPossible.idr:12:16:Warning - TestLambdaPossible.case block in wrongPossible' at TestLambdaPossible.idr:12:25 is not total as there are missing cases TestLambdaPossible.idr:12:1:Warning - TestLambdaPossible.wrongPossible' is possibly not total due to: TestLambdaPossible.case block in wrongPossible' at TestLambdaPossible.idr:12:25+TestLambdaPossible2.idr:10:1:TestLambdaPossible.wrongPossible is possibly not total due to: TestLambdaPossible.case block in wrongPossible at TestLambdaPossible2.idr:10:25+TestLambdaPossible2.idr:14:1:TestLambdaPossible.wrongPossible' is possibly not total due to: TestLambdaPossible.case block in wrongPossible' at TestLambdaPossible2.idr:14:25
test/totality009/run view
@@ -2,4 +2,5 @@ OPTS="--consolewidth infinite --nocolour" ${IDRIS:-idris} "$@" $OPTS --check TestLambdaImpossible ${IDRIS:-idris} "$@" $OPTS --check --warnpartial TestLambdaPossible+${IDRIS:-idris} "$@" $OPTS --check TestLambdaPossible2 rm -f *.ibc
+ test/totality012/expected view
@@ -0,0 +1,4 @@+totality012a.idr:9:1:+Main.echo2 is possibly not total due to recursive path Main.echo2 --> Main.echo2+totality012b.idr:11:1:+Main.echo is possibly not total due to recursive path Main.echo
+ test/totality012/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ totality012.idr --check+${IDRIS:-idris} $@ totality012a.idr --check+${IDRIS:-idris} $@ totality012b.idr --check+rm -f *.ibc
+ test/totality012/totality012.idr view
@@ -0,0 +1,30 @@+%default total++data InfIO : Type -> Type where+     PutStr : String -> InfIO ()+     GetStr : InfIO String+     (>>=) : InfIO a -> (a -> Inf (InfIO b)) -> InfIO b++echo : InfIO ()+echo = do PutStr "$ "+          x <- GetStr+          PutStr (x ++ "\n")+          case (x == "quit") of+             True => PutStr "Bye!\n"+             False => do PutStr (x ++ "\n")+                         echo+echo1 : InfIO ()+echo1 = do PutStr "$ "+           x <- GetStr+           PutStr (x ++ "\n")+           case (x == "quit") of+              True => PutStr "Bye!\n"+              False => echo1++echo2 : String -> InfIO ()+echo2 x = case (x == "quit") of+               True => PutStr "Bye!\n"+               False => do PutStr "Foo"+                           echo2 x++
+ test/totality012/totality012a.idr view
@@ -0,0 +1,13 @@+%default total++data InfIO : Type -> Type where+     PutStr : String -> InfIO ()+     GetStr : InfIO String+     (>>=) : InfIO a -> (a -> Inf (InfIO b)) -> InfIO b++echo2 : String -> InfIO ()+echo2 x = case (x == "quit") of+               True => PutStr "Bye!\n"+               False => echo2 x++
+ test/totality012/totality012b.idr view
@@ -0,0 +1,18 @@+%default total++data InfIO : Type -> Type where+     PutStr : String -> InfIO ()+     GetStr : InfIO String+     (>>=) : InfIO a -> (a -> Inf (InfIO b)) -> InfIO b++bad : InfIO a -> InfIO a++echo : InfIO ()+echo = do PutStr "$ "+          x <- GetStr+          PutStr (x ++ "\n")+          case (x == "quit") of+             True => PutStr "Bye!\n"+             False => do PutStr (x ++ "\n")+                         bad echo+
+ test/totality013/expected view
@@ -0,0 +1,4 @@+totality013a.idr:5:3:+Main.foo is possibly not total due to recursive path Main.mtot --> Main.mtot --> Main.mtot --> Main.mtot+totality013a.idr:9:3:+Main.mtot is possibly not total due to recursive path Main.mtot --> Main.mtot --> Main.mtot
+ test/totality013/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ totality013.idr --check+${IDRIS:-idris} $@ totality013a.idr --check+rm -f *.ibc
+ test/totality013/totality013.idr view
@@ -0,0 +1,16 @@+mutual+  total -- old error: foo not total due to check size change graphs wrong+  foo : (a -> a -> Ordering) -> +        a -> List a -> a -> List a -> Ordering -> List a+  foo order x xs y ys _ = mtot order (x :: xs) ys++  total+  mtot : (a -> a -> Ordering) -> List a -> List a -> List a+  mtot order []      right   = right+  mtot order left    []      = left+  mtot order (x::xs) (y::ys) =+      case order x y of+           LT => x :: mtot order xs (y::ys)+           _ => y :: mtot order (x::xs) ys++
+ test/totality013/totality013a.idr view
@@ -0,0 +1,17 @@+mutual+  total -- should fail due to nonsense in mtot +  foo : (a -> a -> Ordering) -> +        a -> List a -> a -> List a -> Ordering -> List a+  foo order x xs y ys _ = mtot order (x :: xs) ys++  total+  mtot : (a -> a -> Ordering) -> List a -> List a -> List a+  mtot order []      right   = right+  mtot order left    []      = left+  mtot order (x::xs) (y::ys) =+      case order x y of+           LT => x :: mtot order xs (y::ys)+           EQ => foo order x xs y (y :: ys) EQ -- throw in some nonsense+           _ => y :: mtot order (x::xs) ys++
+ test/tutorial007/Providers.idr view
@@ -0,0 +1,27 @@+module Providers++%access export++%dynamic "./nativetypes.so"++sizeOfSizeT : IO Int+sizeOfSizeT = foreign FFI_C "sizeof_size_t" (IO Int)++public export+data NativeTypeSize = OneByte | TwoBytes | FourBytes | EightBytes++Show NativeTypeSize where+  show OneByte = "1 byte"+  show TwoBytes = "2 bytes"+  show FourBytes = "4 bytes"+  show EightBytes = "8 bytes"++bytesToType : Int -> Provider NativeTypeSize+bytesToType 1 = Provide OneByte+bytesToType 2 = Provide TwoBytes+bytesToType 4 = Provide FourBytes+bytesToType 8 = Provide EightBytes+bytesToType _ = Error "Unsupported size"++getSizeOfSizeT : IO (Provider NativeTypeSize)+getSizeOfSizeT = map bytesToType sizeOfSizeT
+ test/tutorial007/expected view
@@ -0,0 +1,1 @@+Pass
+ test/tutorial007/nativetypes.c view
@@ -0,0 +1,13 @@+#include <stdio.h>++int sizeof_size_t() {+  int sz = sizeof(size_t);++  FILE *f = fopen("sizefromc.txt", "w");+  if (f == NULL) {+    printf("Failed to open file from C");+  }+  fprintf(f, "%d bytes", sz);++  return sz;+}
+ test/tutorial007/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+gcc -shared -fPIC nativetypes.c -o nativetypes.so+idris $@ tutorial007.idr -o tutorial007+./tutorial007+rm -f tutorial007 *.ibc *.so sizefromc.txt
+ test/tutorial007/tutorial007.idr view
@@ -0,0 +1,12 @@+module Main+import Providers++%language TypeProviders+%provide (szSizeT : NativeTypeSize) with getSizeOfSizeT++main : IO ()+main = do+  (Right expected) <- readFile "sizefromc.txt" | (Left err) => printLn err+  putStrLn $ if show szSizeT == expected+             then "Pass"+             else "Fail: \"" ++ show szSizeT ++ "\" /= \"" ++ expected ++ "\""
+ test/views001/expected view
@@ -0,0 +1,5 @@+Sorting list+[1, 5, 5, 5, 5, 5, 9, 9, 9, 9, 9, 13, 13, 13, 13, 13, 13, 17, 17, 17, 17, 17, 21, 21, 21, 21, 21, 25, 29, 29, 29, 29, 29, 29, 29, 29, 33, 33, 33, 33, 33, 33, 37, 37, 37, 37, 37, 37, 37, 37, 37, 41, 41, 41, 45, 49, 53, 53, 53, 57, 57, 57, 57, 61, 61, 61, 61, 61, 61, 61, 65, 65, 65, 69, 69, 73, 73, 73, 73, 73, 77, 77, 77, 77, 81, 81, 85, 85, 85, 85, 89, 89, 93, 93, 93, 93, 97, 97, 97, 97]+[97, 97, 97, 97, 93, 93, 93, 93, 89, 89, 85, 85, 85, 85, 81, 81, 77, 77, 77, 77, 73, 73, 73, 73, 73, 69, 69, 65, 65, 65, 61, 61, 61, 61, 61, 61, 61, 57, 57, 57, 57, 53, 53, 53, 49, 45, 41, 41, 41, 37, 37, 37, 37, 37, 37, 37, 37, 37, 33, 33, 33, 33, 33, 33, 29, 29, 29, 29, 29, 29, 29, 29, 25, 21, 21, 21, 21, 21, 17, 17, 17, 17, 17, 13, 13, 13, 13, 13, 13, 9, 9, 9, 9, 9, 5, 5, 5, 5, 5, 1]+Sorting list+[1, 5, 5, 5, 5, 5, 9, 9, 9, 9, 9, 13, 13, 13, 13, 13, 13, 17, 17, 17, 17, 17, 21, 21, 21, 21, 21, 25, 29, 29, 29, 29, 29, 29, 29, 29, 33, 33, 33, 33, 33, 33, 37, 37, 37, 37, 37, 37, 37, 37, 37, 41, 41, 41, 45, 49, 53, 53, 53, 57, 57, 57, 57, 61, 61, 61, 61, 61, 61, 61, 65, 65, 65, 69, 69, 73, 73, 73, 73, 73, 77, 77, 77, 77, 81, 81, 85, 85, 85, 85, 89, 89, 93, 93, 93, 93, 97, 97, 97, 97]
+ test/views001/run view
@@ -0,0 +1,6 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ views001.idr -o views001+./views001+${IDRIS:-idris} $@ views001a.idr -o views001a+./views001a+rm -f views001 views001a *.ibc
+ test/views001/views001.idr view
@@ -0,0 +1,43 @@+import Data.List.Views++rev : List a -> List a+rev xs with (snocList xs)+  rev [] | Empty = []+  rev (ys ++ [x]) | (Snoc y) = x :: rev ys | y++-- Show all the splits for all the recursive calls, to demonstrate they really+-- are split in half+showDivisions : (xs : List a) -> List (List a)+showDivisions xs with (splitRec xs)+  showDivisions [] | SplitRecNil = []+  showDivisions [x] | SplitRecOne = [[x]]+  showDivisions (ys ++ zs) | (SplitRecPair ysrec zsrec) = +    (ys ++ zs) :: showDivisions ys | ysrec ++ showDivisions zs | zsrec++total+mergeSort : Ord a => List a -> List a+mergeSort xs with (splitRec xs)+  mergeSort [] | SplitRecNil = []+  mergeSort [x] | SplitRecOne = [x]+  mergeSort (ys ++ zs) | SplitRecPair ysrec zsrec +      = merge (mergeSort ys | ysrec)+              (mergeSort zs | zsrec)++testList : Int -> Int -> List Int -> List Int+testList 0 seed acc = acc+-- Need to explicitly mod since different back ends overflow differently+testList x seed acc = let seed' = seed * 12345 + 768 `mod` 65536 in+                          testList (x - 1) seed' +                               ((seed' `mod` 100) :: acc)++myhead : List a -> a+myhead (x :: xs) = x++main : IO ()+main = do let list = testList 100 12345 []+          putStrLn "Sorting list"+          let list' = mergeSort list+          printLn list'+          printLn (rev list')++
+ test/views001/views001a.idr view
@@ -0,0 +1,29 @@+import Data.Vect+import Data.Vect.Views++total+mergeSort : Ord a => Vect n a -> Vect n a+mergeSort xs with (splitRec xs)+  mergeSort [] | SplitRecNil = []+  mergeSort [x] | SplitRecOne = [x]+  mergeSort (ys ++ zs) | SplitRecPair ysrec zsrec +      = merge (mergeSort ys | ysrec)+              (mergeSort zs | zsrec)++testList : Int -> Int -> List Int -> List Int+testList 0 seed acc = acc+-- Need to explicitly mod since different back ends overflow differently+testList x seed acc = let seed' = seed * 12345 + 768 `mod` 65536 in+                          testList (x - 1) seed' +                               ((seed' `mod` 100) :: acc)++myhead : List a -> a+myhead (x :: xs) = x++main : IO ()+main = do let list = fromList (testList 100 12345 [])+          putStrLn "Sorting list"+          let list' = mergeSort list+          printLn list'++
+ test/views002/expected view
@@ -0,0 +1,2 @@+Sorting list+[1, 5, 5, 5, 5, 5, 9, 9, 9, 9, 9, 13, 13, 13, 13, 13, 13, 17, 17, 17, 17, 17, 21, 21, 21, 21, 21, 25, 29, 29, 29, 29, 29, 29, 29, 29, 33, 33, 33, 33, 33, 33, 37, 37, 37, 37, 37, 37, 37, 37, 37, 41, 41, 41, 45, 49, 53, 53, 53, 57, 57, 57, 57, 61, 61, 61, 61, 61, 61, 61, 65, 65, 65, 69, 69, 73, 73, 73, 73, 73, 77, 77, 77, 77, 81, 81, 85, 85, 85, 85, 89, 89, 93, 93, 93, 93, 97, 97, 97, 97]
+ test/views002/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ views002.idr -o views002+./views002+rm -f views002 *.ibc
+ test/views002/views002.idr view
@@ -0,0 +1,26 @@+import Data.List.Views++total+qsort : Ord a => (xs : List a) -> List a+qsort inp with (filtered (<) inp)+  qsort [] | FNil = []+  qsort (x :: xs) | (FRec lrec rrec) +     = qsort (filter (\v => v < x) xs) | lrec +++         x :: qsort (filter (\v => not (v < x)) xs) | rrec++testList : Int -> Int -> List Int -> List Int+testList 0 seed acc = acc+-- Need to explicitly mod since different back ends overflow differently+testList x seed acc = let seed' = seed * 12345 + 768 `mod` 65536 in+                          testList (x - 1) seed' +                               ((seed' `mod` 100) :: acc)++myhead : List a -> a+myhead (x :: xs) = x++main : IO ()+main = do let list = testList 100 12345 []+          putStrLn "Sorting list"+          let list' = qsort list+          printLn list'+
+ test/views003/expected view
@@ -0,0 +1,1 @@+True
+ test/views003/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ views003.idr -o views003 --warnreach+./views003 10000+rm -f views003 *.ibc
+ test/views003/views003.idr view
@@ -0,0 +1,31 @@+import System+import Data.List.Views++data Palindrome : List a -> Type where+     PNil : Palindrome []+     POne : Palindrome [x]+     PRec : Palindrome xs -> Palindrome (x :: xs ++ [x])++total+palindrome : DecEq a => (xs : List a) -> Maybe (Palindrome xs)+palindrome xs with (vList xs)+  palindrome [] | VNil = Just PNil+  palindrome [x] | VOne = Just POne+  palindrome (x :: (ys ++ [y])) | (VCons z) with (decEq x y)+    palindrome (y :: (ys ++ [y])) | (VCons urec) | (Yes Refl) +       = case palindrome ys | urec of+              Nothing => Nothing+              Just x => Just (PRec x)+    palindrome (x :: (ys ++ [y])) | (VCons z) | (No contra) +       = Nothing++palinBool : DecEq a => List a -> Bool+palinBool xs = case palindrome xs of+                    Nothing => False+                    Just _ => True++main : IO ()+main = do [_, num] <- getArgs+          let list = replicate (cast num) 'a'+          printLn (palinBool list)+