packages feed

idris 0.9.19 → 0.9.19.1

raw patch · 215 files changed

+6612/−2044 lines, 215 filesdep ~utf8-stringnew-component:exe:idris-codegen-cnew-component:exe:idris-codegen-javascriptnew-component:exe:idris-codegen-nodebinary-addedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: utf8-string

API changes (from Hackage documentation)

+ IRTS.Lang: LStrSubstr :: PrimFn
+ Idris.AbsSyntax: addRecord :: Name -> RecordInfo -> Idris ()
+ Idris.AbsSyntax: getDesugarNats :: Idris Bool
+ Idris.AbsSyntax: setDesugarNats :: Bool -> Idris ()
+ Idris.AbsSyntaxTree: DesugarNats :: Opt
+ Idris.AbsSyntaxTree: IBCRecord :: Name -> IBCWrite
+ Idris.AbsSyntaxTree: RI :: [(Name, PTerm)] -> Name -> [Name] -> RecordInfo
+ Idris.AbsSyntaxTree: data RecordInfo
+ Idris.AbsSyntaxTree: idris_records :: IState -> Ctxt RecordInfo
+ Idris.AbsSyntaxTree: instance Show RecordInfo
+ Idris.AbsSyntaxTree: opt_desugarnats :: IOption -> Bool
+ Idris.AbsSyntaxTree: ppopt_desugarnats :: PPOption -> Bool
+ Idris.AbsSyntaxTree: record_constructor :: RecordInfo -> Name
+ Idris.AbsSyntaxTree: record_parameters :: RecordInfo -> [(Name, PTerm)]
+ Idris.AbsSyntaxTree: record_projections :: RecordInfo -> [Name]
+ Idris.Core.DeepSeq: forceDefCtxt :: Context -> Context
+ Idris.Core.DeepSeq: instance NFData Context
+ Idris.Core.DeepSeq: instance NFData NameOutput
+ Idris.Core.DeepSeq: instance NFData Ordering
+ Idris.Core.DeepSeq: instance NFData OutputAnnotation
+ Idris.Core.DeepSeq: instance NFData TextFormatting
+ Idris.Core.ProofTerm: resetProofTerm :: ProofTerm -> ProofTerm
+ Idris.DeepSeq: instance NFData ColourTheme
+ Idris.DeepSeq: instance NFData ConsoleWidth
+ Idris.DeepSeq: instance NFData DynamicLib
+ Idris.DeepSeq: instance NFData IBCWrite
+ Idris.DeepSeq: instance NFData IOption
+ Idris.DeepSeq: instance NFData IState
+ Idris.DeepSeq: instance NFData IdrisColour
+ Idris.DeepSeq: instance NFData LanguageExt
+ Idris.DeepSeq: instance NFData Opt
+ Idris.DeepSeq: instance NFData Optimisation
+ Idris.DeepSeq: instance NFData OutputMode
+ Idris.DeepSeq: instance NFData OutputType
+ Idris.DeepSeq: instance NFData PrimFn
+ Idris.DeepSeq: instance NFData RecordInfo
+ Idris.DeepSeq: instance NFData SyntaxRules
+ Idris.DeepSeq: instance NFData TIData
+ Idris.Delaborate: pprintNoDelab :: IState -> Term -> Doc OutputAnnotation
+ Idris.Docs: RecordDoc :: Name -> d -> (FunDoc' d) -> [FunDoc' d] -> [(Name, PTerm, Maybe d)] -> Docs' d
+ Idris.Elab.Utils: getTCParamsInType :: IState -> [Name] -> [PArg] -> Type -> [Name]
+ Idris.Elab.Utils: getTCinj :: IState -> TT Name -> [Name]
+ Idris.IBC: instance Binary RecordInfo
+ Pkg.Package: rmExe :: String -> IO ()
- Idris.AbsSyntax: aiFn :: Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -> FC -> [[Text]] -> [PArg] -> Either Err PTerm
+ Idris.AbsSyntax: aiFn :: Name -> Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -> FC -> [[Text]] -> [PArg] -> [PArg] -> Either Err PTerm
- Idris.AbsSyntaxTree: IOption :: Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Codegen -> OutputType -> FilePath -> [FilePath] -> String -> String -> [Opt] -> Bool -> Bool -> [FilePath] -> [Optimisation] -> Maybe Int -> Bool -> IOption
+ Idris.AbsSyntaxTree: IOption :: Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Codegen -> OutputType -> FilePath -> [FilePath] -> String -> String -> [Opt] -> Bool -> Bool -> [FilePath] -> [Optimisation] -> Maybe Int -> Bool -> Bool -> IOption
- Idris.AbsSyntaxTree: IState :: Context -> Set ConstraintFC -> [FixDecl] -> Ctxt [PArg] -> Ctxt [Bool] -> Ctxt ClassInfo -> Ctxt DSL -> Ctxt OptInfo -> Ctxt TypeInfo -> Ctxt [Name] -> Ctxt ([([Name], Term, Term)], [PTerm]) -> Ctxt [FnOpt] -> Ctxt CGInfo -> Ctxt [Name] -> Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]) -> Ctxt (Docstring DocTerm) -> Ctxt TIData -> Ctxt FnInfo -> Ctxt [(Term, Term)] -> Ctxt [Name] -> [(FC, Name)] -> [(FC, Name)] -> [(FC, String)] -> IOption -> Int -> [((FilePath, Int), PTerm)] -> [(Name, (Maybe Name, Int, [Name], Bool))] -> [Name] -> [(Term, Term)] -> SyntaxRules -> [String] -> [FilePath] -> [(Name, (Int, PrimFn))] -> [(Codegen, FilePath)] -> [(Codegen, String)] -> [(Codegen, String)] -> [(Codegen, String)] -> [(FilePath, Bool)] -> [(Name, (Bool, [String]))] -> Maybe FC -> [(FC, Err)] -> Maybe Name -> [Int] -> [Maybe Int] -> Maybe FC -> Maybe FC -> [(Name, Maybe Accessibility)] -> Accessibility -> Bool -> [IBCWrite] -> Maybe String -> [DynamicLib] -> [LanguageExt] -> OutputMode -> Bool -> ColourTheme -> [Name] -> (Int, Ctxt (Int, Name)) -> Ctxt (Map Name (Set Name)) -> Map [Text] [Text] -> ConsoleWidth -> Set Name -> Set (Name, Int) -> [(Name, Int)] -> Maybe (Map Name [Name]) -> Maybe (Map Name [Name]) -> [Name] -> [(Name, Bool)] -> Map Name Name -> [Name] -> [(FC, OutputAnnotation)] -> [(FC, OutputAnnotation)] -> IState
+ Idris.AbsSyntaxTree: IState :: Context -> Set ConstraintFC -> [FixDecl] -> Ctxt [PArg] -> Ctxt [Bool] -> Ctxt ClassInfo -> Ctxt RecordInfo -> Ctxt DSL -> Ctxt OptInfo -> Ctxt TypeInfo -> Ctxt [Name] -> Ctxt ([([Name], Term, Term)], [PTerm]) -> Ctxt [FnOpt] -> Ctxt CGInfo -> Ctxt [Name] -> Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]) -> Ctxt (Docstring DocTerm) -> Ctxt TIData -> Ctxt FnInfo -> Ctxt [(Term, Term)] -> Ctxt [Name] -> [(FC, Name)] -> [(FC, Name)] -> [(FC, String)] -> IOption -> Int -> [((FilePath, Int), PTerm)] -> [(Name, (Maybe Name, Int, [Name], Bool))] -> [Name] -> [(Term, Term)] -> SyntaxRules -> [String] -> [FilePath] -> [(Name, (Int, PrimFn))] -> [(Codegen, FilePath)] -> [(Codegen, String)] -> [(Codegen, String)] -> [(Codegen, String)] -> [(FilePath, Bool)] -> [(Name, (Bool, [String]))] -> Maybe FC -> [(FC, Err)] -> Maybe Name -> [Int] -> [Maybe Int] -> Maybe FC -> Maybe FC -> [(Name, Maybe Accessibility)] -> Accessibility -> Bool -> [IBCWrite] -> Maybe String -> [DynamicLib] -> [LanguageExt] -> OutputMode -> Bool -> ColourTheme -> [Name] -> (Int, Ctxt (Int, Name)) -> Ctxt (Map Name (Set Name)) -> Map [Text] [Text] -> ConsoleWidth -> Set Name -> Set (Name, Int) -> [(Name, Int)] -> Maybe (Map Name [Name]) -> Maybe (Map Name [Name]) -> [Name] -> [(Name, Bool)] -> Map Name Name -> [Name] -> [(FC, OutputAnnotation)] -> [(FC, OutputAnnotation)] -> IState
- Idris.AbsSyntaxTree: PPOption :: Bool -> Bool -> Maybe Int -> PPOption
+ Idris.AbsSyntaxTree: PPOption :: Bool -> Bool -> Bool -> Maybe Int -> PPOption
- Idris.AbsSyntaxTree: PQuoteName :: Name -> FC -> PTerm
+ Idris.AbsSyntaxTree: PQuoteName :: Name -> Bool -> FC -> PTerm
- Idris.Core.Elaborate: defer :: [Name] -> Name -> Elab' aux ()
+ Idris.Core.Elaborate: defer :: [Name] -> Name -> Elab' aux Name
- Idris.Core.Elaborate: get_autos :: Elab' aux [(Name, [Name])]
+ Idris.Core.Elaborate: get_autos :: Elab' aux [(Name, ([FailContext], [Name]))]
- Idris.Core.ProofState: PS :: Name -> [Name] -> [Name] -> Int -> ProofTerm -> Type -> [Name] -> (Name, [(Name, Term)]) -> [(Name, Term)] -> [(Name, [Name])] -> Maybe (Name, Term) -> Fails -> [Name] -> [Name] -> [Name] -> [(Name, [Name])] -> [Name] -> Maybe ProofState -> Context -> Ctxt TypeInfo -> String -> Bool -> Bool -> [Name] -> [FailContext] -> ProofState
+ Idris.Core.ProofState: PS :: Name -> [Name] -> [Name] -> Int -> ProofTerm -> Type -> [Name] -> (Name, [(Name, Term)]) -> [(Name, Term)] -> [(Name, [Name])] -> Maybe (Name, Term) -> Fails -> [Name] -> [Name] -> [Name] -> [(Name, ([FailContext], [Name]))] -> [Name] -> Maybe ProofState -> Context -> Ctxt TypeInfo -> String -> Bool -> Bool -> [Name] -> [FailContext] -> ProofState
- Idris.Core.ProofState: autos :: ProofState -> [(Name, [Name])]
+ Idris.Core.ProofState: autos :: ProofState -> [(Name, ([FailContext], [Name]))]
- Idris.Core.TT: CaseN :: Name -> SpecialName
+ Idris.Core.TT: CaseN :: !Name -> SpecialName
- Idris.Core.TT: ElimN :: Name -> SpecialName
+ Idris.Core.TT: ElimN :: !Name -> SpecialName
- Idris.Core.TT: InstanceCtorN :: Name -> SpecialName
+ Idris.Core.TT: InstanceCtorN :: !Name -> SpecialName
- Idris.Core.TT: InstanceN :: Name -> [Text] -> SpecialName
+ Idris.Core.TT: InstanceN :: !Name -> [Text] -> SpecialName
- Idris.Core.TT: MN :: Int -> Text -> Name
+ Idris.Core.TT: MN :: !Int -> !Text -> Name
- Idris.Core.TT: MetaN :: Name -> Name -> SpecialName
+ Idris.Core.TT: MetaN :: !Name -> !Name -> SpecialName
- Idris.Core.TT: MethodN :: Name -> SpecialName
+ Idris.Core.TT: MethodN :: !Name -> SpecialName
- Idris.Core.TT: NS :: Name -> [Text] -> Name
+ Idris.Core.TT: NS :: !Name -> [Text] -> Name
- Idris.Core.TT: ParentN :: Name -> Text -> SpecialName
+ Idris.Core.TT: ParentN :: !Name -> !Text -> SpecialName
- Idris.Core.TT: SN :: SpecialName -> Name
+ Idris.Core.TT: SN :: !SpecialName -> Name
- Idris.Core.TT: UN :: Text -> Name
+ Idris.Core.TT: UN :: !Text -> Name
- Idris.Core.TT: WhereN :: Int -> Name -> Name -> SpecialName
+ Idris.Core.TT: WhereN :: !Int -> !Name -> !Name -> SpecialName
- Idris.Core.TT: WithN :: Int -> Name -> SpecialName
+ Idris.Core.TT: WithN :: !Int -> !Name -> SpecialName
- Idris.Elab.Term: solveAuto :: IState -> Name -> Bool -> Name -> ElabD ()
+ Idris.Elab.Term: solveAuto :: IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()
- Idris.Elab.Utils: recheckC_borrowing :: Bool -> [Name] -> FC -> (Err' (TT Name) -> Err) -> Env -> TT Name -> StateT IState (ExceptT Err IO) (Term, Type)
+ Idris.Elab.Utils: recheckC_borrowing :: Bool -> Bool -> [Name] -> FC -> (Err' (TT Name) -> Err) -> Env -> TT Name -> StateT IState (ExceptT Err IO) (Term, Type)

Files

+ CHANGELOG view
@@ -0,0 +1,624 @@+New in 0.9.20:+==============++Language updates+----------------++* Improved unification by implementing a pattern unification rule+* The syntax `{{n}} quotes n without resolving it, allowing short syntax+  for defining new names. `{n} still quotes n to an existing name in scope.+* A new primitive operator prim__strSubstr for more efficient extraction of+  substrings. External code generators should implement this.+* Changed scoping rules for unbound implicits: any name which would be a+  valid unbound implicit is now *always* an unbound implicit. This is much+  more resilient to changes in inputs, but does require that function names+  be explicitly qualified when in argument position.++Library updates+---------------++* The 'Neg' class now represents numeric types which can be negative. As+such, the (-) operator and 'abs' have been moved there from 'Num'.+* A special version of (-) on 'Nat' requires that the second argument is+smaller than or equal to the first. 'minus' retains the old behaviour,+returning Z if there is an underflow.+* New Logging Effects have been added to facilitate logging of effectful+  programmes.++Tool updates+------------+* Records are now shown as records in :doc, rather than as the underlying+  datatype++Miscellaneous updates+---------------------++[None so far]++New in 0.9.19:+--------------+* The Idris Reference manual has been fleshed out with content originally found+  on the GitHub wiki.+* The Show class has been moved into Prelude.Show and augmented with the method+  showPrec, which allows correct parenthesization of showed terms. This comes+  with the type Prec of precedences and a few helper functions.+* New REPL command :printerdepth that sets the pretty-printer to only descend to+  some particular depth when printing. The default is set to a high number to+  make it less dangerous to experiment with infinite structures. Infinite depth+  can be set by calling :printerdepth with no argument.+* Compiler output shows applications of >>= in do-notation+* fromInteger i where i is an integer constant is now shown just as i in+  compiler output+* An interactive shell, similar to the prover, for running reflected elaborator+  actions. Access it with :elab from the REPL.+* New command-line option --highlight that causes Idris to save highlighting+  information when successfully type checking. The information is in the same+  format sent by the IDE mode, and is saved in a file with the extension ".idh".+* Highlighting information is saved by the parser as well, allowing it to highlight+  keywords like "case", "of", "let", and "do"+* Use predicates instead of boolean equality proofs as preconditions+  on List functions+* More flexible 'case' construct, allowing each branch to target different+  types, provided that the case analysis does not affect the form of any+  variable used in the right hand side of the case.+* Some improvements in interactive editing, particularly in lifting out+  definitions and proof search.+* Moved System.Interactive, along with getArgs to the Prelude.+* Major improvements to reflected elaboration scripts, including the ability to run+  them in a declaration context and many bug fixes.+* "decl syntax" rules to allow syntax extensions at the declaration level+* Experimental Windows support for console colours++New in 0.9.18:+--------------+* GHC 7.10 compatibility+* Add support for bundled toolchains.+* Strings are now UTF8 encoded in the default back end+* Idris source files are now assumed to be in UTF8, regardless of locale+  settings.+* Some reorganisation of primitives:+  + Buffer and BitVector primitives have been removed (they were not+    tested sufficiently, and lack a maintainer)+  + Float has been renamed 'Double' (Float is defined in the Prelude for+    compatibility)+  + Externally defined primitives and  operations now supported with+    '%extern' directive, allowing back ends to define their own special+    purpose primitives+  + Ptr and ManagedPtr have been removed and replaced with external primitives+* Add %hint function annotation, which allows functions to be used as+  hints in proof search for 'auto' arguments. Only functions which return+  an instance of a data or record type are allowed as hints.+* Syntax rules no longer perform variable capture. Users of effects will+  need to explicitly name results in dependent effect signatures instead+  of using the default name "result".+* Pattern-matching lambdas are allowed to be impossible. For example,+  Dec (2 = 3) can now be constructed with No $ \(Refl) impossible, instead of+  requiring a separate lemma.+* Case alternatives are allowed to be impossible:+  case Vect.Nil {a=Nat} of { (x::xs) impossible ; [] => True }+* The default Semigroup and Monoid instances for Maybe are now prioritised+  choice, keeping the first success as Alternative does. The version that+  collects successes is now a named instance.+* :exec REPL command now takes an optional expression to compile and run/show+* The return types of `Vect.findIndex`, `Vect.elemIndex` and+  `Vect.elemIndexBy` were changed from `Maybe Nat` to `Maybe (Fin n)`+* A new :browse command shows the contents of a namespace+* `{n} is syntax for a quotation of the reflected representation of the name+  "n". If "n" is lexically bound, then the resulting quotation will be for it,+  whereas if it is not, then it will succeed with a quotation of the unique+  global name that matches.+* New syntax for records that closely matches our other record-like structures:+  type classes. See the updated tutorial for details.+* Records can be coinductive. Define coinductive records with the "corecord"+  keyword.+* Type class constructors can be assigned user-accessible names. This is done+  using the same syntax as record constructors.+* if ... then ... else ... is now built-in syntax instead of being defined in+  a library. It is shown in REPL output and error messages, rather than its+  desugaring.+* The desugaring of if ... then ... else ... has been renamed to ifThenElse from+  boolElim. This is for consistency with GHC Haskell and scala-virtualized, and+  to reflect that if-notation makes sense with non-Bool datatypes.+* Agda-style semantic highlighting is supported over the IDE protocol.+* Experimental support for elaborator reflection. Users can now script the+  elaborator, for use in code generation and proof automation. This feature is+  still under rapid development and is subject to change without notice. See+  Language.Reflection.Elab and the %runElab constructs+++New in 0.9.17:+--------------+* The --ideslave command line option has been replaced with a --ide-mode+  command line option with the same semantics.+* A new tactic "claim N TY" that introduces a new hole named N with type TY+* A new tactic "unfocus" that moves the current hole to the bottom of the+  hole stack+* Quasiquotation supports the generation of Language.Reflection.Raw terms+  in addition to Language.Reflection.TT. Types are used for disambiguation,+  defaulting to TT at the REPL.+* Language.Reflection.Quotable now takes an extra type parameter which+  determines the type to be quoted to. Instances are provided to quote+  common types to both TT and Raw.+* Library operators have been renamed for consistency with Haskell. In+  particular, Applicative.(<$>) is now Applicative.(<*>) and (<$>) is+  now an alias for Functor.map. Correspondingly, ($>) and (<$) have+  been renamed to (<*) and (*>). The cascading effects of this rename+  are that Algebra.(<*>) has been renamed to Algebra.(<.>) and+  Matrix.(<.>) is now Matrix.(<:>).+* Binding forms in DSL notation are now given an extra argument: a+  reflected representation of the name that the user chose.+  Specifically, the rewritten lambda, pi, and let binders will now get+  an extra argument of type TTName. This allows more understandable+  dynamic errors in DSL code and more readable code generation results.+* DSL notation can now be applied with $+* Added FFI_Export type which allows Idris functions to be exportoed and+  called from foreign code+* Instances can now have documentation strings.+* Type providers can have documentation strings.+* Unification errors now (where possible) contain information about provenance+  of a type+* New REPL command ":core TM" that shows the elaborated form of TM along with+  its elaborated type using the syntax of TT. IDE mode has a corresponding+  command :elaborate-term for serialized terms.+* Effectful and IO function names for sending data to STDOUT have been+  aligned, semantically.+    + `print` is now for putting showable things to STDOUT.+    + `printLn` is for putting showable things to STDOUT with a new line+    + `putCharLn` for putting a single character to STDOUT, with a new line.+* Classes can now be annotated with 'determining parameters' to say which+  must be available before resolving instances. Only determining parameters+  are checked when checking for overlapping instances.+* New package 'contrib' containing things that are less mature or less used+  than the contents of 'base'. 'contrib' is not available by default, so you+  may need to add '-p contrib' to your .ipkg file or Idris command line.+* Arguments to class instances are now checked for injectivity.+  Unification assumes this, so we need to check when instances are defined.++New in 0.9.16:+--------------+* Inductive-inductive definitions are now supported (i.e. simultaneously+  defined types where one is indexed by the other.)+* Implicits and type class constraints can now appear in scopes other than+  the top level.+* Importing a module no longer means it is automatically reexported. A new+  "public" modifier has been added to import statements, which will reexport+  the names exported from that module.+* Implemented @-patterns. A pattern of the form x@p on the left hand side+  matches p, with x in scope on the right hand side with value p.+* A new tactic sourceLocation that fills the current hole with the current+  source code span, if this information is available. If not, it raises an+  error.+* Better Unicode support for the JavaScript/Node codegen+* ':search' and ':apropos' commands can now be given optional package lists+  to search.+* Vect, Fin and So moved out of prelude into base, in modules Data.Vect,+  Data.Fin and Data.So respectively.+* Several long-standing issues resolved, particularly with pattern matching+  and coverage checking.+* Modules can now have API documentation strings.++New in 0.9.15:+--------------+* Two new tactics: skip and fail. Skip does nothing, and fail takes a string+  as an argument and produces it as an error.+* Corresponding reflected tactics Skip and Fail. Reflected Fail takes a list+  of ErrorReportParts as an argument, like error handlers produce, allowing+  access to the pretty-printer.+* Stop showing irrelevant and inaccessible internal names in the interactive+  prover.+* The proof arguments in the List library functions are now implicit and+  solved automatically.+* More efficient representation of proof state, leading to faster elaboration+  of large expressions.+* EXPERIMENTAL Implementation of uniqueness types+* Unary negation now desugars to "negate", which is a method of the Neg type class.+  This allows instances of Num that can't be negative, like Nat, and it makes correct+  IEEE Float operations easier to encode. Additionally, unary negation is now available+  to DSL authors.+* The Java and LLVM backends have been factored out for separate maintenance. Now, the+  compiler distribution only ships with the C and JavaScript backends.+* New REPL command :printdef displays the internal definition of a name+* New REPL command :pprint pretty-prints a definition or term with LaTeX or+  HTML highlighting+* Naming of data and type constructors is made consistent across the standard+  library (see #1516)+* Terms in `code blocks` inside of documentation strings are now parsed and+  type checked. If this succeeds, they are rendered in full color in+  documentation lookups, and with semantic highlighting for IDEs.+* Fenced code blocks in docs defined with the "example" attribute are rendered+  as code examples.+* Fenced code blocks declared to be Idris code that fail to parse or type check now+  provide error messages to IDE clients.+* EXPERIMENTAL support for partial evaluation (Scrapping your Inefficient+  Engine style)++New in 0.9.14:+--------------+* Tactic for case analysis in proofs+* Induction and case tactic now work on expressions+* Support for running tests for a package with the tests section of .ipkg files and the+  --testpkg command-line option+* Clearly distinguish between type providers and postulate providers at the use site+* Allow dependent function syntax to be overridden in dsl blocks, similarly to+  functions and let. The keyword for this is "pi".+* Updated 'effects' library, with simplified API+* All new JavaScript backend (avoids callstack overflows)+* Add support for %lib directive for NodeJS+* Quasiquotes and quasiquote patterns allow easier work with reflected terms.+  `(EXPR) quasiquotes EXPR, causing the elaborator to be used to produce a reflected+  version of it. Subterms prefixed with ~ are unquoted - on the RHS, they are reflected+  terms to splice in, while on the LHS they are patterns.+  A quasiquote expression can be given a goal type for the elaborator, which helps with+  disambiguation. For instance, `(() : ()) quotes the unit constructor, while `(() : Type)+  quotes the unit type.+  Both goal types and quasiquote are typechecked in the global environment.+* Better inference of unbound implicits++New in 0.9.13:+--------------+* IDE support for retrieving structured information about metavariables+* Experimental Bits support for JavaScript+* IdrisDoc: a Haddock- and JavaDoc-like HTML documentation generator+* Command line option -e (or --eval) to evaluate expressions without loading the+  REPL. This is useful for writing more portable tests.+* Many more of the basic functions and datatypes are documented.+* Primitive types such as Int and String are documented+* Removed javascript lib in favor of idris-hackers/iQuery+* Specify codegen for :compile REPL command (e.g. :compile javascript program.js)+* Remove :info REPL command, subsume and enhance its functionality in the :doc command+* New (first class) nested record update/access syntax:+  record { a->b->c = val } x -- sets field accessed by c (b (a x)) to val+  record { a->b->c } x -- accesses field, equivalent to c (b (a x))+* The banner at startup can be suppressed by adding :set nobanner to the initialisation script.+* :apropos now accepts space-delimited lists of query items, and searches for the conjunction+  of its inputs. It also accepts binder syntax as search strings - for instance, -> finds+  functions.+* Totality errors are now treated as warnings until code generation time, when they become+  errors again. This allows users to use the interactive editing features to fix totality+  issues, but no programs that violate the stated assumptions will actually run.+* Added :makelemma command, which adds a new top level definition to solve+  a metavariable.+* Extend :addclause to add instance bodies as well as definitions+* Reverse parameters to BoundedList -- now matches Vect, and is easier to instantiate classes.+* Move foldl into Foldable so it can be overridden.+* Experimental :search REPL command for finding functions by type++Internal changes++* New implementation of erasure++New in 0.9.12:+--------------++* Proof search now works for metavariables in types, giving some interactive+  type inference.+* New 'Lazy' type, replacing laziness annotations.+* JavaScript and Node codegen now understand the %include directive.+* Concept of 'null' is now understood in the JavaScript and Node codegen.+* Lots of performance patches for generated JavaScript.+* New commands :eval (:e) and :type (:t) in the prover, which either normalise+  or show the type of expressions.+* Allow type providers to return postulates in addition to terms.+* Syntax for dealing with match failure in <- and pattern matching let.+* New syntax for inline documentation. Documentation starts with |||, and+  arguments are documented by preceding their name with @. Example:+  ||| Add two natural numbers+  ||| @ n the first number (examined by the function)+  ||| @ m the second number (not examined)+  plus (n, m : Nat) -> Nat+* Allow the auto-solve behaviour in the prover to be disabled, for easier+  debugging of proof automation. Use ":set autosolve" and ":unset autosolve".+* Updated 'effects' library+* New :apropos command at REPL to search documentation, names, and types+* Unification errors are now slightly more informative+* Support mixed induction/coinduction with 'Inf' type+* Add 'covering' function option, which checks whether a function and all+  descendants cover all possible inputs++New in 0.9.11:+--------------++* Agda-style equational reasoning (in Syntax.PreorderReasoning)+* 'case' construct now abstracts over the scrutinee in its type+* Added label type 'name (equivalent to the empty type).+  This is intended for field/effect disambiguation. "name" can be any+  valid identifier. Two labels are definitionally equal if they have the+  same name.+* General improvements in error messages, especially %error_reverse+  annotation, which allows a hint as to how to display a term in error+  messages+* --ideslave mode now transmits semantic information about many of the+  strings that it emits, which can be used by clients to implement+  semantic highlighting like that of the REPL. This has been implemented+  in the Emacs mode and the IRC bot, which can serve as examples.+* New expression form: with NAME EXPR privileges the namespace NAME+  when disambiguating overloaded names. For example, it is possible to+  write "with Vect [1,2,3]" at the REPL instead of "the (Vect _ _) [1,2,3]",+  because the Vect constructors are defined in a namespace called Vect.+* assert_smaller internal function, which marks an expression as smaller than+  a pattern for use in totality checking.+  e.g. "assert_smaller (x :: xs) (f xs)" asserts that "f xs" will always be+  structurally smaller than "(x :: xs)"+* assert_total internal function, which marks a subexpression as assumed to+  be total, e.g "assert_total (tail (x :: xs))".+* Terminal width is automatically detected if Idris is compiled with curses+  support. If curses is not available, automatic mode assumes 80 columns.+* Changed argument order for Prelude.Either.either.+* Experimental 'neweffects' library, intended to replace 'effects' in the+  next release.++Internal changes++* Faster elaboration+* Smaller .ibc files+* Pretty-printer now used for all term output+++New in 0.9.10:+--------------++* Type classes now implemented as dependent records, meaning that method+  types may now depend on earlier methods.+* More flexible class instance resolution, so that function types and lambda+  expressions can be made instances of a type class.+* Add !expr notation for implicit binding of intermediate results in+  monadic/do/etc expressions.+* Extend Effects package to cope with possibly failing operations, using+  "if_valid", "if_error", etc.+* At the REPL, "it" now refers to the previous expression.+* Semantic colouring at the REPL. Turn this off with --nocolour.+* Some prettifying of error messages.+* The contents of ~/.idris/repl/init are run at REPL start-up.+* The REPL stores a command history in ~/.idris/repl/history.+* The [a..b], [a,b..c], [a..], and [a,b..] syntax now pass the totality+  checker and can thus be used in types. The [x..] syntax now returns an+  actually infinite stream.+* Add '%reflection' option for functions, for compile-time operations on+  syntax.+* Add expression form 'quoteGoal x by p in e' which applies p to the expected+  expression type and binds the result to x in the scope e.+* Performance improvements in Strings library.+* Library reorganisation, separated into prelude/ and base/.++Internal changes++* New module/dependency tree checking.+* New parser implementation with more precise errors.+* Improved type class resolution.+* Compiling Nat via GMP integers.+* Performance improvements in elaboration.+* Improvements in termination checking.+* Various REPL commands to support interactive editing, and a client/server+  mode to allow external invocation of REPL commands.++New in 0.9.9:+-------------++* Apply functions by return type, rather than with arguments:+  "t <== f" means "apply f with arguments such that it returns a value+  of type t"+* Allow the result type of a rewrite to be specified+* Allow names to be attached to provisional definitions+  lhs ?= {name} rhs -- generates a lemma called 'name' which makes the+  types of the lhs and rhs match. {name} is optional - a unique name is+  generated if it is absent.+* Experimental LLVM backend+* Added Data.HVect module+* Fix fromInteger to take an Integer, rather than an Int+* Integer literals for Fin+* Renamed O to Z, and fO to fZ+* Swapped Vect arguments, now Vect : Nat -> Type -> Type+* Added DecEq instances+* Add 'equiv' tactic, which rewrites a goal to an equivalent (convertible) goal++Internal changes++* Add annotation for unification traces+* Add 'mrefine' tactic for refining by matching against a type+* Type class resolution fixes+* Much faster coverage checking++New in 0.9.8:+-------------++User visible changes:++* Added "rewrite ... in ..." construct+* Allow type class constraints in 'using' clauses+* Renamed EFF to EFFECT in Effect package+* Experimental Java backend+* Tab completion in REPL+* Dynamic loading of C libraries in the interpreter+* Testing IO actions at the REPL with :x command+* Improve rendering of :t+* Fixed some INTERNAL ERROR messages++Internal changes:++* Fix non-linear pattern checking+* Improved name disambiguation+* More flexible unification and elaboration of lambdas+* Various unification and totality checking bug fixes++New in 0.9.7:+-------------++User visible changes:++* 'implicit' keyword, for implicit type conversion+* Added Effects package+* Primitives for 8,16,32 and 64 bit integers++Internal changes:++* Change unification so that it keeps track of failed constraints in case+  later information helps to resolve them+* Distinguishing parameters and indices in data types+* Faster termination/coverage checking+* Split 'javascript' target into 'javascript' and 'node'++New in 0.9.6:+-------------++User visible changes:++* The type of types is now 'Type' rather than 'Set'+* Forward declarations of data allowed+  - supporting induction recursion and mutually recursive data+* Type inference of definitions in 'where' clauses+  - Provided that the type can be completely determined from the first+    application of the function (in the top level definition)+* 'mutual' blocks added+  - effect is to elaborate all types of declarations in the block before+    elaborating their definitions+  - allows inductive-recursive definitions+* Expression inspected by 'with' clause now abstracted from the goal+  - i.e. "magic" with+* Implicit arguments will be added automatically only if their initial+  letter is lower case, or they are in a using declaration+* Added documentation comments (Haddock style) and ':doc' REPL command+* Pattern matching on strings, big integers and characters+* Added System.Concurrency modules+* Added 'postulate' declarations+* Allow type annotations on 'let' tactic+* EXPERIMENTAL JavaScript generation, with '--target javascript' option++Internal changes:++* Separate inlining methods at compile-time and run-time+* Fixed nested parameters blocks+* Improve efficiency of elaborator by:+   - only normalising when necessary+   - reducing backtracking with resolving ambiguities+* Better compilation of case trees++New in 0.9.5:+-------------++User visible changes:++* Added codata+  - as data declarations, but constructor arguments are evaluated lazily+  - functions which return a codata type do not reduce at compile time+* Added 'parameters' blocks+* Allow local data definitions in where blocks+* Added '%default' directive to declare total-by-default or partial-by-default+  for functions, and a corresponding "partial" reserved words to mark functions+  as allowed to be partial. Also "--total" and "--partial" added as command+  line options.+* Command line option "--warnpartial" for flagging all undeclared+  partial functions, without error.+* New termination checker supporting mutually recursive definitions.+* Added ':load' command to REPL, for loading a new file+* Added ':module' command to REPL, for adding modules+* Renamed library modules (now have initial capital)++Internal changes:++* Several improvements and fixes to unification+* Added collapsing optimisation and more aggressive erasure++New in 0.9.4:+-------------++User visible changes:++* Simple packaging system+* Added --dumpc flag for displaying generated code++Internal changes:++* Improve overloading resolution (especially where this is a type error)+* Various important bug fixes with evaluation and compilation+* More aggressive compile-time evaluation++New in 0.9.3:+-------------++User visible changes:++* Added binding forms to syntax rules+* Named class instances+* Added ':set' command, with options 'errorcontext' for displaying local+  variables in scope when a unification error occurs, and 'showimplicits'+  for displaying elaborated terms in full+* Added '--errorcontext' command line switch+* Added ':proofs' and ':rmproofs' commands+* Various minor REPL improvements and fixes++Internal changes:++* Completely new run time system (not based on Epic or relying on Boehm GC)+* Normalise before forcing to catch more forceable arguments+* Types no longer exported in normal form+* Try to resolve overloading by inspecting types, rather than full type+  checking++New in 0.9.2:+-------------++User visible changes:++* backtick notation added: x `foo` y  ==> foo x y+* case expressions allowed in type signatures+* Library extensions in prelude.vect and prelude.algebra+* malloc/trace_malloc added to builtins.idr++Internal changes:++* Some type class resolution fixes+* Several minor bug fixes+* Performance improvements in resolving overloading and type classes++New in 0.9.1:+-------------++User visible changes:++* DSL notation, for overloading lambda and let bindings+* Dependent records, with projection and update+* Totality checking and 'total' keyword+* Auto implicits and default argument values {auto n : T}, {default val n : T}+* Overlapping type class instances disallowed+* Many extensions to prelude.nat and prelude.list libraries (mostly thanks to+  Dominic Mulligan)+* New libraries: control.monad.identity, control.monad.state+* Small improvements in error reporting++Internal changes:++* Faster compilation (only compiling names which are used)+* Better type class resolution+* Lots of minor bug fixes++0.1.x to 0.9.0:++Complete rewrite. User visible changes:++* New proof/tactics syntax+* New syntax for pairs/dependent pairs+* Indentation-significant syntax+* Added type classes+* Added where clauses+* Added case expressions, pattern matching let and lambda+* Added monad comprehensions+* Added cumulativity and universe checking+* Ad-hoc name overloading+  - Resolved by type or explicit namespace+* Modules (Haskell-style)+* public, abstract and private access to functions and types+* Separate type-checking+* Improved interactive environment+* Replaced 'do using' with Monad class+* Extended syntax macros++Internal changes:++* Everything :-)+* All definitions (functions, classes and instances) are elaborated to top+  level, fully explicit, data declarations and pattern matching definitions,+  which are verified by a minimal type checker.++This is the first release of a complete reimplementation. There will be bugs.+If you find any, please do not hesitate to contact Edwin Brady+(ecb10@st-andrews.ac.uk).
+ CITATION.md view
@@ -0,0 +1,29 @@+# Citing `Idris`++If you use `Idris` in your work we would prefer it if you would use the following reference in your work.++## BibTeX++```bibtex+@article{JFP:9060502,+  author = {BRADY,EDWIN},+  title = {Idris, a general-purpose dependently typed programming language: Design and implementation},+  journal = {Journal of Functional Programming},+  volume = {23},+  issue = {05},+  month = {9},+  year = {2013},+  issn = {1469-7653},+  pages = {552--593},+  numpages = {42},+  doi = {10.1017/S095679681300018X},+  URL = {http://journals.cambridge.org/article_S095679681300018X},+}+```++## Textual++    EDWIN BRADY (2013). Idris, a general-purpose dependently typed+    programming language: Design and implementation. Journal of+    Functional Programming, 23, pp+    552-593. doi:10.1017/S095679681300018X.
+ CONTRIBUTING.md view
@@ -0,0 +1,169 @@+# Contributing to Idris-Dev++The Idris Community welcomes pull requests, bug reporting, and bug squashing!+However, we cannot do it all ourselves, and want to make it as easy as possible to contribute changes to get things working.+Here are a few guidelines that we would like contributors to follow so that we can have a chance of keeping on top of things.++## Getting Started++1. Make sure you are familiar with [Git](http://git-scm.com/book).+1. Make sure you have a [GitHub account](https://github.com/signup/free).+1. Make sure you are familiar with: [Idris](http://eb.host.cs.st-andrews.ac.uk/writings/idris-tutorial.pdf).+1. Make sure you can install Idris:+  * [Mac OS X](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-OS-X-using-Homebrew)+  * [Ubuntu](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-Ubuntu)+  * [Debian](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-Debian)+  * [Windows](https://github.com/idris-lang/Idris-dev/wiki/Idris-on-Windows)++## Issue Reporting++Before you report an issue, or wish to add cool functionality please try and check to see if there are existing [issues](https://github.com/idris-lang/Idris-dev/issues) and [pull requests](https://github.com/idris-lang/Idris-dev/pulls).+We do not want you wasting your time, duplicating somebody's work!++## The Campsite Rule++We try to follow the **campsite rule**: leave the code base in better condition than you found it.+Please clean up any messes that you find, and don't leave behind new messes for the next contributor.++## Contributing to the default libraries.++Idris ships with a set of packages in `libs/` that is provided as a default library.+++ `prelude` is a collection of basic definitions, automatically imported by Idris programs.++ `base` is tried and tested code that may be useful, and has seen active use in multiple projects.++ `contrib` is code that is experimental in design and that we want to test before possible inclusion in `base`.++ `effects` is a library which supports effectful programming.++These packages should not be seen as the *standard* as when working with dependent types; we do not necessarily know how best to work with dependent types yet.+These packages offer functionality that can be built on top of when constructing Idris programs.++Everything in prelude will be imported automatically, unless given the `--noprelude` option.+The contents of base are available with no special options, but modules must be imported.+The other two packages that ship with Idris, contrib and effects, require the use of the `-p` command-line argument to bring their contents into the include path.++New contributions should be added to the contrib package (never directly to base or prelude!).+If they turn out to be widely applicable and useful, they may later be moved into base.++As Idris is still being developed we are open to suggestions and changes that make improvements to these default packages.+Major changes to the library, or Idris itself, should be discussed first through the project's official channels of communication:++1. The mailing List.+1. On our IRC Channel `#idris` on freenode, or+1. As a [Dragon Egg](https://github.com/idris-lang/Idris-dev/wiki/Feature-proposals).++Developers then seeking to add content to Idris's prelude and default library, should do so through a PR where more discussions and refinements can be made.++We do not want you wasting your time nor duplicating somebody's work!++## Making Changes++Idris developers and hackers try to adhere to something similar to the [successful git branching model](http://nvie.com/posts/a-successful-git-branching-model/).+The steps are described below.++### New contributors++For those new to the project:++1. Fork our [main development repository](https://github.com/idris-lang/Idris-dev) `idris-dev` on github e.g.+2. Clone your fork to your local machine:++```+$ git clone git@github.com/<your github user name>/Idris-dev.git+```++3. Add `idris-lang/Idris-dev` as a remote upstream++```+$ git remote add upstream git@github.com:idris-lang/Idris-dev.git+```++### Existing Contributors++For those already contributing to the project:++1. Ensure your existing clone is up-to-date with current `HEAD` e.g.++```+$ git fetch upstream+$ git merge upstream/master+```++### Remaining Steps++The remaining steps are the same for both new and existing contributors:++1. Create, and checkout onto, a topic branch on which to base you work.+  * This is typically the master branch.+  * Please avoid working on the `master` branch.++```+$ git branch fix/master/my_contrib master+$ git checkout fix/master/my_contrib+```++1. Make commits of logical units.+1. Check for unnecessary whitespace with++```+$ git diff --check+```++1. Make sure your commit messages are along the lines of:++        Short (50 chars or less) summary of changes++        More detailed explanatory text, if necessary.  Wrap it to about 72+        characters or so.  In some contexts, the first line is treated as the+        subject of an email and the rest of the text as the body.  The blank+        line separating the summary from the body is critical (unless you omit+        the body entirely); tools like rebase can get confused if you run the+        two together.++        Further paragraphs come after blank lines.++        - Bullet points are okay, too++        - Typically a hyphen or asterisk is used for the bullet, preceded by a+          single space, with blank lines in between, but conventions vary here++1. Make sure you have added any necessary tests for your changes.+1. Run all the tests to ensure nothing else was accidentally broken.++```+$ make test+```++1. Push your changes to a topic branch in your fork of the repository.++```+$ git push origin fix/master/my_contrib+```++1. Go to GitHub and submit a pull request to `idris-dev`++From there you will have to wait on one of the `idris-dev` committers to respond to the request.+This response might be an accept or some changes/improvements/alternatives will be suggest.+We do not guarantee that all requests will be accepted.++## Increasing chances of acceptance.++To help increase the chance of your pull request being accepted:++1. Run the tests.+1. Update the documentation, the surrounding code, examples elsewhere, guides, whatever is affected by your contribution+1. Use appropriate code formatting for both Idris and Haskell.++## Additional Resources++* [Idris Wiki](https://github.com/idris-lang/Idris-dev/wiki);+* [Zen Of Idris](https://github.com/idris-lang/Idris-dev/wiki/The-Zen-of-Idris);+* Idris FAQs: [Official](http://www.idris-lang.org/documentation/faq/); [Unofficial](https://github.com/idris-lang/Idris-dev/wiki/Unofficial-FAQ);+* [Idris Manual](https://github.com/idris-lang/Idris-dev/wiki/Manual);+* [Idris Tutorial](http://eb.host.cs.st-andrews.ac.uk/writings/idris-tutorial.pdf);+* [Idris News](http://www.idris-lang.org/news/);+* [other Idris docs](http://www.idris-lang.org/documentation/).+* [Using Pull Requests](https://help.github.com/articles/using-pull-requests)+* [General GitHub Documentation](https://help.github.com/).+++Adapted from the most excellent contributing files from the [Puppet project](https://github.com/puppetlabs/puppet) and [Factroy Girl Rails](https://github.com/thoughtbot/factory_girl_rails/blob/master/CONTRIBUTING.md)
+ CONTRIBUTORS view
@@ -0,0 +1,47 @@+Thanks to the following for their help and contributions:++Ozgur Akgun+Ahmad Salim Al-Sibahi+Edward Chadwick Amsden+Jan Bessai+Michael R. Bernstein+Nicola Botta+Edwin Brady+Jakob Brünker+Alyssa Carter+David Raymond Christiansen+Carter Charbonneau+Jason Dagit+Guglielmo Fachini+Simon Fowler+Google+Cezar Ionescu+Heath Johns+Irene Knapp+Paul Koerbitz+Niklas Larsson+Shea Levy+Mathnerd314+Hannes Mehnert+Mekeor Melire+Melissa Mozifian+Dominic Mulligan+Jan de Muijnck-Hughes+Tom Prince+raichoo+Philip Rasmussen+Reynir Reynisson+Adam Sandberg Eriksson+Seo Sanghyeon+Benjamin Saunders+Alexander Shabalin+Timo Petteri Sinnemäki+JP Smith+startling+Chetan T+Matúš Tejiščák+Dirk Ullrich+Leif Warner+Daniel Waterworth+Jonas Westerlund+Sean Hunt
+ README.md view
@@ -0,0 +1,78 @@+# Idris++[![Build Status](https://travis-ci.org/idris-lang/Idris-dev.svg?branch=master)](https://travis-ci.org/idris-lang/Idris-dev)+[![Documentation Status](https://readthedocs.org/projects/idris/badge/?version=latest)](https://readthedocs.org/projects/idris/?badge=latest)+[![Hackage](https://budueba.com/hackage/idris)](https://hackage.haskell.org/package/idris)++Idris (http://idris-lang.org/) is a general-purpose functional programming+language with dependent types.++## Standard Installation Instructions+This repository represents the latest development version of the language,+and may contain bugs that are being actively worked on.+For those who wish to use a more stable version of Idris please consider+installing the latest version that has been released on Hackage.+Installation instructions for various platforms can be [found on the Idris Wiki](https://github.com/idris-lang/Idris-dev/wiki/Installation-Instructions).++## Installing Development Versions++If you like to work against the latest development version, please consider+using Cabal Sandboxes to minimise disruption to your local Haskell setup.+Instructions for installing Idris HEAD within a cabal sandbox are+[available on the Idris Wiki](https://github.com/idris-lang/Idris-dev/wiki/Installing-an-Idris-Development-version-in-a-sandbox).++To configure, edit config.mk. The default values should work for most people.++Idris is built using a Makefile common targets include:++* `make` This will install everything using cabal and+typecheck the libraries.+* `make test` This target execute the test suite.+* `make relib` This target will typecheck and recompile the standard library.++Idris has an optional buildtime dependency on the C library `libffi`. If you+would like to use the features that it enables, make sure that it is compiled+for the same architecture as your Haskell compiler (e.g. 64 bit libraries+for 64 bit ghc). By default, Idris builds without it. To build with it, pass+the flag `-f FFI`.++To build with `libffi` by default, create a `custom.mk` file and add the+following line to it:++`CABALFLAGS += -f FFI`++The file custom.mk-alldeps is a suitable example.++The continuous integration builds on travis-ci.org are built using the+ghc-flag -Werror. To enable this behaviour locally also, please compile+using `make CI=true` or adding the following line into `custom.mk`:++`CI = true`++If you are only compiling for installing the most current version, you can+omit the CI flag, but please make sure you use it if you want to contribute.++## Code Generation++Idris has support for external code generators. Supplied with the distribution+is a C code generator to compile executables, and a JavaScript code generator+with support for node.js and browser JavaScript.++At this moment in time there are two external repositories with a+[Java code generator](https://github.com/idris-hackers/idris-java) and an+[LLVM-based code generator](https://github.com/idris-hackers/idris-llvm).++## More Information++If you would like to find out more information, or ask questions, we+currently have a [Wiki](https://github.com/idris-lang/Idris-dev/wiki);+a [mailing list](https://groups.google.com/forum/#!forum/idris-lang),+and an `IRC` channel `#idris` on freenode. To join the IRC channel,+point your irc client to `chat.freenode.net` then `/join #idris`.++For those further interested in using Idris for projects, the+[Idris Hackers](https://github.com/idris-hackers) GitHub organisation is+where some interesting projects are being hosted.++For those interested in contributing to Idris directly we kindly ask that+prospective developers please consult the [Contributing Guide](CONTRIBUTING.md) first.
+ benchmarks/ALL view
@@ -0,0 +1,4 @@+trivial/sortvec 2000+quasigroups/qgsolve board+fasta/fasta 1+pidigits/pidigits 3000
+ benchmarks/README view
@@ -0,0 +1,21 @@+Benchmarks+----------++To run:++$ ./build.pl   -- builds all benchmark binaries+$ ./run.pl     -- runs all benchmarks++Adding a test +-------------++Add a line to the 'ALL' file of the following form:++dir/main   arg++where 'dir' is the directory the benchmark lives in, 'main' is the name of the+ipkg file and executable (these must be the same), 'arg' is the input to give+to the binary. ++It is assumed that all benchmarks take exactly one argument, which helps to+ensure that they are not simply doing all the work at compile time.
+ benchmarks/build.pl view
@@ -0,0 +1,14 @@+#!/usr/bin/env perl++$bmarks = `cat ALL`;+@bm = split(/\n/, $bmarks);++foreach $b (@bm) {+    if ($b =~ /([a-zA-Z0-9]+)\/([a-zA-Z0-9]+)\s+(.*)/) {+        print "Building $1 / $2\n";+        chdir $1;+        system("idris --clean $2.ipkg");+        system("idris --build $2.ipkg");+        chdir "..";+    }+}
+ benchmarks/fasta/fasta.idr view
@@ -0,0 +1,84 @@+module Main++import System+import Data.Floats++alu : String+alu = "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG\+    \TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG\+    \CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC\+    \GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"++iub : List (Char, Float)+iub = [('a',0.27),('c',0.12),('g',0.12),('t',0.27),('B',0.02)+      ,('D',0.02),('H',0.02),('K',0.02),('M',0.02),('N',0.02)+      ,('R',0.02),('S',0.02),('V',0.02),('W',0.02),('Y',0.02)]++homosapiens : List (Char, Float)+homosapiens = [('a',0.3029549426680),('c',0.1979883004921)+              ,('g',0.1975473066391),('t',0.3015094502008)]+++takeRepeat : Int -> String -> String+takeRepeat n s = if n > m+                 then s ++ takeRepeat (n-m) s+                 else pack $ take (cast n) $ unpack s+  where+    m = cast $ length s++splitAt' : Nat -> String -> (String, String)+splitAt' n s = let s' = unpack s in (pack $ take n s', pack $ drop n s')++writeAlu : String -> String -> IO ()+writeAlu name s0 = putStrLn name $> go s0+  where+    go "" = return ()+    go s  = let (h,t) = splitAt' 60 s in putStrLn h $> go t++replicate : Int -> Char -> String+replicate 0 c = ""+replicate n c = singleton c <+> replicate (n-1) c++scanl : (f : acc -> a -> acc) -> acc -> List a -> List acc+scanl f q ls = q :: (case ls of+                        []    => []+                        x::xs => scanl f (f q x) xs)++accum : (Char,Float) -> (Char,Float) -> (Char,Float)+accum (_,p) (c,q) = (c,p+q)++make : String -> Int -> List (Char, Float) -> Int -> IO Int+make name n0 tbl seed0 = do+    putStrLn name+    make' n0 0 seed0 ""+  where+    modulus : Int+    modulus = 139968++    fill : List (Char,Float) -> Int -> List String+    fill ((c,p) :: cps) j =+      let k = min modulus (cast (cast modulus * p + 1))+      in replicate (k - j) c :: fill cps k+    fill _ _ = []++    lookupTable : String+    lookupTable = Foldable.concat (fill (scanl accum ('a',0) tbl) 0)++    make' : Int -> Int -> Int -> String -> IO Int+    make' 0 col seed buf = when (col > 0) (putStrLn buf) $> return seed+    make' n col seed buf = do+      let newseed  = modInt (seed * 3877 + 29573) modulus+      let nextchar = strIndex lookupTable newseed+      let newbuf   = buf <+> singleton nextchar+      if col+1 >= 60+        then putStrLn newbuf $> make' (n-1) 0 newseed ""+        else make' (n-1) (col+1) newseed newbuf+++main : IO ()+main = do+    (_ :: n :: _) <- getArgs+    writeAlu ">ONE Homo sapiens alu" (takeRepeat (fromInteger (cast n)*2) alu)+    nseed <- make ">TWO IUB ambiguity codes" (fromInteger (cast n)*3) iub 42+    make ">THREE Homo sapiens frequency" (fromInteger (cast n)*5) homosapiens nseed+    return ()
+ benchmarks/fasta/fasta.ipkg view
@@ -0,0 +1,6 @@+package fasta++modules = fasta++executable = fasta+main = fasta
+ benchmarks/pidigits/pidigits.idr view
@@ -0,0 +1,52 @@+import System++{- Toy program that outputs the n first digits of Pi.++   Inspired from http://www.haskell.org/haskellwiki/Shootout/Pidigits. +   The original ns and str lazy lists have been replaced by strict functions.++   Memory usage seems to be excessive. One of the branches of str is tail recursive, and +   the other one only needs to cons an extra Integer.++   For reference, the Haskell version runs in 0m0.230s when printing to /dev/null. +   It almost runs in constant space.+-}++data F = mkF Integer Integer Integer++-- Prints the list of digits by groups of 10+loop : Nat -> Nat -> List Integer -> IO()+loop n k' Nil         = putStrLn $ (pack $ Vect.replicate n ' ') ++ "\t:" ++ show k'+loop Z k' xs          = do putStrLn ("\t:"++show k')+                           loop 10 k' xs+loop (S k) k' (x::xs) = do putStr (show x)+                           loop k (S k') xs++fn : Integer -> F+fn k = mkF k (4*k+2) (2*k+1)++flr : Integer -> F -> Integer+flr x (mkF q r t) = (q*x + r) `div` t++comp : F -> F -> F+comp (mkF q r t) (mkF u v x) = mkF (q*u) (q*v+r*x) (t*x)++-- Returns the list of digits of pi. Memory hungry.+str : F -> Integer -> Nat -> List Integer+str _ _ Z     = Nil+str z k (S n) = if(y == flr 4 z)+                   then y :: str (comp (mkF 10 (-10*y) 1) z    ) k     n+                   else      str (comp z                 (fn k)) (k+1) (S n)+  where y = flr 3 z++pidigit : IO()+pidigit = do+  [_,a] <- getArgs+  let n = fromIntegerNat (the Integer (cast a))+  let l = str (mkF 1 0 1) 1 n+  loop 10 0 l+  return ()++main : IO ()+main = pidigit+
+ benchmarks/pidigits/pidigits.ipkg view
@@ -0,0 +1,6 @@+package pidigits++modules = pidigits++executable = pidigits+main = pidigits
+ benchmarks/quasigroups/Main.idr view
@@ -0,0 +1,24 @@+module Main++import System+import Parser+import Solver++main : IO ()+main = do+  args <- getArgs+  case args of+    [_, path] => do+      f <- readFile path+      case parse f of+        Left err => putStrLn err+        Right (_ ** (board ** legal)) => do+          putStrLn "Got board:"+          printLn board+          putStrLn "Solving..."+          case fillBoard board legal of+            Nothing => putStrLn "No solution found"+            Just (solved ** _) => do+              putStrLn "Solution found:"+              printLn solved+    [self] => putStrLn ("Usage: " ++ self ++ " <board file>")
+ benchmarks/quasigroups/Parser.idr view
@@ -0,0 +1,79 @@+module Parser++import Decidable.Equality++import Solver++ParseErr : Type+ParseErr = String++Parser : Nat -> Type+Parser n = Either ParseErr (b : Board n ** LegalBoard b)++mapM : Monad m => (a -> m b) -> Vect n a -> m (Vect n b)+mapM _ Nil = return Vect.Nil+mapM f (x::xs) = do+  x' <- f x+  xs' <- mapM f xs+  return (Vect.(::) x' xs')++parseToken : String -> Either String (Cell n)+parseToken "." = return Nothing+parseToken "0" = Left "Got cell 0, expected 1-based numbering"+parseToken x = map Just (tryParseFin ((cast x) - 1))+  where+    tryParseFin : Int -> Either String (Fin n)+    tryParseFin {n=Z} _ = Left ("Given cell " ++ x ++ " out of range")+    tryParseFin {n=S k} 0 = return FZ+    tryParseFin {n=S k} x =+      case tryParseFin {n=k} (x-1) of+        Left err => Left err+        Right fin => return (FS fin)++length : Vect n a -> Nat+length {n=n} _ = n++parseCols : {b : Board n} -> Fin n -> LegalBoard b -> Vect n String -> Parser n+parseCols {n=Z} _ l _ = Right (_ ** l)+parseCols {n=S k} row l cs = helper last l+  where+    step : {b : Board (S k)} -> LegalBoard b -> Fin (S k) -> Parser (S k)+    step {b=b} l x = do+      let here = (x, row) -- TODO: Determine why naming this makes idris smarter+      tok <- parseToken {n=S k} (index x cs)+      case tok of+        Nothing => return (_ ** l)+        Just t =>+           case legalVal b here t of+             Yes prf => Right (_ ** Step prf l)+             No _ => Left ("Illegal cell " ++ index x cs)++    helper : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k)+    helper FZ l = step l FZ+    helper (FS k) l = do+      (_ ** next) <- step l (FS k)+      helper (weaken k) next++parseRows : (b : Board n) -> LegalBoard b -> Vect n String -> Parser n+parseRows {n=Z}   _ l _  = Right (_ ** l)+parseRows {n=S k} _ l rs = helper last l+  where+    step : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k)+    step i l =+      let cs = fromList (words (index i rs)) in+      case decEq (length cs) (S k) of+        No _  => Left "Row length not equal to column height"+        Yes prf => let foo = (replace {P=\n => Vect n String} prf cs) in parseCols i l foo -- TODO: foo shouldn't be needed++    helper : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k)+    helper FZ l = step FZ l+    helper (FS k) l = do+      (_ ** next) <- step (FS k) l+      helper (weaken k) next++parse : String -> Either String (n : Nat ** (b : Board n ** LegalBoard b))+parse str =+  let rows = fromList (lines str) in+  case parseRows {n=length rows} emptyBoard Base rows of+    Left msg => Left msg+    Right board => return (_ ** board)
+ benchmarks/quasigroups/Solver.idr view
@@ -0,0 +1,204 @@+module Solver++import Decidable.Equality+import Control.Monad.State+import Data.Vect.Quantifiers++%default total++Cell : Nat -> Type+Cell n = Maybe (Fin n)++data Board : Nat -> Type where+  MkBoard : {n : Nat} -> Vect n (Vect n (Cell n)) -> Board n++emptyBoard : Board n+emptyBoard {n=n} = MkBoard (replicate n (replicate n Nothing))++showElt : Cell n -> String+showElt Nothing = "."+showElt (Just x) = show (1 + (the Int (fromInteger (cast x))))++-- FIXME: Inline type decl should not be necessary here+showRow : Vect n (Cell n) -> String+showRow {n=n} xs = unwords (toList (the (Vect n String) (map showElt xs)))++unlines : Vect n String -> String+unlines Nil = ""+unlines (l::Nil) = l+unlines (l::ls) = pack (foldl addLine (unpack l) (map unpack ls))+  where+    addLine : List Char -> List Char -> List Char+    addLine w s = w ++ ('\n' :: s)++instance Show (Board n) where+  show (MkBoard rs) = unlines (map showRow rs)++updateAt : Fin n -> Vect n a -> (a -> a) -> Vect n a+updateAt FZ (x::xs) f = f x :: xs+updateAt (FS i) (x::xs) f = x :: updateAt i xs f++setCell : Board n -> (Fin n, Fin n) -> Fin n -> Board n+setCell (MkBoard b) (x, y) value = MkBoard (updateAt y b (\row => updateAt x row (const (Just value))))++getCell : Board n -> (Fin n, Fin n) -> Cell n+getCell (MkBoard b) (x, y) = index x (index y b)++anyElim : {xs : Vect n a} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b+anyElim _ f (Here p) = f p+anyElim f _ (There p) = f p++getRow : Fin n -> Board n -> Vect n (Cell n)+getRow i (MkBoard b) = index i b++getCol : Fin n -> Board n -> Vect n (Cell n)+getCol i (MkBoard b) = helper i b+  where+    helper : Fin n -> Vect m (Vect n a) -> Vect m a+    helper _ Nil = Nil+    helper i (xs::xss) = index i xs :: helper i xss++LegalNeighbors : Cell n -> Cell n -> Type+LegalNeighbors (Just x) (Just y) = Not (x = y)+LegalNeighbors _ _ = ()++legalNeighbors : (x : Cell n) -> (y : Cell n) -> Dec (LegalNeighbors x y)+legalNeighbors (Just x) (Just y) with (decEq x y)+  | Yes prf = No (\pf => pf prf)+  | No prf = Yes prf+legalNeighbors Nothing (Just _) = Yes ()+legalNeighbors (Just _) Nothing = Yes ()+legalNeighbors Nothing Nothing = Yes ()++rowSafe : (b : Board n) -> (r : Fin n) -> (val : Fin n) -> Dec (All (LegalNeighbors (Just val)) (getRow r b))+rowSafe b r v = all (legalNeighbors (Just v)) (getRow r b)++colSafe : (b : Board n) -> (r : Fin n) -> (val : Fin n) -> Dec (All (LegalNeighbors (Just val)) (getCol r b))+colSafe b r v = all (legalNeighbors (Just v)) (getCol r b)++Empty : Cell n -> Type+Empty {n=n} x = (the (Cell n) Nothing) = x++empty : (cell : Cell n) -> Dec (Empty cell)+empty Nothing = Yes Refl+empty (Just _) = No nothingNotJust++-- Predicate for legal cell assignments+LegalVal : Board n -> (Fin n, Fin n) -> Fin n -> Type+LegalVal b (x, y) val = (Empty (getCell b (x, y)), All (LegalNeighbors (Just val)) (getCol x b), All (LegalNeighbors (Just val)) (getRow y b))++legalVal : (b : Board n) -> (coord : (Fin n, Fin n)) -> (val : Fin n) -> Dec (LegalVal b coord val)+legalVal b (x, y) v =+  case rowSafe b y v of+    No prf => No (\(_, _, rf) => prf rf)+    Yes prf =>+      case colSafe b x v of+        No prf' => No (\(_, cf, _) => prf' cf)+        Yes prf' =>+          case empty (getCell b (x, y)) of+            No prf'' => No (\(ef, _, _) => prf'' ef)+            Yes prf'' => Yes (prf'', prf', prf)+++Filled : Cell n -> Type+--Filled {n=n} x = Not (Empty x) -- TODO: Find out why this doesn't work+Filled {n=n} = (\x => Not (Empty x))+--Filled {n=n} x = the (Maybe (Fin n)) Nothing = x -> Void+--Filled {n=n} = \x => the (Maybe (Fin n)) Nothing = x -> Void++filled : (cell : Cell n) -> Dec (Filled cell)+filled Nothing = No (\f => f Refl)+filled (Just _) = Yes nothingNotJust++FullBoard : Board n -> Type+FullBoard (MkBoard b) = All (All Filled) b++fullBoard : (b : Board n) -> Dec (FullBoard b)+fullBoard (MkBoard b) = all (all filled) b++fins : Vect n (Fin n)+fins {n=Z} = Nil+fins {n=(S m)} = last :: map weaken fins++data LegalBoard : Board n -> Type where+  Base : LegalBoard (emptyBoard {n})+  Step : {b : Board n} -> {coords : (Fin n, Fin n)} -> {v : Fin n} -> LegalVal b coords v -> LegalBoard b -> LegalBoard (setCell b coords v)++CompleteBoard : Board n -> Type+CompleteBoard b = (LegalBoard b, FullBoard b)++indexStep : {i : Fin n} -> {xs : Vect n a} -> {x : a} -> index i xs = index (FS i) (x::xs)+indexStep = Refl++find : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a)+       -> Either (All (\x => Not (P x)) xs) (y : a ** (P y, (i : Fin n ** y = index i xs)))+find _ Nil = Left Nil+find d (x::xs) with (d x)+  | Yes prf = Right (x ** (prf, (FZ ** Refl)))+  | No prf =+    case find d xs of+      Right (y ** (prf', (i ** prf''))) =>+        Right (y ** (prf', (FS i ** replace {P=(\x => y = x)} (indexStep {x=x}) prf'')))+      Left prf' => Left (prf::prf')++findEmptyInRow : (xs : Vect n (Cell n)) -> Either (All Filled xs) (i : Fin n ** Empty (index i xs))+findEmptyInRow xs =+  case find {P=Empty} empty xs of+    Right (_ ** (pempty, (i ** pidx))) => Right (i ** trans pempty pidx)+    Left p => Left p++emptyCell : (b : Board n) -> Either (FullBoard b) (c : (Fin n, Fin n) ** Empty (getCell b c))+emptyCell (MkBoard rs) =+  case helper rs of+    Left p => Left p+    Right (ri ** (ci ** pf)) => Right ((ci, ri) ** pf)+  where+    helper : (rs : Vect m (Vect n (Cell n)))+             -> Either (All (All Filled) rs) (r : Fin m ** (c : Fin n ** Empty (index c (index r rs))))+    helper Nil = Left Nil+    helper (r::rs) =+      case findEmptyInRow r of+        Right (ci ** pf) => Right (FZ ** (ci ** pf))+        Left prf =>+          case helper rs of+            Left prf' => Left (prf::prf')+            Right (ri ** (ci ** pf)) => Right (FS ri ** (ci ** pf))+++tryValue : {b : Board (S n)} -> LegalBoard b -> (c : (Fin (S n), Fin (S n))) -> Empty (getCell b c) -> (v : Fin (S n))+           -> Either (Not (LegalVal b c v)) (b' : Board (S n) ** LegalBoard b')+tryValue {b=b} l c _ v =+  case legalVal b c v of+    No prf => Left prf+    Yes prf => Right (_ ** Step prf l)++nullBoardFull : (b : Board Z) -> FullBoard b+nullBoardFull (MkBoard Nil) = Nil++-- TODO: Prove complete by induction on illegal values wrt. some base state, e.g. every value is illegal for 123\21_\3_2+fillBoard : (b : Board n) -> LegalBoard b -> Maybe (b' : Board n ** CompleteBoard b')+fillBoard {n=Z} b l = Just (b ** (l, nullBoardFull b))+fillBoard {n=(S n)} b l with (emptyCell b)+  | Left full = Just (b ** (l, full))+  | Right (coords ** p) = recurse last+  where+    %assert_total+    tryAll : (v : Fin (S n)) -> (Fin (S n), Maybe (b' : Board (S n) ** LegalBoard b'))+    tryAll v = --trace ("Trying " ++ show (the Int (cast v))) $+      case tryValue l coords p v of+        Right success => (v, Just success)+        Left _ => -- TODO: Prove unsolvable+          case v of+            FS k => tryAll (weaken k)+            FZ => (v, Nothing)++    %assert_total+    recurse : Fin (S n) -> Maybe (b' : Board (S n) ** CompleteBoard b')+    recurse start = +      case tryAll start of+        (_, Nothing) => Nothing+        (FZ, Just (b' ** l')) => fillBoard b' l'+        (FS next, Just (b' ** l')) =>+          case fillBoard b' l' of+            Just solution => Just solution+            Nothing => recurse (weaken next)
+ benchmarks/quasigroups/board view
@@ -0,0 +1,12 @@+. . . . . . . . . . . 1+. . . . . . . . . . 1 .+. . . . . . . . . 1 . .+. . . . . . . . 1 . . .+. . . . . . . 1 . . . .+. . . . . . 1 . . . . .+. . . . . 1 . . . . . .+. . . . 1 . . . . . . .+. . . . . . . . . . . .+. . 9 . . . . . . . . .+. 1 . . . . . . . . . .+1 . . . . . . . . . . .
+ benchmarks/quasigroups/qgsolve.ipkg view
@@ -0,0 +1,7 @@+package qgsolve++modules = Solver, Parser, Main++executable = qgsolve+main = Main+
+ benchmarks/run.pl view
@@ -0,0 +1,24 @@+#!/usr/bin/env perl++$bmarks = `cat ALL`;+@bm = split(/\n/, $bmarks);++$total = 0;++foreach $b (@bm) {+    if ($b =~ /([a-zA-Z0-9]+)\/([a-zA-Z0-9]+)\s+(.*)/) {+        #print "Running $1 $2\n";+        chdir $1;+        $result = `/usr/bin/time ./$2 $3 2> .times`;+        $time = `cat .times`; +        chdir "..";+        #print $time;+        @timeflds = split(/\s+/, $time);+        $user = $timeflds[3];+        print "$1 / $2 $user\n";+        $total += $user;+    }+}++print "\nTOTAL $total\n";+
+ benchmarks/trivial/sortvec.idr view
@@ -0,0 +1,24 @@+module Main++import System+import Effect.Random++total+insert : Ord a => a -> Vect n a -> Vect (S n) a+insert x [] = [x]+insert x (y :: ys) = if (x < y) then x :: y :: ys else y :: insert x ys++vsort : Ord a => Vect n a -> Vect n a+vsort [] = []+vsort (x :: xs) = insert x (vsort xs)++mkSortVec : (n : Nat) -> Eff m [RND] (Vect n Int)+mkSortVec Z = return []+mkSortVec (S k) = return (fromInteger !(rndInt 0 10000) :: !(mkSortVec k))++main : IO ()+main = do (_ :: arg :: _) <- getArgs+--           let arg = "2000"+          let vec = runPure [123456789] (mkSortVec (fromInteger (cast arg)))+          putStrLn "Made vector"+          printLn (vsort vec)
+ benchmarks/trivial/sortvec.ipkg view
@@ -0,0 +1,8 @@+package sort++modules = sortvec +opts = "-p effects" ++executable = sortvec+main = sortvec+
− codegen/idris-c/Main.hs 
@@ -1,52 +0,0 @@-module Main where--import Idris.Core.TT-import Idris.AbsSyntax-import Idris.ElabDecls-import Idris.REPL--import IRTS.Compiler-import IRTS.CodegenC--import System.Environment-import System.Exit-import Control.Monad--import Paths_idris--import Util.System--data Opts = Opts { inputs :: [FilePath],-                   interface :: Bool,-                   output :: FilePath }--showUsage = do putStrLn "Usage: idris-c <ibc-files> [-o <output-file>]"-               exitWith ExitSuccess--getOpts :: IO Opts-getOpts = do xs <- getArgs-             return $ process (Opts [] False "a.out") xs-  where-    process opts ("-o":o:xs) = process (opts { output = o }) xs-    process opts ("--interface":xs) = process (opts { interface = True }) xs-    process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs-    process opts [] = opts--c_main :: Opts -> Idris ()-c_main opts = do runIO setupBundledCC-                 elabPrims-                 loadInputs (inputs opts) Nothing-                 mainProg <- if interface opts -                                then liftM Just elabMain-                                else return Nothing-                 ir <- compile (Via "c") (output opts) mainProg-                 runIO $ codegenC ir--main :: IO ()-main = do opts <- getOpts-          if (null (inputs opts)) -             then showUsage-             else runMain (c_main opts)---
+ codegen/idris-codegen-c/Main.hs view
@@ -0,0 +1,50 @@+module Main where++import Idris.Core.TT+import Idris.AbsSyntax+import Idris.ElabDecls+import Idris.REPL++import IRTS.Compiler+import IRTS.CodegenC++import System.Environment+import System.Exit+import Control.Monad++import Paths_idris++import Util.System++data Opts = Opts { inputs :: [FilePath],+                   interface :: Bool,+                   output :: FilePath }++showUsage = do putStrLn "A code generator which is intended to be called by the compiler, not by a user."+               putStrLn "Usage: idris-codegen-c <ibc-files> [-o <output-file>]"+               exitWith ExitSuccess++getOpts :: IO Opts+getOpts = do xs <- getArgs+             return $ process (Opts [] False "a.out") xs+  where+    process opts ("-o":o:xs) = process (opts { output = o }) xs+    process opts ("--interface":xs) = process (opts { interface = True }) xs+    process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs+    process opts [] = opts++c_main :: Opts -> Idris ()+c_main opts = do runIO setupBundledCC+                 elabPrims+                 loadInputs (inputs opts) Nothing+                 mainProg <- if interface opts+                                then liftM Just elabMain+                                else return Nothing+                 ir <- compile (Via "c") (output opts) mainProg+                 runIO $ codegenC ir++main :: IO ()+main = do opts <- getOpts+          if (null (inputs opts))+             then showUsage+             else  runMain (c_main opts)
+ codegen/idris-codegen-javascript/Main.hs view
@@ -0,0 +1,44 @@+module Main where++import Idris.Core.TT+import Idris.AbsSyntax+import Idris.ElabDecls+import Idris.REPL++import IRTS.Compiler+import IRTS.CodegenJavaScript++import System.Environment+import System.Exit++import Paths_idris++data Opts = Opts {+                   inputs :: [FilePath]+                 , output :: FilePath+                 }++showUsage = do putStrLn "A code generator which is intended to be called by the compiler, not by a user."+               putStrLn "Usage: idris-codegen-javascript <ibc-files> [-o <output-file>]"+               exitWith ExitSuccess++getOpts :: IO Opts+getOpts = do xs <- getArgs+             return $ process (Opts [] "main.js") xs+  where+    process opts ("-o":o:xs) = process (opts { output = o }) xs+    process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs+    process opts [] = opts++jsMain :: Opts -> Idris ()+jsMain opts = do elabPrims+                 loadInputs (inputs opts) Nothing+                 mainProg <- elabMain+                 ir <- compile (Via "javascript") (output opts) (Just mainProg)+                 runIO $ codegenJavaScript ir++main :: IO ()+main = do opts <- getOpts+          if (null (inputs opts))+             then showUsage+             else runMain (jsMain opts)
+ codegen/idris-codegen-node/Main.hs view
@@ -0,0 +1,43 @@+module Main where++import Idris.Core.TT+import Idris.AbsSyntax+import Idris.ElabDecls+import Idris.REPL++import IRTS.Compiler+import IRTS.CodegenJavaScript++import System.Environment+import System.Exit++import Paths_idris++data Opts = Opts { inputs :: [FilePath]+                 , output :: FilePath+                 }++showUsage = do putStrLn "A code generator which is intended to be called by the compiler, not by a user."+               putStrLn "Usage: idris-codegen-node <ibc-files> [-o <output-file>]"+               exitWith ExitSuccess++getOpts :: IO Opts+getOpts = do xs <- getArgs+             return $ process (Opts [] "main.js") xs+  where+    process opts ("-o":o:xs) = process (opts { output = o }) xs+    process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs+    process opts [] = opts++jsMain :: Opts -> Idris ()+jsMain opts = do elabPrims+                 loadInputs (inputs opts) Nothing+                 mainProg <- elabMain+                 ir <- compile (Via "node") (output opts) (Just mainProg)+                 runIO $ codegenNode ir++main :: IO ()+main = do opts <- getOpts+          if (null (inputs opts))+             then showUsage+             else  runMain (jsMain opts)
− codegen/idris-javascript/Main.hs 
@@ -1,42 +0,0 @@-module Main where--import Idris.Core.TT-import Idris.AbsSyntax-import Idris.ElabDecls-import Idris.REPL--import IRTS.Compiler-import IRTS.CodegenJavaScript--import System.Environment-import System.Exit--import Paths_idris--data Opts = Opts { inputs :: [FilePath]-                 , output :: FilePath-                 }--showUsage = do putStrLn "Usage: idris-javascript <ibc-files> [-o <output-file>]"-               exitWith ExitSuccess--getOpts :: IO Opts-getOpts = do xs <- getArgs-             return $ process (Opts [] "main.js") xs-  where-    process opts ("-o":o:xs) = process (opts { output = o }) xs-    process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs-    process opts [] = opts--jsMain :: Opts -> Idris ()-jsMain opts = do elabPrims-                 loadInputs (inputs opts) Nothing-                 mainProg <- elabMain-                 ir <- compile (Via "javascript") (output opts) (Just mainProg)-                 runIO $ codegenJavaScript ir--main :: IO ()-main = do opts <- getOpts-          if (null (inputs opts))-             then showUsage-             else runMain (jsMain opts)
− codegen/idris-node/Main.hs 
@@ -1,42 +0,0 @@-module Main where--import Idris.Core.TT-import Idris.AbsSyntax-import Idris.ElabDecls-import Idris.REPL--import IRTS.Compiler-import IRTS.CodegenJavaScript--import System.Environment-import System.Exit--import Paths_idris--data Opts = Opts { inputs :: [FilePath]-                 , output :: FilePath-                 }--showUsage = do putStrLn "Usage: idris-node <ibc-files> [-o <output-file>]"-               exitWith ExitSuccess--getOpts :: IO Opts-getOpts = do xs <- getArgs-             return $ process (Opts [] "main.js") xs-  where-    process opts ("-o":o:xs) = process (opts { output = o }) xs-    process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs-    process opts [] = opts--jsMain :: Opts -> Idris ()-jsMain opts = do elabPrims-                 loadInputs (inputs opts) Nothing-                 mainProg <- elabMain-                 ir <- compile (Via "node") (output opts) (Just mainProg)-                 runIO $ codegenNode ir--main :: IO ()-main = do opts <- getOpts-          if (null (inputs opts))-             then showUsage-             else runMain (jsMain opts)
config.mk view
@@ -27,7 +27,11 @@ ifneq (, $(findstring mingw, $(MACHINE))) 	OS      :=windows else+ifneq (, $(findstring windows, $(MACHINE)))+	OS      :=windows+else 	OS      :=unix+endif endif endif endif
+ idris-tutorial.pdf view

binary file changed (absent → 287080 bytes)

idris.cabal view
@@ -1,5 +1,5 @@ Name:           idris-Version:        0.9.19+Version:        0.9.19.1 License:        BSD3 License-file:   LICENSE Author:         Edwin Brady@@ -76,9 +76,23 @@                        rts/mini-gmp.h                        rts/libtest.c +Extra-doc-files:+                       CHANGELOG+                       CITATION.md+                       CONTRIBUTING.md+                       CONTRIBUTORS+                       README.md+                       idris-tutorial.pdf+                       man/idris.1+                       samples/effects/*.idr+                       samples/misc/*.idr+                       samples/misc/*.lidr+                       samples/tutorial/*.idr+ Extra-source-files:                        Makefile                        config.mk+                       stack.yaml                         rts/*.c                        rts/*.h@@ -143,36 +157,18 @@                        test/reg004/run                        test/reg004/*.idr                        test/reg004/expected-                       test/reg005/run-                       test/reg005/*.idr-                       test/reg005/expected                        test/reg006/run                        test/reg006/*.idr                        test/reg006/expected                        test/reg007/run                        test/reg007/*.lidr                        test/reg007/expected-                       test/reg009/run-                       test/reg009/*.lidr-                       test/reg009/expected                        test/reg010/run                        test/reg010/*.idr                        test/reg010/expected-                       test/reg011/run-                       test/reg011/*.idr-                       test/reg011/expected-                       test/reg012/run-                       test/reg012/*.lidr-                       test/reg012/expected                        test/reg013/run                        test/reg013/*.idr                        test/reg013/expected-                       test/reg014/run-                       test/reg014/*.idr-                       test/reg014/expected-                       test/reg015/run-                       test/reg015/*.idr-                       test/reg015/expected                        test/reg016/run                        test/reg016/*.idr                        test/reg016/expected@@ -182,18 +178,9 @@                        test/reg018/run                        test/reg018/*.idr                        test/reg018/expected-                       test/reg019/run-                       test/reg019/*.idr-                       test/reg019/expected                        test/reg020/run                        test/reg020/*.idr                        test/reg020/expected-                       test/reg021/run-                       test/reg021/*.idr-                       test/reg021/expected-                       test/reg022/run-                       test/reg022/*.idr-                       test/reg022/expected                        test/reg023/run                        test/reg023/*.idr                        test/reg023/expected@@ -203,9 +190,6 @@                        test/reg025/run                        test/reg025/*.idr                        test/reg025/expected-                       test/reg026/run-                       test/reg026/*.idr-                       test/reg026/expected                        test/reg027/run                        test/reg027/*.idr                        test/reg027/expected@@ -215,18 +199,12 @@                        test/reg029/run                        test/reg029/*.idr                        test/reg029/expected-                       test/reg030/run-                       test/reg030/*.idr-                       test/reg030/expected                        test/reg031/run                        test/reg031/*.idr                        test/reg031/expected                        test/reg032/run                        test/reg032/*.idr                        test/reg032/expected-                       test/reg033/run-                       test/reg033/*.idr-                       test/reg033/expected                        test/reg034/run                        test/reg034/*.idr                        test/reg034/expected@@ -365,6 +343,12 @@                        test/basic013/run                        test/basic013/*.idr                        test/basic013/expected+                       test/basic014/run+                       test/basic014/*.idr+                       test/basic014/expected+                       test/basic015/run+                       test/basic015/*.idr+                       test/basic015/expected                         test/bignum001/run                        test/bignum001/*.idr@@ -569,6 +553,7 @@                        test/primitives001/run                        test/primitives001/*.idr                        test/primitives001/expected+                       test/primitives001/input                        test/primitives002/run                        test/primitives002/expected                        test/primitives003/run@@ -606,6 +591,16 @@                        test/proof010/run                        test/proof010/*.idr                        test/proof010/expected+                       +                       test/proofsearch001/run+                       test/proofsearch001/*.idr+                       test/proofsearch001/expected+                       test/proofsearch002/run+                       test/proofsearch002/*.idr+                       test/proofsearch002/expected+                       test/proofsearch003/run+                       test/proofsearch003/*.idr+                       test/proofsearch003/expected                         test/quasiquote001/run                        test/quasiquote001/*.idr@@ -695,6 +690,9 @@                        test/totality009/run                        test/totality009/*.idr                        test/totality009/expected+                       test/totality010/run+                       test/totality010/*.idr+                       test/totality010/expected                         test/tutorial001/run                        test/tutorial001/*.idr@@ -738,7 +736,23 @@                        test/docs003/*.idr                        test/docs003/expected +                       benchmarks/ALL+                       benchmarks/*.pl+                       benchmarks/README +                       benchmarks/fasta/fasta.idr+                       benchmarks/fasta/fasta.ipkg++                       benchmarks/pidigits/pidigits.idr+                       benchmarks/pidigits/pidigits.ipkg++                       benchmarks/quasigroups/board+                       benchmarks/quasigroups/*.idr+                       benchmarks/quasigroups/qgsolve.ipkg++                       benchmarks/trivial/sortvec.idr+                       benchmarks/trivial/sortvec.ipkg+ source-repository head   type:     git   location: git://github.com/idris-lang/Idris-dev.git@@ -923,7 +937,7 @@                 , trifecta >= 1.1 && < 1.6                 , uniplate >=1.6 && < 1.7                 , unordered-containers < 0.3-                , utf8-string <= 1+                , utf8-string < 1.1                 , vector < 0.11                 , vector-binary-instances < 0.3                 , zip-archive > 0.2.3.5 && < 0.2.4@@ -984,9 +998,9 @@   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -funbox-strict-fields -Executable idris-c+Executable idris-codegen-c   Main-is:        Main.hs-  hs-source-dirs: codegen/idris-c+  hs-source-dirs: codegen/idris-codegen-c    Build-depends:  idris                 , base@@ -997,9 +1011,9 @@   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -funbox-strict-fields -Executable idris-javascript+Executable idris-codegen-javascript   Main-is:        Main.hs-  hs-source-dirs: codegen/idris-javascript+  hs-source-dirs: codegen/idris-codegen-javascript    Build-depends:  idris                 , base@@ -1010,9 +1024,9 @@   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -funbox-strict-fields -Executable idris-node+Executable idris-codegen-node   Main-is:        Main.hs-  hs-source-dirs: codegen/idris-node+  hs-source-dirs: codegen/idris-codegen-node    Build-depends:  idris                 , base
jsrts/Runtime-node.js view
@@ -10,14 +10,20 @@    return function() {     var ret = "";-+    var b = new Buffer(1024);+    var i = 0;     while(true) {-      var b = new Buffer(1);-      fs.readSync(0, b, 0, 1 )-      if (b[0] == 10)+      fs.readSync(0, b, i, 1 )+      if (b[i] == 10) {+        ret = b.toString('utf8', 0, i);         break;-      else-        ret += String.fromCharCode(b[0]);+      }+      i++;+      if (i == b.length) {+        nb = new Buffer (b.length*2);+        b.copy(nb)+        b = nb;+      }     }      return ret;
libs/base/Control/Category.idr view
@@ -10,7 +10,9 @@  instance Category Morphism where   id                = Mor id-  (Mor f) . (Mor g) = Mor (f . g)+  -- disambiguation needed below, because unification can now get further+  -- here with Category.(.) and it's only type class resolution that fails!+  (Mor f) . (Mor g) = with Basics (Mor (f . g))  instance Monad m => Category (Kleislimorphism m) where   id                        = Kleisli (return . id)
libs/base/Data/Bits.idr view
@@ -42,7 +42,7 @@     | S (S (S _)) = natToBits' {n=3} (prim__truncInt_B64 0) x  getPad : Nat -> machineTy n-getPad n = natToBits ((bitsUsed (nextBytes n)) - n)+getPad n = natToBits (minus (bitsUsed (nextBytes n)) n)  public data Bits : Nat -> Type where
libs/base/Data/Complex.idr view
@@ -5,8 +5,6 @@  module Data.Complex -import Data.Floats- ------------------------------ Rectangular form  infix 6 :+@@ -57,20 +55,21 @@  ------------------------------ Conjugate -conjugate : Num a => Complex a -> Complex a+conjugate : Neg a => Complex a -> Complex a conjugate (r:+i) = (r :+ (0-i))  instance Functor Complex where-  map f (r :+ i) = f r :+ f i--instance Neg a => Neg (Complex a) where-  negate = map negate+    map f (r :+ i) = f r :+ f i  -- We can't do "instance Num a => Num (Complex a)" because -- we need "abs" which needs "magnitude" which needs "sqrt" which needs Float instance Num (Complex Float) where     (+) (a:+b) (c:+d) = ((a+c):+(b+d))-    (-) (a:+b) (c:+d) = ((a-c):+(b-d))     (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d))     fromInteger x = (fromInteger x:+0)++instance Neg (Complex Float) where+    negate = map negate+    (-) (a:+b) (c:+d) = ((a-c):+(b-d))     abs (a:+b) = (magnitude (a:+b):+0)+
− libs/base/Data/Floats.idr 
@@ -1,59 +0,0 @@-module Data.Floats--%access public-%default total--%include C "math.h"-%lib C "m"--pi : Float-pi = 3.14159265358979323846 --euler : Float-euler = 2.7182818284590452354--exp : Float -> Float-exp x = prim__floatExp x--log : Float -> Float-log x = prim__floatLog x--sin : Float -> Float-sin x = prim__floatSin x--cos : Float -> Float-cos x = prim__floatCos x--tan : Float -> Float-tan x = prim__floatTan x--asin : Float -> Float-asin x = prim__floatASin x--acos : Float -> Float-acos x = prim__floatACos x--atan : Float -> Float-atan x = prim__floatATan x--atan2 : Float -> Float -> Float-atan2 y x = atan (y/x)--sinh : Float -> Float-sinh x = (exp x - exp (-x)) / 2--cosh : Float -> Float-cosh x = (exp x + exp (-x)) / 2--tanh : Float -> Float-tanh x = sinh x / cosh x--sqrt : Float -> Float-sqrt x = prim__floatSqrt x--floor : Float -> Float-floor x = prim__floatFloor x--ceiling : Float -> Float-ceiling x = prim__floatCeil x-
libs/base/Data/Mod2.idr view
@@ -40,9 +40,7 @@  instance Num (Mod2 n) where     (+) = modBin plus-    (-) = modBin minus     (*) = modBin times-    abs = id     fromInteger = intToMod  instance Cast (Mod2 n) (Bits n) where
libs/base/Data/Vect.idr view
@@ -1,12 +1,572 @@ module Data.Vect +import public Data.Fin import Language.Reflection-import public Data.VectType  %access public %default total +infixr 7 ::++||| Vectors: Generic lists with explicit length in the type+%elim+data Vect : Nat -> Type -> Type where+  ||| Empty vector+  Nil  : Vect Z a+  ||| A non-empty vector of length `S k`, consisting of a head element and+  ||| the rest of the list, of length `k`.+  (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a++-- Hints for interactive editing+%name Vect xs,ys,zs,ws+ --------------------------------------------------------------------------------+-- Length+--------------------------------------------------------------------------------++||| Calculate the length of a `Vect`.+|||+||| **Note**: this is only useful if you don't already statically know the length+||| and you want to avoid matching the implicit argument for erasure reasons.+||| @ n the length (provably equal to the return value)+||| @ xs the vector+length : (xs : Vect n a) -> Nat+length [] = 0+length (x::xs) = 1 + length xs++||| Show that the length function on vectors in fact calculates the length+private lengthCorrect : (n : Nat) -> (xs : Vect n a) -> length xs = n+lengthCorrect Z     []        = Refl+lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in Refl++--------------------------------------------------------------------------------+-- Indexing into vectors+--------------------------------------------------------------------------------++||| All but the first element of the vector+tail : Vect (S n) a -> Vect n a+tail (x::xs) = xs++||| Only the first element of the vector+head : Vect (S n) a -> a+head (x::xs) = x++||| The last element of the vector+last : Vect (S n) a -> a+last (x::[])    = x+last (x::y::ys) = last $ y::ys++||| All but the last element of the vector+init : Vect (S n) a -> Vect n a+init (x::[])    = []+init (x::y::ys) = x :: init (y::ys)++||| Extract a particular element from a vector+index : Fin n -> Vect n a -> a+index FZ     (x::xs) = x+index (FS k) (x::xs) = index k xs+++||| Insert an element at a particular index+insertAt : Fin (S n) -> a -> Vect n a -> Vect (S n) a+insertAt FZ     y xs      = y :: xs+insertAt (FS k) y (x::xs) = x :: insertAt k y xs+insertAt (FS k) y []      = absurd k++||| Construct a new vector consisting of all but the indicated element+deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a+deleteAt           FZ     (x::xs) = xs+deleteAt {n = S m} (FS k) (x::xs) = x :: deleteAt k xs+deleteAt {n = Z}   (FS k) (x::xs) = absurd k+deleteAt           _      []      impossible++||| Replace an element at a particlar index with another+replaceAt : Fin n -> t -> Vect n t -> Vect n t+replaceAt FZ     y (x::xs) = y :: xs+replaceAt (FS k) y (x::xs) = x :: replaceAt k y xs++||| Replace the element at a particular index with the result of applying a function to it+||| @ i the index to replace at+||| @ f the update function+||| @ xs the vector to replace in+updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t+updateAt FZ     f (x::xs) = f x :: xs+updateAt (FS k) f (x::xs) = x :: updateAt k f xs++--------------------------------------------------------------------------------+-- Subvectors+--------------------------------------------------------------------------------++||| Get the first n elements of a Vect+||| @ n the number of elements to take+take : (n : Nat) -> Vect (n + m) a -> Vect n a+take Z     xs        = []+take (S k) (x :: xs) = x :: take k xs++||| Remove the first n elements of a Vect+||| @ n the number of elements to remove+drop : (n : Nat) -> Vect (n + m) a -> Vect m a+drop Z     xs        = xs+drop (S k) (x :: xs) = drop k xs++||| Take the longest prefix of a Vect such that all elements satisfy some+||| Boolean predicate.+|||+||| @ p the predicate+takeWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a)+takeWhile p []      = (_ ** [])+takeWhile p (x::xs) =+  let (len ** ys) = takeWhile p xs+  in if p x then+      (S len ** x :: ys)+    else+      (_ ** [])++||| Remove the longest prefix of a Vect such that all removed elements satisfy some+||| Boolean predicate.+|||+||| @ p the predicate+dropWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a)+dropWhile p [] = (_ ** [])+dropWhile p (x::xs) =+  if p x then+    dropWhile p xs+  else+    (_ ** x::xs)++--------------------------------------------------------------------------------+-- Transformations+--------------------------------------------------------------------------------++||| Reverse the order of the elements of a vector+reverse : Vect n a -> Vect n a+reverse xs = go [] xs+  where go : Vect n a -> Vect m a -> Vect (n+m) a+        go {n}         acc []        = rewrite plusZeroRightNeutral n in acc+        go {n} {m=S m} acc (x :: xs) = rewrite sym $ plusSuccRightSucc n m+                                       in go (x::acc) xs++||| Alternate an element between the other elements of a vector+||| @ sep the element to intersperse+||| @ xs the vector to separate with `sep`+intersperse : (sep : a) -> (xs : Vect n a) -> Vect (n + pred n) a+intersperse sep []      = []+intersperse sep (x::xs) = x :: intersperse' sep xs+  where+    intersperse' : a -> Vect n a -> Vect (n + n) a+    intersperse'         sep []      = []+    intersperse' {n=S n} sep (x::xs) = rewrite sym $ plusSuccRightSucc n n+                                       in sep :: x :: intersperse' sep xs++--------------------------------------------------------------------------------+-- Conversion from list (toList is provided by Foldable)+--------------------------------------------------------------------------------+++fromList' : Vect n a -> (l : List a) -> Vect (length l + n) a+fromList' ys [] = ys+fromList' {n} ys (x::xs) =+  rewrite (plusSuccRightSucc (length xs) n) ==>+          Vect (plus (length xs) (S n)) a in+  fromList' (x::ys) xs++||| Convert a list to a vector.+|||+||| The length of the list should be statically known.+fromList : (l : List a) -> Vect (length l) a+fromList l =+  rewrite (sym $ plusZeroRightNeutral (length l)) in+  reverse $ fromList' [] l++--------------------------------------------------------------------------------+-- Building (bigger) vectors+--------------------------------------------------------------------------------++||| Append two vectors+(++) : Vect m a -> Vect n a -> Vect (m + n) a+(++) []      ys = ys+(++) (x::xs) ys = x :: xs ++ ys++||| Repeate some value n times+||| @ n the number of times to repeat it+||| @ x the value to repeat+replicate : (n : Nat) -> (x : a) -> Vect n a+replicate Z     x = []+replicate (S k) x = x :: replicate k x++--------------------------------------------------------------------------------+-- Zips and unzips+--------------------------------------------------------------------------------++||| Combine two equal-length vectors pairwise with some function+zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c+zipWith f []      []      = []+zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys++||| Combine three equal-length vectors into a vector with some function+zipWith3 : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d+zipWith3 f []      []      []      = []+zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs++||| Combine two equal-length vectors pairwise+zip : Vect n a -> Vect n b -> Vect n (a, b)+zip = zipWith (\x,y => (x,y))++||| Combine three equal-length vectors elementwise into a vector of tuples+zip3 : Vect n a -> Vect n b -> Vect n c -> Vect n (a, b, c)+zip3 = zipWith3 (\x,y,z => (x,y,z))++||| Convert a vector of pairs to a pair of vectors+unzip : Vect n (a, b) -> (Vect n a, Vect n b)+unzip []           = ([], [])+unzip ((l, r)::xs) with (unzip xs)+  | (lefts, rights) = (l::lefts, r::rights)++||| Convert a vector of three-tuples to a triplet of vectors+unzip3 : Vect n (a, b, c) -> (Vect n a, Vect n b, Vect n c)+unzip3 []            = ([], [], [])+unzip3 ((l,c,r)::xs) with (unzip3 xs)+  | (lefts, centers, rights) = (l::lefts, c::centers, r::rights)++--------------------------------------------------------------------------------+-- Equality+--------------------------------------------------------------------------------++instance (Eq a) => Eq (Vect n a) where+  (==) []      []      = True+  (==) (x::xs) (y::ys) = x == y && xs == ys+++--------------------------------------------------------------------------------+-- Order+--------------------------------------------------------------------------------++instance Ord a => Ord (Vect n a) where+  compare []      []      = EQ+  compare (x::xs) (y::ys) = compare x y `thenCompare` compare xs ys+++--------------------------------------------------------------------------------+-- Maps+--------------------------------------------------------------------------------++instance Functor (Vect n) where+  map f []        = []+  map f (x::xs) = f x :: map f xs+++||| Map a partial function across a vector, returning those elements for which+||| the function had a value.+|||+||| The first projection of the resulting pair (ie the length) will always be+||| at most the length of the input vector. This is not, however, guaranteed+||| by the type.+|||+||| @ f the partial function (expressed by returning `Maybe`)+||| @ xs the vector to check for results+mapMaybe : (f : a -> Maybe b) -> (xs : Vect n a) -> (m : Nat ** Vect m b)+mapMaybe f []      = (_ ** [])+mapMaybe f (x::xs) =+  let (len ** ys) = mapMaybe f xs+  in case f x of+       Just y  => (S len ** y :: ys)+       Nothing => (  len **      ys)+++--------------------------------------------------------------------------------+-- Folds+--------------------------------------------------------------------------------++foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> Vect n t -> acc+foldrImpl f e go [] = go e+foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs++instance Foldable (Vect n) where+  foldr f e xs = foldrImpl f e id xs++--------------------------------------------------------------------------------+-- Special folds+--------------------------------------------------------------------------------++||| Flatten a vector of equal-length vectors+concat : Vect m (Vect n a) -> Vect (m * n) a+concat []      = []+concat (v::vs) = v ++ concat vs++||| Foldr without seeding the accumulator+foldr1 : (t -> t -> t) -> Vect (S n) t -> t+foldr1 f (x::xs) = foldr f x xs++||| Foldl without seeding the accumulator+foldl1 : (t -> t -> t) -> Vect (S n) t -> t+foldl1 f (x::xs) = foldl f x xs+--------------------------------------------------------------------------------+-- Scans+--------------------------------------------------------------------------------++scanl : (b -> a -> b) -> b -> Vect n a -> Vect (S n) b+scanl f q []      = [q]+scanl f q (x::xs) = q :: scanl f (f q x) xs++--------------------------------------------------------------------------------+-- Membership tests+--------------------------------------------------------------------------------++||| Search for an item using a user-provided test+||| @ p the equality test+||| @ e the item to search for+||| @ xs the vector to search in+elemBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n a) -> Bool+elemBy p e []      = False+elemBy p e (x::xs) = p e x || elemBy p e xs++||| Use the default Boolean equality on elements to search for an item+||| @ x what to search for+||| @ xs where to search+elem : Eq a => (x : a) -> (xs : Vect n a) -> Bool+elem = elemBy (==)++||| Find the association of some key with a user-provided comparison+||| @ p the comparison operator for keys (True if they match)+||| @ e the key to look for+lookupBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n (a, b)) -> Maybe b+lookupBy p e []           = Nothing+lookupBy p e ((l, r)::xs) = if p e l then Just r else lookupBy p e xs++||| Find the assocation of some key using the default Boolean equality test+lookup : Eq a => a -> Vect n (a, b) -> Maybe b+lookup = lookupBy (==)++||| Check if any element of xs is found in elems by a user-provided comparison+||| @ p the comparison operator+||| @ elems the vector to search+||| @ xs what to search for+hasAnyBy : (p : a -> a -> Bool) -> (elems : Vect m a) -> (xs : Vect n a) -> Bool+hasAnyBy p elems []      = False+hasAnyBy p elems (x::xs) = elemBy p x elems || hasAnyBy p elems xs++||| Check if any element of xs is found in elems using the default Boolean equality test+hasAny : Eq a => Vect m a -> Vect n a -> Bool+hasAny = hasAnyBy (==)++--------------------------------------------------------------------------------+-- Searching with a predicate+--------------------------------------------------------------------------------++||| Find the first element of the vector that satisfies some test+||| @ p the test to satisfy+find : (p : a -> Bool) -> (xs : Vect n a) -> Maybe a+find p []      = Nothing+find p (x::xs) = if p x then Just x else find p xs++||| Find the index of the first element of the vector that satisfies some test+findIndex : (a -> Bool) -> Vect n a -> Maybe (Fin n)+findIndex p []        = Nothing+findIndex p (x :: xs) = if p x then Just 0 else map FS (findIndex p xs)++||| Find the indices of all elements that satisfy some test+findIndices : (a -> Bool) -> Vect m a -> List (Fin m)+findIndices p []        = []+findIndices p (x :: xs) = let is = map FS $ findIndices p xs+                           in if p x then 0 :: is else is++elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe (Fin m)+elemIndexBy p e = findIndex $ p e++elemIndex : Eq a => a -> Vect m a -> Maybe (Fin m)+elemIndex = elemIndexBy (==)++elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> List (Fin m)+elemIndicesBy p e = findIndices $ p e++elemIndices : Eq a => a -> Vect m a -> List (Fin m)+elemIndices = elemIndicesBy (==)++--------------------------------------------------------------------------------+-- Filters+--------------------------------------------------------------------------------++||| Find all elements of a vector that satisfy some test+filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)+filter p []      = ( _ ** [] )+filter p (x::xs) =+  let (_ ** tail) = filter p xs+   in if p x then+        (_ ** x::tail)+      else+        (_ ** tail)++||| Make the elements of some vector unique by some test+nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)+nubBy = nubBy' []+  where+    nubBy' : Vect m a -> (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)+    nubBy' acc p []      = (_ ** [])+    nubBy' acc p (x::xs) with (elemBy p x acc)+      | True  = nubBy' acc p xs+      | False with (nubBy' (x::acc) p xs)+        | (_ ** tail) = (_ ** x::tail)++||| Make the elements of some vector unique by the default Boolean equality+nub : Eq a => Vect n a -> (p ** Vect p a)+nub = nubBy (==)++deleteBy : (a -> a -> Bool) -> a -> Vect n a -> (p ** Vect p a)+deleteBy _  _ []      = (_ ** [])+deleteBy eq x (y::ys) =+  let (len ** zs) = deleteBy eq x ys+  in if x `eq` y then (_ ** ys) else (S len ** y ::zs)++delete : (Eq a) => a -> Vect n a -> (p ** Vect p a)+delete = deleteBy (==)++--------------------------------------------------------------------------------+-- Splitting and breaking lists+--------------------------------------------------------------------------------++||| A tuple where the first element is a Vect of the n first elements and+||| the second element is a Vect of the remaining elements of the original Vect+||| It is equivalent to (take n xs, drop n xs)+||| @ n   the index to split at+||| @ xs  the Vect to split in two+splitAt : (n : Nat) -> (xs : Vect (n + m) a) -> (Vect n a, Vect m a)+splitAt n xs = (take n xs, drop n xs)++partition : (a -> Bool) -> Vect n a -> ((p ** Vect p a), (q ** Vect q a))+partition p []      = ((_ ** []), (_ ** []))+partition p (x::xs) =+  let ((leftLen ** lefts), (rightLen ** rights)) = partition p xs in+    if p x then+      ((S leftLen ** x::lefts), (rightLen ** rights))+    else+      ((leftLen ** lefts), (S rightLen ** x::rights))++--------------------------------------------------------------------------------+-- Predicates+--------------------------------------------------------------------------------++isPrefixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool+isPrefixOfBy p [] right        = True+isPrefixOfBy p left []         = False+isPrefixOfBy p (x::xs) (y::ys) = p x y && isPrefixOfBy p xs ys++isPrefixOf : Eq a => Vect m a -> Vect n a -> Bool+isPrefixOf = isPrefixOfBy (==)++isSuffixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool+isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right)++isSuffixOf : Eq a => Vect m a -> Vect n a -> Bool+isSuffixOf = isSuffixOfBy (==)++--------------------------------------------------------------------------------+-- Conversions+--------------------------------------------------------------------------------++maybeToVect : Maybe a -> (p ** Vect p a)+maybeToVect Nothing  = (_ ** [])+maybeToVect (Just j) = (_ ** [j])++vectToMaybe : Vect n a -> Maybe a+vectToMaybe []      = Nothing+vectToMaybe (x::xs) = Just x++--------------------------------------------------------------------------------+-- Misc+--------------------------------------------------------------------------------++catMaybes : Vect n (Maybe a) -> (p ** Vect p a)+catMaybes []             = (_ ** [])+catMaybes (Nothing::xs)  = catMaybes xs+catMaybes ((Just j)::xs) =+  let (_ ** tail) = catMaybes xs+   in (_ ** j::tail)++diag : Vect n (Vect n a) -> Vect n a+diag []             = []+diag ((x::xs)::xss) = x :: diag (map tail xss)++range : {n : Nat} -> Vect n (Fin n)+range {n=Z}   = []+range {n=S _} = FZ :: map FS range++||| Transpose a Vect of Vects, turning rows into columns and vice versa.+|||+||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`.+transpose : {n : Nat} -> Vect m (Vect n a) -> Vect n (Vect m a)+transpose []        = replicate _ []+transpose (x :: xs) = zipWith (::) x (transpose xs)++--------------------------------------------------------------------------------+-- Applicative/Monad/Traversable+--------------------------------------------------------------------------------++instance Applicative (Vect k) where+    pure = replicate _++    fs <*> vs = zipWith apply fs vs++||| This monad is different from the List monad, (>>=)+||| uses the diagonal.+instance Monad (Vect n) where+    m >>= f = diag (map f m)++instance Traversable (Vect n) where+    traverse f [] = pure Vect.Nil+    traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |]++--------------------------------------------------------------------------------+-- Show+--------------------------------------------------------------------------------++instance Show a => Show (Vect n a) where+    show = show . toList++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++vectConsCong : (x : a) -> (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> (x :: xs = x :: ys)+vectConsCong x xs xs Refl = Refl++vectNilRightNeutral : (xs : Vect n a) -> xs ++ [] = xs+vectNilRightNeutral [] = Refl+vectNilRightNeutral (x :: xs) =+  vectConsCong _ _ _ (vectNilRightNeutral xs)++vectAppendAssociative : (x : Vect xLen a) -> (y : Vect yLen a) -> (z : Vect zLen a) -> x ++ (y ++ z) = (x ++ y) ++ z+vectAppendAssociative [] y z = Refl+vectAppendAssociative (x :: xs) ys zs =+  vectConsCong _ _ _ (vectAppendAssociative xs ys zs)++--------------------------------------------------------------------------------+-- DecEq+--------------------------------------------------------------------------------++vectInjective1 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> x = y+vectInjective1 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl++vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys+vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl++instance DecEq a => DecEq (Vect n a) where+  decEq [] [] = Yes Refl+  decEq (x :: xs) (y :: ys) with (decEq x y)+    decEq (x :: xs) (x :: ys)   | Yes Refl with (decEq xs ys)+      decEq (x :: xs) (x :: xs) | Yes Refl | Yes Refl = Yes Refl+      decEq (x :: xs) (x :: ys) | Yes Refl | No  neq  = No (neq . vectInjective2)+    decEq (x :: xs) (y :: ys)   | No  neq             = No (neq . vectInjective1)++{- The following definition is elaborated in a wrong case-tree. Examination pending.+instance DecEq a => DecEq (Vect n a) where+  decEq [] [] = Yes Refl+  decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)+    decEq (x :: xs) (x :: xs) | (Yes Refl, Yes Refl) = Yes Refl+    decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p))+    decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p))+-}++-------------------------------------------------------------------------------- -- Elem -------------------------------------------------------------------------------- @@ -32,12 +592,6 @@   isElem x (y :: xs) | (No xneqy) with (isElem x xs)     isElem x (y :: xs) | (No xneqy) | (Yes xinxs) = Yes (There xinxs)     isElem x (y :: xs) | (No xneqy) | (No xninxs) = No (neitherHereNorThere xneqy xninxs)--||| A tactic for discovering where, if anywhere, an element is in a vector-||| @ n how many elements to search before giving up-findElem : (n : Nat) -> List (TTName, Binder TT) -> TT -> Tactic-findElem Z ctxt goal = Refine "Here" `Seq` Solve-findElem (S n) ctxt goal = GoalType "Elem" (Try (Refine "Here" `Seq` Solve) (Refine "There" `Seq` (Solve `Seq` findElem n ctxt goal)))  replaceElem : (xs : Vect k t) -> Elem x xs -> (y : t) -> (ys : Vect k t ** Elem y ys) replaceElem (x::xs) Here y = (y :: xs ** Here)
− libs/base/Data/VectType.idr 
@@ -1,601 +0,0 @@-module Data.VectType--import public Data.Fin--%access public-%default total--namespace Vect {--infixr 7 ::--||| Vectors: Generic lists with explicit length in the type-%elim -data Vect : Nat -> Type -> Type where-  ||| Empty vector -  Nil  : Vect Z a-  ||| A non-empty vector of length `S k`, consisting of a head element and -  ||| the rest of the list, of length `k`.-  (::) : (x : a) -> (xs : Vect k a) -> Vect (S k) a---- Hints for interactive editing-%name Vect xs,ys,zs,ws------------------------------------------------------------------------------------- Length-----------------------------------------------------------------------------------||| Calculate the length of a `Vect`.-|||-||| **Note**: this is only useful if you don't already statically know the length-||| and you want to avoid matching the implicit argument for erasure reasons.-||| @ n the length (provably equal to the return value)-||| @ xs the vector-length : (xs : Vect n a) -> Nat-length [] = 0-length (x::xs) = 1 + length xs--||| Show that the length function on vectors in fact calculates the length-private lengthCorrect : (n : Nat) -> (xs : Vect n a) -> length xs = n-lengthCorrect Z     []        = Refl-lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in Refl------------------------------------------------------------------------------------- Indexing into vectors-----------------------------------------------------------------------------------||| All but the first element of the vector-tail : Vect (S n) a -> Vect n a-tail (x::xs) = xs--||| Only the first element of the vector-head : Vect (S n) a -> a-head (x::xs) = x--||| The last element of the vector-last : Vect (S n) a -> a-last (x::[])    = x-last (x::y::ys) = last $ y::ys--||| All but the last element of the vector-init : Vect (S n) a -> Vect n a-init (x::[])    = []-init (x::y::ys) = x :: init (y::ys)--||| Extract a particular element from a vector-index : Fin n -> Vect n a -> a-index FZ     (x::xs) = x-index (FS k) (x::xs) = index k xs---||| Insert an element at a particular index-insertAt : Fin (S n) -> a -> Vect n a -> Vect (S n) a-insertAt FZ     y xs      = y :: xs-insertAt (FS k) y (x::xs) = x :: insertAt k y xs-insertAt (FS k) y []      = absurd k--||| Construct a new vector consisting of all but the indicated element-deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a-deleteAt           FZ     (x::xs) = xs-deleteAt {n = S m} (FS k) (x::xs) = x :: deleteAt k xs-deleteAt {n = Z}   (FS k) (x::xs) = absurd k-deleteAt           _      []      impossible--||| Replace an element at a particlar index with another-replaceAt : Fin n -> t -> Vect n t -> Vect n t-replaceAt FZ     y (x::xs) = y :: xs-replaceAt (FS k) y (x::xs) = x :: replaceAt k y xs--||| Replace the element at a particular index with the result of applying a function to it-||| @ i the index to replace at-||| @ f the update function-||| @ xs the vector to replace in-updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t-updateAt FZ     f (x::xs) = f x :: xs-updateAt (FS k) f (x::xs) = x :: updateAt k f xs------------------------------------------------------------------------------------- Subvectors-----------------------------------------------------------------------------------||| Get the first n elements of a Vect-||| @ n the number of elements to take-take : (n : Nat) -> Vect (n + m) a -> Vect n a-take Z     xs        = []-take (S k) (x :: xs) = x :: take k xs--||| Remove the first n elements of a Vect-||| @ n the number of elements to remove-drop : (n : Nat) -> Vect (n + m) a -> Vect m a-drop Z     xs        = xs-drop (S k) (x :: xs) = drop k xs--||| Take the longest prefix of a Vect such that all elements satisfy some-||| Boolean predicate.-|||-||| @ p the predicate-takeWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a)-takeWhile p []      = (_ ** [])-takeWhile p (x::xs) =-  let (len ** ys) = takeWhile p xs-  in if p x then-      (S len ** x :: ys)-    else-      (_ ** [])--||| Remove the longest prefix of a Vect such that all removed elements satisfy some-||| Boolean predicate.-|||-||| @ p the predicate-dropWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a)-dropWhile p [] = (_ ** [])-dropWhile p (x::xs) =-  if p x then-    dropWhile p xs-  else-    (_ ** x::xs)------------------------------------------------------------------------------------- Transformations-----------------------------------------------------------------------------------||| Reverse the order of the elements of a vector-reverse : Vect n a -> Vect n a-reverse xs = go [] xs-  where go : Vect n a -> Vect m a -> Vect (n+m) a-        go {n}         acc []        = rewrite plusZeroRightNeutral n in acc-        go {n} {m=S m} acc (x :: xs) = rewrite sym $ plusSuccRightSucc n m-                                       in go (x::acc) xs--||| Alternate an element between the other elements of a vector-||| @ sep the element to intersperse-||| @ xs the vector to separate with `sep`-intersperse : (sep : a) -> (xs : Vect n a) -> Vect (n + pred n) a-intersperse sep []      = []-intersperse sep (x::xs) = x :: intersperse' sep xs-  where-    intersperse' : a -> Vect n a -> Vect (n + n) a-    intersperse'         sep []      = []-    intersperse' {n=S n} sep (x::xs) = rewrite sym $ plusSuccRightSucc n n-                                       in sep :: x :: intersperse' sep xs------------------------------------------------------------------------------------- Conversion from list (toList is provided by Foldable)------------------------------------------------------------------------------------fromList' : Vect n a -> (l : List a) -> Vect (length l + n) a-fromList' ys [] = ys-fromList' {n} ys (x::xs) =-  rewrite (plusSuccRightSucc (length xs) n) ==>-          Vect (plus (length xs) (S n)) a in-  fromList' (x::ys) xs--||| Convert a list to a vector.-|||-||| The length of the list should be statically known.-fromList : (l : List a) -> Vect (length l) a-fromList l =-  rewrite (sym $ plusZeroRightNeutral (length l)) in-  reverse $ fromList' [] l------------------------------------------------------------------------------------- Building (bigger) vectors-----------------------------------------------------------------------------------||| Append two vectors-(++) : Vect m a -> Vect n a -> Vect (m + n) a-(++) []      ys = ys-(++) (x::xs) ys = x :: xs ++ ys--||| Repeate some value n times-||| @ n the number of times to repeat it-||| @ x the value to repeat-replicate : (n : Nat) -> (x : a) -> Vect n a-replicate Z     x = []-replicate (S k) x = x :: replicate k x------------------------------------------------------------------------------------- Zips and unzips-----------------------------------------------------------------------------------||| Combine two equal-length vectors pairwise with some function-zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c-zipWith f []      []      = []-zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys--||| Combine three equal-length vectors into a vector with some function-zipWith3 : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d-zipWith3 f []      []      []      = []-zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs--||| Combine two equal-length vectors pairwise-zip : Vect n a -> Vect n b -> Vect n (a, b)-zip = zipWith (\x,y => (x,y))--||| Combine three equal-length vectors elementwise into a vector of tuples-zip3 : Vect n a -> Vect n b -> Vect n c -> Vect n (a, b, c)-zip3 = zipWith3 (\x,y,z => (x,y,z))--||| Convert a vector of pairs to a pair of vectors-unzip : Vect n (a, b) -> (Vect n a, Vect n b)-unzip []           = ([], [])-unzip ((l, r)::xs) with (unzip xs)-  | (lefts, rights) = (l::lefts, r::rights)--||| Convert a vector of three-tuples to a triplet of vectors-unzip3 : Vect n (a, b, c) -> (Vect n a, Vect n b, Vect n c)-unzip3 []            = ([], [], [])-unzip3 ((l,c,r)::xs) with (unzip3 xs)-  | (lefts, centers, rights) = (l::lefts, c::centers, r::rights)------------------------------------------------------------------------------------- Equality-----------------------------------------------------------------------------------instance (Eq a) => Eq (Vect n a) where-  (==) []      []      = True-  (==) (x::xs) (y::ys) =-    if x == y then-      xs == ys-    else-      False-------------------------------------------------------------------------------------- Order-----------------------------------------------------------------------------------instance Ord a => Ord (Vect n a) where-  compare []      []      = EQ-  compare (x::xs) (y::ys) =-    if x /= y then-      compare x y-    else-      compare xs ys-------------------------------------------------------------------------------------- Maps-----------------------------------------------------------------------------------instance Functor (Vect n) where-  map f []        = []-  map f (x::xs) = f x :: map f xs---||| Map a partial function across a vector, returning those elements for which-||| the function had a value.-|||-||| The first projection of the resulting pair (ie the length) will always be-||| at most the length of the input vector. This is not, however, guaranteed-||| by the type.-|||-||| @ f the partial function (expressed by returning `Maybe`)-||| @ xs the vector to check for results-mapMaybe : (f : a -> Maybe b) -> (xs : Vect n a) -> (m : Nat ** Vect m b)-mapMaybe f []      = (_ ** [])-mapMaybe f (x::xs) =-  let (len ** ys) = mapMaybe f xs-  in case f x of-       Just y  => (S len ** y :: ys)-       Nothing => (  len **      ys)-------------------------------------------------------------------------------------- Folds-----------------------------------------------------------------------------------total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> Vect n t -> acc-foldrImpl f e go [] = go e-foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs--instance Foldable (Vect n) where-  foldr f e xs = foldrImpl f e id xs------------------------------------------------------------------------------------- Special folds-----------------------------------------------------------------------------------||| Flatten a vector of equal-length vectors-concat : Vect m (Vect n a) -> Vect (m * n) a-concat []      = []-concat (v::vs) = v ++ concat vs--||| Foldr without seeding the accumulator-foldr1 : (t -> t -> t) -> Vect (S n) t -> t-foldr1 f (x::xs) = foldr f x xs--||| Foldl without seeding the accumulator-foldl1 : (t -> t -> t) -> Vect (S n) t -> t-foldl1 f (x::xs) = foldl f x xs------------------------------------------------------------------------------------ Scans-----------------------------------------------------------------------------------scanl : (b -> a -> b) -> b -> Vect n a -> Vect (S n) b-scanl f q []      = [q]-scanl f q (x::xs) = q :: scanl f (f q x) xs------------------------------------------------------------------------------------- Membership tests-----------------------------------------------------------------------------------||| Search for an item using a user-provided test-||| @ p the equality test-||| @ e the item to search for-||| @ xs the vector to search in-elemBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n a) -> Bool-elemBy p e []      = False-elemBy p e (x::xs) with (p e x)-  | True  = True-  | False = elemBy p e xs--||| Use the default Boolean equality on elements to search for an item-||| @ x what to search for-||| @ xs where to search-elem : Eq a => (x : a) -> (xs : Vect n a) -> Bool-elem = elemBy (==)--||| Find the association of some key with a user-provided comparison-||| @ p the comparison operator for keys (True if they match)-||| @ e the key to look for-lookupBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n (a, b)) -> Maybe b-lookupBy p e []           = Nothing-lookupBy p e ((l, r)::xs) with (p e l)-  | True  = Just r-  | False = lookupBy p e xs--||| Find the assocation of some key using the default Boolean equality test-lookup : Eq a => a -> Vect n (a, b) -> Maybe b-lookup = lookupBy (==)--||| Check if any element of xs is found in elems by a user-provided comparison-||| @ p the comparison operator-||| @ elems the vector to search-||| @ xs what to search for-hasAnyBy : (p : a -> a -> Bool) -> (elems : Vect m a) -> (xs : Vect n a) -> Bool-hasAnyBy p elems []      = False-hasAnyBy p elems (x::xs) with (elemBy p x elems)-  | True  = True-  | False = hasAnyBy p elems xs--||| Check if any element of xs is found in elems using the default Boolean equality test-hasAny : Eq a => Vect m a -> Vect n a -> Bool-hasAny = hasAnyBy (==)------------------------------------------------------------------------------------- Searching with a predicate-----------------------------------------------------------------------------------||| Find the first element of the vector that satisfies some test-||| @ p the test to satisfy-find : (p : a -> Bool) -> (xs : Vect n a) -> Maybe a-find p []      = Nothing-find p (x::xs) with (p x)-  | True  = Just x-  | False = find p xs--||| Find the index of the first element of the vector that satisfies some test-findIndex : (a -> Bool) -> Vect n a -> Maybe (Fin n)-findIndex p []        = Nothing-findIndex p (x :: xs) with (p x)-  | True  = Just 0-  | False = map FS (findIndex p xs)--||| Find the indices of all elements that satisfy some test-total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)-findIndices = findIndices' 0-  where-    total findIndices' : Nat -> (a -> Bool) -> Vect m a -> (p ** Vect p Nat)-    findIndices' cnt p []      = (_ ** [])-    findIndices' cnt p (x::xs) with (findIndices' (S cnt) p xs)-      | (_ ** tail) =-       if p x then-        (_ ** cnt::tail)-       else-        (_ ** tail)--elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe (Fin m)-elemIndexBy p e = findIndex $ p e--elemIndex : Eq a => a -> Vect m a -> Maybe (Fin m)-elemIndex = elemIndexBy (==)--total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat)-elemIndicesBy p e = findIndices $ p e--total elemIndices : Eq a => a -> Vect m a -> (p ** Vect p Nat)-elemIndices = elemIndicesBy (==)------------------------------------------------------------------------------------- Filters-----------------------------------------------------------------------------------||| Find all elements of a vector that satisfy some test-total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)-filter p [] = ( _ ** [] )-filter p (x::xs) with (filter p xs)-  | (_ ** tail) =-    if p x then-      (_ ** x::tail)-    else-      (_ ** tail)--||| Make the elements of some vector unique by some test-nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)-nubBy = nubBy' []-  where-    nubBy' : Vect m a -> (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)-    nubBy' acc p []      = (_ ** [])-    nubBy' acc p (x::xs) with (elemBy p x acc)-      | True  = nubBy' acc p xs-      | False with (nubBy' (x::acc) p xs)-        | (_ ** tail) = (_ ** x::tail)--||| Make the elements of some vector unique by the default Boolean equality-nub : Eq a => Vect n a -> (p ** Vect p a)-nub = nubBy (==)--deleteBy : (a -> a -> Bool) -> a -> Vect n a -> (p ** Vect p a)-deleteBy _  _ []      = (_ ** [])-deleteBy eq x (y::ys) =-  let (len ** zs) = deleteBy eq x ys-  in if x `eq` y then (_ ** ys) else (S len ** y ::zs)--delete : (Eq a) => a -> Vect n a -> (p ** Vect p a)-delete = deleteBy (==)------------------------------------------------------------------------------------- Splitting and breaking lists-----------------------------------------------------------------------------------||| A tuple where the first element is a Vect of the n first elements and-||| the second element is a Vect of the remaining elements of the original Vect-||| It is equivalent to (take n xs, drop n xs)-||| @ n   the index to split at-||| @ xs  the Vect to split in two-splitAt : (n : Nat) -> (xs : Vect (n + m) a) -> (Vect n a, Vect m a)-splitAt n xs = (take n xs, drop n xs)--partition : (a -> Bool) -> Vect n a -> ((p ** Vect p a), (q ** Vect q a))-partition p []      = ((_ ** []), (_ ** []))-partition p (x::xs) =-  let ((leftLen ** lefts), (rightLen ** rights)) = partition p xs in-    if p x then-      ((S leftLen ** x::lefts), (rightLen ** rights))-    else-      ((leftLen ** lefts), (S rightLen ** x::rights))------------------------------------------------------------------------------------- Predicates-----------------------------------------------------------------------------------isPrefixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool-isPrefixOfBy p [] right        = True-isPrefixOfBy p left []         = False-isPrefixOfBy p (x::xs) (y::ys) with (p x y)-  | True  = isPrefixOfBy p xs ys-  | False = False--isPrefixOf : Eq a => Vect m a -> Vect n a -> Bool-isPrefixOf = isPrefixOfBy (==)--isSuffixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool-isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right)--isSuffixOf : Eq a => Vect m a -> Vect n a -> Bool-isSuffixOf = isSuffixOfBy (==)------------------------------------------------------------------------------------- Conversions-----------------------------------------------------------------------------------total maybeToVect : Maybe a -> (p ** Vect p a)-maybeToVect Nothing  = (_ ** [])-maybeToVect (Just j) = (_ ** [j])--total vectToMaybe : Vect n a -> Maybe a-vectToMaybe []      = Nothing-vectToMaybe (x::xs) = Just x------------------------------------------------------------------------------------- Misc-----------------------------------------------------------------------------------catMaybes : Vect n (Maybe a) -> (p ** Vect p a)-catMaybes []             = (_ ** [])-catMaybes (Nothing::xs)  = catMaybes xs-catMaybes ((Just j)::xs) with (catMaybes xs)-  | (_ ** tail) = (_ ** j::tail)--diag : Vect n (Vect n a) -> Vect n a-diag []             = []-diag ((x::xs)::xss) = x :: diag (map tail xss)--range : Vect n (Fin n)-range {n=Z}   = []-range {n=S _} = FZ :: map FS range--||| Transpose a Vect of Vects, turning rows into columns and vice versa.-|||-||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`.-transpose : Vect m (Vect n a) -> Vect n (Vect m a)-transpose []        = replicate _ []-transpose (x :: xs) = zipWith (::) x (transpose xs)------------------------------------------------------------------------------------- Applicative/Monad/Traversable-----------------------------------------------------------------------------------instance Applicative (Vect k) where-    pure = replicate _--    fs <*> vs = zipWith apply fs vs--||| This monad is different from the List monad, (>>=)-||| uses the diagonal.-instance Monad (Vect n) where-    m >>= f = diag (map f m)--instance Traversable (Vect n) where-    traverse f [] = pure Vect.Nil-    traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |]------------------------------------------------------------------------------------- Show-----------------------------------------------------------------------------------instance Show a => Show (Vect n a) where-    show = show . toList------------------------------------------------------------------------------------- Properties-----------------------------------------------------------------------------------vectConsCong : (x : a) -> (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> (x :: xs = x :: ys)-vectConsCong x xs xs Refl = Refl--vectNilRightNeutral : (xs : Vect n a) -> xs ++ [] = xs-vectNilRightNeutral [] = Refl-vectNilRightNeutral (x :: xs) =-  vectConsCong _ _ _ (vectNilRightNeutral xs)--vectAppendAssociative : (x : Vect xLen a) -> (y : Vect yLen a) -> (z : Vect zLen a) -> x ++ (y ++ z) = (x ++ y) ++ z-vectAppendAssociative [] y z = Refl-vectAppendAssociative (x :: xs) ys zs =-  vectConsCong _ _ _ (vectAppendAssociative xs ys zs)--}------------------------------------------------------------------------------------- DecEq-----------------------------------------------------------------------------------total-vectInjective1 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> x = y-vectInjective1 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl--total-vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys-vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl--instance DecEq a => DecEq (Vect n a) where-  decEq [] [] = Yes Refl-  decEq (x :: xs) (y :: ys) with (decEq x y)-    decEq (x :: xs) (x :: ys)   | Yes Refl with (decEq xs ys)-      decEq (x :: xs) (x :: xs) | Yes Refl | Yes Refl = Yes Refl-      decEq (x :: xs) (x :: ys) | Yes Refl | No  neq  = No (neq . vectInjective2)-    decEq (x :: xs) (y :: ys)   | No  neq             = No (neq . vectInjective1)--{- The following definition is elaborated in a wrong case-tree. Examination pending.-instance DecEq a => DecEq (Vect n a) where-  decEq [] [] = Yes Refl-  decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)-    decEq (x :: xs) (x :: xs) | (Yes Refl, Yes Refl) = Yes Refl-    decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p))-    decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p))--}---- For the primitives, we have to cheat because we don't have access to their--- internal implementations.
libs/base/base.ipkg view
@@ -13,9 +13,9 @@            Data.Morphisms,           Data.Bits, Data.Mod2,-          Data.Fin, Data.Vect, Data.VectType,+          Data.Fin, Data.Vect,           Data.HVect, Data.Vect.Quantifiers,-          Data.Floats, Data.Complex,+          Data.Complex,           Data.Erased, Data.List,           Data.So,
libs/contrib/Classes/Verified.idr view
@@ -17,12 +17,10 @@                        (g1 : a -> b) -> (g2 : b -> c) ->                        map (g2 . g1) x = (map g2 . map g1) x -- class (Applicative f, VerifiedFunctor f) => VerifiedApplicative (f : Type -> Type) where   applicativeMap : (x : f a) -> (g : a -> b) ->                    map g x = pure g <*> x-  applicativeIdentity : (x : f a) -> pure id <*> x = x+  applicativeIdentity : (x : f a) -> pure Basics.id <*> x = x   applicativeComposition : (x : f a) -> (g1 : f (a -> b)) -> (g2 : f (b -> c)) ->                            ((pure (.) <*> g2) <*> g1) <*> x = g2 <*> (g1 <*> x)   applicativeHomomorphism : (x : a) -> (g : a -> b) ->@@ -30,14 +28,13 @@   applicativeInterchange : (x : a) -> (g : f (a -> b)) ->                            g <*> pure x = pure (\g' : a -> b => g' x) <*> g - class (Monad m, VerifiedApplicative m) => VerifiedMonad (m : Type -> Type) where   monadApplicative : (mf : m (a -> b)) -> (mx : m a) ->                      mf <*> mx = mf >>= \f =>                                  mx >>= \x =>                                         pure (f x)   monadLeftIdentity : (x : a) -> (f : a -> m b) -> return x >>= f = f x-  monadRightIdentity : (mx : m a) -> mx >>= return = mx+  monadRightIdentity : (mx : m a) -> mx >>= Monad.return = mx   monadAssociativity : (mx : m a) -> (f : a -> m b) -> (g : b -> m c) ->                        (mx >>= f) >>= g = mx >>= (\x => f x >>= g) @@ -53,8 +50,8 @@   class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where-  total monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l-  total monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r+  total monoidNeutralIsNeutralL : (l : a) -> l <+> Algebra.neutral = l+  total monoidNeutralIsNeutralR : (r : a) -> Algebra.neutral <+> r = r  -- instance VerifiedMonoid Nat where --   monoidNeutralIsNeutralL = plusZeroRightNeutral@@ -65,8 +62,8 @@   monoidNeutralIsNeutralR xs = Refl  class (VerifiedMonoid a, Group a) => VerifiedGroup a where-  total groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral-  total groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral+  total groupInverseIsInverseL : (l : a) -> l <+> inverse l = Algebra.neutral+  total groupInverseIsInverseR : (r : a) -> inverse r <+> r = Algebra.neutral  class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where   total abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l@@ -77,12 +74,12 @@   total ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <.> r = (l <.> r) <+> (c <.> r)  class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where-  total ringWithUnityIsUnityL : (l : a) -> l <.> unity = l-  total ringWithUnityIsUnityR : (r : a) -> unity <.> r = r+  total ringWithUnityIsUnityL : (l : a) -> l <.> Algebra.unity = l+  total ringWithUnityIsUnityR : (r : a) -> Algebra.unity <.> r = r  --class (VerifiedRingWithUnity a, Field a) => VerifiedField a where---  total fieldInverseIsInverseL : (l : a) -> (notId : Not (l = neutral)) -> l <.> (inverseM l notId) = unity---  total fieldInverseIsInverseR : (r : a) -> (notId : Not (r = neutral)) -> (inverseM r notId) <.> r = unity+--  total fieldInverseIsInverseL : (l : a) -> (notId : Not (l = neutral)) -> l <.> (inverseM l notId) = Algebra.unity+--  total fieldInverseIsInverseR : (r : a) -> (notId : Not (r = neutral)) -> (inverseM r notId) <.> r = Algebra.unity   class JoinSemilattice a => VerifiedJoinSemilattice a where@@ -96,10 +93,10 @@   total meetSemilatticeMeetIsIdempotent  : (e : a)       -> meet e e = e  class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where-  total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = e+  total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e Algebra.bottom = e  class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where-  total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = e+  total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e Algebra.top = e  class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where   total latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l@@ -110,7 +107,7 @@  --class (VerifiedRingWithUnity a, VerifiedAbelianGroup b, Module a b) => VerifiedModule a b where --  total moduleScalarMultiplyComposition : (x,y : a) -> (v : b) -> x <#> (y <#> v) = (x <.> y) <#> v---  total moduleScalarUnityIsUnity : (v : b) -> unity {a} <#> v = v+--  total moduleScalarUnityIsUnity : (v : b) -> Algebra.unity {a} <#> v = v --  total moduleScalarMultDistributiveWRTVectorAddition : (s : a) -> (v, w : b) -> s <#> (v <+> w) = (s <#> v) <+> (s <#> w) --  total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v)
libs/contrib/Control/Algebra.idr view
@@ -113,7 +113,7 @@ |||     forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c) |||     forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c) class RingWithUnity a => Field a where-  inverseM : (x : a) -> Not (x = neutral) -> a+  inverseM : (x : a) -> Not (x = Algebra.neutral) -> a  sum' : (Foldable t, Monoid a) => t a -> a sum' = concat
libs/contrib/Data/Matrix/Numeric.idr view
@@ -24,11 +24,14 @@  instance Num a => Num (Vect n a) where   (+) = zipWith (+)-  (-) = zipWith (+)   (*) = zipWith (*)-  abs = id   fromInteger n = replicate _ (fromInteger n) +instance Neg a => Neg (Vect n a) where+  (-) = zipWith (-)+  abs = map abs+  negate = map negate+ ----------------------------------------------------------------------- --                        Vector functions -----------------------------------------------------------------------@@ -88,7 +91,7 @@ (><) x y = col x <> row y  ||| Matrix commutator-(<<>>) : Num a => Matrix n n a -> Matrix n n a -> Matrix n n a+(<<>>) : Neg a => Matrix n n a -> Matrix n n a -> Matrix n n a (<<>>) m1 m2 = (m1 <> m2) - (m2 <> m1)  ||| Matrix anti-commutator@@ -112,17 +115,17 @@ -----------------------------------------------------------------------  ||| Alternating sum-altSum : Num a => Vect n a -> a+altSum : Neg a => Vect n a -> a altSum (x::y::zs) = (x - y) + altSum zs altSum [x]        = x altSum []         = 0  ||| Determinant of a 2-by-2 matrix-det2 : Num a => Matrix 2 2 a -> a+det2 : Neg a => Matrix 2 2 a -> a det2 [[x1,x2],[y1,y2]] = x1*y2 - x2*y1  ||| Determinant of a square matrix-det : Num a => Matrix (S (S n)) (S (S n)) a -> a+det : Neg a => Matrix (S (S n)) (S (S n)) a -> a det {n} m = case n of   Z     => det2 m   (S k) => altSum . map (\c => indices FZ c m * det (subMatrix FZ c m))
libs/contrib/Data/Nat/DivMod/IteratedSubtraction.idr view
@@ -47,7 +47,7 @@ ltToLTE (LTStep lt) = lteSuccRight $ ltToLTE lt  ||| Subtraction gives a result that is actually smaller.-minusLT' : (x,y : Nat) -> x - y `LT'` S x+minusLT' : (x,y : Nat) -> minus x y `LT'` S x minusLT' Z     y = LTSucc minusLT' (S k) Z = LTSucc minusLT' (S k) (S j) = LTStep (minusLT' k j)
libs/contrib/Data/ZZ.idr view
@@ -28,11 +28,6 @@   show (Pos n) = show n   show (NegS n) = "-" ++ show (S n) -instance Neg ZZ where-  negate (Pos Z)     = Pos Z-  negate (Pos (S n)) = NegS n-  negate (NegS n)    = Pos (S n)- negNat : Nat -> ZZ negNat Z = Pos Z negNat (S n) = NegS n@@ -51,10 +46,6 @@ plusZ (Pos n) (NegS m) = minusNatZ n (S m) plusZ (NegS n) (Pos m) = minusNatZ m (S n) -||| Subtract two `ZZ`s. Consider using `(-) {a=ZZ}`.-subZ : ZZ -> ZZ -> ZZ-subZ n m = plusZ n (negate m)- instance Eq ZZ where   (Pos n) == (Pos m) = n == m   (NegS n) == (NegS m) = n == m@@ -85,10 +76,22 @@  instance Num ZZ where   (+) = plusZ-  (-) = subZ   (*) = multZ-  abs = cast . absZ   fromInteger = fromInt++mutual+  instance Neg ZZ where+    negate (Pos Z)     = Pos Z+    negate (Pos (S n)) = NegS n+    negate (NegS n)    = Pos (S n)+  +    (-) = subZ+    abs = cast . absZ++  ||| Subtract two `ZZ`s. Consider using `(-) {a=ZZ}`.+  subZ : ZZ -> ZZ -> ZZ+  subZ n m = plusZ n (negate m)+  instance Cast ZZ Integer where   cast (Pos n) = cast n
+ libs/effects/Effect/Logging/Category.idr view
@@ -0,0 +1,184 @@+-- ------------------------------------------------------------ [ Category.idr ]+-- Module    : Category.idr+-- Copyright : (c) The Idris Community+-- License   : see LICENSE+-- --------------------------------------------------------------------- [ EOH ]+||| A logging effect that allows messages to be logged using both+||| numerical levels and user specified categories. The higher the+||| logging level the grater in verbosity the logging.+|||+||| In this effect the resource we are computing over is the logging+||| level itself and the list of categories to show.+module Effect.Logging.Category++import Effects+import public Effect.Logging.Level++%access public++-- -------------------------------------------------------- [ Logging Resource ]++||| The Logging details, this is the resource that the effect is+||| defined over.+record LogRes (a : Type) where+  constructor MkLogRes+  getLevel      : LogLevel n+  getCategories : List a++instance (Show a) => Show (LogRes a) where+  show (MkLogRes l cs) = unwords ["Log Settings:", show l, show cs]++instance Default (LogRes a) where+  default = MkLogRes OFF Nil++-- ------------------------------------------------------- [ Effect Definition ]++||| A Logging effect to log levels and categories.+data Logging : Effect where+    ||| Log a message.+    |||+    ||| @lvl  The logging level it should appear at.+    ||| @cats The categories it should appear under.+    ||| @msg  The message to log.+    Log : (Show a, Eq a) =>+          (lvl : LogLevel n)+       -> (cats : List a)+       -> (msg : String)+       -> sig Logging () (LogRes a)++    ||| Change the logging level.+    |||+    ||| @nlvl The new logging level+    SetLogLvl : (Show a, Eq a) =>+                (nlvl : LogLevel n) ->+                sig Logging () (LogRes a) (LogRes a)++    ||| Change the categories to show.+    |||+    ||| @ncats The new categories.+    SetLogCats : (Show a, Eq a) =>+                 (ncats : List a) ->+                 sig Logging () (LogRes a) (LogRes a)++    ||| Initialise the logging.+    |||+    ||| @nlvl  The new logging level.+    ||| @ncats The categories to show.+    InitLogger : (Show a, Eq a) =>+                 (nlvl  : LogLevel n) ->+                 (ncats : List a) ->+                 sig Logging () (LogRes a) (LogRes a)++-- -------------------------------------------------------------- [ IO Handler ]++instance Handler Logging IO where+    handle st (SetLogLvl  nlvl)  k = do+        let newSt = record {getLevel = nlvl}  st+        k () newSt+    handle st (SetLogCats newcs) k = do+        let newSt = record {getCategories = newcs} st+        k () newSt++    handle st  (InitLogger l cs) k = do+        let newSt = MkLogRes l cs+        k () newSt++    handle st (Log l cs' msg) k = do+      case cmpLevel l (getLevel st) of+        GT        => k () st+        otherwise =>  do+          let res = and $ map (\x => elem x cs') (getCategories st)+          let prompt = if isNil (getCategories st)+                         then unwords [show l, ":"]+                         else unwords [show l, ":", show (getCategories st), ":"]+          if res || isNil (getCategories st)+            then do+              putStrLn $ unwords [prompt, msg]+              k () st+            else k () st+++-- ------------------------------------------------------- [ Effect Descriptor ]++||| The Logging effect.+|||+||| @a The type used to differentiate categories.+LOG : (a : Type) -> EFFECT+LOG a = MkEff (LogRes a) Logging++-- ----------------------------------------------------------- [ Effectful API ]++||| Change the logging level.+|||+||| @l  The new logging level.+setLoglvl : (Show a, Eq a) => (l : LogLevel n) -> Eff () [LOG a]+setLoglvl l = call $ SetLogLvl l++||| Change the categories to show.+|||+||| @cs The new categories.+setLogCats : (Show a, Eq a) => (cs : List a) -> Eff () [LOG a]+setLogCats cs = call $ SetLogCats cs++||| Initialise the Logger.+|||+||| @l  The logging level.+||| @cs The categories to show.+initLogger : (Show a, Eq a) => (l : LogLevel n)+                            -> (cs : List a)+                            -> Eff () [LOG a]+initLogger l cs = call $ InitLogger l cs++||| Log the given message at the given level indicated by a natural number and assign it the list of categories.+|||+||| @l The logging level.+||| @cs The logging categories.+||| @m THe message to be logged.+log : (Show a, Eq a) => (l : LogLevel n)+                     -> (cs : List a)+                     -> (m : String)+                     -> Eff () [LOG a]+log l cs msg = call $ Log l cs msg++||| Log the given message at the given level indicated by a natural number and assign it the list of categories.+|||+||| @l The logging level.+||| @cs The logging categories.+||| @m THe message to be logged.+logN : (Show a, Eq a) => (l : Nat)+                      -> {auto prf : LTE l 70}+                      -> (cs : List a)+                      -> (m : String)+                      -> Eff () [LOG a]+logN l cs msg = call $ Log (getProof lvl) cs msg+  where+    lvl : (n ** LogLevel n)+    lvl = case cast {to=String} (cast {to=Int} l) of+            "0"  => (_ ** OFF)+            "10" => (_ ** TRACE)+            "20" => (_ ** DEBUG)+            "30" => (_ ** INFO)+            "40" => (_ ** WARN)+            "50" => (_ ** FATAL)+            "60" => (_ ** ERROR)+            _    => (_ ** CUSTOM l)++trace : (Show a, Eq a) => List a -> String -> Eff () [LOG a]+trace cs msg = call $ Log TRACE cs msg++debug : (Show a, Eq a) => List a -> String -> Eff () [LOG a]+debug cs msg = call $ Log DEBUG cs msg++info : (Show a, Eq a) => List a -> String -> Eff () [LOG a]+info cs msg = call $ Log INFO cs msg++warn : (Show a, Eq a) => List a -> String -> Eff () [LOG a]+warn cs msg = call $ Log WARN cs msg++fatal : (Show a, Eq a) => List a -> String -> Eff () [LOG a]+fatal cs msg = call $ Log FATAL cs msg++error : (Show a, Eq a) => List a -> String -> Eff () [LOG a]+error cs msg = call $ Log ERROR cs msg++-- --------------------------------------------------------------------- [ EOF ]
libs/effects/Effect/Logging/Default.idr view
@@ -2,56 +2,117 @@ -- Module    : Default.idr -- Copyright : (c) The Idris Community -- License   : see LICENSE--- --------------------------------------------------------------------- [ EOH ]--||| A logging effect that allows messages to be logged using both-||| numerical levels and user specified categories. The higher the-||| logging level the grater in verbosity the logging.+--------------------------------------------------------------------- [ EOH ]+||| The default logging effect that allows messages to be logged at+||| different numerical levels. The higher the number the greater in+||| verbosity the logging. ||| ||| In this effect the resource we are computing over is the logging-||| level itself and the list of categories to show.+||| level itself. ||| module Effect.Logging.Default  import Effects import public Effect.Logging.Level -import Control.IOExcept -- TODO Add IOExcept Logger.+%access public -||| A Logging effect to log levels and categories.+-- ------------------------------------------------------------ [ The Resource ]++||| The resource that the log effect is defined over.+record LogRes where+  constructor MkLogRes+  getLevel : LogLevel n++instance Default LogRes where+  default = MkLogRes OFF++-- ------------------------------------------------------ [ The Logging Effect ]++||| A Logging effect that displays a logging message to be logged at a+||| certain level. data Logging : Effect where-    Log : (Eq a, Show a) =>-          (lvl : Nat)-       -> (cats : List a)+    ||| Change the logging level.+    |||+    ||| @lvl The new logging level.+    SetLvl : (lvl : LogLevel n)+          -> sig Logging () (LogRes) (LogRes)++    ||| Log a message.+    |||+    ||| @lvl  The logging level it should appear at.+    ||| @msg  The message to log.+    Log : (lvl : LogLevel n)        -> (msg : String)-       -> Logging () (Nat,List a) (\v => (Nat,List a))+       -> sig Logging () (LogRes) -||| The Logging effect.-|||-||| @cTy The type used to differentiate categories.-LOG : (cTy : Type) -> EFFECT-LOG a = MkEff (Nat, List a) Logging+-- -------------------------------------------------------------- [ IO Handler ] +-- For logging in the IO context instance Handler Logging IO where-    handle (l,cs) (Log lvl cs' msg) k = do-      case lvl <= l  of-        False => k () (l,cs)-        True  =>  do-          let res = and $ map (\x => elem x cs') cs-          let prompt = if isNil cs then "" else show cs-          if res || isNil cs-            then do-              printLn $ unwords [show lvl, ":", prompt, ":", msg]-              k () (l,cs)-            else k () (l,cs)+    handle st (SetLvl newLvl) k = k () (MkLogRes newLvl)+    handle st (Log lvl msg) k = do+      case cmpLevel lvl (getLevel st)  of+        GT        => k () st+        otherwise =>  do+          putStrLn $ unwords [show lvl, ":", msg]+          k () st -||| Log the given message at the given level and assign it the list of categories.+-- ------------------------------------------------------- [ Effect Descriptor ]++||| A Logging Effect.+LOG : EFFECT+LOG = MkEff (LogRes) Logging++-- ----------------------------------------------------------- [ Effectful API ]++||| Set the logging level. |||-||| @l The logging level.-||| @cs The logging categories.-||| @m THe message to be logged.-log : (Show a, Eq a) => (l : Nat)-    -> (cs : List a) -> (m : String) -> Eff () [LOG a]-log lvl cs msg = call $ Log lvl cs msg+||| @l The new logging level.+setLogLvl : (l : LogLevel n) -> Eff () [LOG]+setLogLvl l = call $ SetLvl l++||| Log `msg` at the given level specified as a natural number.+|||+||| @l The level to log.+||| @m The message to log.+log : (l : LogLevel n) -> (m : String) -> Eff () [LOG]+log l msg = call $ Log l msg++||| Log `msg` at the given level specified as a natural number.+|||+||| @l The level to log.+||| @m The message to log.+logN : (l : Nat) -> {auto prf : LTE l 70} -> (m : String) -> Eff () [LOG]+logN l msg = call $ Log (getProof lvl) msg+  where+    lvl : (n ** LogLevel n)+    lvl = case cast {to=String} (cast {to=Int} l) of+            "0"  => (_ ** OFF)+            "10" => (_ ** TRACE)+            "20" => (_ ** DEBUG)+            "30" => (_ ** INFO)+            "40" => (_ ** WARN)+            "50" => (_ ** FATAL)+            "60" => (_ ** ERROR)+            _    => (_ ** CUSTOM l)++trace :  String -> Eff () [LOG]+trace msg = call $ Log TRACE msg++debug :  String -> Eff () [LOG]+debug msg = call $ Log DEBUG msg++info :  String -> Eff () [LOG]+info msg = call $ Log INFO msg++warn :  String -> Eff () [LOG]+warn msg = call $ Log WARN msg++fatal :  String -> Eff () [LOG]+fatal msg = call $ Log FATAL msg++error :  String -> Eff () [LOG]+error msg = call $ Log ERROR msg  -- --------------------------------------------------------------------- [ EOF ]
libs/effects/Effect/Logging/Level.idr view
@@ -1,49 +1,81 @@--- -------------------------------------------------------------- [ Levels.idr ]--- Module    : Levels.idr--- Copyright : (c) Jan de Muijnck-Hughes+-- --------------------------------------------------------------- [ Level.idr ]+-- Module    : Level.idr+-- Copyright : (c) The Idris Community -- License   : see LICENSE -- --------------------------------------------------------------------- [ EOH ]-||| Common aliases and definitions of Logging Levels.+||| A dependently typed logging level representation where logging+||| levels are based on a Natural number range [0,70].+|||+||| The `LogLevel` type allows for semantic constructors to be used+||| for the majority of logging levels, with an option for custom+||| levels to be defined.+|||+||| The logging level design comes from the Log4j/Python family of+||| loggers. module Effect.Logging.Level  %access public--- ---------------------------------------------- [ Nat Derived Logging Levels ]------ Several aliases have been defined to aide in semantic use of the--- logging levels. These aliases have come from the Log4j family of--- loggers.+%default total -||| No events will be logged.-OFF : Nat-OFF = 0+-- ---------------------------------------------------- [ Log Level Definition ] -||| A severe error that will prevent the application from continuing.-FATAL : Nat-FATAL = 1+||| Logging levels are natural numbers wrapped in a data type for+||| convenience.+|||+||| Several aliases have been defined to aide in semantic use of the+||| logging levels. These aliases have come from the Log4j/Python+||| family of loggers.+data LogLevel : Nat -> Type where+  ||| Log No Events+  OFF : LogLevel 0 -||| An error in the application, possibly recoverable.-ERROR : Nat-ERROR = 2+  ||| A fine-grained debug message, typically capturing the flow through+  ||| the application.+  TRACE : LogLevel 10 -||| An event that might possible lead to an error.-WARN : Nat-WARN = 3+  ||| A general debugging event.+  DEBUG : LogLevel 20 -|||  An event for informational purposes.-INFO : Nat-INFO = 4+  |||  An event for informational purposes.+  INFO : LogLevel 30 -||| A general debugging event.-DEBUG : Nat-DEBUG = 5+  ||| An event that might possible lead to an error.+  WARN : LogLevel 40 -||| A fine-grained debug message, typically capturing the flow through-||| the application.-TRACE : Nat-TRACE = 6+  ||| An error in the application, possibly recoverable.+  ERROR : LogLevel 50 -||| All events should be logged.-ALL : Nat-ALL = 7+  ||| A severe error that will prevent the application from continuing.+  FATAL : LogLevel 60++  ||| All events should be logged.+  ALL : LogLevel 70++  ||| User defined logging level.+  CUSTOM : (n : Nat) -> {auto prf : LTE n 70} -> LogLevel n++instance Cast (LogLevel n) Nat where+  cast {n} _ = n++instance Show (LogLevel n) where+  show OFF        = "OFF"+  show TRACE      = "TRACE"+  show DEBUG      = "DEBUG"+  show INFO       = "INFO"+  show WARN       = "WARN"+  show FATAL      = "FATAL"+  show ERROR      = "ERROR"+  show ALL        = "ALL"+  show (CUSTOM n) = unwords ["CUSTOM", show n]++instance Eq (LogLevel n) where+  (==) x y = lvlEq x y+    where+      lvlEq : LogLevel a -> LogLevel b -> Bool+      lvlEq {a} {b} _ _ = a == b++||| Compare to logging levels.+cmpLevel : LogLevel a -> LogLevel b -> Ordering+cmpLevel {a} {b} _ _ = compare a b  -- --------------------------------------------------------------------- [ EOF ]
− libs/effects/Effect/Logging/Simple.idr 
@@ -1,48 +0,0 @@--- -------------------------------------------------------------- [ Simple.idr ]--- Module    : Logging.idr--- Copyright : (c) The Idris Community--- License   : see LICENSE---------------------------------------------------------------------- [ EOH ]--||| A simple logging effect that allows messages to be logged at-||| different numerical level. The higher the number the grater in-||| verbosity the logging.-|||-||| In this effect the resource we are computing over is the logging-||| level itself.-|||-module Effect.Logging.Simple--import Effects-import public Effect.Logging.Level--import Control.IOExcept -- TODO Add IO Logging Handler--||| A Logging effect that displays a logging message to be logged at a-||| certain level.-data Logging : Effect where-    Log : (lvl : Nat)-       -> (msg : String)-       -> Logging () Nat (\v => Nat)--||| A Logging Effect.-LOG : EFFECT-LOG = MkEff Nat Logging---- For logging in the IO context-instance Handler Logging IO where-    handle l (Log lvl msg) k = do-      case lvl <= l  of-        False   => k () l-        True  =>  do-          printLn $ unwords [show lvl, ":", msg]-          k () l--||| Log `msg` at the given level.-|||-||| @l The level to log.-||| @m The message to log.-log : (l : Nat) -> (m : String) -> Eff () [LOG]-log lvl msg = call $ Log lvl msg---- --------------------------------------------------------------------- [ EOF ]
libs/effects/Effects.idr view
@@ -25,7 +25,7 @@      MkEff : Type -> Effect -> EFFECT  -- 'sig' gives the signature for an effect. There are four versions--- depending on whether there is no resource needed, +-- depending on whether there is no resource needed, -- no state change, a non-dependent change, -- or a dependent change. These are easily disambiguated by type. @@ -42,7 +42,7 @@   sig e r e_in e_out = e r e_in (\v => e_out)  namespace DepUpdateEffect-  sig : Effect -> +  sig : Effect ->         (ret : Type) -> (res_in : Type) -> (res_out : ret -> Type) -> Type   sig e r e_in e_out = e r e_in e_out @@ -193,17 +193,17 @@   Eff : (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type   Eff x es ce = {m : Type -> Type} -> EffM m x es (\_ => ce) -  EffT : (m : Type -> Type) -> +  EffT : (m : Type -> Type) ->          (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type   EffT m x es ce = EffM m x es (\_ => ce)  namespace DepEff   -- Dependent effects, updates dependent on result-  Eff : (x : Type) -> (es : List EFFECT) +  Eff : (x : Type) -> (es : List EFFECT)         -> (ce : x -> List EFFECT) -> Type   Eff x es ce = {m : Type -> Type} -> EffM m x es ce -  EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) +  EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT)         -> (ce : x -> List EFFECT) -> Type   EffT m x es ce = EffM m x es ce @@ -269,7 +269,7 @@ eff env (liftP prf effP) k    = let env' = dropEnv env prf in          eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))-eff env (new (MkEff resTy newEff) res {prf=Refl} effP) k +eff env (new (MkEff resTy newEff) res {prf=Refl} effP) k    = eff (res :: env) effP (\p', (val :: envk) => k p' envk) -- FIXME: -- xs is needed explicitly because otherwise the pattern binding for@@ -313,7 +313,7 @@ ||| ||| @prog The effectful program to run. %no_implicit-run : Applicative m => +run : Applicative m =>       (prog : EffM m a xs xs') -> {default MkDefaultEnv env : Env m xs} ->       m a run prog {env} = eff env prog (\r, env => pure r)@@ -325,8 +325,8 @@ ||| ||| @prog The effectful program to run. %no_implicit-runPure : (prog : EffM id a xs xs') -> -          {default MkDefaultEnv env : Env id xs} -> a +runPure : (prog : EffM Basics.id a xs xs') ->+          {default MkDefaultEnv env : Env Basics.id xs} -> a runPure prog {env} = eff env prog (\r, env => r)  ||| Run an effectful program in a given context `m` with a default value for the environment.@@ -346,7 +346,7 @@ ||| @env The environment to use. ||| @prog The effectful program to run. %no_implicit-runPureInit : (env : Env id xs) -> (prog : EffM id a xs xs') -> a+runPureInit : (env : Env Basics.id xs) -> (prog : EffM Basics.id a xs xs') -> a runPureInit env prog = eff env prog (\r, env => r)  %no_implicit
libs/effects/effects.ipkg view
@@ -16,5 +16,5 @@         , Effect.System         , Effect.Trans         , Effect.Logging.Level-        , Effect.Logging.Simple         , Effect.Logging.Default+        , Effect.Logging.Category
libs/prelude/Prelude.idr view
@@ -27,6 +27,7 @@ import public Prelude.Show import public Prelude.Interactive import public Prelude.File+import public Prelude.Doubles import public Decidable.Equality import public Language.Reflection import public Language.Reflection.Errors@@ -134,10 +135,10 @@ total natEnumFromThen : Nat -> Nat -> Stream Nat natEnumFromThen n inc = n :: natEnumFromThen (inc + n) inc total natEnumFromTo : Nat -> Nat -> List Nat-natEnumFromTo n m = map (plus n) (natRange ((S m) - n))+natEnumFromTo n m = map (plus n) (natRange (minus (S m) n)) total natEnumFromThenTo : Nat -> Nat -> Nat -> List Nat natEnumFromThenTo _ Z       _ = []-natEnumFromThenTo n (S inc) m = map (plus n . (* (S inc))) (natRange (S (divNatNZ (m - n) (S inc) SIsNotZ)))+natEnumFromThenTo n (S inc) m = map (plus n . (* (S inc))) (natRange (S (divNatNZ (minus m n) (S inc) SIsNotZ)))  class Enum a where   total pred : a -> a
libs/prelude/Prelude/Cast.idr view
@@ -3,7 +3,7 @@ import Prelude.Bool import public Builtins -||| Type class for transforming a instance of a data type to another type.+||| Type class for transforming an instance of a data type to another type. class Cast from to where     ||| Perform a cast operation.     |||
libs/prelude/Prelude/Chars.idr view
@@ -7,16 +7,16 @@ import Prelude.Cast import Builtins -||| Return the ASCII representation of the character.+||| Convert the number to its ASCII equivalent. chr : Int -> Char-chr x = if (x >= 0 && x < 0x11000)+chr x = if (x >= 0 && x < 0x110000)                 then assert_total (prim__intToChar x)                 else '\0'  instance Cast Int Char where     cast = chr -||| Convert the number to its ASCII equivalent.+||| Return the ASCII representation of the character. ord : Char -> Int ord x = prim__charToInt x
libs/prelude/Prelude/Classes.idr view
@@ -71,6 +71,12 @@     GT == GT = True     _  == _  = False +||| Compose two comparisons into the lexicographic product+thenCompare : Ordering -> Lazy Ordering -> Ordering+thenCompare LT y = LT+thenCompare EQ y = y+thenCompare GT y = GT+ ||| The Ord class defines comparison operations on ordered data types. class Eq a => Ord a where     compare : a -> a -> Ordering@@ -143,85 +149,78 @@       then compare xl yl       else compare xr yr --- --------------------------------------------------------- [ Negatable Class ]-||| The `Neg` class defines unary negation (-).-class Neg a where-    ||| The underlying implementation of unary minus. `-5` desugars to `negate (fromInteger 5)`.-    negate : a -> a--instance Neg Integer where-    negate x = prim__subBigInt 0 x--instance Neg Int where-    negate x = prim__subInt 0 x--instance Neg Float where-    negate x = prim__negFloat x- -- --------------------------------------------------------- [ Numerical Class ] ||| The Num class defines basic numerical arithmetic. class Num a where     (+) : a -> a -> a-    (-) : a -> a -> a     (*) : a -> a -> a-    ||| Absolute value-    abs : a -> a     ||| Conversion from Integer.     fromInteger : Integer -> a  instance Num Integer where     (+) = prim__addBigInt-    (-) = prim__subBigInt     (*) = prim__mulBigInt -    abs x = if x < 0 then -x else x     fromInteger = id  instance Num Int where     (+) = prim__addInt-    (-) = prim__subInt     (*) = prim__mulInt      fromInteger = prim__truncBigInt_Int-    abs x = if x < (prim__truncBigInt_Int 0) then -x else x   instance Num Float where     (+) = prim__addFloat-    (-) = prim__subFloat     (*) = prim__mulFloat -    abs x = if x < (prim__toFloatBigInt 0) then -x else x     fromInteger = prim__toFloatBigInt  instance Num Bits8 where   (+) = prim__addB8-  (-) = prim__subB8   (*) = prim__mulB8-  abs = id   fromInteger = prim__truncBigInt_B8  instance Num Bits16 where   (+) = prim__addB16-  (-) = prim__subB16   (*) = prim__mulB16-  abs = id   fromInteger = prim__truncBigInt_B16  instance Num Bits32 where   (+) = prim__addB32-  (-) = prim__subB32   (*) = prim__mulB32-  abs = id   fromInteger = prim__truncBigInt_B32  instance Num Bits64 where   (+) = prim__addB64-  (-) = prim__subB64   (*) = prim__mulB64-  abs = id   fromInteger = prim__truncBigInt_B64 +-- --------------------------------------------------------- [ Negatable Class ]+||| The `Neg` class defines operations on numbers which can be negative.+class Num a => Neg a where+    ||| The underlying implementation of unary minus. `-5` desugars to `negate (fromInteger 5)`.+    negate : a -> a+    (-) : a -> a -> a+    ||| Absolute value+    abs : a -> a++instance Neg Integer where+    negate x = prim__subBigInt 0 x+    (-) = prim__subBigInt+    abs x = if x < 0 then -x else x++instance Neg Int where+    negate x = prim__subInt 0 x+    (-) = prim__subInt+    abs x = if x < (prim__truncBigInt_Int 0) then -x else x++instance Neg Float where+    negate x = prim__negFloat x+    (-) = prim__subFloat+    abs x = if x < (prim__toFloatBigInt 0) then -x else x++-- ------------------------------------------------------------ instance Eq Bits8 where   x == y = intToBool (prim__eqB8 x y)
+ libs/prelude/Prelude/Doubles.idr view
@@ -0,0 +1,63 @@+module Prelude.Doubles ++import Builtins+import Prelude.Classes++%access public+%default total++%include C "math.h"+%lib C "m"++pi : Double+pi = 3.14159265358979323846 ++euler : Double+euler = 2.7182818284590452354++exp : Double -> Double+exp x = prim__floatExp x++log : Double -> Double+log x = prim__floatLog x++sin : Double -> Double+sin x = prim__floatSin x++cos : Double -> Double+cos x = prim__floatCos x++tan : Double -> Double+tan x = prim__floatTan x++asin : Double -> Double+asin x = prim__floatASin x++acos : Double -> Double+acos x = prim__floatACos x++atan : Double -> Double+atan x = prim__floatATan x++atan2 : Double -> Double -> Double+atan2 y x = atan (y/x)++sinh : Double -> Double+sinh x = (exp x - exp (-x)) / 2++cosh : Double -> Double+cosh x = (exp x + exp (-x)) / 2++tanh : Double -> Double+tanh x = sinh x / cosh x++sqrt : Double -> Double+sqrt x = prim__floatSqrt x++floor : Double -> Double+floor x = prim__floatFloor x++ceiling : Double -> Double+ceiling x = prim__floatCeil x++
libs/prelude/Prelude/List.idr view
@@ -52,13 +52,12 @@     ||| The proof that a cons cell is non-empty     IsNonEmpty : NonEmpty (x :: xs) -private-nonEmptyNil : NonEmpty [] -> Void-nonEmptyNil IsNonEmpty impossible+instance Uninhabited (NonEmpty []) where+  uninhabited IsNonEmpty impossible  ||| Decide whether a list is non-empty nonEmpty : (xs : List a) -> Dec (NonEmpty xs)-nonEmpty [] = No nonEmptyNil+nonEmpty [] = No absurd nonEmpty (x :: xs) = Yes IsNonEmpty  ||| Satisfiable if `k` is a valid index into `xs`
libs/prelude/Prelude/Nat.idr view
@@ -180,6 +180,9 @@ 	toIntNat' Z     x = x 	toIntNat' (S n) x = toIntNat' n (x + 1) +(-) : (m : Nat) -> (n : Nat) -> {auto smaller : LTE n m} -> Nat+(-) m n {smaller} = minus m n+ -------------------------------------------------------------------------------- -- Type class instances --------------------------------------------------------------------------------@@ -200,11 +203,8 @@  instance Num Nat where   (+) = plus-  (-) = minus   (*) = mult -  abs x = x-   fromInteger = fromIntegerNat  instance MinBound Nat where@@ -307,7 +307,7 @@       if lte centre right then         centre       else-        mod' left (centre - (S right)) right+        mod' left (minus centre (S right)) right  partial modNat : Nat -> Nat -> Nat@@ -323,7 +323,7 @@       if lte centre right then         Z       else-        S (div' left (centre - (S right)) right)+        S (div' left (minus centre (S right)) right)  partial divNat : Nat -> Nat -> Nat@@ -544,34 +544,34 @@  -- Minus total minusSuccSucc : (left : Nat) -> (right : Nat) ->-  (S left) - (S right) = left - right+  minus (S left) (S right) = minus left right minusSuccSucc left right = Refl -total minusZeroLeft : (right : Nat) -> 0 - right = Z+total minusZeroLeft : (right : Nat) -> minus 0 right = Z minusZeroLeft right = Refl -total minusZeroRight : (left : Nat) -> left - 0 = left+total minusZeroRight : (left : Nat) -> minus left 0 = left minusZeroRight Z        = Refl minusZeroRight (S left) = Refl -total minusZeroN : (n : Nat) -> Z = n - n+total minusZeroN : (n : Nat) -> Z = minus n n minusZeroN Z     = Refl minusZeroN (S n) = minusZeroN n -total minusOneSuccN : (n : Nat) -> S Z = (S n) - n+total minusOneSuccN : (n : Nat) -> S Z = minus (S n) n minusOneSuccN Z     = Refl minusOneSuccN (S n) = minusOneSuccN n -total minusSuccOne : (n : Nat) -> S n - 1 = n+total minusSuccOne : (n : Nat) -> minus (S n) 1 = n minusSuccOne Z     = Refl minusSuccOne (S n) = Refl -total minusPlusZero : (n : Nat) -> (m : Nat) -> n - (n + m) = Z+total minusPlusZero : (n : Nat) -> (m : Nat) -> minus n (n + m) = Z minusPlusZero Z     m = Refl minusPlusZero (S n) m = minusPlusZero n m  total minusMinusMinusPlus : (left : Nat) -> (centre : Nat) -> (right : Nat) ->-  left - centre - right = left - (centre + right)+  minus (minus left centre) right = minus left (centre + right) minusMinusMinusPlus Z        Z          right = Refl minusMinusMinusPlus (S left) Z          right = Refl minusMinusMinusPlus Z        (S centre) right = Refl@@ -581,7 +581,7 @@             Refl  total plusMinusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) ->-  (left + right) - (left + right') = right - right'+  minus (left + right) (left + right') = minus right right' plusMinusLeftCancel Z right right'        = Refl plusMinusLeftCancel (S left) right right' =   let inductiveHypothesis = plusMinusLeftCancel left right right' in@@ -589,7 +589,7 @@             Refl  total multDistributesOverMinusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) ->-  (left - centre) * right = (left * right) - (centre * right)+  (minus left centre) * right = minus (left * right) (centre * right) multDistributesOverMinusLeft Z        Z          right = Refl multDistributesOverMinusLeft (S left) Z          right =     rewrite (minusZeroRight (plus right (mult left right))) in Refl@@ -601,7 +601,7 @@             Refl  total multDistributesOverMinusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->-  left * (centre - right) = (left * centre) - (left * right)+  left * (minus centre right) = minus (left * centre) (left * right) multDistributesOverMinusRight left centre right =     rewrite multCommutative left (minus centre right) in     rewrite multDistributesOverMinusLeft centre right left in@@ -658,7 +658,7 @@ predSucc n = Refl  total minusSuccPred : (left : Nat) -> (right : Nat) ->-  left - (S right) = pred (left - right)+  minus left (S right) = pred (minus left right) minusSuccPred Z        right = Refl minusSuccPred (S left) Z =     rewrite minusZeroRight left in Refl
libs/prelude/Prelude/Strings.idr view
@@ -308,12 +308,15 @@ length = fromInteger . prim__zextInt_BigInt . prim_lenString  ||| Returns a substring of a given string-||| @index The (zero based) index of the string to extract. If this is-||| beyond the end of the String, the function returns the empty string.-||| @len The desired length of the substring. Truncated if this exceeds-||| the length of the input.-substr : (index : Nat) -> (len : Nat) -> String -> String-substr i len = pack . List.take len . drop i . unpack+|||+||| @ index The (zero based) index of the string to extract. If this is+|||         beyond the end of the string, the function returns the empty+|||         string.+||| @ len The desired length of the substring. Truncated if this exceeds+|||       the length of the input.+||| @ subject The string to return a portion of+substr : (index : Nat) -> (len : Nat) -> (subject : String) -> String+substr i len subject = prim__strSubstr (cast i) (cast len) subject  ||| Lowercases all characters in the string. |||
libs/prelude/prelude.ipkg view
@@ -9,7 +9,7 @@           Prelude.Strings, Prelude.Chars, Prelude.Show, Prelude.Functor,           Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,           Prelude.Uninhabited, Prelude.Pairs, Prelude.Providers,-          Prelude.Interactive, Prelude.File,+          Prelude.Interactive, Prelude.File, Prelude.Doubles,            Language.Reflection, Language.Reflection.Errors, Language.Reflection.Elab,
+ man/idris.1 view
@@ -0,0 +1,94 @@+.\" Manpage for Idris.+.\" Contact <> to correct errors or typos.+.TH man 1 "06 August 2014" "0.9.14.1" "Idris man page"+.SH NAME+idris -\ a general purpose pure functional programming language with dependent types.+.SH SYNOPSIS+idris [ options] [FILES]+.SH DESCRIPTION+Idris is a general purpose pure functional programming language with+dependent types. Dependent types allow types to be predicated on+values, meaning that some aspects of a program’s behaviour can be+specified precisely in the type. It is compiled, with eager+evaluation. Its features are influenced by Haskell and ML.+++ Full dependent types with dependent pattern matching+++ where clauses, with rule, simple case expressions+++ pattern matching let and lambda bindings+++ Type classes, monad comprehensions+++ do notation, idiom brackets+++ syntactic conveniences for lists, tuples, dependent pairs+++ Totality checking+++ Coinductive types+++ Indentation significant syntax, extensible syntax+++ Tactic based theorem proving (influenced by Coq)+++ Cumulative universes+++ Simple foreign function interface (to C)+++ Hugs style interactive environment++It is important to note that Idris is first and foremost a research tool+and project. Thus the tooling provided and resulting programs created+should not necessarily be seen as production ready nor for industrial use.++.SH OPTIONS+  --nobanner               Suppress the banner+  -q,--quiet               Quiet verbosity+  --log LEVEL              Debugging log level+  -o,--output FILE         Specify output file+  --total                  Require functions to be total by default+  --warnpartial            Warn about undeclared partial functions+  --warnreach              Warn about reachable but inaccessible arguments+  --link                   Display link flags+  --libdir                 Display library directory+  --include                Display the includes flags+  -V,--verbose             Loud verbosity+  --ibcsubdir FILE         Write IBC files into sub directory+  -i,--idrispath ARG       Add directory to the list of import paths+  --build IPKG             Build package+  --install IPKG           Install package+  --clean IPKG             Clean package+  --mkdoc IPKG             Generate IdrisDoc for package+  --checkpkg IPKG          Check package only+  --testpkg IPKG           Run tests for package+  -S,--codegenonly         Do no further compilation of code generator output+  -c,--compileonly         Compile to object files rather than an executable+  --mvn                    Create a maven project (for Java codegen)+  --codegen TARGET         Select code generator: C, Java, bytecode+  -e,--eval EXPR           Evaluate an expression without loading the REPL+  --execute                Execute as idris+  --exec EXPR              Execute as idris+  -X,--extension EXT       Turn on language extension (TypeProviders or+                           ErrorReflection)+  --target TRIPLE          Select target triple (for llvm codegen)+  --cpu CPU                Select target CPU e.g. corei7 or cortex-m3 (for LLVM+                           codegen)+  --color,--colour         Force coloured output+  --nocolor,--nocolour     Disable coloured output+  -v,--version             Print version information+  -h,--help                Show this help text+.SH SEE ALSO+++ The IDRIS web site (http://idris-lang.org/+++  The IRC channel #idris, on chat.freenode.net+++ The wiki (https://github.com/idris-lang/Idris-dev/wiki/) has further user provided information, in particular:++  – https://github.com/idris-lang/Idris-dev/wiki/Manual++  – https://github.com/idris-lang/Idris-dev/wiki/Language-Features++.SH AUTHOR+The Idris Community
rts/idris_rts.c view
@@ -594,6 +594,17 @@     return MKINT((i_int)idx); } +VAL idris_substr(VM* vm, VAL offset, VAL length, VAL str) {+    char *start = idris_utf8_advance(GETSTR(str), GETINT(offset));+    char *end = idris_utf8_advance(start, GETINT(length));+    Closure* newstr = allocate(sizeof(Closure) + (end - start) +1, 0);+    SETTY(newstr, STRING);+    newstr -> info.str = (char*)newstr + sizeof(Closure);+    memcpy(newstr -> info.str, start, end - start);+    *(newstr -> info.str + (end - start) + 1) = '\0';+    return newstr;+}+ VAL idris_strRev(VM* vm, VAL str) {     char *xstr = GETSTR(str);     Closure* cl = allocate(sizeof(Closure) +
rts/idris_rts.h view
@@ -145,6 +145,11 @@ #define GETMPTR(x) (((VAL)(x))->info.mptr->data) #define GETFLOAT(x) (((VAL)(x))->info.f) +#define GETBITS8(x) (((VAL)(x))->info.bits8)+#define GETBITS16(x) (((VAL)(x))->info.bits16)+#define GETBITS32(x) (((VAL)(x))->info.bits32)+#define GETBITS64(x) (((VAL)(x))->info.bits64)+ #define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity >> 8 : (-1)) ) #define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity & 0x000000ff : (-1)) ) @@ -309,6 +314,7 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs); VAL idris_strIndex(VM* vm, VAL str, VAL i); VAL idris_strRev(VM* vm, VAL str);+VAL idris_substr(VM* vm, VAL offset, VAL length, VAL str);  // system infox // used indices:
rts/idris_utf8.c view
@@ -78,6 +78,32 @@    return top; } +char* idris_utf8_advance(char* str, int i) {+    while (i > 0 && *str != '\0') {+        // In a UTF8 single-byte char, the highest bit is 0.  In the+        // first byte of a multi-byte char, the highest two bits are+        // 11, but the rest of the bytes start with 10. So we can+        // decrement our character counter when we see something other+        // than 10 at the front.++        // This is a bit of an overapproximation, as invalid multibyte+        // sequences that are too long will be treated as if they are+        // OK, but it's always paying attention to null-termination.+        if ((*str & 0xc0) != 0x80) {+            i--;+        }+        str++;+    }+    // Now we've found the first byte of the last character. Advance+    // to the end of it, or the end of the string, whichever is first.+    // Here, we don't risk overrunning the end of the string because+    // ('\0' & 0xc0) != 0x80.+    while ((*str & 0xc0) == 0x80) { str++; }++    return str;+}++ char* idris_utf8_fromChar(int x) {     char* str;     int bytes = 0, top = 0;
rts/idris_utf8.h view
@@ -18,5 +18,7 @@ char* idris_utf8_fromChar(int x); // Reverse a UTF8 encoded string, putting the result in 'result' char* idris_utf8_rev(char* s, char* result);-+// Advance a pointer into a string by i UTF8 characters.+// Return original pointer if i <= 0.+char* idris_utf8_advance(char* str, int i); #endif
+ samples/effects/ConsoleIO.idr view
@@ -0,0 +1,15 @@+module Main++import Effects+import Effect.StdIO+import Effect.State++hello : { [STATE Int, STDIO] } Eff ()+hello = do putStr "Name? "+           putStrLn ("Hello " ++ trim !getStr ++ "!")+           update (+1)+           putStrLn ("I've said hello to: " ++ show !get ++ " people")+           hello++main : IO ()+main = run hello
+ samples/effects/Exception.idr view
@@ -0,0 +1,21 @@+module Main++import Effects+import Effect.Exception+import Effect.StdIO+import Control.IOExcept++data MyErr = NotANumber | OutOfRange++instance Show MyErr where+    show NotANumber = "Not a number"+    show OutOfRange = "Out of range"++parseNumber : Int -> String -> { [EXCEPTION MyErr] } Eff Int+parseNumber num str+   = if all isDigit (unpack str)+        then let x = cast str in+             if (x >=0 && x <= num)+                then pure x+                else raise OutOfRange+        else raise NotANumber
+ samples/effects/Random.idr view
@@ -0,0 +1,37 @@+module Main++import Effects+import Effect.Random+import Effect.Exception+import Effect.StdIO++data MyErr = NotANumber | OutOfRange++parseNumber : Int -> String -> { [EXCEPTION MyErr] } Eff Int+parseNumber num str+   = if all isDigit (unpack str)+        then let x = cast str in+             if (x >=0 && x <= num)+                then pure x+                else raise OutOfRange+        else raise NotANumber++guess : Int -> { [STDIO] } Eff ()+guess target+    = do putStr "Guess: "+         case run {m=Maybe} (parseNumber 100 (trim !getStr)) of+              Nothing => do putStrLn "Invalid input"+                            guess target+              Just v => case compare v target of+                             LT => do putStrLn "Too low"+                                      guess target+                             EQ => putStrLn "You win!"+                             GT => do putStrLn "Too high"+                                      guess target++game : { [RND, STDIO] } Eff ()+game = do srand 123456789+          guess (fromInteger !(rndInt 0 100))++main : IO ()+main = run game
+ samples/effects/ReadInt.idr view
@@ -0,0 +1,22 @@+module ReadInt++import Effects+import Effect.State+import Effect.StdIO++readInt : { [STATE (Vect n Int), STDIO] ==>+            {ok} if ok then [STATE (Vect (S n) Int), STDIO]+                       else [STATE (Vect n Int), STDIO] } Eff Bool+readInt = do let x = trim !getStr+             case all isDigit (unpack x) of+                  False => pure False+                  True => do updateM (\xs => cast x ::xs)+                             pure True++readN : (n : Nat) ->+        { [STATE (Vect m Int), STDIO] ==>+          [STATE (Vect (n + m) Int), STDIO] } Eff ()+readN Z = pure ()+readN {m} (S k) = case !readInt of+                      True => rewrite plusSuccRightSucc k m in readN k+                      False => readN (S k)
+ samples/effects/Select.idr view
@@ -0,0 +1,17 @@+module Main++import Effects+import Effect.Select+import Effect.Exception++triple : Int -> { [SELECT, EXCEPTION String] } Eff (Int, Int, Int)+triple max = do z <- select [1..max]+                y <- select [1..z]+                x <- select [1..y]+                if (x * x + y * y == z * z)+                   then pure (x, y, z)+                   else raise "No triple"++main : IO ()+main = do print $ the (Maybe _) $ run (triple 100)+          print $ the (List _) $ run (triple 100)
+ samples/effects/TreeTag-noeff.idr view
@@ -0,0 +1,21 @@++data BTree a = Leaf+             | Node (BTree a) a (BTree a)++testTree : BTree String+testTree = Node (Node Leaf "Jim" Leaf)+                "Fred"+                (Node (Node Leaf "Alice" Leaf)+                      "Sheila"+                      (Node Leaf "Bob" Leaf))++treeTagAux : (i : Int) -> BTree a -> (Int, BTree (Int, a))+treeTagAux i Leaf = (i, Leaf)+treeTagAux i (Node l x r)+       = let (i', l') = treeTagAux i l in+         let x' = (i', x) in+         let (i'', r') = treeTagAux (i' + 1) r in+             (i'', Node l' x' r')++treeTag : (i : Int) -> BTree a -> BTree (Int, a)+treeTag i x = snd (treeTagAux i x)
+ samples/effects/TreeTag.idr view
@@ -0,0 +1,40 @@+module Main++import Effects+import Effect.State++data BTree a = Leaf+             | Node (BTree a) a (BTree a)++instance Show a => Show (BTree a) where+  show Leaf = "[]"+  show (Node l x r) = "[" ++ show l ++ " "+                          ++ show x ++ " "+                          ++ show r ++ "]"++testTree : BTree String+testTree = Node (Node Leaf "Jim" Leaf)+                "Fred"+                (Node (Node Leaf "Alice" Leaf)+                      "Sheila"+                      (Node Leaf "Bob" Leaf))++treeTagAux : BTree a -> { [STATE Int] } Eff (BTree (Int, a))+treeTagAux Leaf = return Leaf+treeTagAux (Node l x r)+    = do l' <- treeTagAux l+         i <- get+         put (i + 1)+         r' <- treeTagAux r+         return (Node l' (i, x) r')++treeTag : (i : Int) -> BTree a -> BTree (Int, a)+treeTag i x = runPure (do put i+                          treeTagAux x)++treeTagIO : (i : Int) -> BTree a -> IO (BTree (Int, a))+treeTagIO i x = run (do put i+                        treeTagAux x)++main : IO ()+main = print (treeTag 1 testTree)
+ samples/effects/TreeTagCount.idr view
@@ -0,0 +1,29 @@+import Effects+import Effect.State+import Effect.StdIO++data BTree a = Leaf+             | Node (BTree a) a (BTree a)++testTree : BTree String+testTree = Node (Node Leaf "Jim" Leaf)+                "Fred"+                (Node (Node Leaf "Alice" Leaf)+                      "Sheila"+                      (Node Leaf "Bob" Leaf))++treeTagAux : BTree a -> { ['Tag ::: STATE Int,+                           'Leaves ::: STATE Int] } Eff (BTree (Int, a))+treeTagAux Leaf = do 'Leaves :- update (+1)+                     pure Leaf+treeTagAux (Node l x r)+    = do l' <- treeTagAux l+         i <- 'Tag :- get+         'Tag :- put (i + 1)+         r' <- treeTagAux r+         pure (Node l' (i, x) r')++treeTag : (i : Int) -> BTree a -> (BTree (Int, a), Int)+treeTag i x = runPureInit ['Tag := i, 'Leaves := 0]+                         (do x' <- treeTagAux x+                             pure (x', !('Leaves :- get)))
+ samples/effects/hworld.idr view
@@ -0,0 +1,10 @@+module Main++import Effects+import Effect.StdIO++hello : { [STDIO] } Eff ()+hello = putStrLn "Hello world!"++main : IO ()+main = run hello
+ samples/effects/vadd.idr view
@@ -0,0 +1,41 @@+module Main++import Effects+import Effect.Exception+import Effect.StdIO++parseNumber : String -> { [EXCEPTION String] } Eff Int+parseNumber str+   = if all (\x => isDigit x || x == '-') (unpack str)+        then pure (cast str)+        else raise "Not a number"++vadd : Vect n Int -> Vect n Int -> Vect n Int+vadd [] [] = []+vadd (x :: xs) (y :: ys) = x + y :: vadd xs ys++vadd_check : Vect n Int -> Vect m Int ->+             { [EXCEPTION String] } Eff (Vect m Int)+vadd_check {n} {m} xs ys with (decEq n m)+  vadd_check {n} {m=n} xs ys | (Yes Refl) = pure (vadd xs ys)+  vadd_check {n} {m}   xs ys | (No _)     = raise "Length mismatch"++read_vec : { [STDIO] } Eff (p ** Vect p Int)+read_vec = do putStr "Number (-1 when done): "+              case run {m=Maybe} (parseNumber (trim !getStr)) of+                   Nothing => do putStrLn "Input error"+                                 read_vec+                   Just v => if (v /= -1)+                                then do (_ ** xs) <- read_vec+                                        pure (_ ** v :: xs)+                                else pure (_ ** [])++do_vadd : { [STDIO, EXCEPTION String] } Eff ()+do_vadd = do putStrLn "Vector 1"+             (_ ** xs) <- read_vec+             putStrLn "Vector 2"+             (_ ** ys) <- read_vec+             putStrLn (show !(vadd_check xs ys))++main : IO ()+main = run do_vadd
+ samples/misc/binary.idr view
@@ -0,0 +1,94 @@+module main++data Bit : Nat -> Type where+     b0 : Bit 0+     b1 : Bit 1++instance Show (Bit n) where+     show b0 = "0"+     show b1 = "1"++infixl 5 #++data Binary : (width : Nat) -> (value : Nat) -> Type where+     zero : Binary Z Z+     (#)  : Binary w v -> Bit bit -> Binary (S w) (bit + 2 * v)++instance Show (Binary w k) where+     show zero = ""+     show (bin # bit) = show bin ++ show bit++pattern syntax bitpair [x] [y] = (_ ** (_ ** (x, y, _)))+term    syntax bitpair [x] [y] = (_ ** (_ ** (x, y, Refl)))++addBit : Bit x -> Bit y -> Bit c ->+          (bx ** (by ** (Bit bx, Bit by, c + x + y = by + 2 * bx)))+addBit b0 b0 b0 = bitpair b0 b0+addBit b0 b0 b1 = bitpair b0 b1+addBit b0 b1 b0 = bitpair b0 b1+addBit b0 b1 b1 = bitpair b1 b0+addBit b1 b0 b0 = bitpair b0 b1+addBit b1 b0 b1 = bitpair b1 b0+addBit b1 b1 b0 = bitpair b1 b0+addBit b1 b1 b1 = bitpair b1 b1++adc : Binary w x -> Binary w y -> Bit c -> Binary (S w) (c + x + y)+adc zero        zero        carry ?= zero # carry+adc (numx # bx) (numy # by) carry+   ?= let (bitpair carry0 lsb) = addBit bx by carry in+          adc numx numy carry0 # lsb++main : IO ()+main = do let n1 = zero # b1 # b0 # b1 # b0+          let n2 = zero # b1 # b1 # b1 # b0+          print (adc n1 n2 b0)++++++++++---------- Proofs ----------++-- There is almost certainly an easier proof. I don't care, for now :)++main.adc_lemma_2 = proof {+    intro c,w,v,bit0,num0;+    intro b0,v1,bit1,num1,b1;+    intro bc,x,x1,bx,bx1,prf;+    intro;+    rewrite sym (plusZeroRightNeutral v);+    rewrite sym (plusZeroRightNeutral v1);+    rewrite sym (plusAssociative (plus c (plus bit0 (plus v v))) bit1 (plus v1 v1));+    rewrite (plusAssociative c (plus bit0 (plus v v)) bit1);+    rewrite (plusAssociative bit0 (plus v v) bit1);+    rewrite sym (plusCommutative (plus v v) bit1);+    rewrite sym (plusAssociative c bit0 (plus bit1 (plus v v)));+    rewrite sym (plusAssociative (plus c bit0) bit1 (plus v v));+    rewrite sym prf;+    rewrite sym (plusZeroRightNeutral x);+    rewrite plusAssociative x1 (plus x x) (plus v v);+    rewrite plusAssociative x x (plus v v);+    rewrite sym (plusAssociative x v v);+    rewrite plusCommutative v (plus x v);+    rewrite sym (plusAssociative x v (plus x v));+    rewrite plusAssociative x1 (plus (plus x v) (plus x v)) (plus v1 v1);+    rewrite plusAssociative (plus x v) (plus x v) (plus v1 v1);+    rewrite plusAssociative x v (plus v1 v1);+    rewrite sym (plusAssociative v v1 v1);+    rewrite sym (plusAssociative x (plus v v1) v1);+    rewrite sym (plusAssociative x v v1);+    rewrite sym (plusCommutative (plus (plus x v) v1) v1);+    rewrite plusZeroRightNeutral (plus (plus x v) v1);+    rewrite sym (plusAssociative (plus x v) v1 (plus (plus (plus x v) v1) Z));+    trivial;+}++main.adc_lemma_1 = proof {+    intros;+    rewrite sym (plusZeroRightNeutral c) ;+    trivial;+}
+ samples/misc/interp-alt.idr view
@@ -0,0 +1,81 @@+module main++data Ty = TyInt | TyBool| TyFun Ty Ty++interpTy : Ty -> Type+interpTy TyInt       = Int+interpTy TyBool      = Bool+interpTy (TyFun s t) = interpTy s -> interpTy t++using (G : Vect n Ty)++  data Env : Vect n Ty -> Type where+      Nil  : Env Nil+      (::) : interpTy a -> Env G -> Env (a :: G)++--   data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where+--       stop : HasType FZ (t :: G) t+--       pop  : HasType k G t -> HasType (FS k) (u :: G) t++  lookup : (i:Fin n) -> Env G -> interpTy (index i G)+  lookup FZ     (x :: xs) = x+  lookup (FS i) (x :: xs) = lookup i xs++  data Expr : Vect n Ty -> Ty -> Type where+      Var : (i : Fin n) -> Expr G (index i G)+      Val : (x : Int) -> Expr G TyInt+      Lam : Expr (a :: G) t -> Expr G (TyFun a t)+      App : Expr G (TyFun a t) -> Expr G a -> Expr G t+      Op  : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b ->+            Expr G c+      If  : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a+      Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b++  interp : Env G -> {static} Expr G t -> interpTy t+  interp env (Var i)     = lookup i env+  interp env (Val x)     = x+  interp env (Lam sc)    = \x => interp (x :: env) sc+  interp env (App f s)   = (interp env f) (interp env s)+  interp env (Op op x y) = op (interp env x) (interp env y)+  interp env (If x t e)  = if (interp env x) then (interp env t) else (interp env e)+  interp env (Bind v f)  = interp env (f (interp env v))++  eId : Expr G (TyFun TyInt TyInt)+  eId = Lam (Var FZ)++  eTEST : Expr G (TyFun TyInt (TyFun TyInt TyInt))+  eTEST = Lam (Lam (Var (FS FZ)))++  eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt))+  eAdd = Lam (Lam (Op prim__addInt (Var FZ) (Var (FS FZ))))++--   eDouble : Expr G (TyFun TyInt TyInt)+--   eDouble = Lam (App (App (Lam (Lam (Op' (+) (Var FZ) (Var (FS FZ))))) (Var FZ)) (Var FZ))++  eDouble : Expr G (TyFun TyInt TyInt)+  eDouble = Lam (App (App eAdd (Var FZ)) (Var FZ))++  app : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t+  app = \f, a => App f a++  eFac : Expr G (TyFun TyInt TyInt)+  eFac = Lam (If (Op (==) (Var FZ) (Val 0))+                 (Val 1) (Op (*) (app eFac (Op (-) (Var FZ) (Val 1))) (Var FZ)))++  -- Exercise elaborator: Complicated way of doing \x y => x*4 + y*2++  eProg : Expr G (TyFun TyInt (TyFun TyInt TyInt))+  eProg = Lam (Lam (Bind (App eDouble (Var (FS FZ)))+              (\x => Bind (App eDouble (Var FZ))+              (\y => Bind (App eDouble (Val x))+              (\z => App (App eAdd (Val y)) (Val z))))))++test : Int+test = interp [] eProg 2 2++testFac : Int+testFac = interp [] eFac 4++main : IO ()+main = do printLn test+          printLn testFac
+ samples/misc/interp.idr view
@@ -0,0 +1,91 @@+module Main++data Ty = TyInt | TyBool | TyFun Ty Ty++interpTy : Ty -> Type+interpTy TyInt       = Int+interpTy TyBool      = Bool+interpTy (TyFun s t) = interpTy s -> interpTy t++using (G : Vect n Ty)++  data Env : Vect n Ty -> Type where+      Nil  : Env Nil+      (::) : interpTy a -> Env G -> Env (a :: G)++  data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where+      stop : HasType FZ (t :: G) t+      pop  : HasType k G t -> HasType (FS k) (u :: G) t++  lookup : HasType i G t -> Env G -> interpTy t+  lookup stop    (x :: xs) = x+  lookup (pop k) (x :: xs) = lookup k xs++  data Expr : Vect n Ty -> Ty -> Type where+      Var : HasType i G t -> Expr G t+      Val : (x : Int) -> Expr G TyInt+      Lam : Expr (a :: G) t -> Expr G (TyFun a t)+      App : Expr G (TyFun a t) -> Expr G a -> Expr G t+      Op  : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b ->+            Expr G c+      If  : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a+      Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b++  dsl expr+      lambda      = Lam+      variable    = Var+      index_first = stop+      index_next  = pop++  (<*>) : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t+  (<*>) = \f, a => App f a++  pure : Expr G a -> Expr G a+  pure = id++  syntax IF [x] THEN [t] ELSE [e] = If x t e++  (==) : Expr G TyInt -> Expr G TyInt -> Expr G TyBool+  (==) = Op (==)++  (<) : Expr G TyInt -> Expr G TyInt -> Expr G TyBool+  (<) = Op (<)++  instance Num (Expr G TyInt) where+    (+) x y = Op (+) x y+    (-) x y = Op (-) x y+    (*) x y = Op (*) x y++    abs x = IF (x < 0) THEN (-x) ELSE x++    fromInteger = Val . fromInteger++  interp : Env G -> {static} Expr G t -> interpTy t+  interp env (Var i)     = lookup i env+  interp env (Val x)     = x+  interp env (Lam sc)    = \x => interp (x :: env) sc+  interp env (App f s)   = (interp env f) (interp env s)+  interp env (Op op x y) = op (interp env x) (interp env y)+  interp env (If x t e)  = if (interp env x) then (interp env t) else (interp env e)+  interp env (Bind v f)  = interp env (f (interp env v))++  eId : Expr G (TyFun TyInt TyInt)+  eId = expr (\x => x)++  eTEST : Expr G (TyFun TyInt (TyFun TyInt TyInt))+  eTEST = expr (\x, y => y)++  eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt))+  eAdd = expr (\x, y => Op (+) x y)++  eDouble : Expr G (TyFun TyInt TyInt)+  eDouble = expr (\x => App (App eAdd x) (Var stop))++  eFac : Expr G (TyFun TyInt TyInt)+  eFac = expr (\x => IF x == 0 THEN 1 ELSE [| eFac (x - 1) |] * x)++testFac : Int+testFac = interp [] eFac 4++main : IO ()+main = printLn testFac
+ samples/misc/javaffi.idr view
@@ -0,0 +1,12 @@+module Main++%include Java "com.google.common.math.IntMath"+%lib Java "com.google.guava:guava:14.0"++binom : Int -> Int -> IO Int+binom n k = mkForeign (FFun "IntMath.binomial" [FInt, FInt] FInt) n k++main : IO ()+main = do print "The number of possibilities in lotto is 49 choose 6:"+       	  res <- binom 49 6+       	  printLn res
+ samples/misc/named_instance.lidr view
@@ -0,0 +1,36 @@+> module MyOrd++An alternative Ord instance for Nats, with an explicit name "myord"+for the dictionary:++> instance [myord] Ord Nat where+>    compare O (S n)     = GT+>    compare (S n) O     = LT+>    compare O O         = EQ++The @{name} syntax below gives an explicit dictionary for the compare function.+Here, we're telling it to use the "myord" dictionary. Otherwise, it'd just+use the default (unnamed) instance. Note that there can only be one unnamed+instance --- they must not overlap.++>    compare (S x) (S y) = compare @{myord} x y++> foo : List Nat+> foo = [1,4,2,8,3,7,5,6]++Sort foo using the default comparison operator:++> test1 : List Nat+> test1 = sort foo++-- which gives [1,2,3,4,5,6,7,8]++Sort foo using the alternative instance. No need for 'sortBy' and other+such functions. Hoorah!++> test2 : List Nat+> test2 = sort @{myord} foo++-- which gives [8,7,6,5,4,3,2,1]++
+ samples/misc/reflection.idr view
@@ -0,0 +1,151 @@+module ReflectionExamples++import Language.Reflection++||| The reflected term for (\ x => reverse "bba")+reflectVal : TT+reflectVal = ?valPrf++||| intEq for the integers 3 and 3+applyTac1 : Int+applyTac1 = ?tacPrf1++||| intEq for the integers 3 and 42+applyTac0 : Int+applyTac0 = ?tacPrf0++||| intEq for the two arguments+applyTacDyn : Int -> Int -> Int+applyTacDyn x y = ?tacPrfDyn++||| Restored version for RConstant (I 42)+fill : Int+fill = ?fillPrf++||| The type (TTName, TT) computed from its reflected raw rep.+envTuple : Type+envTuple = ?envTuplePrf++||| The type List (TTName, TT) computed from its reflected raw rep.+envList : List (TTName, TT)+envList = ?envListPrf++||| Reflected raw rep. for the type (TTName, TT)+tupleType : Raw+tupleType = RApp (RApp (Var (UN "Pair"))+                       (Var (NS (UN "TTName") ["Reflection", "Language"])))+                 (Var (NS (UN "TT") ["Reflection", "Language"]))++||| Reflected raw rep for the type List (TTName, TT)+mkTuple : Raw+mkTuple = RApp (RApp (Var (UN "MkPair"))+                     (Var (NS (UN "TTName") ["Reflection", "Language"])))+               (Var (NS (UN "TT") ["Reflection", "Language"]))++||| Reflected raw rep for Prelude.List.Nil+nil : Raw+nil = (Var (NS (UN "Nil") ["List", "Prelude"]))++||| Reflected raw rep for Prelude.List.::+cons : Raw+cons = (Var (NS (UN "::") ["List", "Prelude"]))++||| 1 if the two arguments are equal, 0 otherwise+||| This function is chosen as simple as possible for+||| demo purposes.+intEq : Int -> Int -> Int+intEq x y = case x == y of+              True  => 1+              False => 0++||| A tactic script to run intEq on two let-bound or introduced+||| arguments of the current (otherwise empty) proof context+firstEq : List (TTName, Binder TT) -> TT -> Tactic+firstEq ((_, (Let _ y))::(_, (Let _ x))::(_, Let _ f)::Nil) _ = Exact (App (App f x) y)+firstEq ((y, Lam yt)::(x, Lam xt)::(_, Let _ f)::Nil) _ = Exact (App (App f (P (Bound) x xt)) (P Bound y yt))+firstEq xs _ = Exact (TConst (I 0))++||| Skip 1 argument of the proof context and return the second one which+||| has to be introduced. Used for the tactical dispatch example, which+||| will push dispatch, as first env agrument.+innerTac : List (TTName, Binder TT) -> TT -> Tactic+innerTac (_::(x, Lam xt)::_) _ = Exact (P Bound x xt)++||| Returns the reflected representation of innerTac+innerTacTT : TT+innerTacTT = ?innerTacTTPrf++||| Dispatch to the reflected rep. of innerTac+dispatch : List (TTName, Binder TT) -> TT -> Tactic+dispatch xs _ = ApplyTactic (innerTacTT)++||| Call dispatch which will then dispatch to innerTac.+tacticalDispatch : Int -> Int+tacticalDispatch = ?tacticalDispatchPrf++||| A tactic to get the representation of its goal+studyGoalTac : List (TTName, Binder TT) -> TT -> Tactic+studyGoalTac _ goal = Reflect goal++||| Returns the representation of its goal, TT+||| (so this is reflect on the type TT)+studyGoal : TT+studyGoal = ?studyGoalPrf++---------- Proofs ----------++ReflectionExamples.studyGoalPrf = proof {+  applyTactic studyGoalTac;+}++ReflectionExamples.envTuplePrf = proof {+  let x = tupleType;+  fill x;+}++ReflectionExamples.envListPrf = proof {+  let x : Raw = RApp nil tupleType;+  fill x;+}+++ReflectionExamples.valPrf = proof {+  let x : (List String -> String) = (\ x => reverse "bba");+  reflect x;+}+++ReflectionExamples.tacPrf1 = proof {+  let f : (Int -> Int -> Int) = intEq;+  let x : Int = 3;+  let y : Int = 3;+  applyTactic firstEq;+}++ReflectionExamples.tacPrf0 = proof {+  let f : (Int -> Int -> Int) = intEq;+  let x : Int = 3;+  let y : Int = 42;+  applyTactic firstEq;+}++ReflectionExamples.tacPrfDyn = proof {+  let f : (Int ->  Int -> Int) = intEq;+  intros;+  applyTactic firstEq;+}++ReflectionExamples.fillPrf = proof {+  let x : Raw = RConstant (I 42);+  fill x;+}++ReflectionExamples.innerTacTTPrf = proof {+  reflect innerTac;+}++ReflectionExamples.tacticalDispatchPrf = proof {+  intros;+  applyTactic dispatch;+}+
+ samples/tutorial/binary.idr view
@@ -0,0 +1,61 @@+module Main++data Binary : Nat -> Type where+    bEnd : Binary Z+    bO : Binary n -> Binary (n + n)+    bI : Binary n -> Binary (S (n + n))++instance Show (Binary n) where+    show (bO x) = show x ++ "0"+    show (bI x) = show x ++ "1"+    show bEnd = ""++data Parity : Nat -> Type where+   Even : Parity (n + n)+   Odd  : Parity (S (n + n))++parity : (n:Nat) -> Parity n+parity Z     = Even {n=Z}+parity (S Z) = Odd {n=Z}+parity (S (S k)) with (parity k)+    parity (S (S (j + j)))     | Even ?= Even {n=S j}+    parity (S (S (S (j + j)))) | Odd  ?= Odd {n=S j}++natToBin : (n:Nat) -> Binary n+natToBin Z = bEnd+natToBin (S k) with (parity k)+   natToBin (S (j + j))     | Even  = bI (natToBin j)+   natToBin (S (S (j + j))) | Odd  ?= bO (natToBin (S j))++intToNat : Int -> Nat+intToNat 0 = Z+intToNat x = if (x>0) then (S (intToNat (x-1))) else Z++main : IO ()+main = do putStr "Enter a number: "+          x <- getLine+          print (natToBin (fromInteger (cast x)))++---------- Proofs ----------++Main.natToBin_lemma_1 = proof+  intros+  rewrite plusSuccRightSucc j j+  rewrite sym (plusSuccRightSucc j j)+  trivial+++parity_lemma_1 = proof+    intros+    rewrite sym (plusSuccRightSucc j j)+    trivial+++parity_lemma_2 = proof {+    intro;+    intro;+    rewrite sym (plusSuccRightSucc j j);+    trivial;+}++
+ samples/tutorial/bmain.idr view
@@ -0,0 +1,8 @@+module Main++import btree++main : IO ()+main = do let t = toTree [1,8,2,7,9,3]+          print (btree.toList t)+
+ samples/tutorial/btree.idr view
@@ -0,0 +1,18 @@+module btree++data BTree a = Leaf+             | Node (BTree a) a (BTree a)++insert : Ord a => a -> BTree a -> BTree a+insert x Leaf = Node Leaf x Leaf+insert x (Node l v r) = if (x < v) then (Node (insert x l) v r)+                                   else (Node l v (insert x r))++toList : BTree a -> List a+toList Leaf = []+toList (Node l v r) = btree.toList l ++ (v :: btree.toList r)++toTree : Ord a => List a -> BTree a+toTree [] = Leaf+toTree (x :: xs) = insert x (toTree xs)+
+ samples/tutorial/btreemod.idr view
@@ -0,0 +1,20 @@+module btree++abstract data BTree a = Leaf+                      | Node (BTree a) a (BTree a)++abstract+insert : Ord a => a -> BTree a -> BTree a+insert x Leaf = Node Leaf x Leaf+insert x (Node l v r) = if (x < v) then (Node (insert x l) v r)+                                   else (Node l v (insert x r))++abstract+toList : BTree a -> List a+toList Leaf = []+toList (Node l v r) = btree.toList l ++ (v :: btree.toList r)++abstract+toTree : Ord a => List a -> BTree a+toTree [] = Leaf+toTree (x :: xs) = insert x (toTree xs)
+ samples/tutorial/classes.idr view
@@ -0,0 +1,10 @@+m_add : Maybe Int -> Maybe Int -> Maybe Int+m_add x y = do x' <- x -- Extract value from x+               y' <- y -- Extract value from y+               return (x' + y') -- Add them++m_add' : Maybe Int -> Maybe Int -> Maybe Int+m_add' x y = [ x' + y' | x' <- x, y' <- y ]++sortAndShow : (Ord a, Show a) => List a -> String+sortAndShow xs = show (sort xs)
+ samples/tutorial/foo.idr view
@@ -0,0 +1,10 @@+module foo++namespace x+  test : Int -> Int+  test x = x * 2++namespace y+  test : String -> String+  test x = x ++ x+
+ samples/tutorial/hello.idr view
@@ -0,0 +1,5 @@+module Main++main : IO ()+main = putStrLn "Hello world"+
+ samples/tutorial/idiom.idr view
@@ -0,0 +1,38 @@+module idiom++data Expr = Var String+          | Val Int+          | Add Expr Expr++data Eval : Type -> Type where+   MkEval : (List (String, Int) -> Maybe a) -> Eval a++fetch : String -> Eval Int+fetch x = MkEval fetchVal where+    fetchVal : List (String, Int) -> Maybe Int+    fetchVal [] = Nothing+    fetchVal ((v, val) :: xs) = if (x == v) then (Just val) else (fetchVal xs)++instance Functor Eval where+    map f (MkEval g) = MkEval (\e => map f (g e))++instance Applicative Eval where+    pure x = MkEval (\e => Just x)++    (<*>) (MkEval f) (MkEval g) = MkEval (\x => app (f x) (g x)) where+       app : Maybe (a -> b) -> Maybe a -> Maybe b+       app (Just fx) (Just gx) = Just (fx gx)+       app _         _         = Nothing++eval : Expr -> Eval Int+eval (Var x)   = fetch x+eval (Val x)   = [| x |]+eval (Add x y) = [| eval x + eval y |]++runEval : List (String, Int) -> Expr -> Maybe Int+runEval env e = case eval e of+    MkEval envFn => envFn env++m_add' : Maybe Int -> Maybe Int -> Maybe Int+m_add' x y = [| x + y |]+
+ samples/tutorial/interp.idr view
@@ -0,0 +1,71 @@+module Main++import Data.Vect+import Data.Fin++data Ty = TyInt | TyBool| TyFun Ty Ty++interpTy : Ty -> Type+interpTy TyInt       = Int+interpTy TyBool      = Bool+interpTy (TyFun s t) = interpTy s -> interpTy t++using (G : Vect n Ty)++  data Env : Vect n Ty -> Type where+      Nil  : Env Nil+      (::) : interpTy a -> Env G -> Env (a :: G)++  data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where+      Stop : HasType FZ (t :: G) t+      Pop  : HasType k G t -> HasType (FS k) (u :: G) t++  lookup : HasType i G t -> Env G -> interpTy t+  lookup Stop    (x :: xs) = x+  lookup (Pop k) (x :: xs) = lookup k xs++  data Expr : Vect n Ty -> Ty -> Type where+      Var : HasType i G t -> Expr G t+      Val : (x : Int) -> Expr G TyInt+      Lam : Expr (a :: G) t -> Expr G (TyFun a t)+      App : Expr G (TyFun a t) -> Expr G a -> Expr G t+      Op  : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b ->+            Expr G c+      If  : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a++  interp : Env G -> [static] (e : Expr G t) -> interpTy t+  interp env (Var i)     = lookup i env+  interp env (Val x)     = x+  interp env (Lam sc)    = \x => interp (x :: env) sc+  interp env (App f s)   = interp env f (interp env s)+  interp env (Op op x y) = op (interp env x) (interp env y)+  interp env (If x t e)  = if interp env x then interp env t+                                           else interp env e++  eId : Expr G (TyFun TyInt TyInt)+  eId = Lam (Var Stop)++  eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt))+  eAdd = Lam (Lam (Op (+) (Var Stop) (Var (Pop Stop))))++  eEq : Expr G (TyFun TyInt (TyFun TyInt TyBool))+  eEq = Lam (Lam (Op (==) (Var Stop) (Var (Pop Stop))))++  eDouble : Expr G (TyFun TyInt TyInt)+  eDouble = Lam (App (App eAdd (Var Stop)) (Var Stop))++  fact : Expr G (TyFun TyInt TyInt)+  fact = Lam (If (Op (==) (Var Stop) (Val 0))+                 (Val 1) (Op (*) (App fact (Op (-) (Var Stop) (Val 1))) (Var Stop)))++testFac : Int+testFac = interp [] fact 4++-- unitTestFac : so (interp [] fact 4 == 24)+-- unitTestFac = oh++main : IO ()+main = do putStr "Enter a number: "+          x <- getLine+          print (interp [] fact (cast x))+
+ samples/tutorial/letbind.idr view
@@ -0,0 +1,16 @@+module letbind++mirror : List a -> List a+mirror xs = let xs' = reverse xs in+                xs ++ xs'++data Person = MkPerson String Int++showPerson : Person -> String+showPerson p = let MkPerson name age = p in+                   name ++ " is " ++ show age ++ " years old"++splitAt : Char -> String -> (String, String)+splitAt c x = case break (== c) x of+                  (x, y) => (x, strTail y)+
+ samples/tutorial/prims.idr view
@@ -0,0 +1,14 @@+module prims++x : Int+x = 42++foo : String+foo = "Sausage machine"++bar : Char+bar = 'Z'++quux : Bool+quux = False+
+ samples/tutorial/theorems.idr view
@@ -0,0 +1,57 @@++fiveIsFive : 5 = 5+fiveIsFive = Refl++twoPlusTwo : 2 + 2 = 4+twoPlusTwo = Refl++total disjoint : (n : Nat) -> Z = S n -> Void+disjoint n p = replace {P = disjointTy} p ()+  where+    disjointTy : Nat -> Type+    disjointTy Z = ()+    disjointTy (S k) = Void++total acyclic : (n : Nat) -> n = S n -> Void+acyclic Z p = disjoint _ p+acyclic (S k) p = acyclic k (succInjective _ _ p)++empty1 : Void+empty1 = hd [] where+    hd : List a -> a+    hd (x :: xs) = x++empty2 : Void+empty2 = empty2++plusReduces : (n:Nat) -> plus Z n = n+plusReduces n = Refl++plusReducesZ : (n:Nat) -> n = plus n Z+plusReducesZ Z = Refl+plusReducesZ (S k) = cong (plusReducesZ k)++plusReducesS : (n:Nat) -> (m:Nat) -> S (plus n m) = plus n (S m)+plusReducesS Z m = Refl+plusReducesS (S k) m = cong (plusReducesS k m)++plusReducesZ' : (n:Nat) -> n = plus n Z+plusReducesZ' Z     = ?plusredZ_Z+plusReducesZ' (S k) = let ih = plusReducesZ' k in+                      ?plusredZ_S+++---------- Proofs ----------++plusredZ_S = proof {+    intro;+    intro;+    rewrite ih;+    trivial;+}++plusredZ_Z = proof {+    compute;+    trivial;+}+
+ samples/tutorial/universe.idr view
@@ -0,0 +1,7 @@+myid : (a : Type) -> a -> a+myid _ x = x++idid :  (a : Type) -> a -> a+idid = myid _ myid++
+ samples/tutorial/usefultypes.idr view
@@ -0,0 +1,20 @@++intVec : Vect 5 Int+intVec = [1, 2, 3, 4, 5]++double : Int -> Int+double x = x * 2++vec : (n ** Vect n Int)+vec = (_ ** [3, 4])++list_lookup : Nat -> List a -> Maybe a+list_lookup _     Nil         = Nothing+list_lookup Z     (x :: xs) = Just x+list_lookup (S k) (x :: xs) = list_lookup k xs++lookup_default : Nat -> List a -> a -> a+lookup_default i xs def = case list_lookup i xs of+                              Nothing => def+                              Just x => x+
+ samples/tutorial/vbroken.idr view
@@ -0,0 +1,10 @@+module Vect++data Vect : Nat -> Type -> Type where+     Nil : Vect Z a+     (::) : a -> Vect k a -> Vect (S k) a++(++) : Vect n a -> Vect m a -> Vect (n + m) a+(++) Nil       ys = ys+(++) (x :: xs) ys = x :: xs ++ xs -- BROKEN+
+ samples/tutorial/views.idr view
@@ -0,0 +1,37 @@+module views++data Parity : Nat -> Type where+   Even : Parity (n + n)+   Odd  : Parity (S (n + n))++parity : (n:Nat) -> Parity n+parity Z     = Even {n=Z}+parity (S Z) = Odd {n=Z}+parity (S (S k)) with (parity k)+  parity (S (S (j + j)))     | Even ?= Even {n=S j}+  parity (S (S (S (j + j)))) | Odd  ?= Odd {n=S j}++natToBin : Nat -> List Bool+natToBin Z = Nil+natToBin k with (parity k)+   natToBin (j + j)     | Even = False :: natToBin j+   natToBin (S (j + j)) | Odd  = True  :: natToBin j+++---------- Proofs ----------++views.parity_lemma_2 = proof {+    intro;+    intro;+    rewrite sym (plusSuccRightSucc j j);+    trivial;+}++views.parity_lemma_1 = proof {+    intro;+    intro;+    rewrite sym (plusSuccRightSucc j j);+    trivial;+}++
+ samples/tutorial/viewsbroken.idr view
@@ -0,0 +1,12 @@++data Parity : Nat -> Type where+   Even : Parity (n + n)+   Odd  : Parity (S (n + n))++parity : (n:Nat) -> Parity n+parity Z     = Even {n=Z}+parity (S Z) = Odd {n=Z}+parity (S (S k)) with (parity k)+  parity (S (S (j + j)))     | Even = Even {n=S j}+  parity (S (S (S (j + j)))) | Odd  = Odd {n=S j}+
+ samples/tutorial/wheres.idr view
@@ -0,0 +1,14 @@+module wheres++even : Nat -> Bool+even Z = True+even (S k) = odd k where+  odd Z = False+  odd (S k) = even k++test : List Nat+test = [c (S 1), c Z, d (S Z)]+  where c x = 42 + x+        d y = c (y + 1 + z y)+              where z w = y + w+
src/IRTS/CodegenC.hs view
@@ -259,6 +259,10 @@   where     intConsts ((I _, _ ) : _) = True     intConsts ((Ch _, _ ) : _) = True+    intConsts ((B8 _, _ ) : _) = True+    intConsts ((B16 _, _ ) : _) = True+    intConsts ((B32 _, _ ) : _) = True+    intConsts ((B64 _, _ ) : _) = True     intConsts _ = False      bigintConsts ((BI _, _ ) : _) = True@@ -279,7 +283,18 @@     iCase v (Ch b, bc) =         indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"            ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"-+    iCase v (B8 w, bc) =+        indent i ++ "if (GETBITS8(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"+           ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"+    iCase v (B16 w, bc) =+        indent i ++ "if (GETBITS16(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"+           ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"+    iCase v (B32 w, bc) =+        indent i ++ "if (GETBITS32(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"+           ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"+    iCase v (B64 w, bc) =+        indent i ++ "if (GETBITS64(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"+           ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"     showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"                          ++ concatMap (bcc (i+1)) bc ++                             indent (i + 1) ++ "break;\n"@@ -544,6 +559,7 @@ doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")" doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")" doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"+doOp v LStrSubstr [x,y,z] = v ++ "idris_substr(vm, " ++ creg x ++ "," ++ creg y ++ "," ++ creg z ++ ")"  doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"
src/IRTS/CodegenJavaScript.hs view
@@ -1140,6 +1140,15 @@                 JSNum (JSInt 1),                 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))               ]+      | LStrSubstr <- op+      , (offset:length:string:_) <- args =+        let off = translateReg offset+            len = translateReg length+            str = translateReg string+        in JSApp (JSProj str "substr") [+             jsCall "Math.max" [JSNum (JSInt 0), off],+             jsCall "Math.max" [JSNum (JSInt 0), len]+           ]        | LSystemInfo <- op       , (arg:_) <- args = jsCall "i$systemInfo"  [translateReg arg]
src/IRTS/Compiler.hs view
@@ -44,8 +44,7 @@ import System.Environment import System.FilePath ((</>), addTrailingPathSeparator) --- |  Given a 'main' term to compiler, return the IRs which can be used to--- generate code.+-- |  Compile to simplified forms and return CodegenInfo compile :: Codegen -> FilePath -> Maybe Term -> Idris CodegenInfo compile codegen f mtm    = do checkMVs  -- check for undefined metavariables@@ -74,7 +73,7 @@                          Just _ -> False          let defs = defsIn ++ maindef-        -- iputStrLn $ showSep "\n" (map show defs)+         -- Inlined top level LDecl made here         let defsInlined = inlineAll defs         let defsUniq = map (allocUnique (addAlist defsInlined emptyContext))@@ -90,7 +89,7 @@         let defuns = inline defuns_in         logLvl 5 $ show defuns         logLvl 1 "Resolving variables for CG"-        -- iputStrLn $ showSep "\n" (map show (toAlist defuns))+         let checked = simplifyDefs defuns (toAlist defuns)         outty <- outputTy         dumpCases <- getDumpCases@@ -109,13 +108,6 @@                                             hdrs impdirs objs libs flags                                             NONE c (toAlist defuns)                                             tagged iface exports---                        runIO $ case codegen of---                               ViaC -> codegenC cginfo---                               ViaJava -> codegenJava cginfo---                               ViaJavaScript -> codegenJavaScript cginfo---                               ViaNode -> codegenNode cginfo---                               ViaLLVM -> codegenLLVM cginfo---                               Bytecode -> dumpBC c f             Error e -> ierror e   where checkMVs = do i <- getIState                       case map fst (idris_metavars i) \\ primDefs of@@ -125,9 +117,6 @@                            case idris_totcheckfail i of                              [] -> return ()                              ((fc, msg):fs) -> ierror . At fc . Msg $ "Cannot compile:\n  " ++ msg-        inDir d h = do let f = d </> h-                       ex <- doesFileExist f-                       if ex then return f else return h  generate :: Codegen -> FilePath -> CodegenInfo -> IO () generate codegen mainmod ir@@ -135,7 +124,7 @@        -- Built-in code generators (FIXME: lift these out!)        Via "c" -> codegenC ir        -- Any external code generator-       Via cg -> do let cmd = "idris-" ++ cg+       Via cg -> do let cmd = "idris-codegen-" ++ cg                         args = [mainmod, "-o", outputFile ir] ++ compilerFlags ir                     exit <- rawSystem cmd args                     when (exit /= ExitSuccess) $@@ -485,75 +474,6 @@     deNS n = n doForeign vs env xs = ifail "Badly formed foreign function call" -{-- - | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn-    = case getFTypes fgnArgTys of-        Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)-        Just tys -> do-            args' <- mapM (irTerm vs env) (init args)-            return $ LForeign LANG_C (mkIty' ret) fgnName (zip tys args')--    | otherwise = ifail "Badly formed foreign function call"-  where-    getFTypes :: TT Name -> Maybe [FType]-    getFTypes tm = case unApply tm of-        -- nil : {a : Type} -> List a-        (nil,  [_])         -> Just []-        -- cons : {a : Type} -> a -> List a -> List a-        (cons, [_, ty, xs]) -> (mkIty' ty :) <$> getFTypes xs-        _ -> Nothing--    mkIty' (P _ (UN ty) _) = mkIty (str ty)-    mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))-        | fi == txt "FIntT"-        = mkIntIty (str intTy)--    mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))-        | ff == txt "FFunction"-        , fa == txt "FAny"-        , io == txt "IO"-        = FFunctionIO--    mkIty' (App (App (P _ (UN ff) _) _) _)-        | ff == txt "FFunction"-        = FFunction--    mkIty' _ = FAny--    -- would be better if these FInt types were evaluated at compile time-    -- TODO: add %eval directive for such things-    -- Issue #1742 on the issue tracker.-    --     https://github.com/idris-lang/Idris-dev/issues/1742-    mkIty "FFloat"      = FArith ATFloat-    mkIty "FInt"        = mkIntIty "ITNative"-    mkIty "FChar"       = mkIntIty "ITChar"-    mkIty "FByte"       = mkIntIty "IT8"-    mkIty "FShort"      = mkIntIty "IT16"-    mkIty "FLong"       = mkIntIty "IT64"-    mkIty "FBits8"      = mkIntIty "IT8"-    mkIty "FBits16"     = mkIntIty "IT16"-    mkIty "FBits32"     = mkIntIty "IT32"-    mkIty "FBits64"     = mkIntIty "IT64"-    mkIty "FString"     = FString-    mkIty "FPtr"        = FPtr-    mkIty "FManagedPtr" = FManagedPtr-    mkIty "FUnit"       = FUnit-    mkIty "FFunction"   = FFunction-    mkIty "FFunctionIO" = FFunctionIO-    mkIty "FBits8x16"   = FArith (ATInt (ITVec IT8 16))-    mkIty "FBits16x8"   = FArith (ATInt (ITVec IT16 8))-    mkIty "FBits32x4"   = FArith (ATInt (ITVec IT32 4))-    mkIty "FBits64x2"   = FArith (ATInt (ITVec IT64 2))-    mkIty x             = error $ "Unknown type " ++ x--    mkIntIty "ITNative" = FArith (ATInt ITNative)-    mkIntIty "ITChar" = FArith (ATInt ITChar)-    mkIntIty "IT8"  = FArith (ATInt (ITFixed IT8))-    mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))-    mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))-    mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))--}- irTree :: [Name] -> SC -> Idris LExp irTree args tree = do     logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree@@ -685,6 +605,10 @@     matchable (BI _) = True     matchable (Ch _) = True     matchable (Str _) = True+    matchable (B8 _) = True+    matchable (B16 _) = True+    matchable (B32 _) = True+    matchable (B64 _) = True     matchable _ = False      matchableTy (AType (ATInt ITNative)) = True
src/IRTS/Lang.hs view
@@ -74,7 +74,7 @@             | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan             | LFSqrt | LFFloor | LFCeil | LFNegate -            | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev+            | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev | LStrSubstr             | LReadStr | LWriteStr              -- system info
src/Idris/AbsSyntax.hs view
@@ -31,6 +31,8 @@ import qualified Data.Set as S import Data.Word (Word) +import Data.Generics.Uniplate.Data (descend, descendM)+ import Debug.Trace  import System.IO.Error(isUserError, ioeGetErrorString, tryIOError)@@ -200,7 +202,7 @@     where findCoercions t [] = []           findCoercions t (n : ns) =              let ps = case lookupTy n (tt_ctxt i) of-                        [ty'] -> case unApply (getRetTy ty') of+                        [ty'] -> case unApply (getRetTy (normalise (tt_ctxt i) [] ty')) of                                    (t', _) ->                                       if t == t' then [n] else []                         _ -> [] in@@ -397,6 +399,10 @@                       _ -> i         putIState $ ist { idris_classes = addDef n i' (idris_classes ist) } +addRecord :: Name -> RecordInfo -> Idris ()+addRecord n ri = do ist <- getIState+                    putIState $ ist { idris_records = addDef n ri (idris_records ist) }+ addAutoHint :: Name -> Name -> Idris () addAutoHint n hint =     do ist <- getIState@@ -796,6 +802,18 @@                     let opt' = opts { opt_evaltypes = n }                     putIState $ i { idris_options = opt' } +getDesugarNats :: Idris Bool+getDesugarNats = do i <- getIState+                    let opts = idris_options i+                    return (opt_desugarnats opts)+++setDesugarNats :: Bool -> Idris ()+setDesugarNats n = do i <- getIState+                      let opts = idris_options i+                      let opt' = opts { opt_desugarnats = n }+                      putIState $ i { idris_options = opt' }+ setQuiet :: Bool -> Idris () setQuiet q = do i <- getIState                 let opts = idris_options i@@ -976,7 +994,7 @@                 [Name] -> -- all names                 [Name] -> -- names with no declaration                 PTerm -> PTerm-expandParams dec ps ns infs tm = en tm+expandParams dec ps ns infs tm = en 0 tm   where     -- if we shadow a name (say in a lambda binding) that is used in a call to     -- a lifted function, we need access to both names - once in the scope of the@@ -988,78 +1006,85 @@     mkShadow (MN i n) = MN (i+1) n     mkShadow (NS x s) = NS (mkShadow x) s -    en (PLam fc n nfc t s)+    en :: Int -- ^ The quotation level - only transform terms that are used, not terms+              -- that are merely mentioned.+        -> PTerm -> PTerm+    en 0 (PLam fc n nfc t s)        | n `elem` (map fst ps ++ ns)                = let n' = mkShadow n in-                     PLam fc n' nfc (en t) (en (shadow n n' s))-       | otherwise = PLam fc n nfc (en t) (en s)-    en (PPi p n nfc t s)+                     PLam fc n' nfc (en 0 t) (en 0 (shadow n n' s))+       | otherwise = PLam fc n nfc (en 0 t) (en 0 s)+    en 0 (PPi p n nfc t s)        | n `elem` (map fst ps ++ ns)                = let n' = mkShadow n in -- TODO THINK SHADOWING TacImp?-                     PPi (enTacImp p) n' nfc (en t) (en (shadow n n' s))-       | otherwise = PPi (enTacImp p) n nfc (en t) (en s)-    en (PLet fc n nfc ty v s)+                     PPi (enTacImp 0 p) n' nfc (en 0 t) (en 0 (shadow n n' s))+       | otherwise = PPi (enTacImp 0 p) n nfc (en 0 t) (en 0 s)+    en 0 (PLet fc n nfc ty v s)        | n `elem` (map fst ps ++ ns)                = let n' = mkShadow n in-                     PLet fc n' nfc (en ty) (en v) (en (shadow n n' s))-       | otherwise = PLet fc n nfc (en ty) (en v) (en s)+                     PLet fc n' nfc (en 0 ty) (en 0 v) (en 0 (shadow n n' s))+       | otherwise = PLet fc n nfc (en 0 ty) (en 0 v) (en 0 s)     -- FIXME: Should only do this in a type signature!-    en (PDPair f hls p (PRef f' fcs n) t r)+    en 0 (PDPair f hls p (PRef f' fcs n) t r)        | n `elem` (map fst ps ++ ns) && t /= Placeholder            = let n' = mkShadow n in-                 PDPair f hls p (PRef f' fcs n') (en t) (en (shadow n n' r))-    en (PRewrite f l r g) = PRewrite f (en l) (en r) (fmap en g)-    en (PTyped l r) = PTyped (en l) (en r)-    en (PPair f hls p l r) = PPair f hls p (en l) (en r)-    en (PDPair f hls p l t r) = PDPair f hls p (en l) (en t) (en r)-    en (PAlternative ns a as) = PAlternative ns a (map en as)-    en (PHidden t) = PHidden (en t)-    en (PUnifyLog t) = PUnifyLog (en t)-    en (PDisamb ds t) = PDisamb ds (en t)-    en (PNoImplicits t) = PNoImplicits (en t)-    en (PDoBlock ds) = PDoBlock (map (fmap en) ds)-    en (PProof ts)   = PProof (map (fmap en) ts)-    en (PTactics ts) = PTactics (map (fmap en) ts)+                 PDPair f hls p (PRef f' fcs n') (en 0 t) (en 0 (shadow n n' r))+    en 0 (PRewrite f l r g) = PRewrite f (en 0 l) (en 0 r) (fmap (en 0) g)+    en 0 (PTyped l r) = PTyped (en 0 l) (en 0 r)+    en 0 (PPair f hls p l r) = PPair f hls p (en 0 l) (en 0 r)+    en 0 (PDPair f hls p l t r) = PDPair f hls p (en 0 l) (en 0 t) (en 0 r)+    en 0 (PAlternative ns a as) = PAlternative ns a (map (en 0) as)+    en 0 (PHidden t) = PHidden (en 0 t)+    en 0 (PUnifyLog t) = PUnifyLog (en 0 t)+    en 0 (PDisamb ds t) = PDisamb ds (en 0 t)+    en 0 (PNoImplicits t) = PNoImplicits (en 0 t)+    en 0 (PDoBlock ds) = PDoBlock (map (fmap (en 0)) ds)+    en 0 (PProof ts)   = PProof (map (fmap (en 0)) ts)+    en 0 (PTactics ts) = PTactics (map (fmap (en 0)) ts) -    en (PQuote (Var n))+    en 0 (PQuote (Var n))         | n `nselem` ns = PQuote (Var (dec n))-    en (PApp fc (PInferRef fc' hl n) as)+    en 0 (PApp fc (PInferRef fc' hl n) as)         | n `nselem` ns = PApp fc (PInferRef fc' hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap en) as))-    en (PApp fc (PRef fc' hl n) as)+                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))+    en 0 (PApp fc (PRef fc' hl n) as)         | n `elem` infs = PApp fc (PInferRef fc' hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap en) as))+                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))         | n `nselem` ns = PApp fc (PRef fc' hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap en) as))-    en (PAppBind fc (PRef fc' hl n) as)+                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))+    en 0 (PAppBind fc (PRef fc' hl n) as)         | n `elem` infs = PAppBind fc (PInferRef fc' hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap en) as))+                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))         | n `nselem` ns = PAppBind fc (PRef fc' hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap en) as))-    en (PRef fc hl n)+                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))+    en 0 (PRef fc hl n)         | n `elem` infs = PApp fc (PInferRef fc hl (dec n))                            (map (pexp . (PRef fc hl)) (map fst ps))         | n `nselem` ns = PApp fc (PRef fc hl (dec n))                            (map (pexp . (PRef fc hl)) (map fst ps))-    en (PInferRef fc hl n)+    en 0 (PInferRef fc hl n)         | n `nselem` ns = PApp fc (PInferRef fc hl (dec n))                            (map (pexp . (PRef fc hl)) (map fst ps))-    en (PApp fc f as) = PApp fc (en f) (map (fmap en) as)-    en (PAppBind fc f as) = PAppBind fc (en f) (map (fmap en) as)-    en (PCase fc c os) = PCase fc (en c) (map (pmap en) os)-    en (PIfThenElse fc c t f) = PIfThenElse fc (en c) (en t) (en f)-    en (PRunElab fc tm ns) = PRunElab fc (en tm) ns-    en (PConstSugar fc tm) = PConstSugar fc (en tm)-    en t = t+    en 0 (PApp fc f as) = PApp fc (en 0 f) (map (fmap (en 0)) as)+    en 0 (PAppBind fc f as) = PAppBind fc (en 0 f) (map (fmap (en 0)) as)+    en 0 (PCase fc c os) = PCase fc (en 0 c) (map (pmap (en 0)) os)+    en 0 (PIfThenElse fc c t f) = PIfThenElse fc (en 0 c) (en 0 t) (en 0 f)+    en 0 (PRunElab fc tm ns) = PRunElab fc (en 0 tm) ns+    en 0 (PConstSugar fc tm) = PConstSugar fc (en 0 tm) +    en ql (PQuasiquote tm ty) = PQuasiquote (en (ql + 1) tm) (fmap (en ql) ty)+    en ql (PUnquote tm) = PUnquote (en (ql - 1) tm)++    en ql t = descend (en ql) t+     nselem x [] = False     nselem x (y : xs) | nseq x y = True                       | otherwise = nselem x xs      nseq x y = nsroot x == nsroot y -    enTacImp (TacImp aos st scr)  = TacImp aos st (en scr)-    enTacImp other                = other+    enTacImp ql (TacImp aos st scr)  = TacImp aos st (en ql scr)+    enTacImp ql other                = other  expandParamsD :: Bool -> -- True = RHS only                  IState ->@@ -1550,103 +1575,109 @@  addImpl' :: Bool -> [Name] -> [Name] -> [Name] -> IState -> PTerm -> PTerm addImpl' inpat env infns imp_meths ist ptm-         = mkUniqueNames env [] (ai False (zip env (repeat Nothing)) [] ptm)+   = mkUniqueNames env [] (ai inpat False (zip env (repeat Nothing)) [] ptm)   where-    ai :: Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm-    ai qq env ds (PRef fc fcs f)+    topname = case ptm of+                   PRef _ _ n -> n+                   PApp _ (PRef _ _ n) _ -> n+                   _ -> sUN "" -- doesn't matter then++    ai :: Bool -> Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm+    ai inpat qq env ds (PRef fc fcs f)         | f `elem` infns = PInferRef fc fcs f-        | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat qq imp_meths ist fc f fc ds []-    ai qq env ds (PHidden (PRef fc hl f))-        | not (f `elem` map fst env) = PHidden (handleErr $ aiFn inpat False qq imp_meths ist fc f fc ds [])-    ai qq env ds (PRewrite fc l r g)-       = let l' = ai qq env ds l-             r' = ai qq env ds r-             g' = fmap (ai qq env ds) g in+        | not (f `elem` map fst env) = handleErr $ aiFn topname inpat inpat qq imp_meths ist fc f fc ds [] []+    ai inpat qq env ds (PHidden (PRef fc hl f))+        | not (f `elem` map fst env) = PHidden (handleErr $ aiFn topname inpat False qq imp_meths ist fc f fc ds [] [])+    ai inpat qq env ds (PRewrite fc l r g)+       = let l' = ai inpat qq env ds l+             r' = ai inpat qq env ds r+             g' = fmap (ai inpat qq env ds) g in          PRewrite fc l' r' g'-    ai qq env ds (PTyped l r)-      = let l' = ai qq env ds l-            r' = ai qq env ds r in+    ai inpat qq env ds (PTyped l r)+      = let l' = ai inpat qq env ds l+            r' = ai inpat qq env ds r in             PTyped l' r'-    ai qq env ds (PPair fc hls p l r)-      = let l' = ai qq env ds l-            r' = ai qq env ds r in+    ai inpat qq env ds (PPair fc hls p l r)+      = let l' = ai inpat qq env ds l+            r' = ai inpat qq env ds r in             PPair fc hls p l' r'-    ai qq env ds (PDPair fc hls p l t r)-         = let l' = ai qq env ds l-               t' = ai qq env ds t-               r' = ai qq env ds r in+    ai inpat qq env ds (PDPair fc hls p l t r)+         = let l' = ai inpat qq env ds l+               t' = ai inpat qq env ds t+               r' = ai inpat qq env ds r in            PDPair fc hls p l' t' r'-    ai qq env ds (PAlternative ms a as)-           = let as' = map (ai qq env ds) as in+    ai inpat qq env ds (PAlternative ms a as)+           = let as' = map (ai inpat qq env ds) as in                  PAlternative ms a as'-    ai qq env _ (PDisamb ds' as) = ai qq env ds' as-    ai qq env ds (PApp fc (PInferRef ffc hl f) as)-        = let as' = map (fmap (ai qq env ds)) as in+    ai inpat qq env _ (PDisamb ds' as) = ai inpat qq env ds' as+    ai inpat qq env ds (PApp fc (PInferRef ffc hl f) as)+        = let as' = map (fmap (ai inpat qq env ds)) as in               PApp fc (PInferRef ffc hl f) as'-    ai qq env ds (PApp fc ftm@(PRef ffc hl f) as)-        | f `elem` infns = ai qq env ds (PApp fc (PInferRef ffc hl f) as)+    ai inpat qq env ds (PApp fc ftm@(PRef ffc hl f) as)+        | f `elem` infns = ai inpat qq env ds (PApp fc (PInferRef ffc hl f) as)         | not (f `elem` map fst env)-                          = let as' = map (fmap (ai qq env ds)) as in-                                handleErr $ aiFn inpat False qq imp_meths ist fc f ffc ds as'+                          = let as' = map (fmap (ai inpat qq env ds)) as +                                asdotted' = map (fmap (ai False qq env ds)) as in+                                handleErr $ aiFn topname inpat False qq imp_meths ist fc f ffc ds as' asdotted'         | Just (Just ty) <- lookup f env =-             let as' = map (fmap (ai qq env ds)) as+             let as' = map (fmap (ai inpat qq env ds)) as                  arity = getPArity ty in               mkPApp fc arity ftm as'-    ai qq env ds (PApp fc f as)-      = let f' = ai qq env ds f-            as' = map (fmap (ai qq env ds)) as in+    ai inpat qq env ds (PApp fc f as)+      = let f' = ai inpat qq env ds f+            as' = map (fmap (ai inpat qq env ds)) as in             mkPApp fc 1 f' as'-    ai qq env ds (PCase fc c os)-      = let c' = ai qq env ds c in+    ai inpat qq env ds (PCase fc c os)+      = let c' = ai inpat qq env ds c in         -- leave os alone, because they get lifted into a new pattern match-        -- definition which is passed through addImpl again with more scope+        -- definition which is passed through addImpl agai inpatn with more scope         -- information             PCase fc c' os -    ai qq env ds (PIfThenElse fc c t f) = PIfThenElse fc (ai qq env ds c)-                                                         (ai qq env ds t)-                                                         (ai qq env ds f)+    ai inpat qq env ds (PIfThenElse fc c t f) = PIfThenElse fc (ai inpat qq env ds c)+                                                         (ai inpat qq env ds t)+                                                         (ai inpat qq env ds f)      -- If the name in a lambda is a constructor name, do this as a 'case'     -- instead (it is harmless to do so, especially since the lambda will     -- be lifted anyway!)-    ai qq env ds (PLam fc n nfc ty sc)+    ai inpat qq env ds (PLam fc n nfc ty sc)       = case lookupDef n (tt_ctxt ist) of-             [] -> let ty' = ai qq env ds ty-                       sc' = ai qq ((n, Just ty):env) ds sc in+             [] -> let ty' = ai inpat qq env ds ty+                       sc' = ai inpat qq ((n, Just ty):env) ds sc in                        PLam fc n nfc ty' sc'-             _ -> ai qq env ds (PLam fc (sMN 0 "lamp") NoFC ty+             _ -> ai inpat qq env ds (PLam fc (sMN 0 "lamp") NoFC ty                                      (PCase fc (PRef fc [] (sMN 0 "lamp") )                                         [(PRef fc [] n, sc)]))-    ai qq env ds (PLet fc n nfc ty val sc)+    ai inpat qq env ds (PLet fc n nfc ty val sc)       = case lookupDef n (tt_ctxt ist) of-             [] -> let ty' = ai qq env ds ty-                       val' = ai qq env ds val-                       sc' = ai qq ((n, Just ty):env) ds sc in+             [] -> let ty' = ai inpat qq env ds ty+                       val' = ai inpat qq env ds val+                       sc' = ai inpat qq ((n, Just ty):env) ds sc in                        PLet fc n nfc ty' val' sc'              defs ->-               ai qq env ds (PCase fc val [(PRef fc [] n, sc)])-    ai qq env ds (PPi p n nfc ty sc)-      = let ty' = ai qq env ds ty+               ai inpat qq env ds (PCase fc val [(PRef fc [] n, sc)])+    ai inpat qq env ds (PPi p n nfc ty sc)+      = let ty' = ai inpat qq env ds ty             env' = if n `elem` imp_meths then env                       else ((n, Just ty) : env)-            sc' = ai qq env' ds sc in+            sc' = ai inpat qq env' ds sc in             PPi p n nfc ty' sc'-    ai qq env ds (PGoal fc r n sc)-      = let r' = ai qq env ds r-            sc' = ai qq ((n, Nothing):env) ds sc in+    ai inpat qq env ds (PGoal fc r n sc)+      = let r' = ai inpat qq env ds r+            sc' = ai inpat qq ((n, Nothing):env) ds sc in             PGoal fc r' n sc'-    ai qq env ds (PHidden tm) = PHidden (ai qq env ds tm)+    ai inpat qq env ds (PHidden tm) = PHidden (ai inpat qq env ds tm)     -- Don't do PProof or PTactics since implicits get added when scope is     -- properly known in ElabTerm.runTac-    ai qq env ds (PUnifyLog tm) = PUnifyLog (ai qq env ds tm)-    ai qq env ds (PNoImplicits tm) = PNoImplicits (ai qq env ds tm)-    ai qq env ds (PQuasiquote tm g) = PQuasiquote (ai True env ds tm)-                                                  (fmap (ai True env ds) g)-    ai qq env ds (PUnquote tm) = PUnquote (ai False env ds tm)-    ai qq env ds (PRunElab fc tm ns) = PRunElab fc (ai False env ds tm) ns-    ai qq env ds (PConstSugar fc tm) = PConstSugar fc (ai qq env ds tm)-    ai qq env ds tm = tm+    ai inpat qq env ds (PUnifyLog tm) = PUnifyLog (ai inpat qq env ds tm)+    ai inpat qq env ds (PNoImplicits tm) = PNoImplicits (ai inpat qq env ds tm)+    ai inpat qq env ds (PQuasiquote tm g) = PQuasiquote (ai inpat True env ds tm)+                                                  (fmap (ai inpat True env ds) g)+    ai inpat qq env ds (PUnquote tm) = PUnquote (ai inpat False env ds tm)+    ai inpat qq env ds (PRunElab fc tm ns) = PRunElab fc (ai inpat False env ds tm) ns+    ai inpat qq env ds (PConstSugar fc tm) = PConstSugar fc (ai inpat qq env ds tm)+    ai inpat qq env ds tm = tm      handleErr (Left err) = PElabError err     handleErr (Right x) = x@@ -1654,14 +1685,15 @@ -- if in a pattern, and there are no arguments, and there's no possible -- names with zero explicit arguments, don't add implicits. -aiFn :: Bool -> Bool -> Bool+aiFn :: Name -> Bool -> Bool -> Bool      -> [Name]      -> IState -> FC      -> Name -- ^ function being applied      -> FC -> [[T.Text]]-     -> [PArg] -- ^ initial arguments+     -> [PArg] -- ^ initial arguments (if in a pattern)+     -> [PArg] -- ^ initial arguments (if in an expression)      -> Either Err PTerm-aiFn inpat True qq imp_meths ist fc f ffc ds []+aiFn topname inpat True qq imp_meths ist fc f ffc ds [] _   = case lookupDef f (tt_ctxt ist) of         [] -> Right $ PPatvar ffc f         alts -> let ialts = lookupCtxtName f (idris_implicits ist) in@@ -1669,7 +1701,7 @@                     if (not (vname f) || tcname f                            || any (conCaf (tt_ctxt ist)) ialts) --                            any constructor alts || any allImp ialts))-                        then aiFn inpat False qq imp_meths ist fc f ffc ds [] -- use it as a constructor+                        then aiFn topname inpat False qq imp_meths ist fc f ffc ds [] [] -- use it as a constructor                         else Right $ PPatvar ffc f     where imp (PExp _ _ _ _) = False           imp _ = True@@ -1683,9 +1715,9 @@           vname (UN n) = True -- non qualified           vname _ = False -aiFn inpat expat qq imp_meths ist fc f ffc ds as+aiFn topname inpat expat qq imp_meths ist fc f ffc ds as asexp     | f `elem` primNames = Right $ PApp fc (PRef ffc [ffc] f) as-aiFn inpat expat qq imp_meths ist fc f ffc ds as+aiFn topname inpat expat qq imp_meths ist fc f ffc ds as asexp           -- This is where namespaces get resolved by adding PAlternative      = do let ns = lookupCtxtName f (idris_implicits ist)           let nh = filter (\(n, _) -> notHidden n) ns@@ -1693,15 +1725,25 @@                          [] -> nh                          x -> x           case ns' of-            [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f')) (insertImpl ns as)+            [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f')) +                                     (insertImpl ns (chooseArgs f' as asexp))             [] -> if f `elem` (map fst (idris_metavars ist))                     then Right $ PApp fc (PRef ffc [ffc] f) as                     else Right $ mkPApp fc (length as) (PRef ffc [ffc] f) as             alts -> Right $                          PAlternative [] (ExactlyOne True) $                            map (\(f', ns) -> mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f'))-                                                  (insertImpl ns as)) alts+                                                  (insertImpl ns (chooseArgs f' as asexp))) alts   where+    -- choose whether to treat the arguments as patterns or expressions+    -- if 'f' is a defined function, treat as expression, otherwise do the default.+    -- This is so any names which later go under a PHidden are treated+    -- as function names rather than bound pattern variables+    chooseArgs f as asexp | isConName f (tt_ctxt ist) = as+                          | f == topname = as+                          | Nothing <- lookupDefExact f (tt_ctxt ist) = as+                          | otherwise = asexp+     -- if the name is in imp_meths, we should actually refer to the bound     -- name rather than the global one after expanding implicits     isImpName f f' | f `elem` imp_meths = f@@ -2081,43 +2123,46 @@     fullApp x = x  shadow :: Name -> Name -> PTerm -> PTerm-shadow n n' t = sm t where-    sm (PRef fc hl x) | n == x = PRef fc hl n'-    sm (PLam fc x xfc t sc) | n /= x = PLam fc x xfc (sm t) (sm sc)-                            | otherwise = PLam fc x xfc (sm t) sc-    sm (PPi p x fc t sc) | n /= x = PPi p x fc (sm t) (sm sc)-                         | otherwise = PPi p x fc (sm t) sc-    sm (PLet fc x xfc t v sc) | n /= x = PLet fc x xfc (sm t) (sm v) (sm sc)-                              | otherwise = PLet fc x xfc (sm t) (sm v) sc-    sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)-    sm (PAppBind f x as) = PAppBind f (sm x) (map (fmap sm) as)-    sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as)-    sm (PIfThenElse fc c t f) = PIfThenElse fc (sm c) (sm t) (sm f)-    sm (PRewrite f x y tm) = PRewrite f (sm x) (sm y) (fmap sm tm)-    sm (PTyped x y) = PTyped (sm x) (sm y)-    sm (PPair f hls p x y) = PPair f hls p (sm x) (sm y)-    sm (PDPair f hls p x t y) = PDPair f hls p (sm x) (sm t) (sm y)-    sm (PAlternative ms a as) = PAlternative ms a (map sm as)-    sm (PTactics ts) = PTactics (map (fmap sm) ts)-    sm (PProof ts) = PProof (map (fmap sm) ts)-    sm (PHidden x) = PHidden (sm x)-    sm (PUnifyLog x) = PUnifyLog (sm x)-    sm (PNoImplicits x) = PNoImplicits (sm x)-    sm x = x+shadow n n' t = sm 0 t where+    sm 0 (PRef fc hl x) | n == x = PRef fc hl n'+    sm 0 (PLam fc x xfc t sc) | n /= x = PLam fc x xfc (sm 0 t) (sm 0 sc)+                            | otherwise = PLam fc x xfc (sm 0 t) sc+    sm 0 (PPi p x fc t sc) | n /= x = PPi p x fc (sm 0 t) (sm 0 sc)+                         | otherwise = PPi p x fc (sm 0 t) sc+    sm 0 (PLet fc x xfc t v sc) | n /= x = PLet fc x xfc (sm 0 t) (sm 0 v) (sm 0 sc)+                              | otherwise = PLet fc x xfc (sm 0 t) (sm 0 v) sc+    sm 0 (PApp f x as) = PApp f (sm 0 x) (map (fmap (sm 0)) as)+    sm 0 (PAppBind f x as) = PAppBind f (sm 0 x) (map (fmap (sm 0)) as)+    sm 0 (PCase f x as) = PCase f (sm 0 x) (map (pmap (sm 0)) as)+    sm 0 (PIfThenElse fc c t f) = PIfThenElse fc (sm 0 c) (sm 0 t) (sm 0 f)+    sm 0 (PRewrite f x y tm) = PRewrite f (sm 0 x) (sm 0 y) (fmap (sm 0) tm)+    sm 0 (PTyped x y) = PTyped (sm 0 x) (sm 0 y)+    sm 0 (PPair f hls p x y) = PPair f hls p (sm 0 x) (sm 0 y)+    sm 0 (PDPair f hls p x t y) = PDPair f hls p (sm 0 x) (sm 0 t) (sm 0 y)+    sm 0 (PAlternative ms a as) = PAlternative ms a (map (sm 0) as)+    sm 0 (PTactics ts) = PTactics (map (fmap (sm 0)) ts)+    sm 0 (PProof ts) = PProof (map (fmap (sm 0)) ts)+    sm 0 (PHidden x) = PHidden (sm 0 x)+    sm 0 (PUnifyLog x) = PUnifyLog (sm 0 x)+    sm 0 (PNoImplicits x) = PNoImplicits (sm 0 x)+    sm 0 (PCoerced t) = PCoerced (sm 0 t)+    sm ql (PQuasiquote tm ty) = PQuasiquote (sm (ql + 1) tm) (fmap (sm ql) ty)+    sm ql (PUnquote tm) = PUnquote (sm (ql - 1) tm)+    sm ql x = descend (sm ql) x  -- | Rename any binders which are repeated (so that we don't have to mess -- about with shadowing anywhere else). mkUniqueNames :: [Name] -> [(Name, Name)] -> PTerm -> PTerm mkUniqueNames env shadows tm -      = evalState (mkUniq initMap tm) (S.fromList env) where+      = evalState (mkUniq 0 initMap tm) (S.fromList env) where    initMap = M.fromList shadows    inScope :: S.Set Name   inScope = S.fromList $ boundNamesIn tm -  mkUniqA nmap arg = do t' <- mkUniq nmap (getTm arg)-                        return (arg { getTm = t' })+  mkUniqA ql nmap arg = do t' <- mkUniq ql nmap (getTm arg)+                           return (arg { getTm = t' })    -- Initialise the unique name with the environment length (so we're not   -- looking for too long...)@@ -2127,10 +2172,11 @@    -- FIXME: Probably ought to do this for completeness! It's fine as   -- long as there are no bindings inside tactics though.-  mkUniqT nmap tac = return tac+  mkUniqT _ nmap tac = return tac -  mkUniq :: M.Map Name Name -> PTerm -> State (S.Set Name) PTerm-  mkUniq nmap (PLam fc n nfc ty sc)+  mkUniq :: Int -- ^ The number of quotations that we're under+         -> M.Map Name Name -> PTerm -> State (S.Set Name) PTerm+  mkUniq 0 nmap (PLam fc n nfc ty sc)          = do env <- get               (n', sc') <-                     if n `S.member` env@@ -2140,10 +2186,10 @@                        else return (n, sc)               put (S.insert n' env)               let nmap' = M.insert n n' nmap-              ty' <- mkUniq nmap ty-              sc'' <- mkUniq nmap' sc'+              ty' <- mkUniq 0 nmap ty+              sc'' <- mkUniq 0 nmap' sc'               return $! PLam fc n' nfc ty' sc''-  mkUniq nmap (PPi p n fc ty sc)+  mkUniq 0 nmap (PPi p n fc ty sc)          = do env <- get               (n', sc') <-                     if n `S.member` env@@ -2153,10 +2199,10 @@                        else return (n, sc)               put (S.insert n' env)               let nmap' = M.insert n n' nmap-              ty' <- mkUniq nmap ty-              sc'' <- mkUniq nmap' sc'+              ty' <- mkUniq 0 nmap ty+              sc'' <- mkUniq 0 nmap' sc'               return $! PPi p n' fc ty' sc''-  mkUniq nmap (PLet fc n nfc ty val sc)+  mkUniq 0 nmap (PLet fc n nfc ty val sc)          = do env <- get               (n', sc') <-                     if n `S.member` env@@ -2166,28 +2212,28 @@                        else return (n, sc)               put (S.insert n' env)               let nmap' = M.insert n n' nmap-              ty' <- mkUniq nmap ty; val' <- mkUniq nmap val-              sc'' <- mkUniq nmap' sc'+              ty' <- mkUniq 0 nmap ty; val' <- mkUniq 0 nmap val+              sc'' <- mkUniq 0 nmap' sc'               return $! PLet fc n' nfc ty' val' sc''-  mkUniq nmap (PApp fc t args)-         = do t' <- mkUniq nmap t-              args' <- mapM (mkUniqA nmap) args+  mkUniq 0 nmap (PApp fc t args)+         = do t' <- mkUniq 0 nmap t+              args' <- mapM (mkUniqA 0 nmap) args               return $! PApp fc t' args'-  mkUniq nmap (PAppBind fc t args)-         = do t' <- mkUniq nmap t-              args' <- mapM (mkUniqA nmap) args+  mkUniq 0 nmap (PAppBind fc t args)+         = do t' <- mkUniq 0 nmap t+              args' <- mapM (mkUniqA 0 nmap) args               return $! PAppBind fc t' args'-  mkUniq nmap (PCase fc t alts)-         = do t' <- mkUniq nmap t-              alts' <- mapM (\(x,y)-> do x' <- mkUniq nmap x; y' <- mkUniq nmap y+  mkUniq 0 nmap (PCase fc t alts)+         = do t' <- mkUniq 0 nmap t+              alts' <- mapM (\(x,y)-> do x' <- mkUniq 0 nmap x; y' <- mkUniq 0 nmap y                                          return (x', y')) alts               return $! PCase fc t' alts'-  mkUniq nmap (PIfThenElse fc c t f)-         = liftM3 (PIfThenElse fc) (mkUniq nmap c) (mkUniq nmap t) (mkUniq nmap f)-  mkUniq nmap (PPair fc hls p l r)-         = do l' <- mkUniq nmap l; r' <- mkUniq nmap r+  mkUniq 0 nmap (PIfThenElse fc c t f)+         = liftM3 (PIfThenElse fc) (mkUniq 0 nmap c) (mkUniq 0 nmap t) (mkUniq 0 nmap f)+  mkUniq 0 nmap (PPair fc hls p l r)+         = do l' <- mkUniq 0 nmap l; r' <- mkUniq 0 nmap r               return $! PPair fc hls p l' r'-  mkUniq nmap (PDPair fc hls p (PRef fc' hls' n) t sc)+  mkUniq 0 nmap (PDPair fc hls p (PRef fc' hls' n) t sc)       | t /= Placeholder          = do env <- get               (n', sc') <- if n `S.member` env@@ -2196,26 +2242,37 @@                               else return (n, sc)               put (S.insert n' env)               let nmap' = M.insert n n' nmap-              t' <- mkUniq nmap t-              sc'' <- mkUniq nmap' sc'+              t' <- mkUniq 0 nmap t+              sc'' <- mkUniq 0 nmap' sc'               return $! PDPair fc hls p (PRef fc' hls' n') t' sc''-  mkUniq nmap (PDPair fc hls p l t r)-         = do l' <- mkUniq nmap l; t' <- mkUniq nmap t; r' <- mkUniq nmap r+  mkUniq 0 nmap (PDPair fc hls p l t r)+         = do l' <- mkUniq 0 nmap l; t' <- mkUniq 0 nmap t; r' <- mkUniq 0 nmap r               return $! PDPair fc hls p l' t' r'-  mkUniq nmap (PAlternative ns b as)+  mkUniq 0 nmap (PAlternative ns b as)          -- store the nmap and defer the rest until we've pruned the set          -- during elaboration          = return $ PAlternative (M.toList nmap ++ ns) b as-  mkUniq nmap (PHidden t) = liftM PHidden (mkUniq nmap t)-  mkUniq nmap (PUnifyLog t) = liftM PUnifyLog (mkUniq nmap t)-  mkUniq nmap (PDisamb n t) = liftM (PDisamb n) (mkUniq nmap t)-  mkUniq nmap (PNoImplicits t) = liftM PNoImplicits (mkUniq nmap t)-  mkUniq nmap (PProof ts) = liftM PProof (mapM (mkUniqT nmap) ts)-  mkUniq nmap (PTactics ts) = liftM PTactics (mapM (mkUniqT nmap) ts)-  mkUniq nmap (PRunElab fc ts ns) = liftM (\tm -> PRunElab fc tm ns) (mkUniq nmap ts)-  mkUniq nmap (PConstSugar fc tm) = liftM (PConstSugar fc) (mkUniq nmap tm)-  mkUniq nmap t = return (shadowAll (M.toList nmap) t)+  mkUniq 0 nmap (PHidden t) = liftM PHidden (mkUniq 0 nmap t)+  mkUniq 0 nmap (PUnifyLog t) = liftM PUnifyLog (mkUniq 0 nmap t)+  mkUniq 0 nmap (PDisamb n t) = liftM (PDisamb n) (mkUniq 0 nmap t)+  mkUniq 0 nmap (PNoImplicits t) = liftM PNoImplicits (mkUniq 0 nmap t)+  mkUniq 0 nmap (PProof ts) = liftM PProof (mapM (mkUniqT 0 nmap) ts)+  mkUniq 0 nmap (PTactics ts) = liftM PTactics (mapM (mkUniqT 0 nmap) ts)+  mkUniq 0 nmap (PRunElab fc ts ns) = liftM (\tm -> PRunElab fc tm ns) (mkUniq 0 nmap ts)+  mkUniq 0 nmap (PConstSugar fc tm) = liftM (PConstSugar fc) (mkUniq 0 nmap tm)+  mkUniq 0 nmap (PCoerced tm) = liftM PCoerced (mkUniq 0 nmap tm)+  mkUniq 0 nmap t = return $ shadowAll (M.toList nmap) t     where       shadowAll [] t = t       shadowAll ((n, n') : ns) t = shadow n n' (shadowAll ns t) +  mkUniq ql nmap (PQuasiquote tm ty) =+    do tm' <- mkUniq (ql + 1) nmap tm+       ty' <- case ty of+                Nothing -> return Nothing+                Just t -> fmap Just $ mkUniq ql nmap t+       return $! PQuasiquote tm' ty'+  mkUniq ql nmap (PUnquote tm) = fmap PUnquote (mkUniq (ql - 1) nmap tm)++  mkUniq ql nmap tm = descendM (mkUniq ql nmap) tm+
src/Idris/AbsSyntaxTree.hs view
@@ -28,7 +28,7 @@  import Data.Data (Data) import Data.Function (on)-import Data.Generics.Uniplate.Data (universe)+import Data.Generics.Uniplate.Data (universe, children) import Data.List hiding (group) import Data.Char import qualified Data.Map.Strict as M@@ -90,8 +90,9 @@                          opt_autoImport   :: [FilePath], -- ^ e.g. Builtins+Prelude                          opt_optimise     :: [Optimisation],                          opt_printdepth   :: Maybe Int,-                         opt_evaltypes    :: Bool -- ^ normalise types in :t-                       }+                         opt_evaltypes    :: Bool, -- ^ normalise types in :t+                         opt_desugarnats  :: Bool+       }     deriving (Show, Eq)  defaultOpts = IOption { opt_logLevel   = 0@@ -117,10 +118,12 @@                       , opt_optimise   = defaultOptimise                       , opt_printdepth = Just 5000                       , opt_evaltypes  = True+                      , opt_desugarnats = False                       }  data PPOption = PPOption {     ppopt_impl :: Bool -- ^^ whether to show implicits+  , ppopt_desugarnats :: Bool   , ppopt_pinames :: Bool -- ^^ whether to show names in pi bindings   , ppopt_depth :: Maybe Int } deriving (Show)@@ -133,12 +136,14 @@ -- | Pretty printing options with default verbosity. defaultPPOption :: PPOption defaultPPOption = PPOption { ppopt_impl = False, +                             ppopt_desugarnats = False,                              ppopt_pinames = False,                              ppopt_depth = Just 200 }  -- | Pretty printing options with the most verbosity. verbosePPOption :: PPOption verbosePPOption = PPOption { ppopt_impl = True,+                             ppopt_desugarnats = True,                              ppopt_pinames = True,                              ppopt_depth = Just 200 } @@ -147,7 +152,8 @@ ppOption opt = PPOption {     ppopt_impl = opt_showimp opt,     ppopt_pinames = False,-    ppopt_depth = opt_printdepth opt+    ppopt_depth = opt_printdepth opt,+    ppopt_desugarnats = opt_desugarnats opt }  -- | Get pretty printing options from an idris state record.@@ -177,6 +183,7 @@     idris_implicits :: Ctxt [PArg],     idris_statics :: Ctxt [Bool],     idris_classes :: Ctxt ClassInfo,+    idris_records :: Ctxt RecordInfo,     idris_dsls :: Ctxt DSL,     idris_optimisation :: Ctxt OptInfo,     idris_datatypes :: Ctxt TypeInfo,@@ -290,6 +297,7 @@               | IBCImp Name               | IBCStatic Name               | IBCClass Name+              | IBCRecord Name               | IBCInstance Bool Bool Name Name               | IBCDSL Name               | IBCData Name@@ -336,7 +344,7 @@                    emptyContext emptyContext emptyContext emptyContext                    emptyContext emptyContext emptyContext emptyContext                    emptyContext emptyContext emptyContext emptyContext-                   emptyContext+                   emptyContext emptyContext                    [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] []                    [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] []                    (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty@@ -501,6 +509,7 @@          | AutoSolve -- ^ Automatically issue "solve" tactic in interactive prover          | UseConsoleWidth ConsoleWidth          | DumpHighlights+         | DesugarNats     deriving (Show, Eq)  data ElabShellCmd = EQED | EAbandon | EUndo | EProofState | EProofTerm@@ -967,7 +976,7 @@            | PNoImplicits PTerm -- ^ never run implicit converions on the term            | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term])            | PUnquote PTerm -- ^ ~Term-           | PQuoteName Name FC -- ^ `{n} where the FC is the precise highlighting for the name in particular+           | PQuoteName Name Bool FC -- ^ `{n} where the FC is the precise highlighting for the name in particular. If the Bool is False, then it's `{{n}} and the name won't be resolved.            | PRunElab FC PTerm [String] -- ^ %runElab tm - New-style proof script. Args are location, script, enclosing namespace.            | PConstSugar FC PTerm -- ^ A desugared constant. The FC is a precise source location that will be used to highlight it later.        deriving (Eq, Data, Typeable)@@ -1030,7 +1039,7 @@ mapPTermFC f g (PUnquote t) = PUnquote (mapPTermFC f g t) mapPTermFC f g (PRunElab fc tm ns) = PRunElab (f fc) (mapPTermFC f g tm) ns mapPTermFC f g (PConstSugar fc tm) = PConstSugar (g fc) (mapPTermFC f g tm)-mapPTermFC f g (PQuoteName n fc) = PQuoteName n (g fc)+mapPTermFC f g (PQuoteName n x fc) = PQuoteName n x (g fc)  {-! dg instance Binary PTerm@@ -1257,7 +1266,7 @@ highestFC (PNoImplicits tm) = highestFC tm highestFC (PQuasiquote _ _) = Nothing highestFC (PUnquote tm) = highestFC tm-highestFC (PQuoteName _ fc) = Just fc+highestFC (PQuoteName _ _ fc) = Just fc highestFC (PRunElab fc _ _) = Just fc highestFC (PConstSugar fc _) = Just fc highestFC (PAppImpl t _) = highestFC t@@ -1277,6 +1286,12 @@ deriving instance NFData ClassInfo !-} +-- Record data+data RecordInfo = RI { record_parameters :: [(Name,PTerm)],+                       record_constructor :: Name,+                       record_projections :: [Name] }+    deriving Show+ -- Type inference data  data TIData = TIPartial -- ^ a function with a partially defined type@@ -1645,7 +1660,7 @@     prettySe d p bnd (PPatvar fc n) = pretty n     prettySe d p bnd e       | Just str <- slist d p bnd e = depth d $ str-      | Just n <- snat d p e = depth d $ annotate (AnnData "Nat" "") (text (show n))+      | Just n <- snat ppo d p e = depth d $ annotate (AnnData "Nat" "") (text (show n))     prettySe d p bnd (PRef fc _ n) = prettyName True (ppopt_impl ppo) bnd n     prettySe d p bnd (PLam fc n nfc ty sc) =       depth d . bracket p startPrec . group . align . hang 2 $@@ -1862,7 +1877,9 @@     prettySe d p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe (decD d) p [] t <> text ")"     prettySe d p bnd (PQuasiquote t (Just g)) = text "`(" <> prettySe (decD d) p [] t <+> colon <+> prettySe (decD d) p [] g <> text ")"     prettySe d p bnd (PUnquote t) = text "~" <> prettySe (decD d) p bnd t-    prettySe d p bnd (PQuoteName n _) = text "`{" <> prettyName True (ppopt_impl ppo) bnd n <> text "}"+    prettySe d p bnd (PQuoteName n res _) = text start <> prettyName True (ppopt_impl ppo) bnd n <> text end+      where start = if res then "`{" else "`{{"+            end = if res then "}" else "}}"     prettySe d p bnd (PRunElab _ tm _) =       bracket p funcAppPrec . group . align . hang 2 $       text "%runElab" <$>@@ -1934,15 +1951,20 @@      natns = "Prelude.Nat." -    snat :: Maybe Int -> Int -> PTerm -> Maybe Integer-    snat (Just x) _ _ | x <= 0 = Nothing-    snat d p (PRef _ _ z)-      | show z == (natns++"Z") || show z == "Z" = Just 0-    snat d p (PApp _ s [PExp {getTm=n}])-      | show s == (natns++"S") || show s == "S",-        Just n' <- snat (decD d) p n-      = Just $ 1 + n'-    snat _ _ _ = Nothing+    snat :: PPOption -> Maybe Int -> Int -> PTerm -> Maybe Integer+    snat ppo d p e+         | ppopt_desugarnats ppo = Nothing+         | otherwise = snat' d p e+         where+             snat' :: Maybe Int -> Int -> PTerm -> Maybe Integer+             snat' (Just x) _ _ | x <= 0 = Nothing+             snat' d p (PRef _ _ z)+               | show z == (natns++"Z") || show z == "Z" = Just 0+             snat' d p (PApp _ s [PExp {getTm=n}])+               | show s == (natns++"S") || show s == "S",+                 Just n' <- snat' (decD d) p n+                 = Just $ 1 + n'+             snat' _ _ _ = Nothing      bracket outer inner doc       | outer > inner = lparen <> doc <> rparen@@ -2155,160 +2177,216 @@ -- Return all names, free or globally bound, in the given term.  allNamesIn :: PTerm -> [Name]-allNamesIn tm = nub $ ni [] tm+allNamesIn tm = nub $ ni 0 [] tm   where -- TODO THINK added niTacImp, but is it right?-    ni env (PRef _ _ n)+    ni 0 env (PRef _ _ n)         | not (n `elem` env) = [n]-    ni env (PPatvar _ n) = [n]-    ni env (PApp _ f as)   = ni env f ++ concatMap (ni env) (map getTm as)-    ni env (PAppBind _ f as)   = ni env f ++ concatMap (ni env) (map getTm as)-    ni env (PCase _ c os)  = ni env c ++ concatMap (ni env) (map snd os)-    ni env (PIfThenElse _ c t f) = ni env c ++ ni env t ++ ni env f-    ni env (PLam fc n _ ty sc)  = ni env ty ++ ni (n:env) sc-    ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc-    ni env (PLet _ n _ ty val sc) = ni env ty ++ ni env val ++ ni (n:env) sc-    ni env (PHidden tm)    = ni env tm-    ni env (PRewrite _ l r _) = ni env l ++ ni env r-    ni env (PTyped l r)    = ni env l ++ ni env r-    ni env (PPair _ _ _ l r)   = ni env l ++ ni env r-    ni env (PDPair _ _ _ (PRef _ _ n) Placeholder r)  = n : ni env r-    ni env (PDPair _ _ _ (PRef _ _ n) t r)  = ni env t ++ ni (n:env) r-    ni env (PDPair _ _ _ l t r)  = ni env l ++ ni env t ++ ni env r-    ni env (PAlternative ns a ls) = concatMap (ni env) ls-    ni env (PUnifyLog tm)    = ni env tm-    ni env (PDisamb _ tm)    = ni env tm-    ni env (PNoImplicits tm)    = ni env tm-    ni env _               = []+    ni 0 env (PPatvar _ n) = [n]+    ni 0 env (PApp _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)+    ni 0 env (PAppBind _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)+    ni 0 env (PCase _ c os)  = ni 0 env c ++ concatMap (ni 0 env) (map snd os)+    ni 0 env (PIfThenElse _ c t f) = ni 0 env c ++ ni 0 env t ++ ni 0 env f+    ni 0 env (PLam fc n _ ty sc)  = ni 0 env ty ++ ni 0 (n:env) sc+    ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc+    ni 0 env (PLet _ n _ ty val sc) = ni 0 env ty ++ ni 0 env val ++ ni 0 (n:env) sc+    ni 0 env (PHidden tm)    = ni 0 env tm+    ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r+    ni 0 env (PTyped l r)    = ni 0 env l ++ ni 0 env r+    ni 0 env (PPair _ _ _ l r)   = ni 0 env l ++ ni 0 env r+    ni 0 env (PDPair _ _ _ (PRef _ _ n) Placeholder r)  = n : ni 0 env r+    ni 0 env (PDPair _ _ _ (PRef _ _ n) t r)  = ni 0 env t ++ ni 0 (n:env) r+    ni 0 env (PDPair _ _ _ l t r)  = ni 0 env l ++ ni 0 env t ++ ni 0 env r+    ni 0 env (PAlternative ns a ls) = concatMap (ni 0 env) ls+    ni 0 env (PUnifyLog tm)    = ni 0 env tm+    ni 0 env (PDisamb _ tm)    = ni 0 env tm+    ni 0 env (PNoImplicits tm)    = ni 0 env tm -    niTacImp env (TacImp _ _ scr) = ni env scr-    niTacImp _ _                   = []+    ni i env (PQuasiquote tm ty) = ni (i+1) env tm ++ maybe [] (ni i env) ty+    ni i env (PUnquote tm) = ni (i - 1) env tm +    ni i env tm               = concatMap (ni i env) (children tm) +    niTacImp i env (TacImp _ _ scr) = ni i env scr+    niTacImp _ _ _                  = []++ -- Return all names defined in binders in the given term boundNamesIn :: PTerm -> [Name]-boundNamesIn tm = S.toList (ni S.empty tm)+boundNamesIn tm = S.toList (ni 0 S.empty tm)   where -- TODO THINK Added niTacImp, but is it right?-    ni set (PApp _ f as) = niTms (ni set f) (map getTm as)-    ni set (PAppBind _ f as) = niTms (ni set f) (map getTm as)-    ni set (PCase _ c os)  = niTms (ni set c) (map snd os)-    ni set (PIfThenElse _ c t f) = niTms set [c, t, f]-    ni set (PLam fc n _ ty sc)  = S.insert n $ ni (ni set ty) sc-    ni set (PLet fc n nfc ty val sc) = S.insert n $ ni (ni (ni set ty) val) sc-    ni set (PPi p n _ ty sc) = niTacImp (S.insert n $ ni (ni set ty) sc) p-    ni set (PRewrite _ l r _) = ni (ni set l) r-    ni set (PTyped l r) = ni (ni set l) r-    ni set (PPair _ _ _ l r) = ni (ni set l) r-    ni set (PDPair _ _ _ (PRef _ _ n) t r) = ni (ni set t) r-    ni set (PDPair _ _ _ l t r) = ni (ni (ni set l) t) r-    ni set (PAlternative ns a as) = niTms set as-    ni set (PHidden tm) = ni set tm-    ni set (PUnifyLog tm) = ni set tm-    ni set (PDisamb _ tm) = ni set tm-    ni set (PNoImplicits tm) = ni set tm-    ni set _               = set+    ni :: Int -> S.Set Name -> PTerm -> S.Set Name+    ni 0 set (PApp _ f as) = niTms 0 (ni 0 set f) (map getTm as)+    ni 0 set (PAppBind _ f as) = niTms 0 (ni 0 set f) (map getTm as)+    ni 0 set (PCase _ c os)  = niTms 0 (ni 0 set c) (map snd os)+    ni 0 set (PIfThenElse _ c t f) = niTms 0 set [c, t, f]+    ni 0 set (PLam fc n _ ty sc)  = S.insert n $ ni 0 (ni 0 set ty) sc+    ni 0 set (PLet fc n nfc ty val sc) = S.insert n $ ni 0 (ni 0 (ni 0 set ty) val) sc+    ni 0 set (PPi p n _ ty sc) = niTacImp 0 (S.insert n $ ni 0 (ni 0 set ty) sc) p+    ni 0 set (PRewrite _ l r _) = ni 0 (ni 0 set l) r+    ni 0 set (PTyped l r) = ni 0 (ni 0 set l) r+    ni 0 set (PPair _ _ _ l r) = ni 0 (ni 0 set l) r+    ni 0 set (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 (ni 0 set t) r+    ni 0 set (PDPair _ _ _ l t r) = ni 0 (ni 0 (ni 0 set l) t) r+    ni 0 set (PAlternative ns a as) = niTms 0 set as+    ni 0 set (PHidden tm) = ni 0 set tm+    ni 0 set (PUnifyLog tm) = ni 0 set tm+    ni 0 set (PDisamb _ tm) = ni 0 set tm+    ni 0 set (PNoImplicits tm) = ni 0 set tm -    niTms set [] = set-    niTms set (x : xs) = niTms (ni set x) xs+    ni i set (PQuasiquote tm ty) = ni (i + 1) set tm `S.union` maybe S.empty (ni i set) ty+    ni i set (PUnquote tm) = ni (i - 1) set tm -    niTacImp set (TacImp _ _ scr) = ni set scr-    niTacImp set _                = set+    ni i set tm               = foldr S.union set (map (ni i set) (children tm)) +    niTms :: Int -> S.Set Name -> [PTerm] -> S.Set Name+    niTms i set [] = set+    niTms i set (x : xs) = niTms i (ni i set x) xs++    niTacImp i set (TacImp _ _ scr) = ni i set scr+    niTacImp i set _                = set+ -- Return names which are valid implicits in the given term (type). implicitNamesIn :: [Name] -> IState -> PTerm -> [Name]-implicitNamesIn uvars ist tm = nub $ ni [] tm+implicitNamesIn uvars ist tm +      = let (imps, fns) = execState (ni 0 [] tm) ([], []) in+            nub imps \\ nub fns   where-    ni env (PRef _ _ n)+    addImp n = do (imps, fns) <- get+                  put (n : imps, fns)+    addFn n = do (imps, fns) <- get+                 put (imps, n: fns)++    notCAF [] = False+    notCAF (PExp _ _ _ _ : _) = True+    notCAF (_ : xs) = notCAF xs++    notHidden (n, _) = case getAccessibility n of+                            Hidden -> False+                            _ -> True++    getAccessibility n+             = case lookupDefAccExact n False (tt_ctxt ist) of+                    Just (n,t) -> t+                    _ -> Public++    ni 0 env (PRef _ _ n@(NS _ _))         | not (n `elem` env)-            = case lookupTy n (tt_ctxt ist) of-                [] -> [n]-                _ -> if n `elem` uvars then [n] else []-    ni env (PApp _ f@(PRef _ _ n) as)-        | n `elem` uvars = ni env f ++ concatMap (ni env) (map getTm as)-        | otherwise = concatMap (ni env) (map getTm as)-    ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)-    ni env (PAppBind _ f as)   = ni env f ++ concatMap (ni env) (map getTm as)-    ni env (PCase _ c os)  = ni env c +++          -- Never implicitly bind if there's a namespace+            = addFn n+    ni 0 env (PRef _ _ n)+        | not (n `elem` env) && implicitable n || n `elem` uvars = addImp n+    ni 0 env (PApp _ f@(PRef _ _ n) as)+        | n `elem` uvars = do ni 0 env f +                              mapM_ (ni 0 env) (map getTm as)+        | otherwise = do case lookupTy n (tt_ctxt ist) of+                              [] -> return ()+                              _ -> addFn n+                         mapM_ (ni 0 env) (map getTm as)+    ni 0 env (PApp _ f as) = do ni 0 env f +                                mapM_ (ni 0 env) (map getTm as)+    ni 0 env (PAppBind _ f as) = do ni 0 env f +                                    mapM_ (ni 0 env) (map getTm as)+    ni 0 env (PCase _ c os)  = do ni 0 env c     -- names in 'os', not counting the names bound in the cases-                                (nub (concatMap (ni env) (map snd os))-                                     \\ nub (concatMap (ni env) (map fst os)))-    ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]-    ni env (PLam fc n _ ty sc)  = ni env ty ++ ni (n:env) sc-    ni env (PPi p n _ ty sc) = ni env ty ++ ni (n:env) sc-    ni env (PRewrite _ l r _) = ni env l ++ ni env r-    ni env (PTyped l r)    = ni env l ++ ni env r-    ni env (PPair _ _ _ l r)   = ni env l ++ ni env r-    ni env (PDPair _ _ _ (PRef _ _ n) t r) = ni env t ++ ni (n:env) r-    ni env (PDPair _ _ _ l t r) = ni env l ++ ni env t ++ ni env r-    ni env (PAlternative ns a as) = concatMap (ni env) as-    ni env (PHidden tm)    = ni env tm-    ni env (PUnifyLog tm)    = ni env tm-    ni env (PDisamb _ tm)    = ni env tm-    ni env (PNoImplicits tm) = ni env tm-    ni env _               = []+                                  mapM_ (ni 0 env) (map snd os)+                                  (imps, fns) <- get+                                  put ([] ,[])+                                  mapM_ (ni 0 env) (map fst os)+                                  (impsfst, _) <- get+                                  put (nub imps \\ nub impsfst, fns)+    ni 0 env (PIfThenElse _ c t f) = mapM_ (ni 0 env) [c, t, f]+    ni 0 env (PLam fc n _ ty sc)  = do ni 0 env ty; ni 0 (n:env) sc+    ni 0 env (PPi p n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc+    ni 0 env (PRewrite _ l r _) = do ni 0 env l; ni 0 env r+    ni 0 env (PTyped l r)    = do ni 0 env l; ni 0 env r+    ni 0 env (PPair _ _ _ l r)   = do ni 0 env l; ni 0 env r+    ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = do ni 0 env t; ni 0 (n:env) r+    ni 0 env (PDPair _ _ _ l t r) = do ni 0 env l +                                       ni 0 env t+                                       ni 0 env r+    ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as+    ni 0 env (PHidden tm)    = ni 0 env tm+    ni 0 env (PUnifyLog tm)    = ni 0 env tm+    ni 0 env (PDisamb _ tm)    = ni 0 env tm+    ni 0 env (PNoImplicits tm) = ni 0 env tm +    ni i env (PQuasiquote tm ty) = do ni (i + 1) env tm+                                      maybe (return ()) (ni i env) ty+    ni i env (PUnquote tm) = ni (i - 1) env tm++    ni i env tm               = mapM_ (ni i env) (children tm)+ -- Return names which are free in the given term. namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]-namesIn uvars ist tm = nub $ ni [] tm+namesIn uvars ist tm = nub $ ni 0 [] tm   where-    ni env (PRef _ _ n)+    ni 0 env (PRef _ _ n)         | not (n `elem` env)             = case lookupTy n (tt_ctxt ist) of                 [] -> [n]                 _ -> if n `elem` (map fst uvars) then [n] else []-    ni env (PApp _ f as)   = ni env f ++ concatMap (ni env) (map getTm as)-    ni env (PAppBind _ f as)   = ni env f ++ concatMap (ni env) (map getTm as)-    ni env (PCase _ c os)  = ni env c +++    ni 0 env (PApp _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)+    ni 0 env (PAppBind _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)+    ni 0 env (PCase _ c os)  = ni 0 env c ++     -- names in 'os', not counting the names bound in the cases-                                (nub (concatMap (ni env) (map snd os))-                                     \\ nub (concatMap (ni env) (map fst os)))-    ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]-    ni env (PLam fc n nfc ty sc)  = ni env ty ++ ni (n:env) sc-    ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc-    ni env (PRewrite _ l r _) = ni env l ++ ni env r-    ni env (PTyped l r)    = ni env l ++ ni env r-    ni env (PPair _ _ _ l r)   = ni env l ++ ni env r-    ni env (PDPair _ _ _ (PRef _ _ n) t r) = ni env t ++ ni (n:env) r-    ni env (PDPair _ _ _ l t r) = ni env l ++ ni env t ++ ni env r-    ni env (PAlternative ns a as) = concatMap (ni env) as-    ni env (PHidden tm)    = ni env tm-    ni env (PUnifyLog tm)    = ni env tm-    ni env (PDisamb _ tm)    = ni env tm-    ni env (PNoImplicits tm) = ni env tm-    ni env _               = []+                                (nub (concatMap (ni 0 env) (map snd os))+                                     \\ nub (concatMap (ni 0 env) (map fst os)))+    ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]+    ni 0 env (PLam fc n nfc ty sc)  = ni 0 env ty ++ ni 0 (n:env) sc+    ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc+    ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r+    ni 0 env (PTyped l r)    = ni 0 env l ++ ni 0 env r+    ni 0 env (PPair _ _ _ l r)   = ni 0 env l ++ ni 0 env r+    ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r+    ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r+    ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as+    ni 0 env (PHidden tm)    = ni 0 env tm+    ni 0 env (PUnifyLog tm)    = ni 0 env tm+    ni 0 env (PDisamb _ tm)    = ni 0 env tm+    ni 0 env (PNoImplicits tm) = ni 0 env tm -    niTacImp env (TacImp _ _ scr) = ni env scr-    niTacImp _ _                  = []+    ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty+    ni i env (PUnquote tm) = ni (i - 1) env tm +    ni i env tm               = concatMap (ni i env) (children tm)++    niTacImp i env (TacImp _ _ scr) = ni i env scr+    niTacImp _ _ _                  = []+ -- Return which of the given names are used in the given term.  usedNamesIn :: [Name] -> IState -> PTerm -> [Name]-usedNamesIn vars ist tm = nub $ ni [] tm+usedNamesIn vars ist tm = nub $ ni 0 [] tm   where -- TODO THINK added niTacImp, but is it right?-    ni env (PRef _ _ n)+    ni 0 env (PRef _ _ n)         | n `elem` vars && not (n `elem` env)             = case lookupDefExact n (tt_ctxt ist) of                 Nothing -> [n]                 _ -> []-    ni env (PApp _ f as)   = ni env f ++ concatMap (ni env) (map getTm as)-    ni env (PAppBind _ f as)   = ni env f ++ concatMap (ni env) (map getTm as)-    ni env (PCase _ c os)  = ni env c ++ concatMap (ni env) (map snd os)-    ni env (PIfThenElse _ c t f) = concatMap (ni env) [c, t, f]-    ni env (PLam fc n _ ty sc)  = ni env ty ++ ni (n:env) sc-    ni env (PPi p n _ ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc-    ni env (PRewrite _ l r _) = ni env l ++ ni env r-    ni env (PTyped l r)    = ni env l ++ ni env r-    ni env (PPair _ _ _ l r)   = ni env l ++ ni env r-    ni env (PDPair _ _ _ (PRef _ _ n) t r) = ni env t ++ ni (n:env) r-    ni env (PDPair _ _ _ l t r) = ni env l ++ ni env t ++ ni env r-    ni env (PAlternative ns a as) = concatMap (ni env) as-    ni env (PHidden tm)    = ni env tm-    ni env (PUnifyLog tm)    = ni env tm-    ni env (PDisamb _ tm)    = ni env tm-    ni env (PNoImplicits tm) = ni env tm-    ni env _               = []+    ni 0 env (PApp _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)+    ni 0 env (PAppBind _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)+    ni 0 env (PCase _ c os)  = ni 0 env c ++ concatMap (ni 0 env) (map snd os)+    ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]+    ni 0 env (PLam fc n _ ty sc)  = ni 0 env ty ++ ni 0 (n:env) sc+    ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc+    ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r+    ni 0 env (PTyped l r)    = ni 0 env l ++ ni 0 env r+    ni 0 env (PPair _ _ _ l r)   = ni 0 env l ++ ni 0 env r+    ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r+    ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r+    ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as+    ni 0 env (PHidden tm)    = ni 0 env tm+    ni 0 env (PUnifyLog tm)    = ni 0 env tm+    ni 0 env (PDisamb _ tm)    = ni 0 env tm+    ni 0 env (PNoImplicits tm) = ni 0 env tm -    niTacImp env (TacImp _ _ scr) = ni env scr-    niTacImp _ _                = []+    ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty+    ni i env (PUnquote tm) = ni (i - 1) env tm++    ni i env tm               = concatMap (ni i env) (children tm)++    niTacImp i env (TacImp _ _ scr) = ni i env scr+    niTacImp _ _ _                = []  -- Return the list of inaccessible (= dotted) positions for a name. getErasureInfo :: IState -> Name -> [Int]
src/Idris/Completion.hs view
@@ -87,6 +87,7 @@                                               , "originalerrors"                                               , "autosolve"                                               , "nobanner"+                                              , "desugarnats"                                               ]  completeConsoleWidth :: CompletionFunc Idris
src/Idris/Core/DeepSeq.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns, ViewPatterns #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}  module Idris.Core.DeepSeq where@@ -15,6 +16,48 @@         rnf NErased = ()         rnf (SN x1) = rnf x1 `seq` ()         rnf (SymRef x1) = rnf x1 `seq` ()++instance NFData Context where+  rnf ctxt = rnf (next_tvar ctxt) `seq` rnf (definitions ctxt) `seq` ()++-- | Forcing the contents of a context, for diagnosing and working+-- around space leaks+forceDefCtxt :: Context -> Context+forceDefCtxt (force -> !ctxt) = ctxt++instance NFData NameOutput where+    rnf TypeOutput = ()+    rnf FunOutput = ()+    rnf DataOutput = ()+    rnf MetavarOutput = ()+    rnf PostulateOutput = ()++instance NFData TextFormatting where+  rnf BoldText = ()+  rnf ItalicText = ()+  rnf UnderlineText = ()++instance NFData Ordering where+  rnf LT = ()+  rnf EQ = ()+  rnf GT = ()++instance NFData OutputAnnotation where+  rnf (AnnName x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+  rnf (AnnBoundName x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+  rnf (AnnConst x1) = rnf x1 `seq` ()+  rnf (AnnData x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+  rnf (AnnType x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+  rnf (AnnKeyword) = ()+  rnf (AnnFC x) = rnf x `seq` ()+  rnf (AnnTextFmt x) = rnf x `seq` ()+  rnf (AnnLink x) = rnf x `seq` ()+  rnf (AnnTerm x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+  rnf (AnnSearchResult  x1) = rnf x1 `seq` ()+  rnf (AnnErr x1) = rnf x1 `seq` ()+  rnf (AnnNamespace x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+  rnf (AnnQuasiquote) = ()+  rnf (AnnAntiquote) = ()  instance NFData SpecialName where         rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()
src/Idris/Core/Elaborate.hs view
@@ -309,7 +309,7 @@                    return $! (instances (fst p))  -- | get auto argument names-get_autos :: Elab' aux [(Name, [Name])]+get_autos :: Elab' aux [(Name, ([FailContext], [Name]))] get_autos = do ES p _ _ <- get                return $! (autos (fst p)) @@ -502,9 +502,10 @@ unifyProblems :: Elab' aux () unifyProblems = processTactic' UnifyProblems -defer :: [Name] -> Name -> Elab' aux ()+defer :: [Name] -> Name -> Elab' aux Name defer ds n = do n' <- unique_hole n                 processTactic' (Defer ds n')+                return n'  deferType :: Name -> Raw -> [Name] -> Elab' aux () deferType n ty ns = processTactic' (DeferType n ty ns)
src/Idris/Core/Evaluate.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns,              PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} @@ -802,12 +802,14 @@                   definitions     :: Ctxt (Def, Accessibility, Totality, MetaInformation)                 } deriving Show + -- | The initial empty context initContext = MkContext 0 emptyContext + mapDefCtxt :: (Def -> Def) -> Context -> Context-mapDefCtxt f (MkContext t defs) = MkContext t (mapCtxt f' defs)-   where f' (d, a, t, m) = f' (f d, a, t, m)+mapDefCtxt f (MkContext t !defs) = MkContext t (mapCtxt f' defs)+   where f' (!d, a, t, m) = f' (f d, a, t, m)  -- | Get the definitions from a context ctxtAlist :: Context -> [(Name, Def)]@@ -818,44 +820,44 @@ addToCtxt :: Name -> Term -> Type -> Context -> Context addToCtxt n tm ty uctxt     = let ctxt = definitions uctxt-          ctxt' = addDef n (Function ty tm, Public, Unchecked, EmptyMI) ctxt in+          !ctxt' = addDef n (Function ty tm, Public, Unchecked, EmptyMI) ctxt in           uctxt { definitions = ctxt' }  setAccess :: Name -> Accessibility -> Context -> Context setAccess n a uctxt     = let ctxt = definitions uctxt-          ctxt' = updateDef n (\ (d, _, t, m) -> (d, a, t, m)) ctxt in+          !ctxt' = updateDef n (\ (d, _, t, m) -> (d, a, t, m)) ctxt in           uctxt { definitions = ctxt' }  setTotal :: Name -> Totality -> Context -> Context setTotal n t uctxt     = let ctxt = definitions uctxt-          ctxt' = updateDef n (\ (d, a, _, m) -> (d, a, t, m)) ctxt in+          !ctxt' = updateDef n (\ (d, a, _, m) -> (d, a, t, m)) ctxt in           uctxt { definitions = ctxt' }  setMetaInformation :: Name -> MetaInformation -> Context -> Context setMetaInformation n m uctxt     = let ctxt = definitions uctxt-          ctxt' = updateDef n (\ (d, a, t, _) -> (d, a, t, m)) ctxt in+          !ctxt' = updateDef n (\ (d, a, t, _) -> (d, a, t, m)) ctxt in           uctxt { definitions = ctxt' }  addCtxtDef :: Name -> Def -> Context -> Context addCtxtDef n d c = let ctxt = definitions c-                       ctxt' = addDef n (d, Public, Unchecked, EmptyMI) $! ctxt in+                       !ctxt' = addDef n (d, Public, Unchecked, EmptyMI) $! ctxt in                        c { definitions = ctxt' }  addTyDecl :: Name -> NameType -> Type -> Context -> Context addTyDecl n nt ty uctxt     = let ctxt = definitions uctxt-          ctxt' = addDef n (TyDecl nt ty, Public, Unchecked, EmptyMI) ctxt in+          !ctxt' = addDef n (TyDecl nt ty, Public, Unchecked, EmptyMI) ctxt in           uctxt { definitions = ctxt' }  addDatatype :: Datatype Name -> Context -> Context addDatatype (Data n tag ty unique cons) uctxt     = let ctxt = definitions uctxt           ty' = normalise uctxt [] ty-          ctxt' = addCons 0 cons (addDef n-                    (TyDecl (TCon tag (arity ty')) ty, Public, Unchecked, EmptyMI) ctxt) in+          !ctxt' = addCons 0 cons (addDef n+                     (TyDecl (TCon tag (arity ty')) ty, Public, Unchecked, EmptyMI) ctxt) in           uctxt { definitions = ctxt' }   where     addCons tag [] ctxt = ctxt
src/Idris/Core/ProofState.hs view
@@ -38,7 +38,7 @@                        injective :: [Name],                        deferred :: [Name], -- ^ names we'll need to define                        instances :: [Name], -- ^ instance arguments (for type classes)-                       autos    :: [(Name, [Name])], -- ^ unsolved 'auto' implicits with their holes+                       autos    :: [(Name, ([FailContext], [Name]))], -- ^ unsolved 'auto' implicits with their holes                        psnames  :: [Name], -- ^ Local names okay to use in proof search                        previous :: Maybe ProofState, -- ^ for undo                        context  :: Context,@@ -154,7 +154,7 @@ holeName i = sMN i "hole"  qshow :: Fails -> String-qshow fs = show (map (\ (x, y, hs, _, _, _, t) -> (t, x, y, hs)) fs)+qshow fs = show (map (\ (x, y, hs, env, _, _, t) -> (t, map fst env, x, y, hs)) fs)  match_unify' :: Context -> Env ->                  (TT Name, Maybe Provenance) -> @@ -218,7 +218,7 @@                         ("Trying " ++ show (topx, topy) ++                          "\nNormalised " ++ show (normalise ctxt env topx,                                                   normalise ctxt env topy) ++-                         " in " ++ show env +++                         " in\n" ++ show env ++                          "\nHoles: " ++ show (holes ps)                          ++ "\nInjective: " ++ show (injective ps)                          ++ "\n") $@@ -415,7 +415,7 @@                              Nothing ->                                let hs = holes ps in                                ps { holes = (hs \\ [x]) ++ [x],-                                    autos = (x, refsIn t) : autos ps }+                                    autos = (x, (while_elaborating ps, refsIn t)) : autos ps }                              Just _ -> ps)          return (Bind x (Hole t) sc) @@ -429,7 +429,8 @@ defer dropped n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =     do let env' = filter (\(n, t) -> n `notElem` dropped) env        action (\ps -> let hs = holes ps in-                          ps { holes = hs \\ [x] })+                          ps { usedns = n : usedns ps,+                               holes = hs \\ [x] })        ps <- get        return (Bind n (GHole (length env') (psnames ps) (mkTy (reverse env') t))                       (mkApp (P Ref n ty) (map getP (reverse env'))))@@ -904,6 +905,8 @@ getProvenance (CantUnify _ (_, lp) (_, rp) _ _ _) = (lp, rp) getProvenance _ = (Nothing, Nothing) +setReady (x, y, _, env, err, c, at) = (x, y, True, env, err, c, at)+ updateProblems :: ProofState -> [(Name, TT Name)] -> Fails                      -> ([(Name, TT Name)], Fails) -- updateProblems ctxt [] ps inj holes = ([], ps)@@ -1009,7 +1012,7 @@                               computeLet (context ps) n                                          (getProofTerm (pterm ps)) }, "") processTactic UnifyProblems ps-    = do let (ns', probs') = updateProblems ps [] (problems ps)+    = do let (ns', probs') = updateProblems ps [] (map setReady (problems ps))              pterm' = updateSolved ns' (pterm ps)          traceWhen (unifylog ps) ("(UnifyProblems) Dropping holes: " ++ show (map fst ns')) $           return (ps { pterm = pterm', solved = Nothing, problems = probs',@@ -1020,15 +1023,18 @@                        holes = holes ps \\ (map fst ns') }, plog ps)    where notIn ns (h, _) = h `notElem` map fst ns processTactic (MatchProblems all) ps-    = do let (ns', probs') = matchProblems all ps [] (problems ps)+    = do let (ns', probs') = matchProblems all ps [] (map setReady (problems ps))              (ns'', probs'') = matchProblems all ps ns' probs'-             pterm' = updateSolved ns'' (pterm ps)-         traceWhen (unifylog ps) ("(MatchProblems) Dropping holes: " ++ show (map fst ns'')) $+             pterm' = orderUpdateSolved ns'' (resetProofTerm (pterm ps))+         traceWhen (unifylog ps) ("(MatchProblems) Dropping holes: " ++ show ns'') $           return (ps { pterm = pterm', solved = Nothing, problems = probs'',                        previous = Just ps, plog = "",                        notunified = updateNotunified ns'' (notunified ps),                        recents = recents ps ++ map fst ns'',                        holes = holes ps \\ (map fst ns'') }, plog ps)+  where+    orderUpdateSolved [] t = t+    orderUpdateSolved (n : ns) t = orderUpdateSolved ns (updateSolved [n] t) processTactic t ps     = case holes ps of         [] -> case t of
src/Idris/Core/ProofTerm.hs view
@@ -6,6 +6,7 @@ -}  module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm,+                            resetProofTerm,                             updateSolved, updateSolvedTerm, updateSolvedTerm',                             bound_in, bound_in_term, refocus, updsubst,                             Hole, RunTactic',@@ -128,6 +129,9 @@  getProofTerm :: ProofTerm -> Term getProofTerm (PT path _ sub ups) = rebuildTerm sub (updateSolvedPath ups path) ++resetProofTerm :: ProofTerm -> ProofTerm+resetProofTerm = mkProofTerm . getProofTerm  same :: Eq a => Maybe a -> a -> Bool same Nothing n  = True
src/Idris/Core/TT.hs view
@@ -51,6 +51,7 @@  import Control.Applicative (Applicative (..), Alternative) import qualified Control.Applicative as A (Alternative (..))+import Control.DeepSeq (($!!)) import Control.Monad.State.Strict import Control.Monad.Trans.Except (Except (..)) import Debug.Trace@@ -376,6 +377,21 @@                                        show x ++ ": " ++ show e     show (Elaborating what n e) = "Elaborating " ++ what ++ show n ++ ":" ++ show e     show (ProofSearchFail e) = "Proof search fail: " ++ show e+    show (InfiniteUnify _ _ _) = "InfiniteUnify"+    show (UnifyScope _ _ _ _) = "UnifyScope"+    show (NonFunctionType _ _) = "NonFunctionType"+    show (NotEquality _ _) = "NotEquality"+    show (TooManyArguments _) = "TooManyArguments"+    show (CantIntroduce _) = "CantIntroduce"+    show (NoSuchVariable _) = "NoSuchVariable"+    show (WithFnType _) = "WithFnType"+    show (NoTypeDecl _) = "NoTypeDecl"+    show (NotInjective _ _ _) = "NotInjective"+    show (CantResolve _ _) = "CantResolve"+    show (InvalidTCArg _ _) = "InvalidTCArg"+    show (CantResolveAlts _) = "CantResolveAlts"+    show (NoValidAlts _) = "NoValidAlts"+    show (IncompleteTerm _) = "IncompleteTerm"     show _ = "Error"  instance Pretty Err OutputAnnotation where@@ -423,11 +439,11 @@  -- | Names are hierarchies of strings, describing scope (so no danger of -- duplicate names, but need to be careful on lookup).-data Name = UN T.Text -- ^ User-provided name-          | NS Name [T.Text] -- ^ Root, namespaces-          | MN Int T.Text -- ^ Machine chosen names+data Name = UN !T.Text -- ^ User-provided name+          | NS !Name [T.Text] -- ^ Root, namespaces+          | MN !Int !T.Text -- ^ Machine chosen names           | NErased -- ^ Name of something which is never used in scope-          | SN SpecialName -- ^ Decorated function names+          | SN !SpecialName -- ^ Decorated function names           | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)   deriving (Eq, Ord, Data, Typeable) @@ -448,7 +464,7 @@ sUN s = UN (txt s)  sNS :: Name -> [String] -> Name-sNS n ss = NS n (map txt ss)+sNS n ss = NS n $!! (map txt ss)  sMN :: Int -> String -> Name sMN i s = MN i (txt s)@@ -458,15 +474,15 @@ deriving instance NFData Name !-} -data SpecialName = WhereN Int Name Name-                 | WithN Int Name-                 | InstanceN Name [T.Text]-                 | ParentN Name T.Text-                 | MethodN Name-                 | CaseN Name-                 | ElimN Name-                 | InstanceCtorN Name-                 | MetaN Name Name+data SpecialName = WhereN !Int !Name !Name+                 | WithN !Int !Name+                 | InstanceN !Name [T.Text]+                 | ParentN !Name !T.Text+                 | MethodN !Name+                 | CaseN !Name+                 | ElimN !Name+                 | InstanceCtorN !Name+                 | MetaN !Name !Name   deriving (Eq, Ord, Data, Typeable) {-! deriving instance Binary SpecialName
src/Idris/Core/Unify.hs view
@@ -8,6 +8,7 @@  import Control.Monad import Control.Monad.State.Strict+import Data.Maybe import Data.List import Debug.Trace @@ -92,31 +93,6 @@           StateT UInfo           TC [(Name, TT Name)] -    -- This rule is highly dubious... it certainly produces a valid answer-    -- but it scares me. However, matching is never guaranteed to give a unique-    -- answer, merely a valid one, so perhaps we're okay.-    -- In other words: it may vanish without warning some day :)-    un names x tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a)-        | (P (TCon _ _) _ _, _) <- unApply x,-          holeIn env f || f `elem` holes-           = let n' = uniqueName (sMN 0 "mv") (map fst env) in-             checkCycle names (f, Bind n' (Lam t) x)-    un names tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a) x-        | (P (TCon _ _) _ _, _) <- unApply x,-          holeIn env f || f `elem` holes-           = let n' = uniqueName fn (map fst env) in-                 checkCycle names (f, Bind n' (Lam t) x)-    un names x tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a)-        | (P (DCon _ _ _) _ _, _) <- unApply x,-          holeIn env f || f `elem` holes-           = let n' = uniqueName (sMN 0 "mv") (map fst env) in-             checkCycle names (f, Bind n' (Lam t) x)-    un names tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a) x-        | (P (DCon _ _ _) _ _, _) <- unApply x,-          holeIn env f || f `elem` holes-           = let n' = uniqueName fn (map fst env) in-                 checkCycle names (f, Bind n' (Lam t) x)-     un names tx@(P _ x _) tm         | tx /= tm && holeIn env x || x `elem` holes             = do sc 1; checkCycle names (x, tm)@@ -346,7 +322,7 @@     un :: Bool -> [((Name, Name), TT Name)] -> TT Name -> TT Name ->           StateT UInfo           TC [(Name, TT Name)]-    un = un'+    un = un' env --     un fn names x y --         = let (xf, _) = unApply x --               (yf, _) = unApply y in@@ -354,23 +330,23 @@ --                   uplus (un' fn names x y) --                         (un' fn names (hnf ctxt env x) (hnf ctxt env y)) -    un' :: Bool -> [((Name, Name), TT Name)] -> TT Name -> TT Name ->+    un' :: Env -> Bool -> [((Name, Name), TT Name)] -> TT Name -> TT Name ->            StateT UInfo            TC [(Name, TT Name)]-    un' fn names x y | x == y = return [] -- shortcut-    un' fn names topx@(P (DCon _ _ _) x _) topy@(P (DCon _ _ _) y _)+    un' env fn names x y | x == y = return [] -- shortcut+    un' env fn names topx@(P (DCon _ _ _) x _) topy@(P (DCon _ _ _) y _)                 | x /= y = unifyFail topx topy-    un' fn names topx@(P (TCon _ _) x _) topy@(P (TCon _ _) y _)+    un' env fn names topx@(P (TCon _ _) x _) topy@(P (TCon _ _) y _)                 | x /= y = unifyFail topx topy-    un' fn names topx@(P (DCon _ _ _) x _) topy@(P (TCon _ _) y _)+    un' env fn names topx@(P (DCon _ _ _) x _) topy@(P (TCon _ _) y _)                 = unifyFail topx topy-    un' fn names topx@(P (TCon _ _) x _) topy@(P (DCon _ _ _) y _)+    un' env fn names topx@(P (TCon _ _) x _) topy@(P (DCon _ _ _) y _)                 = unifyFail topx topy-    un' fn names topx@(Constant _) topy@(P (TCon _ _) y _)+    un' env fn names topx@(Constant _) topy@(P (TCon _ _) y _)                 = unifyFail topx topy-    un' fn names topx@(P (TCon _ _) x _) topy@(Constant _)+    un' env fn names topx@(P (TCon _ _) x _) topy@(Constant _)                 = unifyFail topx topy-    un' fn bnames tx@(P _ x _) ty@(P _ y _)+    un' env fn bnames tx@(P _ x _) ty@(P _ y _)         | (x,y) `elem` map fst bnames || x == y = do sc 1; return []         | injective tx && not (holeIn env y || y `elem` holes)              = unifyTmpFail tx ty@@ -385,7 +361,7 @@        where envPos i n ((n',_):env) | n == n' = i              envPos i n (_:env) = envPos (i+1) n env              envPos _ _ _ = 100000-    un' fn bnames xtm@(P _ x _) tm+    un' env fn bnames xtm@(P _ x _) tm         | pureTerm tm, holeIn env x || x `elem` holes                        = do UI s f <- get                             -- injectivity check@@ -399,7 +375,7 @@         | pureTerm tm, not (injective xtm) && injective tm                        = do checkCycle bnames (x, tm)                             unifyTmpFail xtm tm-    un' fn bnames tm ytm@(P _ y _)+    un' env fn bnames tm ytm@(P _ y _)         | pureTerm tm, holeIn env y || y `elem` holes                        = do UI s f <- get                             -- injectivity check@@ -413,62 +389,119 @@         | pureTerm tm, not (injective ytm) && injective tm                        = do checkCycle bnames (y, tm)                             unifyTmpFail tm ytm-    un' fn bnames (V i) (P _ x _)+    un' env fn bnames (V i) (P _ x _)         | length bnames > i,           fst ((map fst bnames)!!i) == x ||           snd ((map fst bnames)!!i) == x = do sc 1; return []-    un' fn bnames (P _ x _) (V i)+    un' env fn bnames (P _ x _) (V i)         | length bnames > i,           fst ((map fst bnames)!!i) == x ||           snd ((map fst bnames)!!i) == x = do sc 1; return [] -    un' fn names topx@(Bind n (Hole t) sc) y = unifyTmpFail topx y-    un' fn names x topy@(Bind n (Hole t) sc) = unifyTmpFail x topy+    un' env fn names topx@(Bind n (Hole t) sc) y = unifyTmpFail topx y+    un' env fn names x topy@(Bind n (Hole t) sc) = unifyTmpFail x topy -    un' fn bnames appx@(App _ _ _) appy@(App _ _ _)-        = unApp fn bnames appx appy+-- Pattern unification rule+    un' env fn bnames tm app@(App _ _ _)+        | (P _ mv _, args) <- unApply app,+          holeIn env mv || mv `elem` holes,+          all rigid args,+          containsOnly (mapMaybe getname args) (mapMaybe getV args) tm+          -- && TODO: tm does not refer to any variables other than those+          -- in 'args' +        = -- trace ("PATTERN RULE SOLVE: " ++ show (mv, tm, env, bindLams args (substEnv env tm))) $ +          checkCycle bnames (mv, eta [] $ bindLams args (substEnv env tm))+      where rigid (V i) = True+            rigid (P _ t _) = t `elem` map fst env &&+                              not (holeIn env t || t `elem` holes)+            rigid _ = False++            getV (V i) = Just i+            getV _ = Nothing++            getname (P _ n _) = Just n+            getname _ = Nothing++            containsOnly args vs (V i) = i `elem` vs+            containsOnly args vs (P Bound n ty) +                   = n `elem` args && containsOnly args vs ty+            containsOnly args vs (P _ n ty) +                   = not (holeIn env n || n `elem` holes)+                        && containsOnly args vs ty+            containsOnly args vs (App _ f a) +                   = containsOnly args vs f && containsOnly args vs a+            containsOnly args vs (Bind _ b sc) +                   = containsOnly args vs (binderTy b) &&+                     containsOnly args (0 : map (+1) vs) sc+            containsOnly args vs _ = True++            bindLams [] tm = tm+            bindLams (a : as) tm = bindLam a (bindLams as tm)++            bindLam (V i) tm = Bind (fst (env !! i)) +                                    (Lam (binderTy (snd (env !! i)))) +                                    tm+            bindLam (P _ n ty) tm = Bind n (Lam ty) tm+            bindLam _ tm = error "Can't happen [non rigid bindLam]"++            substEnv [] tm = tm+            substEnv ((n, t) : env) tm +                = substEnv env (substV (P Bound n (binderTy t)) tm)++            -- remove any unnecessary lambdas (helps with type class+            -- resolution later).+            eta ks (Bind n (Lam ty) sc) = eta ((n, ty) : ks) sc+            eta ks t = rebind ks t++            rebind ((n, ty) : ks) (App _ f (P _ n' _))+                | n == n' = eta ks f+            rebind ((n, ty) : ks) t = rebind ks (Bind n (Lam ty) t)+            rebind _ t = t++    un' env fn bnames appx@(App _ _ _) appy@(App _ _ _)+        = unApp env fn bnames appx appy --         = uplus (unApp fn bnames appx appy) --                 (unifyTmpFail appx appy) -- take the whole lot -    un' fn bnames x (Bind n (Lam t) (App _ y (P Bound n' _)))-        | n == n' = un' False bnames x y-    un' fn bnames (Bind n (Lam t) (App _ x (P Bound n' _))) y-        | n == n' = un' False bnames x y-    un' fn bnames x (Bind n (Lam t) (App _ y (V 0)))-        = un' False bnames x y-    un' fn bnames (Bind n (Lam t) (App _ x (V 0))) y-        = un' False bnames x y---     un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy)---         = un' False ((x,y):bnames) sx sy---     un' fn bnames (Bind x (PVTy _) sx) (Bind y (PVTy _) sy)---         = un' False ((x,y):bnames) sx sy+    un' env fn bnames x (Bind n (Lam t) (App _ y (P Bound n' _)))+        | n == n' = un' env False bnames x y+    un' env fn bnames (Bind n (Lam t) (App _ x (P Bound n' _))) y+        | n == n' = un' env False bnames x y+    un' env fn bnames x (Bind n (Lam t) (App _ y (V 0)))+        = un' env False bnames x y+    un' env fn bnames (Bind n (Lam t) (App _ x (V 0))) y+        = un' env False bnames x y+--     un' env fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy)+--         = un' env False ((x,y):bnames) sx sy+--     un' env fn bnames (Bind x (PVTy _) sx) (Bind y (PVTy _) sy)+--         = un' env False ((x,y):bnames) sx sy      -- f D unifies with t -> D. This is dubious, but it helps with type     -- class resolution for type classes over functions. -    un' fn bnames (App _ f x) (Bind n (Pi i t k) y)+    un' env fn bnames (App _ f x) (Bind n (Pi i t k) y)       | noOccurrence n y && injectiveApp f-        = do ux <- un' False bnames x y-             uf <- un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))+        = do ux <- un' env False bnames x y+             uf <- un' env False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))                                       (Bind n (Pi i t k) (V 1)))-             combine bnames ux uf+             combine env bnames ux uf -    un' fn bnames (Bind n (Pi i t k) y) (App _ f x)+    un' env fn bnames (Bind n (Pi i t k) y) (App _ f x)       | noOccurrence n y && injectiveApp f-        = do ux <- un' False bnames y x-             uf <- un' False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))+        = do ux <- un' env False bnames y x+             uf <- un' env False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))                                     (Bind n (Pi i t k) (V 1))) f-             combine bnames ux uf+             combine env bnames ux uf -    un' fn bnames (Bind x bx sx) (Bind y by sy)+    un' env fn bnames (Bind x bx sx) (Bind y by sy)         | sameBinder bx by-           = do h1 <- uB bnames bx by-                h2 <- un' False (((x,y),binderTy bx):bnames) sx sy-                combine bnames h1 h2+           = do h1 <- uB env bnames bx by+                h2 <- un' ((x, bx) : env) False (((x,y),binderTy bx):bnames) sx sy+                combine env bnames h1 h2       where sameBinder (Lam _) (Lam _) = True             sameBinder (Pi i _ _) (Pi i' _ _) = True             sameBinder _ _ = False -- never unify holes/guesses/etc-    un' fn bnames x y+    un' env fn bnames x y         | OK True <- convEq' ctxt holes x y = do sc 1; return []         | isUniverse x && isUniverse y = do sc 1; return []         | otherwise = do UI s f <- get@@ -480,11 +513,11 @@                            else do put (UI s ((x, y, True, env, err, from, Unify) : f))                                    return [] -- lift $ tfail err -    unApp fn bnames appx@(App _ fx ax) appy@(App _ fy ay)+    unApp env fn bnames appx@(App _ fx ax) appy@(App _ fy ay)         -- shortcut for the common case where we just want to check the         -- arguments are correct          | (injectiveApp fx && fx == fy)-         = un' False bnames ax ay+         = un' env False bnames ax ay          | (injectiveApp fx && injectiveApp fy)         || (injectiveApp fx && metavarApp fy && ax == ay)         || (injectiveApp fy && metavarApp fx && ax == ay)@@ -493,18 +526,18 @@               -- fail quickly if the heads are disjoint               checkHeads headx heady               uplus-                (do hf <- un' True bnames fx fy+                (do hf <- un' env True bnames fx fy                     let ax' = hnormalise hf ctxt env (substNames hf ax)                     let ay' = hnormalise hf ctxt env (substNames hf ay)-                    ha <- un' False bnames ax' ay'+                    ha <- un' env False bnames ax' ay'                     sc 1-                    combine bnames hf ha)-                (do ha <- un' False bnames ax ay+                    combine env bnames hf ha)+                (do ha <- un' env False bnames ax ay                     let fx' = hnormalise ha ctxt env (substNames ha fx)                     let fy' = hnormalise ha ctxt env (substNames ha fy)-                    hf <- un' False bnames fx' fy'+                    hf <- un' env False bnames fx' fy'                     sc 1-                    combine bnames hf ha)+                    combine env bnames hf ha)        | otherwise = unifyTmpFail appx appy       where hnormalise [] _ _ t = t             hnormalise ns ctxt env t = normalise ctxt env t@@ -522,8 +555,8 @@             unArgs as (x : xs) (y : ys)                 = do let x' = hnormalise as ctxt env (substNames as x)                      let y' = hnormalise as ctxt env (substNames as y)-                     as' <- un' False bnames x' y'-                     vs <- combine bnames as as'+                     as' <- un' env False bnames x' y'+                     vs <- combine env bnames as as'                      unArgs vs xs ys              numArgs tm = let (f, args) = unApply tm in length args@@ -589,21 +622,22 @@                        lift $ tfail err  -    uB bnames (Let tx vx) (Let ty vy)-        = do h1 <- un' False bnames tx ty-             h2 <- un' False bnames vx vy+    uB env bnames (Let tx vx) (Let ty vy)+        = do h1 <- un' env False bnames tx ty+             h2 <- un' env False bnames vx vy              sc 1-             combine bnames h1 h2-    uB bnames (Guess tx vx) (Guess ty vy)-        = do h1 <- un' False bnames tx ty-             h2 <- un' False bnames vx vy+             combine env bnames h1 h2+    uB env bnames (Guess tx vx) (Guess ty vy)+        = do h1 <- un' env False bnames tx ty+             h2 <- un' env False bnames vx vy              sc 1-             combine bnames h1 h2-    uB bnames (Lam tx) (Lam ty) = do sc 1; un' False bnames tx ty-    uB bnames (Pi _ tx _) (Pi _ ty _) = do sc 1; un' False bnames tx ty-    uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty-    uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty-    uB bnames x y = do UI s f <- get+             combine env bnames h1 h2+    uB env bnames (Lam tx) (Lam ty) = do sc 1; un' env False bnames tx ty+    uB env bnames (Pi _ tx _) (Pi _ ty _) = do sc 1; un' env False bnames tx ty+    uB env bnames (Hole tx) (Hole ty) = un' env False bnames tx ty+    uB env bnames (PVar tx) (PVar ty) = un' env False bnames tx ty+    uB env bnames x y +                  = do UI s f <- get                        let r = recoverable (normalise ctxt env (binderTy x))                                            (normalise ctxt env (binderTy y))                        let err = cantUnify from r (topx, xfrom) (topy, yfrom)@@ -638,20 +672,15 @@                         App MaybeHoles (Bind y (Lam ty) (bind (i-1) ns tm))                             (P Bound x ty) -    combineArgs bnames args = ca [] args where-       ca acc [] = return acc-       ca acc (x : xs) = do x' <- combine bnames acc x-                            ca x' xs--    combine bnames as [] = return as-    combine bnames as ((n, t) : bs)+    combine env bnames as [] = return as+    combine env bnames as ((n, t) : bs)         = case lookup n as of-            Nothing -> combine bnames (as ++ [(n,t)]) bs-            Just t' -> do ns <- un' False bnames t t'+            Nothing -> combine env bnames (as ++ [(n,t)]) bs+            Just t' -> do ns <- un' env False bnames t t'                           -- make sure there's n mapping from n in ns                           let ns' = filter (\ (x, _) -> x/=n) ns                           sc 1-                          combine bnames as (ns' ++ bs)+                          combine env bnames as (ns' ++ bs)  boundVs :: Int -> Term -> [Int] boundVs i (V j) | j < i = []@@ -719,10 +748,14 @@     | (P (DCon _ _ _) _ _, _) <- unApply f = False     | (P (TCon _ _) _ _, _) <- unApply f = False     | (Constant _) <- f = False+    | TType _ <- f = False+    | UType _ <- f = False recoverable (Bind _ (Pi _ _ _) sc) f     | (P (DCon _ _ _) _ _, _) <- unApply f = False     | (P (TCon _ _) _ _, _) <- unApply f = False     | (Constant _) <- f = False+    | TType _ <- f = False+    | UType _ <- f = False recoverable (Bind _ (Lam _) sc) f = recoverable sc f recoverable f (Bind _ (Lam _) sc) = recoverable f sc recoverable x y = True
src/Idris/Coverage.hs view
@@ -54,16 +54,16 @@ genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm] genClauses fc n xs given    = do i <- getIState-        let lhs_tms = map (\x -> delab' i x True True) xs+        let lhs_tms = map (\x -> flattenArgs $ delab' i x True True) xs         -- if a placeholder was given, don't bother generating cases for it         let lhs_tms' = zipWith mergePlaceholders lhs_tms -                          (map (stripUnmatchable i) given)+                          (map (stripUnmatchable i) (map flattenArgs given))         let lhss = map pUnApply lhs_tms'          let argss = transpose lhss         let all_args = map (genAll i) argss         logLvl 5 $ "COVERAGE of " ++ show n-        logLvl 5 $ show lhss+        logLvl 5 $ show (lhs_tms, lhss)         logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)         logLvl 10 $ show argss ++ "\n" ++ show all_args         logLvl 3 $ "Original: \n" ++@@ -89,8 +89,12 @@             | (f, args) <- unApply term = map (\t -> delab' i t True True) args             | otherwise = [] -        pUnApply (PApp _ _ args) = map getTm args+        pUnApply (PApp _ f args) = map getTm args         pUnApply _ = []++        flattenArgs (PApp fc (PApp _ f as) as') +             = flattenArgs (PApp fc f (as ++ as'))+        flattenArgs t = t          -- Return whether the given clause matches none of the input clauses         -- (xs)
src/Idris/DeepSeq.hs view
@@ -6,6 +6,10 @@ import Idris.Docstrings import Idris.Core.TT import Idris.AbsSyntaxTree+import Idris.Colours+import IRTS.Lang (PrimFn(..))+import IRTS.CodegenCommon (OutputType (..))+import Util.DynamicLinker  import Control.DeepSeq @@ -18,6 +22,285 @@ instance NFData CT.Options where   rnf (CT.Options x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () +instance NFData ConsoleWidth where+  rnf InfinitelyWide = ()+  rnf (ColsWide x) = rnf x `seq` ()+  rnf AutomaticWidth = ()++instance NFData PrimFn where+    rnf (LPlus x) = rnf x `seq` ()+    rnf (LMinus x) = rnf x `seq` ()+    rnf (LTimes x) = rnf x `seq` ()+    rnf (LUDiv x) = rnf x `seq` ()+    rnf (LSDiv x) = rnf x `seq` ()+    rnf (LURem x) = rnf x `seq` ()+    rnf (LSRem x) = rnf x `seq` ()+    rnf (LAnd x) = rnf x `seq` ()+    rnf (LOr x) = rnf x `seq` ()+    rnf (LXOr x) = rnf x `seq` ()+    rnf (LCompl x) = rnf x `seq` ()+    rnf (LSHL x) = rnf x `seq` ()+    rnf (LLSHR x) = rnf x `seq` ()+    rnf (LASHR x) = rnf x `seq` ()+    rnf (LEq x) = rnf x `seq` ()+    rnf (LLt x) = rnf x `seq` ()+    rnf (LLe x) = rnf x `seq` ()+    rnf (LGt x) = rnf x `seq` ()+    rnf (LGe x) = rnf x `seq` ()+    rnf (LSLt x) = rnf x `seq` ()+    rnf (LSLe x) = rnf x `seq` ()+    rnf (LSGt x) = rnf x `seq` ()+    rnf (LSGe x) = rnf x `seq` ()+    rnf (LSExt x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+    rnf (LZExt x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+    rnf (LTrunc x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+    rnf (LStrConcat) = ()+    rnf (LStrLt) = ()+    rnf (LStrEq) = ()+    rnf (LStrLen) = ()+    rnf (LIntFloat x) = rnf x `seq` ()+    rnf (LFloatInt x) = rnf x `seq` ()+    rnf (LIntStr x) = rnf x `seq` ()+    rnf (LStrInt x) = rnf x `seq` ()+    rnf (LFloatStr) = ()+    rnf (LStrFloat) = ()+    rnf (LChInt x) = rnf x `seq` ()+    rnf (LIntCh x) = rnf x `seq` ()+    rnf (LBitCast x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+    rnf (LFExp) = ()+    rnf (LFLog) = ()+    rnf (LFSin) = ()+    rnf (LFCos) = ()+    rnf (LFTan) = ()+    rnf (LFASin) = ()+    rnf (LFACos) = ()+    rnf (LFATan) = ()+    rnf (LFSqrt) = ()+    rnf (LFFloor) = ()+    rnf (LFCeil) = ()+    rnf (LFNegate) = ()+    rnf (LStrHead) = ()+    rnf (LStrTail) = ()+    rnf (LStrCons) = ()+    rnf (LStrIndex) = ()+    rnf (LStrRev) = ()+    rnf (LStrSubstr) = ()+    rnf (LReadStr) = ()+    rnf (LWriteStr) = ()+    rnf (LSystemInfo) = ()+    rnf (LFork) = ()+    rnf (LPar) = ()+    rnf (LExternal x) = rnf x `seq` ()+    rnf (LNoOp) = ()++instance NFData SyntaxRules where+    rnf (SyntaxRules xs) = rnf xs `seq` ()++instance NFData DynamicLib where+    rnf (Lib x _) = rnf x `seq` ()+++instance NFData Opt where+    rnf (Filename str) = rnf  str `seq` ()+    rnf (Quiet) = ()+    rnf (NoBanner) = ()+    rnf (ColourREPL bool) = rnf  bool `seq` ()+    rnf (Idemode) = ()+    rnf (IdemodeSocket) = ()+    rnf (ShowLibs) = ()+    rnf (ShowLibdir) = ()+    rnf (ShowIncs) = ()+    rnf (ShowPkgs) = ()+    rnf (NoBasePkgs) = ()+    rnf (NoPrelude) = ()+    rnf (NoBuiltins) = ()+    rnf (NoREPL) = ()+    rnf (OLogging i) = rnf  i `seq` ()+    rnf (Output str) = rnf  str `seq` ()+    rnf (Interface) = ()+    rnf (TypeCase) = ()+    rnf (TypeInType) = ()+    rnf (DefaultTotal) = ()+    rnf (DefaultPartial) = ()+    rnf (WarnPartial) = ()+    rnf (WarnReach) = ()+    rnf (EvalTypes) = ()+    rnf (DesugarNats) = ()+    rnf (NoCoverage) = ()+    rnf (ErrContext) = ()+    rnf (ShowImpl) = ()+    rnf (Verbose) = ()+    rnf (Port str) = rnf  str `seq` ()+    rnf (IBCSubDir str) = rnf  str `seq` ()+    rnf (ImportDir str) = rnf  str `seq` ()+    rnf (PkgBuild str) = rnf  str `seq` ()+    rnf (PkgInstall str) = rnf  str `seq` ()+    rnf (PkgClean str) = rnf  str `seq` ()+    rnf (PkgCheck str) = rnf  str `seq` ()+    rnf (PkgREPL str) = rnf  str `seq` ()+    rnf (PkgMkDoc str) = rnf  str `seq` ()+    rnf (PkgTest str) = rnf  str `seq` ()+    rnf (PkgIndex fp) = rnf  fp `seq` ()+    rnf (WarnOnly) = ()+    rnf (Pkg str) = rnf  str `seq` ()+    rnf (BCAsm str) = rnf  str `seq` ()+    rnf (DumpDefun str) = rnf  str `seq` ()+    rnf (DumpCases str) = rnf  str `seq` ()+    rnf (UseCodegen cg) = rnf  cg `seq` ()+    rnf (CodegenArgs str) = rnf  str `seq` ()+    rnf (OutputTy ot) = rnf  ot `seq` ()+    rnf (Extension le) = rnf  le `seq` ()+    rnf (InterpretScript str) = rnf  str `seq` ()+    rnf (EvalExpr str) = rnf  str `seq` ()+    rnf (TargetTriple str) = rnf  str `seq` ()+    rnf (TargetCPU str) = rnf  str `seq` ()+    rnf (OptLevel i) = rnf  i `seq` ()+    rnf (AddOpt o) = rnf  o `seq` ()+    rnf (RemoveOpt o) = rnf  o `seq` ()+    rnf (Client str) = rnf  str `seq` ()+    rnf (ShowOrigErr) = ()+    rnf (AutoWidth) = ()+    rnf (AutoSolve) = ()+    rnf (UseConsoleWidth cw) = rnf  cw `seq` ()+    rnf (DumpHighlights) = ()+++instance NFData TIData where+    rnf TIPartial = ()+    rnf (TISolution xs) = rnf xs `seq` ()++instance NFData IOption where+    rnf (IOption+         opt_logLevel+         opt_typecase+         opt_typeintype+         opt_coverage+         opt_showimp+         opt_errContext+         opt_repl+         opt_verbose+         opt_nobanner+         opt_quiet+         opt_codegen+         opt_outputTy+         opt_ibcsubdir+         opt_importdirs+         opt_triple+         opt_cpu+         opt_cmdline+         opt_origerr+         opt_autoSolve+         opt_autoImport+         opt_optimise+         opt_printdepth+         opt_evaltypes+         opt_desugarnats) =+         rnf opt_logLevel+         `seq` rnf opt_typecase+         `seq` rnf opt_typeintype+         `seq` rnf opt_coverage+         `seq` rnf opt_showimp+         `seq` rnf opt_errContext+         `seq` rnf opt_repl+         `seq` rnf opt_verbose+         `seq` rnf opt_nobanner+         `seq` rnf opt_quiet+         `seq` rnf opt_codegen+         `seq` rnf opt_outputTy+         `seq` rnf opt_ibcsubdir+         `seq` rnf opt_importdirs+         `seq` rnf opt_triple+         `seq` rnf opt_cpu+         `seq` rnf opt_cmdline+         `seq` rnf opt_origerr+         `seq` rnf opt_autoSolve+         `seq` rnf opt_autoImport+         `seq` rnf opt_optimise+         `seq` rnf opt_printdepth+         `seq` rnf opt_evaltypes+         `seq` rnf opt_desugarnats+         `seq` ()++instance NFData LanguageExt where+    rnf TypeProviders = ()+    rnf ErrorReflection = ()+    +instance NFData Optimisation where+    rnf PETransform = ()++instance NFData ColourTheme where+    rnf (ColourTheme keywordColour+                     boundVarColour+                     implicitColour+                     functionColour+                     typeColour+                     dataColour+                     promptColour+                     postulateColour) =+        rnf keywordColour+        `seq` rnf boundVarColour+        `seq` rnf implicitColour+        `seq` rnf functionColour+        `seq` rnf typeColour+        `seq` rnf dataColour+        `seq` rnf promptColour+        `seq` rnf postulateColour+        `seq` ()++instance NFData IdrisColour where+  rnf (IdrisColour _ x2 x3 x4 x5) = rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()++instance NFData OutputType where+    rnf Raw = ()+    rnf Object = ()+    rnf Executable = ()+    rnf MavenProject = ()++instance NFData IBCWrite where+    rnf (IBCFix fixDecl) = rnf fixDecl `seq` ()+    rnf (IBCImp name) = rnf name `seq` ()+    rnf (IBCStatic name) = rnf name `seq` ()+    rnf (IBCClass name) = rnf name `seq` ()+    rnf (IBCInstance b1 b2 n1 n2) = rnf b1 `seq` rnf b2 `seq` rnf n1 `seq` rnf n2 `seq` ()+    rnf (IBCDSL name) = rnf name `seq` ()+    rnf (IBCData name) = rnf name `seq` ()+    rnf (IBCOpt name) = rnf name `seq` ()+    rnf (IBCMetavar name) = rnf name `seq` ()+    rnf (IBCSyntax syntax) = rnf syntax `seq` ()+    rnf (IBCKeyword string) = rnf string `seq` ()+    rnf (IBCImport imp) = rnf imp `seq` ()+    rnf (IBCImportDir filePath) = rnf filePath `seq` ()+    rnf (IBCObj codegen filePath) = rnf codegen `seq` rnf filePath `seq` ()+    rnf (IBCLib codegen string) = rnf codegen `seq` rnf string `seq` ()+    rnf (IBCCGFlag codegen string) = rnf codegen `seq` rnf string `seq` ()+    rnf (IBCDyLib string) = rnf string `seq` ()+    rnf (IBCHeader codegen string) = rnf codegen `seq` rnf string `seq` ()+    rnf (IBCAccess name accessibility) = rnf name `seq` rnf accessibility `seq` ()+    rnf (IBCMetaInformation name metaInformation) = rnf name `seq` rnf metaInformation `seq` ()+    rnf (IBCTotal name totality) = rnf name `seq` rnf totality `seq` ()+    rnf (IBCFlags name fnOpts) = rnf name `seq` rnf fnOpts `seq` ()+    rnf (IBCFnInfo name fnInfo) = rnf name `seq` rnf fnInfo `seq` ()+    rnf (IBCTrans name terms) = rnf name `seq` rnf terms `seq` ()+    rnf (IBCErrRev terms) = rnf terms `seq` ()+    rnf (IBCCG name) = rnf name `seq` ()+    rnf (IBCDoc name) = rnf name `seq` ()+    rnf (IBCCoercion name) = rnf name `seq` ()+    rnf (IBCDef name) = rnf name `seq` ()+    rnf (IBCNameHint names) = rnf names `seq` ()+    rnf (IBCLineApp filePath int pTerm) = rnf filePath `seq` rnf int `seq` rnf pTerm `seq` ()+    rnf (IBCErrorHandler name) = rnf name `seq` ()+    rnf (IBCFunctionErrorHandler n1 n2 n3) = rnf n1 `seq` rnf n2 `seq` rnf n3 `seq` ()+    rnf (IBCPostulate name) = rnf name `seq` ()+    rnf (IBCExtern extern) = rnf extern `seq` ()+    rnf (IBCTotCheckErr fc string) = rnf fc `seq` rnf string `seq` ()+    rnf (IBCParsedRegion fc) = rnf fc `seq` ()+    rnf (IBCModDocs name) = rnf name `seq` ()+    rnf (IBCUsage usage) = rnf usage `seq` ()+    rnf (IBCExport name) = rnf name `seq` ()+    rnf (IBCAutoHint n1 n2) = rnf n1 `seq` rnf n2 `seq` ()+    rnf (IBCRecord x) = rnf x `seq` ()++ instance NFData a => NFData (D.Block a) where   rnf (D.Para lines) = rnf lines `seq` ()   rnf (D.Header i lines) = rnf i `seq` rnf lines `seq` ()@@ -270,7 +553,7 @@         rnf (PNoImplicits x1) = rnf x1 `seq` ()         rnf (PQuasiquote x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PUnquote x1) = rnf x1 `seq` ()-        rnf (PQuoteName x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+        rnf (PQuoteName x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()         rnf (PRunElab x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()         rnf (PConstSugar x1 x2) = rnf x1 `seq` rnf x2 `seq` () @@ -346,6 +629,10 @@           = rnf x1 `seq`               rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` () +instance NFData RecordInfo where+        rnf (RI x1 x2 x3)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+ instance NFData OptInfo where         rnf (Optimise x1 x2)           = rnf x1 `seq` rnf x2 `seq` ()@@ -390,3 +677,18 @@                   rnf x4 `seq`                     rnf x5 `seq`                       rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` ()++instance NFData OutputMode where+  rnf (RawOutput x) = () -- no instance for Handle, so this is a bit wrong+  rnf (IdeMode x y) = rnf x `seq` ()+++instance NFData IState where+  rnf (IState x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 +              x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40+              x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60+              x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73)+     = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` () `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` rnf x14 `seq` rnf x15 `seq` rnf x16 `seq` rnf x17 `seq` rnf x18 `seq` rnf x19 `seq` rnf x20 `seq`+       rnf x21 `seq` rnf x22 `seq` rnf x23 `seq` rnf x24 `seq` rnf x25 `seq` rnf x26 `seq` rnf x27 `seq` rnf x28 `seq` rnf x29 `seq` rnf x30 `seq` rnf x31 `seq` rnf x32 `seq` rnf x33 `seq` rnf x34 `seq` rnf x35 `seq` rnf x36 `seq` rnf x37 `seq` rnf x38 `seq` rnf x39 `seq` rnf x40 `seq`+       rnf x41 `seq` rnf x42 `seq` rnf x43 `seq` rnf x44 `seq` rnf x45 `seq` rnf x46 `seq` rnf x47 `seq` rnf x48 `seq` rnf x49 `seq` rnf x50 `seq` rnf x51 `seq` rnf x52 `seq` rnf x53 `seq` rnf x54 `seq` rnf x55 `seq` rnf x56 `seq` rnf x57 `seq` rnf x58 `seq` rnf x59 `seq` rnf x60 `seq`+       rnf x61 `seq` rnf x62 `seq` rnf x63 `seq` rnf x64 `seq` rnf x65 `seq` rnf x66 `seq` rnf x67 `seq` rnf x68 `seq` rnf x69 `seq` rnf x70 `seq` rnf x71 `seq` rnf x72 `seq` rnf x73 `seq` ()
src/Idris/Delaborate.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}-module Idris.Delaborate (annName, bugaddr, delab, delab', delabMV, delabSugared, delabTy, delabTy', fancifyAnnots, pprintDelab, pprintDelabTy, pprintErr, resugar) where+module Idris.Delaborate (annName, bugaddr, delab, delab', delabMV, delabSugared, delabTy, delabTy', fancifyAnnots, pprintDelab, pprintNoDelab, pprintDelabTy, pprintErr, resugar) where  -- Convert core TT back into high level syntax, primarily for display -- purposes.@@ -226,6 +226,10 @@ pprintDelab ist tm = annotate (AnnTerm [] tm)                               (prettyIst ist (delabSugared ist tm)) +pprintNoDelab :: IState -> Term -> Doc OutputAnnotation+pprintNoDelab ist tm = annotate (AnnTerm [] tm)+                              (prettyIst ist (delab ist tm))+ -- | Pretty-print the type of some name pprintDelabTy :: IState -> Name -> Doc OutputAnnotation pprintDelabTy i n@@ -355,8 +359,11 @@ pprintErr' i (CantMatch t) =   text "Can't match on" <+> annTm t (pprintTerm i (delabSugared i t)) pprintErr' i (IncompleteTerm t) -    = align (cat (punctuate (comma <> space) -            (map pprintIncomplete (nub $ getMissing [] [] t))))+    = let missing = getMissing [] [] t in+          case missing of+            [] -> text "Incomplete term" <+> annTm t (pprintTerm i (delabSugared i t))+            _ -> align (cat (punctuate (comma <> space) +                       (map pprintIncomplete (nub $ getMissing [] [] t))))  where     pprintIncomplete (tm, arg)     | expname arg
src/Idris/Docs.hs view
@@ -41,6 +41,10 @@                         [PTerm] -- subclasses                         [PTerm] -- superclasses                         (Maybe (FunDoc' d)) -- explicit constructor+             | RecordDoc Name d -- record docs+                         (FunDoc' d) -- data constructor docs+                         [FunDoc' d] -- projection docs+                         [(Name, PTerm, Maybe d)] -- parameters with type and doc              | NamedInstanceDoc Name (FunDoc' d) -- name is class              | ModDoc [String] -- Module name                       d@@ -209,6 +213,33 @@          then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty (showDoc ist) md) params)          else hsep (punctuate comma (map (prettyName True False params' . fst) params)) +pprintDocs ist (RecordDoc n doc ctor projs params)+  = nest 4 (text "Record" <+> prettyName True (ppopt_impl ppo) [] n <>+             if nullDocstring doc+                then empty+                else line <>+                     renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) doc)+    -- Parameters+    <$> (if null params+            then empty+            else line <> nest 4 (text "Parameters:" <$> prettyParameters) <> line)+    -- Constructor+    <$> nest 4 (text "Constructor:" <$> pprintFDWithoutTotality ist False ctor)+    -- Projections+    <$> nest 4 (text "Projections:" <$> vsep (map (pprintFDWithoutTotality ist False) projs))+  where+    ppo = ppOptionIst ist+    infixes = idris_infixes ist++    pNames  = [n | (n,_,_) <- params]+    params' = zip pNames (repeat False)++    prettyParameters =+      if any isJust [d | (_,_,d) <- params]+         then vsep (map (\(n,pt,d) -> prettyParam (n,pt) <+> maybe empty (showDoc ist) d) params)+         else hsep (punctuate comma (map prettyParam [(n,pt) | (n,pt,_) <- params]))+    prettyParam (n,pt) = prettyName True False params' n <+> text ":" <+> pprintPTerm ppo params' [] infixes pt+ pprintDocs ist (NamedInstanceDoc _cls doc)    = nest 4 (text "Named instance:" <$> pprintFDWithoutTotality ist True doc) @@ -234,6 +265,8 @@    = do i <- getIState         docs <- if | Just ci <- lookupCtxtExact n (idris_classes i)                      -> docClass n ci+                   | Just ri <- lookupCtxtExact n (idris_records i)+                     -> docRecord n ri                    | Just ti <- lookupCtxtExact n (idris_datatypes i)                      -> docData n ti                    | Just class_ <- classNameForInst i n@@ -295,6 +328,17 @@       = isSubclass pt     isSubclass _       = False++docRecord :: Name -> RecordInfo -> Idris Docs+docRecord n ri+  = do i <- getIState+       let docStrings = listToMaybe $ lookupCtxt n $ idris_docstrings i+           docstr = maybe emptyDocstring fst docStrings+           params = map (\(pn,pt) -> (pn, pt, docStrings >>= (lookup (nsroot pn) . snd)))+                        (record_parameters ri)+       pdocs <- mapM docFun (record_projections ri)+       ctorDocs <- docFun $ record_constructor ri+       return $ RecordDoc n docstr ctorDocs pdocs params  docFun :: Name -> Idris FunDoc docFun n
src/Idris/Elab/Clause.hs view
@@ -162,7 +162,7 @@                  simpleCase tcase (UnmatchedCase "Error") reflect CompileTime fc inacc atys pdef erInfo            cov <- coverage            pmissing <--                   if cov && not (hasDefault cs)+                   if cov && not (hasDefault pats_raw)                       then do missing <- genClauses fc n (map getLHS pdef) cs_full                               -- missing <- genMissing n scargs sc                               missing' <- filterM (checkPossible info fc True n) missing@@ -291,10 +291,20 @@     depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)     depat acc x = (acc, x) -    hasDefault cs | (PClause _ _ last _ _ _ :_) <- reverse cs-                  , (PApp fn s args) <- last = all ((==Placeholder) . getTm) args++    getPVs (Bind x (PVar _) tm) = let (vs, tm') = getPVs tm+                                  in (x:vs, tm')+    getPVs tm = ([], tm)++    isPatVar vs (P Bound n _) = n `elem` vs+    isPatVar _ _ = False++    hasDefault cs | (Right (lhs, rhs) : _) <- reverse cs+                  , (pvs, tm) <- getPVs (explicitNames lhs)+                  , (f, args) <- unApply tm = all (isPatVar pvs) args     hasDefault _ = False +     getLHS (_, l, _) = l      simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y)@@ -491,6 +501,8 @@                     = t { getTm = PRef NoFC [] n } : addP sc ts          addP (Bind n _ sc) (t : ts) = t : addP sc ts          addP _ ts = ts+propagateParams i ps t tm@(PApp fc ap args)+     = PApp fc (propagateParams i ps t ap) args propagateParams i ps t (PRef fc hls n)      = case lookupCtxt n (idris_implicits i) of             [is] -> let ps' = filter (isImplicit is) ps in@@ -543,11 +555,15 @@         let fn_is = case lookupCtxt fname (idris_implicits i) of                          [t] -> t                          _ -> []-        let params = getParamsInType i [] fn_is (normalise ctxt [] fn_ty)+        let norm_ty = normalise ctxt [] fn_ty+        let params = getParamsInType i [] fn_is norm_ty+        let tcparams = getTCParamsInType i [] fn_is norm_ty+         let lhs = mkLHSapp $ stripLinear i $ stripUnmatchable i $-                    propagateParams i params fn_ty (addImplPat i lhs_in)+                    propagateParams i params norm_ty (addImplPat i lhs_in) --         let lhs = mkLHSapp $  --                     propagateParams i params fn_ty (addImplPat i lhs_in)+        logLvl 10 (show (params, fn_ty) ++ " " ++ showTmImpls (addImplPat i lhs_in))         logLvl 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs)         logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++                   "\n" ++ show (fn_ty, fn_is))@@ -576,7 +592,8 @@         -- If we're inferring metavariables in the type, don't recheck,         -- because we're only doing this to try to work out those metavariables         (clhs_c, clhsty) <- if not inf-                               then recheckC fc id [] lhs_tm+                               then recheckC_borrowing False (PEGenerated `notElem` opts)+                                                       [] fc id [] lhs_tm                                else return (lhs_tm, lhs_ty)         let clhs = normalise ctxt [] clhs_c         let borrowed = borrowedNames [] clhs@@ -634,7 +651,7 @@                     (do pbinds ist lhs_tm                         -- proof search can use explicitly written names                         mapM_ addPSname (allNamesIn lhs_in)-                        mapM_ setinj (nub (params ++ inj))+                        mapM_ setinj (nub (tcparams ++ inj))                         setNextName                         (ElabResult _ _ is ctxt' newDecls highlights) <-                           errAt "right hand side of " fname@@ -678,14 +695,16 @@         logLvl 6 $ " ==> " ++ show (forget rhs')          (crhs, crhsty) <- if not inf-                             then recheckC_borrowing True borrowed fc id [] rhs'+                             then recheckC_borrowing True (PEGenerated `notElem` opts)+                                                     borrowed fc id [] rhs'                              else return (rhs', clhsty)         logLvl 6 $ " ==> " ++ showEnvDbg [] crhsty ++ "   against   " ++ showEnvDbg [] clhsty         ctxt <- getContext         let constv = next_tvar ctxt         case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of-            OK (_, cs) -> do addConstraints fc cs -                             logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs+            OK (_, cs) -> when (PEGenerated `notElem` opts) $ do+                             addConstraints fc cs +                             logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs ++ "\n" ++ show (clhsty, crhsty)                              return ()             Error e -> ierror (At fc (CantUnify False (clhsty, Nothing) (crhsty, Nothing) e [] 0))         i <- getIState
src/Idris/Elab/Record.hs view
@@ -64,6 +64,12 @@                            _ -> PDatadecl tyn NoFC tycon [(cdoc, dconsArgDocs, dconName, NoFC, dconTy, fc, [])]        elabData info rsyn doc paramDocs fc opts datadecl +       -- Keep track of the record+       let parameters = [(n,pt) | (n, _, _, pt) <- params]+       let projections = [n | (n, _, _, _, _) <- fieldsWithName]+       addRecord tyn (RI parameters dconName projections)+       addIBC (IBCRecord tyn)+        when (what /= ETypes) $ do            logLvl 1 $ "fieldsWithName " ++ show fieldsWithName            logLvl 1 $ "fieldsWIthNameAndDoc " ++ show fieldsWithNameAndDoc
src/Idris/Elab/Term.hs view
@@ -91,7 +91,7 @@                                 ptm <- get_term                                 resolveTC' True True 10 g fn ist) ivs          -         when (not pattern) $ solveAutos ist fn True+         when (not pattern) $ solveAutos ist fn False           tm <- get_term          ctxt <- get_context@@ -104,6 +104,8 @@                         "Remaining problems:\n" ++ qshow probs) $              do unify_all; matchProblems True; unifyProblems +         when (not pattern) $ solveAutos ist fn True+          probs <- get_probs          case probs of             [] -> return ()@@ -269,8 +271,9 @@         hs <- get_holes         -- If any of the autos use variables which have recently been solved,         -- have another go at solving them now.-        mapM_ (\(a, ns) -> if any (\n -> n `elem` solved) ns && head hs /= a-                              then solveAuto ist fn False a+        mapM_ (\(a, (failc, ns)) -> +                       if any (\n -> n `elem` solved) ns && head hs /= a+                              then solveAuto ist fn False (a, failc)                               else return ()) as               itm <- if not pattern then insertImpLam ina t else return t@@ -442,6 +445,7 @@ --              trace (show (map showHd as')) $               ty <- goal              case as' of+                  [] -> lift $ tfail $ NoValidAlts (map showHd as)                   [x] -> elab' ina fc x                   -- If there's options, try now, and if that fails, postpone                   -- to later.@@ -451,25 +455,31 @@                         (do movelast h                             delayElab 5 $ do                               hs <- get_holes-                              when (not (null hs)) $ do+                              when (h `elem` hs) $ do                                   focus h                                   as'' <- doPrune as'                                   case as'' of                                        [x] -> elab' ina fc x                                        _ -> tryAll (zip (map (elab' ina fc) as'')                                                          (map showHd as'')))-        where showHd (PApp _ (PRef _ _ n) _) = n+        where showHd (PApp _ (PRef _ _ (UN l)) [_, _, arg])+                 | l == txt "Delay" = showHd (getTm arg)+              showHd (PApp _ (PRef _ _ n) _) = n               showHd (PRef _ _ n) = n               showHd (PApp _ h _) = showHd h               showHd x = NErased -- We probably should do something better than this here                doPrune as = -                  do hnf_compute+                  do compute                      ty <- goal-                     let (tc, _) = unApply ty+                     let (tc, _) = unApply (unDelay ty)                      env <- get_env                      return $ pruneByType env tc ist as +              unDelay t | (P _ (UN l) _, [_, arg]) <- unApply t,+                          l == txt "Lazy'" = unDelay arg+                        | otherwise = t+                                 isAmbiguous (CantResolveAlts _) = delayok               isAmbiguous (Elaborating _ _ e) = isAmbiguous e@@ -492,20 +502,21 @@                              solveAutos ist fn False) (trySeq' deferr xs) True     elab' ina fc (PAlternative ms TryImplicit (orig : alts)) = do         env <- get_env+        compute         ty <- goal         let doelab = elab' ina fc orig         tryCatch doelab             (\err ->                  if recoverableErr err                    then -- trace ("NEED IMPLICIT! " ++ show orig ++ "\n" ++-                        --       show alts ++ "\n" ++-                        --       showQuick err) $+                        --      show alts ++ "\n" +++                        --      showQuick err) $                     -- Prune the coercions so that only the ones                     -- with the right type to fix the error will be tried!                     case pruneAlts err alts env of                          [] -> lift $ tfail err-                         alts' -> -                             try' (elab' ina fc (PAlternative [] (ExactlyOne False) alts'))+                         alts' -> do+                             try' (elab' ina fc (PAlternative ms (ExactlyOne False) alts'))                                   (lift $ tfail err) -- take error from original if all fail                                   True                    else lift $ tfail err)@@ -529,8 +540,8 @@                    _ -> filter isLend alts -- special case hack for 'Borrowed'         pruneAlts (ElaboratingArg _ _ _ e) alts env = pruneAlts e alts env         pruneAlts (At _ e) alts env = pruneAlts e alts env-        pruneAlts (NoValidAlts _) alts env = alts-        pruneAlts _ alts _ = filter isLend alts+        pruneAlts (NoValidAlts as) alts env = alts+        pruneAlts err alts _ = filter isLend alts          hasArg n env ap | isLend ap = True -- special case hack for 'Borrowed'         hasArg n env (PApp _ (PRef _ _ a) _) @@ -538,7 +549,8 @@                     Just ty -> let args = map snd (getArgTys (normalise (tt_ctxt ist) env ty)) in                                    any (fnIs n) args                     Nothing -> False-        hasArg n _ _ = False+        hasArg n env (PAlternative _ _ as) = any (hasArg n env) as+        hasArg n _ tm = False          isLend (PApp _ (PRef _ _ l) _) = l == sNS (sUN "lend") ["Ownership"]         isLend _ = False@@ -599,7 +611,6 @@                                 [] -> False                                 _ -> True             bindable (NS _ _) = False-            bindable (UN xs) = True             bindable n = implicitable n     elab' ina _ f@(PInferRef fc hls n) = elab' ina (Just fc) (PApp NoFC f [])     elab' ina fc' tm@(PRef fc hls n)@@ -969,7 +980,7 @@              let n' = metavarName (namespace info) n              attack              psns <- getPSnames-             defer unique_used n'+             n' <- defer unique_used n'              solve              highlightSource nfc (AnnName n' (Just MetavarOutput) Nothing Nothing)     elab' ina fc (PProof ts) = do compute; mapM_ (runTac True ist (elabFC info) fn) ts@@ -1045,10 +1056,9 @@               let args' = filter (\(n, _) -> n `notElem` argsDropped) args -             cname <- unique_hole' True (mkCaseName fn)-             let cname' = mkN cname---              elab' ina fc (PMetavar cname')-             attack; defer argsDropped cname'; solve+             attack+             cname' <- defer argsDropped (mkN (mkCaseName fn))+             solve               -- if the scrutinee is one of the 'args' in env, we should              -- inspect it directly, rather than adding it as a new argument@@ -1192,7 +1202,10 @@       elab' ina fc (PUnquote t) = fail "Found unquote outside of quasiquote"-    elab' ina fc (PQuoteName n nfc) =+    elab' ina fc (PQuoteName n False nfc) =+      do fill $ reflectName n+         solve+    elab' ina fc (PQuoteName n True nfc) =       do ctxt <- get_context          env <- get_env          case lookup n env of@@ -1376,7 +1389,7 @@     notImplicitable (PRef _ _ n)         | [opts] <- lookupCtxt n (idris_flags ist)             = NoImplicit `elem` opts-    notImplicitable (PAlternative _ (ExactlyOne _) as) = any notImplicitable as+    notImplicitable (PAlternative _ _ as) = any notImplicitable as     -- case is tricky enough without implicit coercions! If they are needed,     -- they can go in the branches separately.     notImplicitable (PCase _ _ _) = True@@ -1420,9 +1433,11 @@                          (PCoerced tm, _) -> tm                          (_, []) -> t                          (_, cs) -> PAlternative [] TryImplicit -                                        (t : map (mkCoerce env t) cs)+                                         (t : map (mkCoerce env t) cs)            return t'        where+         mkCoerce env (PAlternative ms aty tms) n+             = PAlternative ms aty (map (\t -> mkCoerce env t n) tms)          mkCoerce env t n = let fc = maybe (fileFC "Coercion") id (highestFC t) in                                 addImplBound ist (map fst env)                                   (PApp fc (PRef fc [] n) [pexp (PCoerced t)])@@ -1520,6 +1535,8 @@          n `elem` map fst env = Just t        | otherwise = locallyBound ts     getName (PRef _ _ n) = Just n+    getName (PApp _ (PRef _ _ (UN l)) [_, _, arg]) -- ignore Delays+       | l == txt "Delay" = getName (getTm arg)     getName (PApp _ f _) = getName f     getName (PHidden t) = getName t     getName _ = Nothing@@ -1528,18 +1545,20 @@ pruneByType env (P _ n _) ist as -- if the goal type is polymorphic, keep everything    | Nothing <- lookupTyExact n ctxt = as+-- if the goal type is a ?metavariable, keep everything+   | Just _ <- lookup n (idris_metavars ist) = as    | otherwise        = let asV = filter (headIs True n) as              as' = filter (headIs False n) as in              case as' of-               [] -> case asV of-                        [] -> as-                        _ -> asV+               [] -> asV                _ -> as'   where     ctxt = tt_ctxt ist       headIs var f (PRef _ _ f') = typeHead var f f'+    headIs var f (PApp _ (PRef _ _ (UN l)) [_, _, arg])+        | l == txt "Delay" = headIs var f (getTm arg)     headIs var f (PApp _ (PRef _ _ f') _) = typeHead var f f'     headIs var f (PApp _ f' _) = headIs var f f'     headIs var f (PPi _ _ _ _ sc) = headIs var f sc@@ -1605,21 +1624,36 @@                                                  "Can't find name" ++ show n  -- Try again to solve auto implicits-solveAuto :: IState -> Name -> Bool -> Name -> ElabD ()-solveAuto ist fn ambigok n-           = do hs <- get_holes-                tm <- get_term-                when (n `elem` hs) $ do-                  focus n-                  g <- goal-                  isg <- is_guess -- if it's a guess, we're working on it recursively, so stop-                  when (not isg) $-                    proofSearch' ist True ambigok 100 True Nothing fn [] []+solveAuto :: IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()+solveAuto ist fn ambigok (n, failc) +  = do hs <- get_holes+       when (not (null hs)) $ do+        env <- get_env+        g <- goal+        handleError cantsolve (when (n `elem` hs) $ do+                        focus n+                        isg <- is_guess -- if it's a guess, we're working on it recursively, so stop+                        when (not isg) $+                          proofSearch' ist True ambigok 100 True Nothing fn [] [])+             (lift $ Error (addLoc failc+                   (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env))))+        return ()+  where addLoc (FailContext fc f x : prev) err +           = At fc (ElaboratingArg f x +                   (map (\(FailContext _ f' x') -> (f', x')) prev) err)+        addLoc _ err = err +        cantsolve (CantSolveGoal _ _) = True+        cantsolve (InternalMsg _) = True+        cantsolve (At _ e) = cantsolve e+        cantsolve (Elaborating _ _ e) = cantsolve e+        cantsolve (ElaboratingArg _ _ _ e) = cantsolve e+        cantsolve _ = False+ solveAutos :: IState -> Name -> Bool -> ElabD () solveAutos ist fn ambigok            = do autos <- get_autos-                mapM_ (solveAuto ist fn ambigok) (map fst autos)+                mapM_ (solveAuto ist fn ambigok) (map (\(n, (fc, _)) -> (n, fc)) autos)  trivial' ist     = trivial (elab ist toplevel ERHS [] (sMN 0 "tac")) ist@@ -2322,6 +2356,7 @@           -- TODO: argument-specific error handlers go here for ElaboratingArg           handle e = do ist <- getIState                         logLvl 2 "Starting error reflection"+                        logLvl 5 (show e)                         let handlers = idris_errorhandlers ist                         applyHandlers e handlers           getFnHandlers :: Name -> Name -> Idris [Name]
src/Idris/Elab/Transform.hs view
@@ -65,7 +65,7 @@          let lhs_ty = getInferType lhs'          let newargs = pvars i lhs_tm -         (clhs_tm_in, clhs_ty) <- recheckC fc id [] lhs_tm+         (clhs_tm_in, clhs_ty) <- recheckC_borrowing False False [] fc id [] lhs_tm          let clhs_tm = renamepats pnames clhs_tm_in          logLvl 3 ("Transform LHS " ++ show clhs_tm)          logLvl 3 ("Transform type " ++ show clhs_ty)@@ -86,7 +86,7 @@          processTacticDecls info newDecls          sendHighlighting highlights -         (crhs_tm_in, crhs_ty) <- recheckC fc id [] rhs'+         (crhs_tm_in, crhs_ty) <- recheckC_borrowing False False [] fc id [] rhs'          let crhs_tm = renamepats pnames crhs_tm_in          logLvl 3 ("Transform RHS " ++ show crhs_tm)
src/Idris/Elab/Type.hs view
@@ -64,6 +64,7 @@          let ty = addImpl (imp_methods syn) i ty'           logLvl 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'+         logLvl 5 $ show "with methods " ++ show (imp_methods syn)          logLvl 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty           (ElabResult tyT' defer is ctxt' newDecls highlights, log) <-
src/Idris/Elab/Utils.hs view
@@ -16,15 +16,16 @@ import Control.Monad.State import Control.Monad import Data.List+import Data.Maybe import qualified Data.Traversable as Traversable  import Debug.Trace  import qualified Data.Map as Map -recheckC = recheckC_borrowing False []+recheckC = recheckC_borrowing False True [] -recheckC_borrowing uniq_check bs fc mkerr env t+recheckC_borrowing uniq_check addConstrs bs fc mkerr env t     = do -- t' <- applyOpts (forget t) (doesn't work, or speed things up...)          ctxt <- getContext          t' <- case safeForget t of@@ -33,8 +34,8 @@          (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs ctxt env t' t of                                    Error e -> tfail (At fc (mkerr e))                                    OK x -> return x-         logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs-         addConstraints fc cs+         logLvl 6 $ "CONSTRAINTS ADDED: " ++ show (tm, ty, cs)+         when addConstrs $ addConstraints fc cs          return (tm, ty)  iderr :: Name -> Err -> Err@@ -211,6 +212,24 @@                                  flex = getFlexInType i env fix t in                                  [x | x <- fix, not (x `elem` flex)] +getTCinj i (Bind n (Pi _ t _) sc) +    = getTCinj i t ++ getTCinj i (instantiate (P Bound n t) sc)+getTCinj i ap@(App _ f a)+    | (P _ n _, args) <- unApply ap,+      isTCName n = mapMaybe getInjName args+    | otherwise = []+  where+    isTCName n = case lookupCtxtExact n (idris_classes i) of+                      Just _ -> True+                      _ -> False+    getInjName t | (P _ x _, _) <- unApply t = Just x+                 | otherwise = Nothing+getTCinj _ _ = []++getTCParamsInType :: IState -> [Name] -> [PArg] -> Type -> [Name]+getTCParamsInType i env ps t = let params = getParamsInType i env ps t+                                   tcs = nub $ getTCinj i t in+                                   filter (flip  elem tcs) params paramNames args env [] = [] paramNames args env (p : ps)    | length args > p = case args!!p of
src/Idris/Error.hs view
@@ -147,7 +147,7 @@ warnDisamb ist (PQuasiquote tm goal) = warnDisamb ist tm >>                                        Foldable.mapM_ (warnDisamb ist) goal warnDisamb ist (PUnquote tm) = warnDisamb ist tm-warnDisamb ist (PQuoteName _ _) = return ()+warnDisamb ist (PQuoteName _ _ _) = return () warnDisamb ist (PAs _ _ tm) = warnDisamb ist tm warnDisamb ist (PAppImpl tm _) = warnDisamb ist tm warnDisamb ist (PRunElab _ tm _) = warnDisamb ist tm
src/Idris/IBC.hs view
@@ -40,7 +40,7 @@ import Codec.Archive.Zip  ibcVersion :: Word16-ibcVersion = 119+ibcVersion = 120  data IBCFile = IBCFile { ver :: Word16,                          sourcefile :: FilePath,@@ -50,6 +50,7 @@                          ibc_fixes :: ![FixDecl],                          ibc_statics :: ![(Name, [Bool])],                          ibc_classes :: ![(Name, ClassInfo)],+                         ibc_records :: ![(Name, RecordInfo)],                          ibc_instances :: ![(Bool, Bool, Name, Name)],                          ibc_dsls :: ![(Name, DSL)],                          ibc_datatypes :: ![(Name, TypeInfo)],@@ -93,7 +94,7 @@ !-}  initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] []+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] []  hasValidIBCVersion :: FilePath -> Idris Bool hasValidIBCVersion fp = do@@ -142,6 +143,7 @@                        makeEntry "ibc_fixes"  (ibc_fixes i),                        makeEntry "ibc_statics"  (ibc_statics i),                        makeEntry "ibc_classes"  (ibc_classes i),+                       makeEntry "ibc_records"  (ibc_records i),                        makeEntry "ibc_instances"  (ibc_instances i),                        makeEntry "ibc_dsls"  (ibc_dsls i),                        makeEntry "ibc_datatypes"  (ibc_datatypes i),@@ -234,6 +236,10 @@                    = case lookupCtxtExact n (idris_classes i) of                         Just v -> return f { ibc_classes = (n,v): ibc_classes f     }                         _ -> ifail "IBC write failed"+ibc i (IBCRecord n) f+                   = case lookupCtxtExact n (idris_records i) of+                        Just v -> return f { ibc_records = (n,v): ibc_records f     }+                        _ -> ifail "IBC write failed" ibc i (IBCInstance int res n ins) f                    = return f { ibc_instances = (int, res, n, ins) : ibc_instances f } ibc i (IBCDSL n) f@@ -303,7 +309,7 @@ getEntry :: (Binary b, NFData b) => b -> FilePath -> Archive -> Idris b getEntry alt f a = case findEntryByPath f a of                 Nothing -> return alt-                Just e -> return $ (force . decode . fromEntry) e+                Just e -> return $! (force . decode . fromEntry) e  process :: Bool -- ^ Reexporting            -> Archive -> FilePath -> Idris ()@@ -324,6 +330,7 @@                 pFixes =<< getEntry [] "ibc_fixes" i                 pStatics =<< getEntry [] "ibc_statics" i                 pClasses =<< getEntry [] "ibc_classes" i+                pRecords =<< getEntry [] "ibc_records" i                 pInstances =<< getEntry [] "ibc_instances" i                 pDSLs =<< getEntry [] "ibc_dsls" i                 pDatatypes =<< getEntry [] "ibc_datatypes" i@@ -442,6 +449,13 @@                                            = addDef n c' (idris_classes i) }))                     cs +pRecords :: [(Name, RecordInfo)] -> Idris ()+pRecords rs = mapM_ (\ (n, r) ->+                        do i <- getIState+                           putIState (i { idris_records+                                           = addDef n r (idris_records i) }))+                    rs+ pInstances :: [(Bool, Bool, Name, Name)] -> Idris () pInstances cs = mapM_ (\ (i, res, n, ins) -> addInstance i res n ins) cs @@ -1660,9 +1674,10 @@                                         put x2                 PUnquote x1 -> do putWord8 43                                   put x1-                PQuoteName x1 x2 -> do putWord8 44-                                       put x1-                                       put x2+                PQuoteName x1 x2 x3 -> do putWord8 44+                                          put x1+                                          put x2+                                          put x3                 PIfThenElse x1 x2 x3 x4 -> do putWord8 45                                               put x1                                               put x2@@ -1808,7 +1823,8 @@                             return (PUnquote x1)                    44 -> do x1 <- get                             x2 <- get-                            return (PQuoteName x1 x2)+                            x3 <- get+                            return (PQuoteName x1 x2 x3)                    45 -> do x1 <- get                             x2 <- get                             x3 <- get@@ -2129,6 +2145,17 @@                x5 <- get                x6 <- get                return (CI x1 x2 x3 x4 x5 [] x6)++instance Binary RecordInfo where+        put (RI x1 x2 x3)+          = do put x1+               put x2+               put x3+        get+          = do x1 <- get+               x2 <- get+               x3 <- get+               return (RI x1 x2 x3)  instance Binary OptInfo where         put (Optimise x1 x2)
src/Idris/IdrisDoc.hs view
@@ -221,6 +221,7 @@   where getFunDocs (FunDoc f)                  = [f]         getFunDocs (DataDoc f fs)              = f:fs         getFunDocs (ClassDoc _ _ fs _ _ _ _ _) = fs+        getFunDocs (RecordDoc _ _ f fs _)      = f:fs         getFunDocs (NamedInstanceDoc _ fd)     = [fd]         getFunDocs (ModDoc _ _)                = []         types (FD _ _ args t _)                = t:(map second args)@@ -594,6 +595,32 @@                          in  if (head n') `elem` opChars                                 then '(':(n' ++ ")")                                 else n'++createOtherDoc ist (RecordDoc n doc ctor projs params) = do+  H.dt ! (A.id $ toValue $ show n) $ do+    H.span ! class_ "word" $ do "record"; nbsp+    H.span ! class_ "name type"+           ! title (toValue $ show n)+           $ toHtml $ name $ nsroot n+    H.span ! class_ "type" $ do nbsp ; prettyParameters+  H.dd $ do+    (if nullDocstring doc then Empty else Docstrings.renderHtml doc)+    if not $ null params+       then H.dl $ forM_ params genParam+       else Empty+    H.dl ! class_ "decls" $ createFunDoc ist ctor+    H.dl ! class_ "decls" $ forM_ projs (createFunDoc ist)+  where name (NS n ns) = show (NS (sUN $ name n) ns)+        name n         = let n' = show n+                         in if (head n') `elem` opChars+                               then '(':(n' ++ ")")+                               else n'++        genParam (name, pt, docstring) = do+          H.dt $ toHtml $ show (nsroot name)+          H.dd $ maybe nbsp Docstrings.renderHtml docstring++        prettyParameters = toHtml $ unwords [show $ nsroot n | (n,_,_) <- params]  createOtherDoc ist (DataDoc fd@(FD n docstring args _ _) fds) = do   H.dt ! (A.id $ toValue $ show n) $ do
src/Idris/ParseExpr.hs view
@@ -226,7 +226,8 @@     update ns (PNoImplicits t) = PNoImplicits $ update ns t     update ns (PQuasiquote tm mty) = PQuasiquote (update ns tm) (fmap (update ns) mty)     update ns (PUnquote t) = PUnquote $ update ns t-    update ns (PQuoteName n fc) = uncurry PQuoteName (updateB ns (n, fc))+    update ns (PQuoteName n res fc) = let (n', fc') = (updateB ns (n, fc))+                                      in PQuoteName n' res fc'     update ns (PRunElab fc t nsp) = PRunElab fc (update ns t) nsp     update ns (PConstSugar fc t) = PConstSugar fc $ update ns t     -- PConstSugar probably can't contain anything substitutable, but it's hard to track@@ -736,15 +737,19 @@  -} namequote :: SyntaxInfo -> IdrisParser PTerm-namequote syn = do startFC <- symbolFC "`{"+namequote syn = do (startFC, res) <-+                     try (do fc <- symbolFC "`{{"+                             return (fc, False)) <|>+                       (do fc <- symbolFC "`{"+                           return (fc, True))                    (n, nfc) <- fnName-                   endFC <- symbolFC "}"+                   endFC <- if res then symbolFC "}" else symbolFC "}}"                    mapM_ (uncurry highlightP)                          [ (startFC, AnnKeyword)                          , (endFC, AnnKeyword)                          , (spanFC startFC endFC, AnnQuasiquote)                          ]-                   return $ PQuoteName n nfc+                   return $ PQuoteName n res nfc                 <?> "quoted name"
src/Idris/Primitives.hs view
@@ -15,6 +15,8 @@ import Data.Function (on) import qualified Data.Vector.Unboxed as V +import Debug.Trace+ data Prim = Prim { p_name  :: Name,                    p_type  :: Type,                    p_arity :: Int,@@ -165,6 +167,8 @@     (2, LStrIndex) partial,    Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)     (1, LStrRev) total,+   Prim (sUN "prim__strSubstr") (ty [AType (ATInt ITNative), AType (ATInt ITNative), StrType] StrType) 3 (p_strSubstr)+    (3, LStrSubstr) total,     Prim (sUN "prim__readString") (ty [WorldType] StrType) 1 (p_cantreduce)      (1, LReadStr) total, -- total is okay, because we have 'WorldType'@@ -493,7 +497,7 @@ p_floatFloor = p_fPrim (fromInteger . floor) p_floatCeil = p_fPrim (fromInteger . ceiling) -p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev :: [Const] -> Maybe Const+p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev, p_strSubstr :: [Const] -> Maybe Const p_strLen [Str xs] = Just $ I (length xs) p_strLen _ = Nothing p_strHead [Str (x:xs)] = Just $ Ch x@@ -507,6 +511,9 @@ p_strCons _ = Nothing p_strRev [Str xs] = Just $ Str (reverse xs) p_strRev _ = Nothing+p_strSubstr [I offset, I length, Str input] = Just $ Str (take length (drop offset input))+p_strSubstr _ = Nothing+  p_cantreduce :: a -> Maybe b p_cantreduce _ = Nothing
src/Idris/ProofSearch.hs view
@@ -165,12 +165,23 @@             if ambigok || argsok then                case lookupCtxt nroot (idris_tyinfodata ist) of                     [TISolution ts] -> findInferredTy ts-                    _ -> psRec rec maxDepth [] S.empty-               else do ptm <- get_term-                       autoArg (sUN "auto") -- not enough info in the type yet+                    _ -> if ambigok then psRec rec maxDepth [] S.empty+                            -- postpone if it fails early in elaboration+                            else handleError cantsolve+                                      (psRec rec maxDepth [] S.empty)+                                      (autoArg (sUN "auto"))+               else autoArg (sUN "auto") -- not enough info in the type yet   where     findInferredTy (t : _) = elab (delab ist (toUN t))  +    cantsolve (InternalMsg _) = True+    cantsolve (CantSolveGoal _ _) = True+    cantsolve (IncompleteTerm _) = True+    cantsolve (At _ e) = cantsolve e+    cantsolve (Elaborating _ _ e) = cantsolve e+    cantsolve (ElaboratingArg _ _ _ e) = cantsolve e+    cantsolve err = False+     conArgsOK ty        = let (f, as) = unApply ty in            case f of@@ -206,7 +217,7 @@        | Constant _ <- c = not (n `elem` hs)     -- if fa is a metavariable applied to anything, we're not ready to run yet.     notHole hs (fa, c)-       | (P _ fn _, args) <- unApply fa = fn `notElem` hs+       | (P _ fn _, args@(_:_)) <- unApply fa = fn `notElem` hs     notHole _ _ = True      inHS hs (P _ n _) = n `elem` hs
src/Idris/Prover.hs view
@@ -127,9 +127,13 @@            _ -> return ()  elabStep :: ElabState EState -> ElabD a -> Idris (a, ElabState EState)-elabStep st e = case runStateT eCheck st of-                     OK (a, st') -> return (a, st')-                     Error a -> ierror a+elabStep st e =+    case runStateT eCheck st of+        OK ((a, ctxt'), ES (ps, est@EState{new_tyDecls = declTodo}) x old) ->+          do setContext ctxt'+             processTacticDecls toplevel declTodo+             return (a, ES (ps, est {new_tyDecls = []}) x old)+        Error a -> ierror a   where eCheck = do res <- e                     matchProblems True                     unifyProblems@@ -138,7 +142,7 @@                          [] -> do tm <- get_term                                   ctxt <- get_context                                   lift $ check ctxt [] (forget tm)-                                  return res+                                  return (res, ctxt)                          ((_,_,_,_,e,_,_):_) -> lift $ Error e  dumpState :: IState -> [(Name, Type, Term)] -> ProofState -> Idris ()@@ -264,6 +268,7 @@ undoElab prf env st [] = ifail "Nothing to undo" undoElab prf env st (h:hs) = do (prf', env', st') <- undoStep prf env st h                                 return (prf', env', st', hs)+  elabloop :: Name -> Bool -> String -> [String] -> ElabState EState -> [ElabShellHistory] -> Maybe History -> [(Name, Type, Term)] -> Idris (Term, [String]) elabloop fn d prompt prf e prev h env
src/Idris/REPL.hs view
@@ -327,10 +327,13 @@                                    reverse unused)]      runIO . hPutStrLn h $ IdeMode.convSExp "return" good id runIdeModeCommand h id orig fn mods (IdeMode.LoadFile filename toline) =+  -- The $!! here prevents a space leak on reloading.+  -- This isn't a solution - but it's a temporary stopgap.+  -- See issue #2386   do i <- getIState      clearErr-     putIState (orig { idris_options = idris_options i,-                       idris_outputmode = (IdeMode id h) })+     putIState $!! orig { idris_options = idris_options i,+                          idris_outputmode = (IdeMode id h) }      mods <- loadInputs [filename] toline      isetPrompt (mkPrompt mods)      -- Report either success or failure@@ -490,12 +493,23 @@              if null underNSs && null names                 then iPrintError "Invalid or empty namespace"                 else do ist <- getIState-                        let msg = (IdeMode.SymbolAtom "ok", (underNSs, map (pn ist) names))+                        underNs <- mapM pn names+                        let msg = (IdeMode.SymbolAtom "ok", (underNSs, underNs))                         runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id-  where pn ist = displaySpans .-                 renderPretty 0.9 1000 .-                 fmap (fancifyAnnots ist True) .-                 prettyName True True []+  where pn n =+          do ctxt <- getContext+             ist <- getIState+             return $+               displaySpans .+               renderPretty 0.9 1000 .+               fmap (fancifyAnnots ist True) $+                 prettyName True False [] n <>+                 case lookupTyExact n ctxt of+                   Just t ->+                     space <> colon <> space <> align (group (pprintDelab ist t))+                   Nothing ->+                     empty+ runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) =   do ctxt <- getContext      ist <- getIState@@ -675,17 +689,23 @@             Failure err ->   do iputStrLn $ show (fixColour c err)                                 return (Just inputs)             Success (Right Reload) ->-                do putIState $ orig { idris_options = idris_options i-                                    , idris_colourTheme = idris_colourTheme i-                                    , imported = imported i-                                    }+                -- The $!! here prevents a space leak on reloading.+                -- This isn't a solution - but it's a temporary stopgap.+                -- See issue #2386+                do putIState $!! orig { idris_options = idris_options i+                                      , idris_colourTheme = idris_colourTheme i+                                      , imported = imported i+                                      }                    clearErr                    mods <- loadInputs inputs Nothing                    return (Just mods)             Success (Right (Load f toline)) ->-                do putIState orig { idris_options = idris_options i-                                  , idris_colourTheme = idris_colourTheme i-                                  }+                -- The $!! here prevents a space leak on reloading.+                -- This isn't a solution - but it's a temporary stopgap.+                -- See issue #2386+                do putIState $!! orig { idris_options = idris_options i+                                      , idris_colourTheme = idris_colourTheme i+                                      }                    clearErr                    mod <- loadInputs [f] toline                    return (Just mod)@@ -735,9 +755,9 @@          let args = line ++ [fixName f]          runIO $ rawSystem editor args          clearErr-         putIState $ orig { idris_options = idris_options i-                          , idris_colourTheme = idris_colourTheme i-                          }+         putIState $!! orig { idris_options = idris_options i+                            , idris_colourTheme = idris_colourTheme i+                            }          loadInputs [f] Nothing --          clearOrigPats          iucheck@@ -788,7 +808,7 @@                       logLvl 3 $ "Raw: " ++ show (tm', ty')                       logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'                       let tmDoc = pprintDelab ist tm'-                          tyDoc = pprintDelab ist ty'+                          tyDoc =  pprintDelab ist ty'                       iPrintTermWithType tmDoc tyDoc   where perhapsForce tm | termSmallerThan 100 tm = force tm                         | otherwise = tm@@ -1246,6 +1266,9 @@ process fn (SetOpt EvalTypes)     = setEvalTypes True process fn (UnsetOpt EvalTypes)   = setEvalTypes False +process fn (SetOpt DesugarNats)   = setDesugarNats True+process fn (UnsetOpt DesugarNats) = setDesugarNats False+ process fn (SetOpt _) = iPrintError "Not a valid option" process fn (UnsetOpt _) = iPrintError "Not a valid option" process fn (SetColour ty c) = setColour ty c@@ -1499,13 +1522,13 @@            -- If it worked, load the whole thing from all the ibcs together            case errSpan inew of               Nothing ->-                do putIState (ist { idris_tyinfodata = tidata })+                do putIState $!! ist { idris_tyinfodata = tidata }                    ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles)))                    tryLoad True (mapMaybe id ibcfiles)               _ -> return ()            ist <- getIState-           putIState (ist { idris_tyinfodata = tidata,-                            idris_patdefs = patdefs })+           putIState $! ist { idris_tyinfodata = tidata,+                              idris_patdefs = patdefs }            exports <- findExports             case opt getOutput opts of@@ -1549,11 +1572,15 @@                       let tidata = idris_tyinfodata inew                       let patdefs = idris_patdefs inew                       ok <- noErrors-                      when ok $ do when (not keepstate) $ putIState ist-                                   ist <- getIState-                                   putIState (ist { idris_tyinfodata = tidata,-                                                    idris_patdefs = patdefs })-                                   tryLoad keepstate fs+                      when ok $+                        -- The $!! here prevents a space leak on reloading.+                        -- This isn't a solution - but it's a temporary stopgap.+                        -- See issue #2386+                        do when (not keepstate) $ putIState $!! ist+                           ist <- getIState+                           putIState $!! ist { idris_tyinfodata = tidata,+                                               idris_patdefs = patdefs }+                           tryLoad keepstate fs           ibc (IBC _ _) = True          ibc _ = False
src/Idris/REPLParser.hs view
@@ -260,6 +260,7 @@               <|> do discard (P.symbol "nobanner") ; return NoBanner               <|> do discard (P.symbol "warnreach"); return WarnReach               <|> do discard (P.symbol "evaltypes"); return EvalTypes+              <|> do discard (P.symbol "desugarnats"); return DesugarNats  proofArg :: (Bool -> Int -> Name -> Command) -> String -> P.IdrisParser (Either String Command) proofArg cmd name = do
src/Idris/Reflection.hs view
@@ -7,6 +7,7 @@  import Control.Applicative ((<$>), (<*>), pure) import Control.Monad (liftM, liftM2, liftM4)+import Control.Monad.State.Strict (lift) import Data.Maybe (catMaybes) import Data.List ((\\), findIndex) import qualified Data.Text as T@@ -21,6 +22,7 @@                             initEState, pairCon, pairTy) import Idris.Delaborate (delab) + data RErasure = RErased | RNotErased deriving Show  data RPlicity = RExplicit | RImplicit | RConstraint deriving Show@@ -351,6 +353,11 @@                 | f == reflm "B32" = return $ c reifyTTConstApp f (Constant c@(B64 _))                 | f == reflm "B64" = return $ c+reifyTTConstApp f v@(P _ _ _) =+    lift . tfail . Msg $+      "Can't reify the variable " +++      show v +++      " as a constant, because its value is not statically known." reifyTTConstApp f arg = fail ("Unknown reflection constant: " ++ show (f, arg))  reifyArithTy :: Term -> ElabD ArithTy
src/Pkg/Package.hs view
@@ -5,7 +5,8 @@ import System.Directory import System.Exit import System.IO-import System.FilePath ((</>), addTrailingPathSeparator, takeFileName, takeDirectory, normalise)+import System.FilePath ((</>), addTrailingPathSeparator, takeFileName,+                        takeDirectory, normalise, addExtension, hasExtension) import System.Directory (createDirectoryIfMissing, copyFile)  import Util.System@@ -118,7 +119,7 @@                rmIdx (pkgname pkgdesc)                case execout pkgdesc of                     Nothing -> return ()-                    Just s -> rmFile $ dir </> s+                    Just s -> rmExe $ dir </> s  -- | Generate IdrisDoc for package -- TODO: Handle case where module does not contain a matching namespace@@ -231,7 +232,13 @@ rmIdx :: String -> IO () rmIdx p = do let f = pkgIndex p              ex <- doesFileExist f-             when ex $ rmFile f +             when ex $ rmFile f++rmExe :: String -> IO ()+rmExe p = do+            fn <- return $ if isWindows && not (hasExtension p)+                                then addExtension p ".exe" else p+            rmFile fn  toIBCFile (UN n) = str n ++ ".ibc" toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : map str ns))
+ stack.yaml view
@@ -0,0 +1,6 @@+flags: {}+packages:+- '.'+extra-deps: +- cheapskate-0.1.0.4+resolver: nightly-2015-07-24
test/basic009/expected view
@@ -1,4 +1,13 @@ MAIN-PASS-Faulty.idr:6:7:When checking type of Faulty.fault:-Can't disambiguate name: A.num, B.C.num+Faulty.idr:7:7:When checking right hand side of fault:+Type mismatch between+        0 = 0 (Type of Refl)+and+        num = 0 (Expected type)++Specifically:+        Type mismatch between+                0+        and+                num Multiple.idr:3:1:import alias not unique: "X"
+ test/basic014/basic014.idr view
@@ -0,0 +1,44 @@+-- Test pattern unification++import Data.Vect++comp : {A : Type} -> {B : (a : A) -> Type} ->+       {C : (a : A) -> (b : B a) -> Type} ->+       (f : {a : A} -> (b : B a) -> C a b) ->+       (g : (a : A) -> B a) ->+       (a : A) -> C a (g a)+comp f g a = f (g a)++add2 : Nat -> Nat+add2 = comp S S++data Foo = MkFoo+data Bar = MkBar++foo : Foo -> Bar++bar : Bar -> Nat++baz : Foo -> Nat+baz = (comp bar foo)++comp0 : (B : Nat -> Type) -> ((n : Nat) -> B n) -> Int+comp0 _ _ = 0++test00 : Int+test00 = comp0 _ S++comp2 : (B : Nat -> Type) ->+        ((n : Nat) -> (y : B n) -> Int) -> Int+comp2 _ _ = 0++test20 : Int+test20 = comp2 _ dummy+  where+    dummy : (n : Nat) -> Vect n Int -> Int+    dummy _ _ = 0++test03 : Int+test03 = comp0 _ dummy where+    dummy : (n : Nat) -> Int -> Int+    dummy _ = \x => x
+ test/basic014/expected view
+ test/basic014/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ basic014.idr --check+rm -f *.ibc
+ test/basic015/basic015.idr view
@@ -0,0 +1,73 @@+{-+data Nat = Z | S Nat++plus : Nat -> Nat -> Nat+plus Z y = y+plus (S x) y = S (plus x y)+-}++data Vect : Nat -> Type -> Type where+     Nil  : Vect Z a+     (::) : a -> Vect k a -> Vect (S k) a++%name Vect xs, ys, zs++append : Vect n a -> Vect m a -> Vect (n + m) a+append [] ys = ys+append (x :: xs) ys = x :: append xs ys+++zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c+zipWith f [] ys = []+zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys++create_empties : Vect m (Vect 0 elem)+create_empties {m = Z} = []+create_empties {m = (S k)} = [] :: create_empties++transpose_helper : (row : Vect m elem) -> (rest_trans : Vect m (Vect k elem)) ->+                   Vect m (Vect (S k) elem)+transpose_helper [] [] = []+transpose_helper (rowval :: xs) (restrow :: ys) = (rowval :: restrow) :: transpose_helper xs ys++transpose_vec : Vect n (Vect m elem) -> Vect m (Vect n elem)+transpose_vec [] = create_empties+transpose_vec (row :: rest) = let rest_trans = transpose_vec rest in+                                  transpose_helper row rest_trans+++++++++------- A main program to read dimensions, generate and tranpose a vector++instance Functor (Vect m) where+    map m [] = []+    map m (x :: xs) = m x :: map m xs++instance Show a => Show (Vect m a) where+    show x = show (toList x)+      where+        toList : Vect m a -> List a+        toList [] = []+        toList (y :: xs) = y :: toList xs++countTo : (m : Nat) -> Vect m Int+countTo Z = []+countTo (S k) = 0 :: map (+1) (countTo k)++mkVect : (n, m : Nat) -> Vect n (Vect m Int)+mkVect Z m = []+mkVect (S k) m = countTo m :: map (map (+ cast m)) (mkVect k m)++main : IO ()+main = do putStr "Rows: "+          let r : Nat = 5 +          putStr "Columns: "+          let c : Nat = 6 +          printLn (mkVect r c)+          putStrLn "Transposed:"+          printLn (transpose_vec (mkVect r c))
+ test/basic015/expected view
@@ -0,0 +1,3 @@+Rows: Columns: [[0, 1, 2, 3, 4, 5], [6, 7, 8, 9, 10, 11], [12, 13, 14, 15, 16, 17], [18, 19, 20, 21, 22, 23], [24, 25, 26, 27, 28, 29]]+Transposed:+[[0, 6, 12, 18, 24], [1, 7, 13, 19, 25], [2, 8, 14, 20, 26], [3, 9, 15, 21, 27], [4, 10, 16, 22, 28], [5, 11, 17, 23, 29]]
+ test/basic015/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ basic015.idr -o basic015+./basic015+rm -f basic015 *.ibc
test/classes001/ClassName.idr view
@@ -21,7 +21,7 @@ test1 : twiceAString 2 = "22" test1 = Refl -test2 : twiceAString @{badShow} 2 = "hejhej"+test2 : twiceAString @{ClassName.badShow} 2 = "hejhej" test2 = Refl  
test/dsl003/DSLPi.idr view
@@ -43,5 +43,5 @@ test3 : Spec [] test3 = ForAll INT . ForAll INT . ItHolds $ Var (FS FZ) === Var FZ -test4 : test2 = test3+test4 : DSLPi.test2 = DSLPi.test3 test4 = Refl
test/effects001/test021.idr view
@@ -23,7 +23,8 @@  testFile : FileIO () () testFile = do True <- open "testFile" Read  | False => putStrLn "Error!"-              putStrLn (show !readFile)+              fcontents <- readFile+              putStrLn (show fcontents)               close               putStrLn (show !(Count :- get)) 
+ test/effects005/categoryLogger.idr view
@@ -0,0 +1,23 @@+import Effects+import Effect.Logging.Category++func : Nat -> Eff () [LOG String]+func x = do+  warn Nil $ unwords ["I do nothing with", show x]+  pure ()++doubleFunc : Nat -> Eff Nat [LOG String]+doubleFunc x = do+  logN 40 ["NumOPS"] $ unwords ["Doing the double with", show x ]+  func x+  pure (x+x)++eMain : Eff Nat [LOG String]+eMain = do+  initLogger ALL ["NumOPS"]+  doubleFunc 3++main : IO ()+main = do+   x <- run eMain+   printLn x
+ test/effects005/defaultLogger.idr view
@@ -0,0 +1,14 @@+import Effects+import Effect.Logging.Default++doubleFunc : Nat -> Eff Nat [LOG]+doubleFunc x = do+  warn $ unwords ["Doing the double with", show x ]+  pure (x+x)++main : IO ()+main = do+   x <- runInit [MkLogRes ALL] (doubleFunc 3)+   printLn x+   y <- run (doubleFunc 4)+   printLn y
− test/effects005/defaultlog.idr 
@@ -1,18 +0,0 @@-import Effects-import Effect.Logging.Default--func : Nat -> Eff () [LOG String]-func x = do-  log WARN Nil $ unwords ["I do nothing with", show x]-  pure ()--doubleFunc : Nat -> Eff Nat [LOG String]-doubleFunc x = do-  log WARN ["NumOPS"] $ unwords ["Doing the double with", show x ]-  func x-  pure (x+x)--main : IO ()-main = do-   x <- runInit [(ALL,["NumOPS"])] (doubleFunc 3)-   printLn x
test/effects005/expected view
@@ -1,5 +1,5 @@-"3 : Doing the double with 3"+WARN : Doing the double with 3 6 8-"3 : [\"NumOPS\"] : Doing the double with 3"+WARN : ["NumOPS"] : Doing the double with 3 6
test/effects005/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris $@ simplelog.idr -o simple -p effects-./simple-idris $@ defaultlog.idr -o default -p effects+idris $@ defaultLogger.idr -o default -p effects ./default-rm -f simple default *.ibc+idris $@ categoryLogger.idr -o category -p effects+./category+rm -f default category *.ibc
− test/effects005/simplelog.idr 
@@ -1,14 +0,0 @@-import Effects-import Effect.Logging.Simple--doubleFunc : Nat -> Eff Nat [LOG]-doubleFunc x = do-  log WARN $ unwords ["Doing the double with", show x ]-  pure (x+x)--main : IO ()-main = do-   x <- runInit [ALL] (doubleFunc 3)-   printLn x-   y <- runInit [OFF] (doubleFunc 4)-   printLn y
test/error003/expected view
@@ -1,2 +1,2 @@ ErrorReflection.idr:68:5:When checking right hand side of bad:-DSL type error: (t(503) => t'(504)) doesn't match ()+DSL type error: (t(504) => t'(503)) doesn't match ()
test/error004/expected view
@@ -1,6 +1,6 @@-FunErrTest.idr:35:10:When checking right hand side of badCadr1:-When checking argument cons1 to function FunErrTest.cadr:+FunErrTest.idr:35:17:When checking right hand side of badCadr1:+When checking argument cons2 to function FunErrTest.cadr:         Could not prove that [] has at least two elements.-FunErrTest.idr:38:10:When checking right hand side of badCadr2:+FunErrTest.idr:38:17:When checking right hand side of badCadr2: When checking argument cons2 to function FunErrTest.cadr:-        Could not prove that tail [1] has at least two elements.+        Could not prove that [] has at least two elements.
test/meta002/Tacs.idr view
@@ -52,7 +52,46 @@ test2 : Nat test2 = %runElab triv +obvious : Elab ()+obvious = do g <- goalType+             case g of+               `(() : Type) =>+                 do fill `(() : ())+                    solve+               `((~a, ~b) : Type) =>+                 do aH <- gensym "a"+                    bH <- gensym "b"+                    claim aH a+                    claim bH b+                    fill `(MkPair {A=~a} {B=~b} ~(Var aH) ~(Var bH))+                    solve+                    focus aH; obvious+                    focus bH; obvious+               `(Either ~a ~b) =>+                 (do h <- gensym "a"+                     claim h a+                     fill  `(Left {a=~a} {b=~b} ~(Var h))+                     solve+                     focus h; obvious) <|>+                   -- This second h didn't work at one point - this+                   -- test makes sure the fix stays fixed. The+                   -- uniquification of binder names didn't+                   -- appropriately treat quotation.+                   (do h <- gensym "a"+                       claim h b+                       fill `(Right {a=~a} {b=~b} ~(Var h))+                       solve+                       focus h; obvious) +easy : ()+easy = %runElab obvious+++easy2 : ((), ((), (Either () Void)))+easy2 = %runElab obvious+++ namespace STLC    data Ty = UNIT | ARR Ty Ty@@ -254,3 +293,4 @@     -- Tacs.idr line 247 col 14:     --     When elaborating right hand side of testElab3:     --     Unifying ty and Tacs.STLC.ARR ty t would lead to infinite value+
test/meta002/expected view
@@ -1,3 +1,3 @@-Tacs.idr:251:15:+Tacs.idr:290:15: When checking right hand side of testElab3: Unifying ty and ARR ty t would lead to infinite value
test/primitives001/expected view
@@ -1,6 +1,27 @@ 8-1 ("abc", "123") ("abc", "123") ([1, 2], [3, 4, 5]) ([1, 2], [3, 4, 5])+ello! here's the thing+22+0+用的依赖类+Idris+[]+is 是一个通用+8+is 是一个通用的依赖类型纯函数式编程语言，其类型系统与 Agda 以及 Epigram 相似。+48+Idris 是一个通用的依赖类型纯函+18++0+is is a +8+is is a general-purpose purely functional programming language with dependent types. +85+Idris is a general+18++0
+ test/primitives001/input view
@@ -0,0 +1,2 @@+Idris 是一个通用的依赖类型纯函数式编程语言，其类型系统与 Agda 以及 Epigram 相似。+Idris is a general-purpose purely functional programming language with dependent types. 
test/primitives001/run view
@@ -1,4 +1,6 @@ #!/usr/bin/env bash idris $@ test005.idr -o test005 ./test005-rm -f test005 test005.ibc+idris $@ substring.idr -o substring+./substring < input+rm -f test005 substring *.ibc
+ test/primitives001/substring.idr view
@@ -0,0 +1,58 @@+-- This is a test of the substring primitive, both in the Idris+-- evaluator and in some backend. It attempts to exercise that+-- negative indices are equivalent to 0, that it works for mixed+-- single- and multi-byte characters, and that overshooting the end+-- doesn't break things.++-- Single byte test+foo : String+foo = "Hello! here's the thing"++-- The first sentence of the Chinese wikipedia article on Idris (to+-- get mixed single-and-multibyte chars)+firstSentence : String+firstSentence = "Idris 是一个通用的依赖类型纯函数式编程语言，其类型系统与 Agda 以及 Epigram 相似。"++emptyTest : prim__strSubstr 100000 14 Main.firstSentence = ""+emptyTest = Refl++multiTest : prim__strSubstr 10 5 Main.firstSentence = "用的依赖类"+multiTest = Refl++negative : prim__strSubstr (-10) 5 Main.firstSentence = "Idris"+negative = Refl++negativeEnd : prim__strSubstr 0 (-1) Main.firstSentence = ""+negativeEnd = Refl++negativeLength : prim__strSubstr 4 (-4) Main.firstSentence = ""+negativeLength = Refl++main : IO ()+main = do putStrLn $ prim__strSubstr 1 1004 foo+          printLn $ length $ prim__strSubstr 1 1000 foo+          printLn $ length $ prim__strSubstr 1000 2 firstSentence+          putStrLn $ prim__strSubstr 10 5 firstSentence+          putStrLn $ prim__strSubstr (-10) 5 firstSentence+          putStrLn $ "[" ++ prim__strSubstr 0 (-1) firstSentence ++ "]"+          -- Multi-byte dynamic string+          input <- getLine+          putStrLn $ prim__strSubstr 3 8 input+          putStrLn $ show (length (prim__strSubstr 3 8 input))+          putStrLn $ prim__strSubstr 3 8000 input+          putStrLn $ show (length (prim__strSubstr 3 8000 input))+          putStrLn $ prim__strSubstr (-13) 18 input+          putStrLn $ show (length (prim__strSubstr (-13) 18 input))+          putStrLn $ prim__strSubstr 4 (-4) input+          putStrLn $ show (length (prim__strSubstr 4 (-4) input))+          -- Single-byte dynamic string+          input <- getLine+          putStrLn $ prim__strSubstr 3 8 input+          putStrLn $ show (length (prim__strSubstr 3 8 input))+          putStrLn $ prim__strSubstr 3 8000 input+          putStrLn $ show (length (prim__strSubstr 3 8000 input))+          putStrLn $ prim__strSubstr (-13) 18 input+          putStrLn $ show (length (prim__strSubstr (-13) 18 input))+          putStrLn $ prim__strSubstr 4 (-4) input+          putStrLn $ show (length (prim__strSubstr 4 (-4) input))+
test/primitives001/test005.idr view
@@ -8,7 +8,6 @@  main : IO () main = do printLn (abs (-8))-          printLn (abs (S Z))           printLn (span isAlpha tstr)           printLn (break isDigit tstr)           printLn (span (\x => x < 3) tlist)
test/primitives002/run view
@@ -2,8 +2,6 @@  HEAD='module Main -import Data.Floats- strtake : Nat -> String -> String strtake n str = pack (take n (unpack str)) 
test/proof003/test015.idr view
@@ -106,7 +106,7 @@ -- There is almost certainly an easier proof. I don't care, for now :)  Main.adc_lemma_2 = proof {-    intro w,v,num0,v1,num1,x,bx,x1,bx1,bit0,b0,bit1,b1,c,bc+    intro v,w,num0,v1,num1,x,bx,x1,bx1,bit0,b0,bit1,b1,c,bc     rewrite sym (plusZeroRightNeutral x);     rewrite sym (plusZeroRightNeutral v1);     rewrite sym (plusZeroRightNeutral (plus (plus x v) v1));
+ test/proofsearch001/expected view
+ test/proofsearch001/proofsearch001.idr view
@@ -0,0 +1,11 @@+%default total++class C a (f : Bool -> Bool) | a where {}+instance C Int Bool.not where {}++foo : C Int g => {auto pf : g True = False} -> Unit+foo = ()++main : IO ()+main = printLn $ foo -- {pf = Refl}+
+ test/proofsearch001/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --check proofsearch001.idr+rm -f *.ibc
+ test/proofsearch002/Process.idr view
@@ -0,0 +1,443 @@+module Process++import System.Concurrency.Raw+import public Data.List -- public, to get proof search machinery++%access public++-- Process IDs are parameterised by their interface. A request of type+-- 'iface t' will get a response of type 't'+data ProcID : (iface : Type -> Type) -> Type where+     MkPID : Ptr -> ProcID iface++data ServerID : Type where+     MkServer : ProcID iface -> ServerID++implicit MkServer' : ProcID iface -> ServerID+MkServer' = MkServer++data Replied = YesR | NoR++data ReqHandle = MkReqH Nat++-- Current state of a process includes:+--   * the servers it currently has an open connection to+--   * the number of clients it currently has connected+--   * whether it has responded to a request yet++-- Therefore, we can write process types which make clear that a process+-- cannot quit while it is talking to a server, or while it still has clients+-- expecting to communicate with it, or if it has not serviced any requests.+data ProcState : Type where+     MkProcState : (servers : List ServerID) -> +                   (clients : Nat) ->+                   Replied ->+                   ProcState ++data Pending : ReqHandle -> List (ReqHandle, Type) -> Type -> Type where+     PendingHere : Pending h ((h, t) :: hs) t+     PendingThere : Pending h hs t -> Pending h ((h', t') :: hs) t++dropPending : (hs : List (ReqHandle, Type)) -> Pending h hs ty -> +              List (ReqHandle, Type)+dropPending ((h, t) :: xs) PendingHere = xs+dropPending ((h', t') :: xs) (PendingThere x) +     = ((h', t') :: dropPending xs x)++data ConnectedTo : ServerID -> ProcState -> Type where+     IsConnectedTo : Elem p servers -> +                     ConnectedTo p (MkProcState servers c reply)++data NoClient : ProcState -> Type where+     IsNoClient : NoClient (MkProcState servers 0 reply)++data OneClient : ProcState -> Type where+     IsOneClient : OneClient (MkProcState servers (S k) reply)++data Reply : ProcState -> Type where+     IsReply : Reply (MkProcState s c YesR)++data NoReply : ProcState -> Type where+     IsNoReply : NoReply (MkProcState s c NoR)++{-- Some useful operations on process state --}+newClient : ProcState -> ProcState +newClient (MkProcState servers clients r) +         = MkProcState servers (S clients) r++setClients : ProcState -> Nat -> ProcState +setClients (MkProcState servers clients r) k +          = MkProcState servers k r++newServer : ProcID iface -> ProcState -> ProcState +newServer p (MkProcState servers clients r) +           = MkProcState (MkServer p :: servers) clients r++dropServer : (pid : ProcID iface) -> (p : ProcState) -> +             ConnectedTo (MkServer pid) p -> ProcState+dropServer pid (MkProcState servers c r) (IsConnectedTo prf) +         = MkProcState (dropElem servers prf) c r++{-+pendingReq : ProcID iface -> (h : ReqHandle) -> iface t -> +             ProcState hs -> ProcState ((h, t) :: hs)+pendingReq {t} p h x (MkProcState s c r) = MkProcState s c r++doneReq : ProcState hs -> (p : Pending h hs) -> ProcState (dropPending hs p)+doneReq (MkProcState s c r) p = MkProcState s c r+-}++replied : ProcState -> ProcState +replied (MkProcState servers clients r) +        = MkProcState servers clients YesR++resetReplied : ProcState -> ProcState+resetReplied (MkProcState servers clients r) +        = MkProcState servers clients NoR++runningServer : Nat -> ProcState+runningServer c = MkProcState [] (S c) NoR++doneServer : ProcState +doneServer = MkProcState [] 0 YesR++init : List ServerID -> ProcState +init s = MkProcState s 0 NoR++{-- Processes themselves.++A process returns some type 'a', responds to requests on the interface+'iface', and has an input and output state.+--}+mutual+  data Process : (a : Type) -> (iface : Type -> Type) -> +                 List (ReqHandle, Type) -> (a -> List (ReqHandle, Type)) ->+                 ProcState -> (a -> ProcState) ->+                 Type where+     -- Some plumbing+     Lift' : IO a -> Process a iface hs (const hs) p (const p)+     Pure : a -> Process a iface hs (const hs) p (const p)+     Quit : a -> Process a iface hs (const hs) p (const (resetReplied p))++     bind : Process a iface hs hs' p p' -> +            ((x : a) -> Process b iface (hs' x) hs'' (p' x) p'') ->+            Process b iface hs hs'' p p''++     Fork : Process () serveri [] (const []) (runningServer 1) (const doneServer) ->+            Process (ProcID serveri) iface hs (const hs) p (\res => (newServer res p))+     Work : (worker : (pid : ProcID iface) -> Worker [pid] ()) ->+            (waiter : Process t iface hs (const hs) (runningServer 1) (const doneServer)) ->+            Process t iface hs (const hs) p (const p)++     Request : (r : ProcID serveri) -> (x : serveri ty) ->+               {auto connected : ConnectedTo (MkServer r) p} ->+               Process ReqHandle iface +                       hs (\h => (h, ty) :: hs)+                       p (const p)++     GetReply : (h : ReqHandle) ->+                {auto pending : Pending h hs ty} ->+                Process ty iface +                        hs (const (dropPending hs pending))+                        p (const p)++     TimeoutRespond : (timeout : Int) ->+                      (def : res) ->+                      ({t : Type} -> (x : iface t) -> +                                     Response (t, res) iface hs p) ->+                      Process res iface hs (const hs) p (const (replied p))++     Respond : ({t : Type} -> (x : iface t) -> +                              Response (t, res) iface hs p) ->+               Process res iface hs (const hs) p (const (replied p))++     Connect : (r : ProcID serveri) -> +               Process Bool iface +                       hs (const hs)+                       p (\ok => case ok of+                                      True => newServer r p+                                      False => p)++     Disconnect : (r : ProcID serveri) ->+                  {auto connected : ConnectedTo (MkServer r) p} ->+                  Process () iface +                          hs (const hs)+                          p (const (dropServer r p connected))++     CountClients : Process Nat iface hs (const hs) p (\n => setClients p n)++     -- FIXME: The process had better be guaranteed to change the system+     -- state (e.g. finish with a YesR since it starts with a NoR) because+     -- then it can't be used in a Respond, so responding can't loop.+     Loop : Inf (Process t iface hs hs' (resetReplied p) p') -> +            Process t iface hs hs' p p'++  -- 'Running a iface' is the type of a process which is currently+  -- responding to requests (i.e. knows it has at least one client connected)+  -- and will not exit unless there are no clients connected+  Running : Type -> (iface : Type -> Type) -> Type+  Running a iface = {k : Nat} -> Process a iface [] (const []) (runningServer k) (const doneServer)++  Response : Type -> (iface : Type -> Type) -> List (ReqHandle, Type) ->+                     ProcState -> Type+  Response a iface hs p =  Process a iface hs (const hs) p (const p)++  -- 'Program a' is the type of a process which does not respond to any requests+  -- and begins and ends with no connections to any server open.+  Program : Type -> (iface : Type -> Type) -> Type+  Program a iface = Process a iface [] (const []) (init []) (const (init []))++  -- 'Connected s a' is the type of a process which does not respond to any +  -- requests and begins and ends with connections to a given server list. +  Connected : List ServerID -> Type -> Type+  Connected s a = Process a (const Void) [] (const []) (init s) (const (init s))++  -- 'Worker s a' is the type of a process which does not respond to any +  -- requests, and begins with a connection to a server it is to send a+  -- notification to.+  Worker : List ServerID -> Type -> Type+  Worker s a = Process a (const Void) [] (const []) (init s) (const (init []))++implicit +Lift : IO a -> Process a iface hs (const hs) p (const p) +Lift = Lift'+     +%no_implicit -- helps error messages, and speeds things up a bit +%inline -- so that the productivity checker treats 'bind' as a constructor!+(>>=) : Process a iface hs hs' p p' -> +        ((x : a) -> Process b iface (hs' x) hs'' (p' x) p'') ->+        Process b iface hs hs'' p p''+(>>=) = bind++TrySend : (proc : ProcID iface) -> iface ty -> +          Process (Maybe ty) iface' +                  hs (const hs)+                  (MkProcState s c r) (const (MkProcState s c r))+TrySend pid req = do True <- Connect pid | False => Pure Nothing+                     h <- Request pid req+                     resp <- GetReply h+                     Disconnect pid+                     Pure (Just resp)++Send : (proc : ProcID iface) -> iface ty -> +       {auto prf : Elem (MkServer proc) s} ->+       Process ty iface'+               hs (const hs)+               (MkProcState s c r) (const (MkProcState s c r))+Send pid req = do h <- Request pid req+                  GetReply h++{--- evaluator --}++-- The evaluator keeps track of the number of client connections open,+-- and manages Connect/Disconnect requests by managing them whenever a+-- 'Respond' or 'TimeoutRespond' is encountered.++data MessageQ : (Type -> Type) -> Type where+     ConnectMsg : MessageQ iface+     CloseMsg : MessageQ iface+     RequestMsg : Nat -> iface t -> MessageQ iface++data MessageR : Type -> Type where+     ReplyMsg : Nat -> (ans : ty) -> MessageR ty++data Message : (Type -> Type) -> List (ReqHandle, Type) -> Type where+     MsgQuery : MessageQ iface -> Message iface hs+     MsgReply : (reply : MessageR ty) -> Message iface hs++readMsg : IO (Maybe (Ptr, Message iface hs))+readMsg {iface} {hs} = +   do if !checkMsgs+      then do msg <- getMsgWithSender {a = Message iface hs}+              pure (Just msg)+      else pure Nothing++readMsgTimeout : Int -> IO (Maybe (Ptr, Message iface hs))+readMsgTimeout {iface} {hs} i = +   do if !(checkMsgsTimeout i)+      then do msg <- getMsgWithSender {a = Message iface hs}+              pure (Just msg)+      else pure Nothing++data RespEnv : List (ReqHandle, Type) -> Type where+     Nil : RespEnv []+     (::) : Maybe ty -> RespEnv hs -> RespEnv ((h, ty) :: hs)++record EvalState (iface : Type -> Type) (hs : List (ReqHandle, Type)) where+  constructor MkEvalState+  queue : List (Ptr, MessageQ iface)+  reply : RespEnv hs +  clients : Nat+  nexthandle : Nat++lookup : Pending h hs ty -> RespEnv hs -> Maybe ty+lookup PendingHere (x :: xs) = x +lookup (PendingThere p) (x :: xs) = lookup p xs++dropResp : (pending : Pending h hs ty) -> +           RespEnv hs -> RespEnv (dropPending hs pending)+dropResp PendingHere (x :: xs) = xs+dropResp (PendingThere p) (x :: xs) = x :: dropResp p xs++updateReplies : Pending h hs ty -> ty -> RespEnv hs -> RespEnv hs+updateReplies PendingHere msg (x :: xs) = Just msg :: xs+updateReplies (PendingThere p) msg (x :: xs) = x :: updateReplies p msg xs++total+findPending : (h : ReqHandle) -> RespEnv hs -> Maybe (ty ** Pending h hs ty)+findPending {hs = []} k [] = Nothing+findPending {hs = ((MkReqH h, t) :: hs)} (MkReqH k) (x :: xs) with (decEq h k)+  findPending {hs = ((MkReqH h, t) :: hs)} (MkReqH h) (x :: xs) | (Yes Refl) +       = Just (t ** PendingHere)+  findPending {hs = ((MkReqH h, t) :: hs)} (MkReqH k) (x :: xs) | (No contra) +       = do (ty' ** p') <- findPending (MkReqH k) xs+            Just (ty' ** PendingThere p')++covering+updateQueue : EvalState iface hs -> IO (EvalState iface hs)+updateQueue {iface} {hs} st +  = case !(readMsg {iface} {hs}) of+         Nothing => pure st+         Just (pid, MsgQuery msg) => +              updateQueue (record { queue = queue st ++ [(pid, msg)] } st)+         Just (pid, MsgReply (ReplyMsg rq ans)) => +              case findPending (MkReqH rq) (reply st) of+                   Nothing => updateQueue {iface} {hs} st -- can't happen!+                   Just (ty ** pend) => +                        updateQueue (record { reply = updateReplies pend (believe_me ans) (reply st) } st)++-- Keep updating the queue with incoming messages until either we get a +-- RequestMsg, or we reach a timeout.+covering+updateQueueTimeout : Int -> EvalState iface hs -> IO (EvalState iface hs)+updateQueueTimeout {iface} {hs} i st +  = case !(readMsgTimeout {iface} {hs} i) of+         Nothing => pure st+         Just (pid, MsgQuery (RequestMsg rq msg)) => +              pure (record { queue = queue st ++ [(pid, RequestMsg rq msg)] } st)+         Just (pid, MsgQuery msg) => do+              -- TODO: Why not update client count here too?+              updateQueueTimeout i (record { queue = queue st ++ [(pid, msg)] } st)+         Just (pid, MsgReply (ReplyMsg rq ans)) => +              case findPending (MkReqH rq) (reply st) of+                   Nothing => updateQueueTimeout i {iface} {hs} st -- can't happen!+                   Just (ty ** pend) => +                        updateQueueTimeout i (record { reply = updateReplies pend (believe_me ans) (reply st) } st)++total+removeReq : List (Ptr, MessageQ iface) -> List (Ptr, MessageQ iface) -> +             Maybe (Ptr, (ty ** (Nat, iface ty)), List (Ptr, MessageQ iface))+removeReq acc [] = Nothing+removeReq acc ((pid, RequestMsg rq m) :: xs) = Just (pid, (_ ** (rq, m)), reverse acc ++ xs)+removeReq acc (x :: xs) = removeReq (x :: acc) xs++total+removeConn : Nat ->+             List (Ptr, MessageQ iface) -> List (Ptr, MessageQ iface) -> +             (Nat, List (Ptr, MessageQ iface))+removeConn cl acc [] = (cl, reverse acc)+removeConn cl acc ((pid, ConnectMsg) :: xs) +     = removeConn (cl + 1) acc xs+removeConn cl acc ((pid, CloseMsg) :: xs) +     = removeConn (minus cl 1) acc xs+removeConn cl acc (x :: xs) = removeConn cl (x :: acc) xs++-- Remove the first thing in the event list which is a request, if it+-- exists.+getRequest :  EvalState iface hs -> Maybe (Ptr, (ty ** (Nat, iface ty)), EvalState iface hs)+getRequest (MkEvalState queue reply clients nh) +     = do (pid, req, queue') <- removeReq [] queue+          return (pid, req, MkEvalState queue' reply clients nh)++countClients : EvalState iface hs -> (Nat, EvalState iface hs)+countClients (MkEvalState queue reply clients nh) +     = let (clients', queue') = removeConn clients [] queue in+           (clients', MkEvalState queue' reply clients' nh)++-- sendResponse : Ptr -> +--                (ty -> EvalState iface hs -> IO a) -> +--                (x, ty) -> EvalState iface hs -> +--                IO a+-- sendResponse {iface} {hs} pid k (resp, val) st = do+--        sendToThread pid (MsgReply {hs} {iface} ?prf (ReplyMsg resp))+--        k val st++covering+eval : EvalState iface hs -> +       {p : ProcState} -> {p' : ty -> ProcState} ->+       Process ty iface hs hs' p p' ->+       ((res : ty) -> EvalState iface (hs' res) -> IO a) -> IO a+eval st (Lift' x) k = do x' <- x+                         k x' st+eval st (Pure x) k = k x st+eval st (Quit x) k = k x st+eval st (bind x f) k = eval st x (\x', st' => eval st' (f x') k)++eval st (Fork proc) k +        = do ptr <- fork (eval (MkEvalState [] [] 1 0) proc (\_, _ => pure ()))+             k (MkPID ptr) st ++eval st (Work proc cont) k +        = do ptr <- fork (eval (MkEvalState [] [] 0 0) (proc (MkPID prim__vm))+                               (\_, _ => pure ()))+             eval (record { clients = clients st + 1 } st) cont k++eval {hs} (MkEvalState q reqs c nh) (Request (MkPID pid) x) k+     = do sendToThread pid (MsgQuery {hs} (RequestMsg nh x))+          k (MkReqH nh) (MkEvalState q (Nothing :: reqs) c (S nh))++eval {p} st (GetReply {pending} h) k +      = do -- Need to keep receiving messages until there's a response +           -- available+           MkEvalState q reqs c nh <- updateQueue st+           case lookup pending reqs of+                Nothing => do checkMsgsTimeout 1+                              eval {p} (MkEvalState q reqs c nh) (GetReply h) k+                Just reply => +                    k reply (MkEvalState q (dropResp pending reqs) c nh)++eval {iface} {hs} st (TimeoutRespond timeout def f) k +      = do st' <- updateQueueTimeout timeout st+           case getRequest st' of+                Nothing => k def st'+                Just (pid, (_ ** (rq, req)), st'') => do +                     eval st'' (f req) -- (sendResponse pid k) -- ?foo +                       -- this weirdness works around an erasure bug+                       -- which causes a seg fault...+                       (\ r, st''' => +                            case r of+                               (resp, val) => do+                                  sendToThread pid (MsgReply {iface} {hs} (ReplyMsg rq resp))+                                  k val st''')++eval {iface} {hs} st (Respond f) k +      = do st' <- updateQueue st+           case getRequest st' of+                Nothing => eval {iface} st' (Respond f) k+                Just (pid, (_ ** (rq, req)), st'') => do+                     eval st'' (f req) (\ (resp, val), st''' => do+                       sendToThread pid (MsgReply {iface} {hs} (ReplyMsg rq resp))+                       k val st''')++eval {hs} st (Connect {serveri} (MkPID pid)) k +     = if pid == prim__vm then k False st else do+          v <- sendToThread pid (MsgQuery {iface=serveri} {hs}+                                          ConnectMsg)+          -- TODO: Wait for ACK+          k (v == 1) st++eval {hs} st (Disconnect {serveri} (MkPID pid)) k +     = do v <- sendToThread pid (MsgQuery {iface=serveri} {hs} +                                          CloseMsg)+          k () st++eval st CountClients k +     = do st' <- updateQueue st+          let (cl, st'') = countClients st'+          k cl st''++eval st (Loop x) k = eval st x k++run : Program a iface -> IO a+run p = eval (MkEvalState [] [] 0 0) p (\res, t => pure res)+
+ test/proofsearch002/expected view
+ test/proofsearch002/proofsearch002.idr view
@@ -0,0 +1,51 @@+import Process++import Data.Vect++data Counter : Type -> Type where+     GetIdle : Counter Int+     Append : Vect n a -> Vect m a -> Counter $ Vect (n + m) a++data Maths : Type -> Type where+     Factorial : Nat -> Maths Nat++count_process : Int -> Counter t -> Response (t, Int) Counter [] p+count_process x GetIdle = Pure (x, x)+count_process x (Append xs ys) = Pure (xs ++ ys, x)++countServer : Int -> Running () Counter+countServer secs = do s' <- TimeoutRespond 1 (secs + 1) (count_process secs) +                      Loop (countServer s')++mathsServer : Running () Maths+mathsServer = do Lift $ putStrLn "Serving maths!"+                 TimeoutRespond 5 () (\val => case val of+                                                   Factorial k => +                                                        Pure (fact k, ()))+                 Loop mathsServer++instance Cast String Nat where+    cast orig = cast (the Integer (cast orig))++-- Start up a couple of servers, send them requests+testProg1 : Program () (const Void)+testProg1 = do -- with Process do +               mpid <- Fork mathsServer+               cpid <- Fork (countServer 0)+               putStr "Number1: "+               x1 <- getLine+               putStr "Number2: "+               x2 <- getLine+ +               fac1h <- Request mpid (Factorial (cast (trim x1)))+               fac2h <- Request mpid (Factorial (cast (trim x2)))++               fac2 <- GetReply fac2h -- {pending = PendingHere}+               fac1 <- GetReply fac1h -- {pending = PendingHere}++               Disconnect cpid+               Disconnect mpid++main : IO ()+main = run testProg1+
+ test/proofsearch002/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ --check proofsearch002.idr+rm -f *.ibc
+ test/proofsearch003/expected view
+ test/proofsearch003/proofsearch003.idr view
@@ -0,0 +1,34 @@+import Data.Fin++data Wrapper = Wrap (Fin 9)++data Seq : Fin 9 -> Fin 9 -> Type where+  Seq12 : {n : Fin 8} -> Seq (weaken n) (FS n)+  Seq21 : {n : Fin 8} -> Seq (FS n) (weaken n)++class Evil t where+  value : t -> Fin 9++instance Evil Wrapper where+  value (Wrap n) = n++consTest : (Evil t) => (a : t) -> (b : t) -> +           {auto p : Seq (value a) (value b)} -> Bool+consTest _ _ = True++-- Fails!+test1 : Bool+test1 = consTest (Wrap 3) (Wrap 4) -- {p = ?foo}++-- Succeeds!+test2 : Bool+test2 = consTest (Wrap 3) (Wrap 4) {p = Seq12}++-- Succeeds!+test3 : Bool+test3 = consTest (Wrap 3) (Wrap 4) {p = (| Seq12, Seq21 |)}++-- Fails!+-- test4 : Bool+-- test4 = consTest (Wrap 3) (Wrap 4) {p = (| Seq21, Seq12 |)}+
+ test/proofsearch003/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --check proofsearch003.idr +rm -f *.ibc
test/quasiquote006/quasiquote006.idr view
@@ -2,7 +2,7 @@ a : TTName a = `{Nat} -aOK : a = NS (UN "Nat") ["Nat", "Prelude"]+aOK : Main.a = NS (UN "Nat") ["Nat", "Prelude"] aOK = Refl  b : TTName@@ -17,5 +17,5 @@ d : TTName d = `{List.(::)} -dOK : d = NS (UN "::") ["List", "Prelude"]+dOK : Main.d = NS (UN "::") ["List", "Prelude"] dOK = Refl
test/reg001/reg001.idr view
@@ -1,9 +1,179 @@+-- Everything here should type check but at some point in the past has+-- not.++import Data.So+import Data.Vect+import Data.Fin+import Control.Isomorphism+ class Functor f => VerifiedFunctor (f : Type -> Type) where-   identity : (fa : f a) -> map id fa = fa+   identity : (fa : f a) -> map Basics.id fa = fa  data Imp : Type where    MkImp : {any : Type} -> any -> Imp  testVal : Imp testVal = MkImp (apply id Z)++zfin : Fin 1+zfin = 0++data Infer = MkInf a++foo : Infer+foo = MkInf (the (Fin 1) 0)++isAnyBy : (alpha -> Bool) -> (n : Nat ** Vect n alpha) -> Bool+isAnyBy _ (_ ** Nil) = False+isAnyBy p (_ ** (a :: as)) = p a || isAnyBy p (_ ** as)++filterTagP : (p  : alpha -> Bool) ->+             (as : Vect n alpha) ->+             So (isAnyBy p (n ** as)) ->+             (m : Nat ** (Vect m (a : alpha ** So (p a)), So (m > Z)))+filterTagP {n = S m} p (a :: as) q with (p a)+  | True  = (_+             **+             ((a ** believe_me Oh)+              ::+              (fst (getProof (filterTagP p as (believe_me Oh)))),+              Oh+             )+            )+  | False = filterTagP p as (believe_me Oh)++vfoldl : (P : Nat -> Type) ->+         ((x : Nat) -> P x -> a -> P (S x)) -> P Z+       -> Vect m a -> P m+vfoldl P cons nil (x :: xs)+    = vfoldl (\k => P (S k)) (\ n => cons (S n)) (cons Z nil x) xs+++total soElim            :  (C : (b : Bool) -> So b -> Type) ->+                           C True Oh                       ->+                           (b : Bool) -> (s : So b) -> (C b s)+soElim C coh True Oh  =  coh++soFalseElim             :  So False -> a+soFalseElim x           =  void (soElim C () False x)+                           where+                           C : (b : Bool) -> So b -> Type+                           C True s = ()+                           C False s = Void++soTrue                  :  So b -> b = True+soTrue {b = False} x    =  soFalseElim x+soTrue {b = True}  x    =  Refl++class Eq alpha => ReflEqEq alpha where+  reflexive_eqeq : (a : alpha) -> So (a == a)++modifyFun : (Eq alpha) =>+            (alpha -> beta) ->+            (alpha, beta) ->+            (alpha -> beta)+modifyFun f (a, b) a' = if a' == a then b else f a'++modifyFunLemma : (ReflEqEq alpha) =>+                 (f : alpha -> beta) ->+                 (ab : (alpha, beta)) ->+                 modifyFun f ab (fst ab) = snd ab+modifyFunLemma f (a,b) =+  rewrite soTrue (reflexive_eqeq a) in Refl+++Matrix : Type -> Nat -> Nat -> Type+Matrix a n m = Vect n (Vect m a)++mytranspose : Matrix a (S n) (S m) -> Matrix a (S m) (S n)+mytranspose ((x:: []) :: []) = [[x]]+mytranspose [x :: y :: xs] = [x] :: (mytranspose [y :: xs])+mytranspose (x :: y :: xs)+    = let tx = mytranspose [x] in+      let ux = mytranspose (y :: xs) in zipWith (++) tx ux++using (A : Type, B : A->Type, C : Type)+  foo2 : ((x:A) -> B x -> C) -> ((x:A ** B x) -> C)+  foo2 f p = f (getWitness p) (getProof p)+++m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) ->+        Maybe (Either Bool Int)+m_add x y = do x' <- x -- Extract value from x+               y' <- y -- Extract value from y+               case x' of+                  Left _ => Nothing+                  Right _ => Nothing++data Ty = TyBool++data Id a = I a++interpTy : Ty -> Type+interpTy TyBool = Id Bool++data Term : Ty -> Type where+  TLit : Bool -> Term TyBool+  TNot : Term TyBool -> Term TyBool++map : (a -> b) -> Id a -> Id b+map f (I x) = I (f x)++interp : Term t -> interpTy t+interp (TLit x) = I x+interp (TNot x) = map not (interp x)++data Result str a = Success str a | Failure String++instance Functor (Result str) where+   map f (Success s x) = Success s (f x)+   map f (Failure e  ) = Failure e++ParserT : (Type -> Type) -> Type -> Type -> Type+ParserT m str a = str -> m (Result str a)++ap : Monad m => ParserT m str (a -> b) -> ParserT m str a ->+                ParserT m str b+ap f x = \s => do f' <- f s+                  case f' of+                          Failure e => (pure (Failure e))+                          Success s' g => x s' >>= pure . map g++X : Nat -> Type+X t = (c : Nat ** So (c < 5))++column : X t -> Nat+column = getWitness++data Action = Left | Ahead | Right++admissible : X t -> Action -> Bool+admissible {t} x Ahead = column {t} x == 0 || column {t} x == 4+admissible {t} x Left  = column {t} x <= 2+admissible {t} x Right = column {t} x >= 2+++class Set univ where+  member : univ -> univ -> Type++isSubsetOf : Set univ => univ -> univ -> Type+isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)++class Set univ => HasPower univ where+  Powerset : (a : univ) -> +             Sigma univ (\Pa => (c : univ) ->+                                 (isSubsetOf c a) -> member c Pa)++powerset : HasPower univ => univ -> univ+powerset {univ} a = getWitness (Powerset a)++mapFilter : (alpha -> beta) ->+           (alpha -> Bool) -> +           Vect n alpha -> +           (n : Nat ** Vect n beta)+mapFilter f p Nil = (_ ** Nil)+mapFilter f p (a :: as) with (p a)+ | True  = (_  ** (f a) :: (getProof (mapFilter f p as)))+ | False = mapFilter f p as+ 
− test/reg005/expected 
− test/reg005/reg005.idr 
@@ -1,12 +0,0 @@-module reg032--import Data.Fin--zfin : Fin 1-zfin = 0--data Infer = MkInf a--foo : Infer-foo = MkInf (the (Fin 1) 0)-
− test/reg005/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg005.idr --check-rm -f *.ibc
− test/reg009/expected 
− test/reg009/reg009.lidr 
@@ -1,21 +0,0 @@-> import Data.So-> import Data.Vect--> isAnyBy : (alpha -> Bool) -> (n : Nat ** Vect n alpha) -> Bool-> isAnyBy _ (_ ** Nil) = False-> isAnyBy p (_ ** (a :: as)) = p a || isAnyBy p (_ ** as)--> filterTagP : (p  : alpha -> Bool) ->->              (as : Vect n alpha) ->->              So (isAnyBy p (n ** as)) ->->              (m : Nat ** (Vect m (a : alpha ** So (p a)), So (m > Z)))-> filterTagP {n = S m} p (a :: as) q with (p a)->   | True  = (_->              **->              ((a ** believe_me Oh)->               ::->               (fst (getProof (filterTagP p as (believe_me Oh)))),->               Oh->              )->             )->   | False = filterTagP p as (believe_me Oh)
− test/reg009/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg009.lidr --check-rm -f reg009 *.ibc
− test/reg011/expected 
− test/reg011/reg011.idr 
@@ -1,11 +0,0 @@-import Data.Vect--vfoldl : (P : Nat -> Type) ->-         ((x : Nat) -> P x -> a -> P (S x)) -> P Z-       -> Vect m a -> P m--- vfoldl P cons nil []---     = nil-vfoldl P cons nil (x :: xs)-    = vfoldl (\k => P (S k)) (\ n => cons (S n)) (cons Z nil x) xs--- vfoldl P cons nil (x :: xs)---     = vfoldl (\n => P (S n)) (\ n => cons _) (cons _ nil x) xs
− test/reg011/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg011.idr --check-rm -f *.ibc
− test/reg012/expected 
− test/reg012/reg012.lidr 
@@ -1,36 +0,0 @@-> import Data.So--> total soElim            :  (C : (b : Bool) -> So b -> Type) ->->                            C True Oh                       ->->                            (b : Bool) -> (s : So b) -> (C b s)-> soElim C coh True Oh  =  coh--> soFalseElim             :  So False -> a-> soFalseElim x           =  void (soElim C () False x)->                            where->                            C : (b : Bool) -> So b -> Type->                            C True s = ()->                            C False s = Void--> soTrue                  :  So b -> b = True-> soTrue {b = False} x    =  soFalseElim x-> soTrue {b = True}  x    =  Refl--> class Eq alpha => ReflEqEq alpha where->   reflexive_eqeq : (a : alpha) -> So (a == a)--> modifyFun : (Eq alpha) =>->             (alpha -> beta) ->->             (alpha, beta) ->->             (alpha -> beta)-> modifyFun f (a, b) a' = if a' == a then b else f a'--> modifyFunLemma : (ReflEqEq alpha) =>->                  (f : alpha -> beta) ->->                  (ab : (alpha, beta)) ->->                  modifyFun f ab (fst ab) = snd ab-> modifyFunLemma f (a,b) =->   rewrite soTrue (reflexive_eqeq a) in Refl--   replace {P = \ z => ifThenElse (a == a) b (f a) = ifThenElse z b (f a)}-           (soTrue (reflexive_eqeq a)) Refl
− test/reg012/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg012.lidr --check-rm -f *.ibc
− test/reg014/expected 
− test/reg014/reg014.idr 
@@ -1,14 +0,0 @@-module reg014--import Data.Vect--Matrix : Type -> Nat -> Nat -> Type-Matrix a n m = Vect n (Vect m a)--mytranspose : Matrix a (S n) (S m) -> Matrix a (S m) (S n)-mytranspose ((x:: []) :: []) = [[x]]-mytranspose [x :: y :: xs] = [x] :: (mytranspose [y :: xs])-mytranspose (x :: y :: xs)-    = let tx = mytranspose [x] in-      let ux = mytranspose (y :: xs) in zipWith (++) tx ux-
− test/reg014/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg014.idr --check-rm -f *.ibc
− test/reg015/expected 
− test/reg015/reg015.idr 
@@ -1,3 +0,0 @@-using (A : Type, B : A->Type, C : Type)-  foo : ((x:A) -> B x -> C) -> ((x:A ** B x) -> C)-  foo f p = f (getWitness p) (getProof p)
− test/reg015/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg015.idr --check-rm -f *.ibc
− test/reg019/expected 
− test/reg019/reg019.idr 
@@ -1,7 +0,0 @@-m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) ->-        Maybe (Either Bool Int)-m_add x y = do x' <- x -- Extract value from x-               y' <- y -- Extract value from y-               case x' of-                  Left _ => Nothing-                  Right _ => Nothing
− test/reg019/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg019.idr --check-rm -f *.ibc
− test/reg021/expected 
− test/reg021/reg021.idr 
@@ -1,22 +0,0 @@-module Main--%default total--data Ty = TyBool--data Id a = I a--interpTy : Ty -> Type-interpTy TyBool = Id Bool--data Term : Ty -> Type where-  TLit : Bool -> Term TyBool-  TNot : Term TyBool -> Term TyBool--map : (a -> b) -> Id a -> Id b-map f (I x) = I (f x)--interp : Term t -> interpTy t-interp (TLit x) = I x-interp (TNot x) = map not (interp x)-
− test/reg021/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg021.idr --check-rm -f *.ibc
− test/reg022/expected 
− test/reg022/reg022.idr 
@@ -1,18 +0,0 @@-module reg022--data Result str a = Success str a | Failure String--instance Functor (Result str) where-   map f (Success s x) = Success s (f x)-   map f (Failure e  ) = Failure e--ParserT : (Type -> Type) -> Type -> Type -> Type-ParserT m str a = str -> m (Result str a)--ap : Monad m => ParserT m str (a -> b) -> ParserT m str a ->-                ParserT m str b-ap f x = \s => do f' <- f s-                  case f' of-                          Failure e => (pure (Failure e))-                          Success s' g => x s' >>= pure . map g-
− test/reg022/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg022.idr --check-rm -f *.ibc
− test/reg026/expected 
− test/reg026/reg026.idr 
@@ -1,16 +0,0 @@-module Test--import Data.So--X : Nat -> Type-X t = (c : Nat ** So (c < 5))--column : X t -> Nat-column = getWitness--data Action = Left | Ahead | Right--admissible : X t -> Action -> Bool-admissible {t} x Ahead = column {t} x == 0 || column {t} x == 4-admissible {t} x Left  = column {t} x <= 2-admissible {t} x Right = column {t} x >= 2
− test/reg026/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg026.idr --check reg026-rm -f *.ibc
− test/reg030/expected 
− test/reg030/reg030.idr 
@@ -1,15 +0,0 @@-import Control.Isomorphism--class Set univ where-  member : univ -> univ -> Type--isSubsetOf : Set univ => univ -> univ -> Type-isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)--class Set univ => HasPower univ where-  Powerset : (a : univ) -> -             Sigma univ (\Pa => (c : univ) ->-                                 (isSubsetOf c a) -> member c Pa)--powerset : HasPower univ => univ -> univ-powerset {univ} a = getWitness (Powerset a)
− test/reg030/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg030.idr --check-rm -f *.ibc
− test/reg033/expected 
− test/reg033/reg033.idr 
@@ -1,12 +0,0 @@-import Data.Vect--mapFilter : (alpha -> beta) ->-           (alpha -> Bool) -> -           Vect n alpha -> -           (n : Nat ** Vect n beta)-mapFilter f p Nil = (_ ** Nil)-mapFilter f p (a :: as) with (p a)- | True  = (_  ** (f a) :: (getProof (mapFilter f p as)))- | False = mapFilter f p as--
− test/reg033/run 
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-idris $@ reg033.idr --check-rm -f reg033 *.ibc
test/reg041/ott.idr view
@@ -37,6 +37,6 @@ EQ (pi s t) f (pi s' t') g = pi s $ \x => pi s' $ \y => EQ s x s' y ~> EQ (t x) (f x) (t' y) (g y) EQ _ _ _ _ = zero -example : <| (id == id in (two ~> two)) |>+example : <| (Basics.id == Basics.id in (OTT.two ~> OTT.two)) |> example = ?prf 
test/reg047/reg047.idr view
@@ -3,7 +3,7 @@ data TTSigma : (A : Type) -> (B : A -> Type) -> Type where     sigma : (A : Type) -> (B : A -> Type) -> (a : A) -> B a -> TTSigma A B -data Nat = zero | succ Nat+data Nat = Zero | Succ Nat  Id : (A : Type) -> A -> A -> Type Id A = (=) {A = A} {B = A}@@ -11,8 +11,8 @@ IdRefl : (A : Type) -> (a : A) -> Id A a a IdRefl A a = Refl {x = a} -zzz : Id Nat zero zero-zzz = IdRefl Nat zero+zzz : Id Nat Zero Zero+zzz = IdRefl Nat Zero -eep : TTSigma Nat (\ a =>  Id Nat a zero)-eep = sigma Nat (\ a =>  Id Nat a zero) zero zzz+eep : TTSigma Nat (\ a =>  Id Nat a Zero)+eep = sigma Nat (\ a =>  Id Nat a Zero) Zero zzz
test/reg047/reg047a.idr view
@@ -3,7 +3,7 @@ data TTSigma : (A : Type) -> (B : A -> Type) -> Type where     sigma : (A : Type) -> (B : A -> Type) -> (a : A) -> B a -> TTSigma A B -data MNat = zero | succ MNat+data MNat = Zero | Succ MNat  Id : (A : Type) -> A -> A -> Type Id = \A,x,y => x = y --  {a = A} {b = A}@@ -11,14 +11,14 @@ IdRefl : (A : Type) -> (a : A) -> Id A a a IdRefl A a = Refl {x = a} -zzzz : Id MNat zero zero-zzzz = IdRefl MNat zero+zzzz : Id MNat Zero Zero+zzzz = IdRefl MNat Zero -eep : TTSigma MNat (\ c =>  Id MNat c zero)-eep = (sigma MNat (\b => Id MNat b zero) zero zzzz)+eep : TTSigma MNat (\ c =>  Id MNat c Zero)+eep = (sigma MNat (\b => Id MNat b Zero) Zero zzzz) -eep2 : TTSigma MNat (\ c =>  Id MNat c zero)-eep2 = (sigma MNat (\b => Id MNat b zero) zero (IdRefl MNat zero))+eep2 : TTSigma MNat (\ c =>  Id MNat c Zero)+eep2 = (sigma MNat (\b => Id MNat b Zero) Zero (IdRefl MNat Zero))   
+ test/totality010/expected view
@@ -0,0 +1,4 @@+totality010.idr:27:1:+Main.evenNotS is not total as there are missing cases+totality010.idr:30:1:+Main.bad is possibly not total due to: Main.evenNotS
+ test/totality010/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ totality010.idr --nocolour --consolewidth 80 --check+rm -f *.ibc
+ test/totality010/totality010.idr view
@@ -0,0 +1,31 @@+%default total++%default total+succNotLTE' : (LTE (S x) x) -> Void+succNotLTE' {x = Z} prf = succNotLTEzero prf+succNotLTE' {x = (S k)} (LTESucc prf) = succNotLTE' prf++succNotLTE : Not (LTE (S x) x)+succNotLTE = succNotLTE'++succNotLTE2 : Not (LTE (S x) x)+succNotLTE2 {x = Z} prf = succNotLTEzero prf+succNotLTE2 {x = (S k)} (LTESucc prf) = succNotLTE prf++-- a defective even-odd definition allows me to prove bottom++mutual+  data Even : Nat -> Type where+    ZeroEven : Even Z+    MkEven : Odd n -> Even (S n)+    MkBad  : Even n -> Even (S n)++  data Odd : Nat -> Type where+    MkOdd : Even n -> Odd (S n)++evenNotS : Even n -> Not (Even (S n))+evenNotS MkEven ZeroEven impossible++bad : Void+bad = evenNotS ZeroEven $ MkBad ZeroEven+
test/tutorial006/expected view
@@ -1,5 +1,5 @@ tutorial006a.idr:5:23-25:When checking right hand side of vapp:-When checking argument xs to constructor Data.VectType.Vect.:::+When checking argument xs to constructor Data.Vect.:::         Type mismatch between                 Vect (k + k) a (Type of vapp xs xs)         and