packages feed

idris 1.0 → 1.1.0

raw patch · 200 files changed

+5830/−3969 lines, 200 filesdep ~optparse-applicativesetup-changed

Dependency ranges changed: optparse-applicative

Files

.travis.yml view
@@ -1,3 +1,4 @@+dist: trusty sudo: false  language: c@@ -10,15 +11,6 @@   include:     - env: CABALVER="1.24" GHCVER="8.0.1" STACKVER="7.14" STYLISH=YES       addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,hscolour], sources: [hvr-ghc]}}-    - os: osx-      env: CABALVER="1.24" GHCVER="8.0.1" TESTS="test_c"-      compiler: ": #GHC 8.0.1"-    - env: CABALVER="1.20" GHCVER="7.6.3" TESTS="test_c"-      compiler: ": #GHC 7.6.3"-      addons: {apt: {packages: [cabal-install-1.20,ghc-7.6.3,cppcheck,hscolour], sources: [hvr-ghc]}}-    - env: CABALVER="1.20" GHCVER="7.8.4" TESTS="test_c"-      compiler: ": #GHC 7.8.4"-      addons: {apt: {packages: [cabal-install-1.20,ghc-7.8.4,cppcheck,hscolour], sources: [hvr-ghc]}}     - env: CABALVER="1.22" GHCVER="7.10.3" TESTS="lib_doc doc"       compiler: ": #GHC 7.10.3"       addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,cppcheck,hscolour], sources: [hvr-ghc]}}@@ -37,10 +29,6 @@     - env: CABALVER="1.24" GHCVER="8.0.1" TESTS="test_c"       compiler: ": #GHC 8.0.1"       addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,cppcheck,hscolour], sources: [hvr-ghc]}}-  allow_failures:-    - os: osx-      env: CABALVER="1.24" GHCVER="8.0.1" TESTS="test_c"-      compiler: ": #GHC 8.0.1"   fast-finish: true  cache:@@ -54,6 +42,8 @@   - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar  before_install:+  - nvm install 6+  - nvm use 6   - unset CC   - if [[ $TRAVIS_OS_NAME == 'linux' ]];     then@@ -151,7 +141,9 @@   - echo -en 'travis_fold:end:script.tests\\r' ###   - echo 'Benchmarks...' && echo -en 'travis_fold:start:script.benchmarks\\r'-  - cd benchmarks && ./build.pl && ./run.pl && cd ..+  - if [[ "$TESTS" == "test_c" ]]; then+      cd benchmarks && ./build.pl && ./run.pl && cd ..;+    fi   - echo -en 'travis_fold:end:script.benchmarks\\r' ### # EOF
CHANGELOG.md view
@@ -1,3 +1,46 @@+# New in 1.1.0++## Library Updates+++ Added `Text.PrettyPrint.WL` an implementation of the Wadler-Leijen+  Pretty-Print algorithm.  Useful for those wishing to pretty print+  things.++ Added `Text.Lexer` and `Text.Parser` to `contrib`. These are small libraries+  for implementing total lexical analysers and parsers.++ New instances:+    + Added `Catchable` for `ReaderT`, `WriterT`, and `RWST`.+    + Added `MonadTrans` for `RWST`.++ Added utility functions to `Data.SortedMap` and `Data.SortedSet` (`contrib`),+  most notably `merge`, merging two maps by their `Semigroup` op (`<+>`)++ `Prelude.WellFounded` now contains an interface `Sized a` that defines a size+  mapping from `a` to `Nat`. For example, there is an implementation for lists,+  where `size = length`.++  The function `sizeAccessible` then proves well-foundedness of the relation+  `Smaller x y = LT (size x) (size y)`, which  allows us to use strong+  induction conveniently with any type that implements `Sized`.++  In practice, this allows us to write functions that recurse not only on+  direct subterms of their arguments but on any value+  with a (strictly) smaller `size`.++  A good example of this idiom at work is `Data.List.Views.splitRec` from `base`.++ Added utility lemma `decEqSelfIsYes : decEq x x = Yes Refl` to+  `Decidable.Equality`. This is primarily useful for proving properties of+  functions defined with the help of `decEq`.++## Tool Updates+++ New JavaScript code generator that uses an higher level intermediate+  representation.+++ Various optimizations of the new JavaScript code generator.+++ Names are now annotated with their representations over the IDE+  protocol, which allows IDEs to provide commands that work on special+  names that don't have syntax, such as case block names.++ # New in 1.0  + It's about time
README.md view
@@ -3,7 +3,7 @@ [![Build Status](https://travis-ci.org/idris-lang/Idris-dev.svg?branch=master)](https://travis-ci.org/idris-lang/Idris-dev) [![Appveyor build](https://ci.appveyor.com/api/projects/status/xi8yu81oy1134g7o/branch/master?svg=true)](https://ci.appveyor.com/project/idrislang/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)+[![Hackage](https://img.shields.io/hackage/v/idris.svg)](https://hackage.haskell.org/package/idris) [![Stackage LTS](http://stackage.org/package/idris/badge/lts)](http://stackage.org/lts/package/idris) [![Stackage Nightly](http://stackage.org/package/idris/badge/nightly)](http://stackage.org/nightly/package/idris) [![IRC](https://img.shields.io/badge/IRC-%23idris-1e72ff.svg?style=flat)](https://www.irccloud.com/invite?channel=%23idris&hostname=irc.freenode.net&port=6697&ssl=1)@@ -28,9 +28,7 @@ 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 about [code generators can be found on the wiki](http://idris.readthedocs.io/en/latest/reference/codegen.html).  ## More Information
RELEASE-CHECKS.md view
@@ -26,6 +26,7 @@  + [ ] Push to GITHUB. + [ ] Upload to Hackage.++ [ ] Upload package documentation to web site  ## Binaries
Setup.hs view
@@ -274,26 +274,15 @@ -- ----------------------------------------------------------------------------- -- Test --- FIXME: We use the __GLASGOW_HASKELL__ macro because MIN_VERSION_cabal seems--- to be broken !- -- There are two "dataDir" in cabal, and they don't relate to each other. -- When fetching modules, idris uses the second path (in the pkg record), -- which by default is the root folder of the project. -- We want it to be the install directory where we put the idris libraries. fixPkg pkg target = pkg { dataDir = target } --- The "Args" argument of the testHooks has been added in cabal 1.22.0,--- and should therefore be ignored for prior versions.-#if __GLASGOW_HASKELL__ < 710-originalTestHook _ = testHook simpleUserHooks-#else-originalTestHook = testHook simpleUserHooks-#endif- idrisTestHook args pkg local hooks flags = do   let target = datadir $ L.absoluteInstallDirs pkg local NoCopyDest-  originalTestHook args (fixPkg pkg target) local hooks flags+  testHook simpleUserHooks args (fixPkg pkg target) local hooks flags  -- ----------------------------------------------------------------------------- -- Main@@ -314,9 +303,5 @@    , preSDist = idrisPreSDist    , sDistHook = idrisSDist (sDistHook simpleUserHooks)    , postSDist = idrisPostSDist-#if __GLASGOW_HASKELL__ < 710-   , testHook = idrisTestHook ()-#else    , testHook = idrisTestHook-#endif    }
appveyor.yml view
@@ -1,7 +1,7 @@ version: 1.0.{build} init: - ps: >--    choco install cabal+    choco install cabal --no-progress      mkdir C:\ghc
codegen/idris-codegen-c/Main.hs view
@@ -4,6 +4,7 @@ import Idris.Core.TT import Idris.ElabDecls import Idris.Main+import Idris.Options import IRTS.CodegenC import IRTS.Compiler
codegen/idris-codegen-javascript/Main.hs view
@@ -4,6 +4,7 @@ import Idris.Core.TT import Idris.ElabDecls import Idris.Main+import Idris.Options import IRTS.CodegenJavaScript import IRTS.Compiler
codegen/idris-codegen-node/Main.hs view
@@ -4,6 +4,7 @@ import Idris.Core.TT import Idris.ElabDecls import Idris.Main+import Idris.Options import IRTS.CodegenJavaScript import IRTS.Compiler
docs/effects/introduction.rst view
@@ -65,7 +65,7 @@    import Effect.StdIO     hello : Eff () [STDIO]-   hello = putStrLn “Hello world!”+   hello = putStrLn "Hello world!"     main : IO ()    main = run hello
docs/reference/codegen.rst view
@@ -27,16 +27,6 @@     $ idris --codegen javascript hello.idr -o hello.js  -Generating code for NodeJS is slightly different. Idris outputs a-JavaScript file that can be directly executed via node.--::--    $ idris --codegen node hello.idr -o hello-    $ ./hello-    Hello world-- Idris can produce very big chunks of JavaScript code (hello world weighs in at 1500 lines). However, the generated code can be minified using the `closure-compiler@@ -49,6 +39,16 @@  Node.js -------++Generating code for NodeJS is slightly different. Idris outputs a+JavaScript file that can be directly executed via node.++::++    $ idris --codegen node hello.idr -o hello+    $ ./hello+    Hello world+   Third Party
docs/reference/elaborator-reflection.rst view
@@ -32,6 +32,9 @@  On their own, tactics have no effect. The meta-operation ``%runElab script`` runs ``script`` in the current elaboration context.+Before you can use ``%runElab``, you will have to enable the language extension by adding+``%language ElabReflection`` in your file (or by passing ``-X ElabReflection`` to the+``idris`` executable from your command line). For example, the following script constructs the identity function at type ``Nat``:  .. code-block:: idris@@ -88,7 +91,9 @@  The interactive elaboration shell accepts a limited number of commands, including a subset of the commands understood by the normal Idris REPL-as well as some elaboration-specific commands.+as well as some elaboration-specific commands. It also supports the +``do``-syntax, meaning you can write ``res <- command`` to bind the result of +``command`` to variable ``res``.  General-purpose commands:
docs/reference/ide-protocol.rst view
@@ -45,15 +45,12 @@  The available commands include: -  ``(:load-file FILENAME)``-    Load the named file.+  ``(:load-file FILENAME [LINE])``+    Load the named file.  If a ``LINE`` number is provided, the file is only loaded up to that line.  Otherwise, the entire file is loaded.    ``(:interpret STRING)``     Interpret ``STRING`` at the Idris REPL, returning a highlighted result. -  ``(:repl-completions STRING)``-    Return the result of tab-completing ``STRING`` as a REPL command.-   ``(:type-of STRING)``     Return the type of the name, written with Idris syntax in the ``STRING``.     The reply may contain highlighting information.@@ -88,9 +85,12 @@     Attempt to fill out the holes on ``LINE`` named ``NAME`` by proof search.     ``HINTS`` is a possibly-empty list of additional things to try while searching. -  ``(:docs-for NAME)``-    Look up the documentation for ``NAME``, and return it as a highlighted string.-+  ``(:docs-for NAME [MODE])``+    Look up the documentation for ``NAME``, and return it as a highlighted string. If ``MODE`` is ``:overview``, only the first paragraph of documentation is provided for ``NAME``.  If ``MODE`` is ``:full``, or omitted, the full documentation is returned for ``NAME``.+ +  ``(:apropos STRING)``+    Search the documentation for mentions of ``STRING``, and return any found as a list of highlighted strings.+    ``(:metavariables WIDTH)``     List the currently-active holes, with their types pretty-printed with ``WIDTH`` columns. @@ -119,9 +119,9 @@     Return the definition of ``NAME`` as a highlighted string.    ``(:repl-completions NAME)``-    Search names, types and documentations which contain ``NAME``.+    Search names, types and documentations which contain ``NAME``. Return the result of tab-completing ``NAME`` as a REPL command. -  ``(:version UID)``+  ``:version``     Return the version information of the Idris compiler.
docs/reference/misc.rst view
@@ -51,7 +51,7 @@  :: -    syntax Trivial = (| oh, refl |)+    syntax Trivial = (| Oh, Refl |)   Totality checking assertions@@ -296,13 +296,13 @@     -- Base case     (Z + m = m + Z) <== plus_comm =         rewrite ((m + Z = m) <== plusZeroRightNeutral) ==>-                (Z + m = m) in refl+                (Z + m = m) in Refl      -- Step case     (S k + m = m + S k) <== plus_comm =         rewrite ((k + m = m + k) <== plus_comm) in         rewrite ((S (m + k) = m + S k) <== plusSuccRightSucc) in-            refl+            Refl  Reflection ==========
docs/reference/syntax-guide.rst view
@@ -223,7 +223,7 @@ wrapped in the ``Inf`` type constructor. This has the effect of delaying the evaluation of the second argument when the data constructor is applied. An ``Inf`` argument is constructed using ``Delay`` (which Idris will insert-implicitly) adn evaluated using ``Force`` (again inserted implicitly).+implicitly) and evaluated using ``Force`` (again inserted implicitly).  Furthermore, recursive calls under a ``Delay`` must be guarded by a constructor to pass the totality checker.@@ -387,9 +387,15 @@ ::      total-    implicit     partial     covering++Implicit Coercion+^^^^^^^^^^^^^^^^^++::++    implicit  Options ^^^^^^^
docs/st/composing.rst view
@@ -348,7 +348,7 @@     initWindow : Int -> Int -> ST m Var [add Surface]  However, this isn't quite right. It's possible that opening a window-will fail, for example if our program is running in a termina without+will fail, for example if our program is running in a terminal without a windowing system available. So, somehow, ``initWindow`` needs to cope with the possibility of failure. We can do this by returning a ``Maybe Var``, rather than a ``Var``, and only adding the ``Surface``@@ -437,7 +437,7 @@  .. code-block:: idris -  interface Draw IO where+  implementation Draw IO where     Surface = State SDLSurface      initWindow x y = do Just srf <- lift (startSDL x y)@@ -657,14 +657,14 @@ ``combine``, the target resource must exist (``comp`` here) and must be of type ``State ()``. -It is instructive to look at the types of ``split`` and combine to see+It is instructive to look at the types of ``split`` and ``combine`` to see the requirements on resource lists they work with. The type of ``split`` is the following:  .. code-block:: idris      split : (lbl : Var) -> {auto prf : InState lbl (Composite vars) res} ->-            STrans m (VarList vars) res (\ vs => mkRes vs ++ updateRes res prf (State ()))+            STrans m (VarList vars) res (\vs => mkRes vs ++ updateRes res prf (State ()))  The implicit ``prf`` argument says that the ``lbl`` being split must be a composite resource. It returns a variable list, built from the composite@@ -713,8 +713,8 @@   Line : Type   Line = ((Int, Int), (Int, Int), Col) -To implement ``start``, which creates a new ``Turtle`` (or returns ``Nothing``)-if this is impossible, we begin by initialising the drawing surface then+To implement ``start``, which creates a new ``Turtle`` (or returns ``Nothing`` +if this is impossible), we begin by initialising the drawing surface then all of the components of the state. Finally, we combine all of these into a composite resource for the turtle:
docs/st/examples.rst view
@@ -225,7 +225,7 @@ The first thing we need to do is create a socket for binding to a port and listening for incoming connections, using ``socket``. This might fail, so we'll need to deal with the case where it returns ``Right sock``, where-``sock`` is the new socket variable, or wher it returns ``Left err``:+``sock`` is the new socket variable, or where it returns ``Left err``:  .. code-block:: idris @@ -340,7 +340,7 @@                ST m () [remove sock (Sock {m} Listening)]   echoServer sock =     do Right new <- accept sock | Left err => do close sock; remove sock-       Right msg <- recv new | Left err => do close sock; remove sock; remove ne+       Right msg <- recv new | Left err => do close sock; remove sock; remove new        Right ok <- send new ("You said " ++ msg)              | Left err => do remove new; close sock; remove sock        close new; remove new; echoServer sock@@ -429,7 +429,7 @@ a higher level network protocol, ``RandServer.idr``, using a hierarchy of state machines to implement a high level network communication protocol in terms of the lower level sockets API. This also uses threading, to-handle incoming requests asyncronously. You can find some more detail+handle incoming requests asynchronously. You can find some more detail on threading and the random number server in the draft paper `State Machines All The Way Down <https://www.idris-lang.org/drafts/sms.pdf>`_ by Edwin Brady.
docs/st/machines.rst view
@@ -352,7 +352,7 @@  We can complete ``getData`` as follows, using a pattern matching bind alternative (see the Idris tutorial, :ref:`monadsdo`) rather than a-``case`` statement to catch the possibilty of an error with ``login``:+``case`` statement to catch the possibility of an error with ``login``:  .. code-block:: idris @@ -367,7 +367,7 @@                disconnect st  We can't yet try this out, however, because we don't have any implementations-of ``getData``! If we try to execute it in an ``IO`` context, for example,+of ``DataStore``! If we try to execute it in an ``IO`` context, for example, we'll get an error saying that there's no implementation of ``DataStore IO``:  .. code::@@ -383,7 +383,7 @@ Implementing the interface ========================== -To execute ``getData`` in ``IO``, we'll need to provided an implementation+To execute ``getData`` in ``IO``, we'll need to provide an implementation of ``DataStore`` which works in the ``IO`` context. We can begin as follows: @@ -526,7 +526,7 @@ using a concrete context ``IO``.  We've now seen how to manipulate states, and how to encapsulate state-transitions for a specific system like the data store inn an interface.+transitions for a specific system like the data store in an interface. However, realistic systems will need to *compose* state machines. We'll either need to use more than one state machine at a time, or implement one state machine in terms of one or more others. We'll see how to achieve this
docs/tutorial/interfaces.rst view
@@ -48,8 +48,8 @@ Only one implementation of an interface can be given for a type — implementations may not overlap. Implementation declarations can themselves have constraints. To help with resolution, the arguments of an implementation must be-constructors (either data or type constructors), variables or-constants (i.e. you cannot give an implementation for a function).  For+constructors (either data or type constructors) or variables +(i.e. you cannot give an implementation for a function).  For example, to define a ``Show`` implementation for vectors, we need to know that there is a ``Show`` implementation for the element type, because we are going to use it to convert each element to a ``String``:
docs/tutorial/miscellany.rst view
@@ -14,7 +14,7 @@ + code generation; and + the universe hierarchy. -Auto implicit arguments+Implicit arguments =======================  We have already seen implicit arguments, which allows arguments to be@@ -23,6 +23,9 @@ .. code-block:: idris      index : {a:Type} -> {n:Nat} -> Fin n -> Vect n a -> a+    +Auto implicit arguments+------------------------  In other situations, it may be possible to infer arguments not by type checking but by searching the context for an appropriate value, or@@ -66,7 +69,31 @@ .. code-block:: idris      head xs {p = ?headProof}+    +Default implicit arguments+--------------------------- +Besides having Idris automatically find a value of a given type, sometimes we +want to have an implicit argument with a specific default value. In Idris, we can+do this using the ``default`` annotation. While this is primarily intended to assist+in automatically constructing a proof where auto fails, or finds an unhelpful value, +it might be easier to first consider a simpler case, not involving proofs. ++If we want to compute the n'th fibonacci number (and defining the 0th fibonacci +number as 0), we could write:++.. code-block:: idris++	fibonacci : {default 0 lag : Nat} -> {default 1 lead : Nat} -> (n : Nat) -> Nat+	fibonacci {lag} Z = lag+	fibonacci {lag} {lead} (S Z) = fibonacci {lag=lead} {lead=lag+lead} n++After this definition, ``fibonacci 5`` is equivalent to ``fibonacci {lag=0} {lead=1} 5``,+and will return the 5th fibonacci number. Note that while this works, this is not the +intended use of the ``default`` annotation. It is included here for illustrative purposes +only. Usually, ``default`` is used to provide things like a custom proof search script.++ Implicit conversions ==================== @@ -467,6 +494,15 @@       %include JavaScript "path/to/external.js"  The given files will be added to the top of the generated code.+For library packages you can also use the ipkg objs option to include the+js file in the installation, and use++.. code-block:: idris++      %include Node "package/external.js"++This javascript and node backends idris will also lookup for the file on+on that location.  Including *NodeJS* modules --------------------------
docs/tutorial/syntax.rst view
@@ -74,14 +74,14 @@      data Interval : Type where        MkInterval : (lower : Double) -> (upper : Double) ->-                    so (lower < upper) -> Interval+                    So (lower < upper) -> Interval -We can define a syntax which, in patterns, always matches ``oh`` for+We can define a syntax which, in patterns, always matches ``Oh`` for the proof argument, and in terms requires a proof term to be provided:  .. code-block:: idris -    pattern syntax "[" [x] "..." [y] "]" = MkInterval x y oh+    pattern syntax "[" [x] "..." [y] "]" = MkInterval x y Oh     term    syntax "[" [x] "..." [y] "]" = MkInterval x y ?bounds_lemma  In terms, the syntax ``[x...y]`` will generate a proof obligation
idris.cabal view
@@ -1,5 +1,5 @@ Name:           idris-Version:        1.0+Version:        1.1.0 License:        BSD3 License-file:   LICENSE Author:         Edwin Brady@@ -40,17 +40,18 @@                 .                 * Hugs style interactive environment -Cabal-Version:  >= 1.8.1+Cabal-Version:  >= 1.18  Build-type:     Custom  Tested-With:    GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1  Data-files:            idrisdoc/styles.css-                       jsrts/Runtime-browser.js+                       jsrts/jsbn/jsbn-browser.js+                       jsrts/jsbn/jsbn-node.js                        jsrts/Runtime-common.js+                       jsrts/Runtime-javascript.js                        jsrts/Runtime-node.js-                       jsrts/jsbn/jsbn.js                        jsrts/jsbn/LICENSE                        rts/arduino/idris_main.c                        rts/idris_bitstring.c@@ -195,6 +196,7 @@                 , Idris.Output                 , Idris.Main                 , Idris.ModeCommon+                , Idris.Options                 , Idris.Parser                 , Idris.Parser.Helpers                 , Idris.Parser.Ops@@ -223,6 +225,11 @@                 , IRTS.CodegenJavaScript                 , IRTS.Exports                 , IRTS.JavaScript.AST+                , IRTS.JavaScript.Name+                , IRTS.JavaScript.Codegen+                , IRTS.JavaScript.LangTransforms+                , IRTS.JavaScript.Specialize+                , IRTS.JavaScript.PrimOp                 , IRTS.Compiler                 , IRTS.Defunctionalise                 , IRTS.DumpBC@@ -273,7 +280,7 @@                 , ieee754 >= 0.7 && <= 0.8.0                 , mtl >= 2.1 && < 2.3                 , network < 2.7-                , optparse-applicative >= 0.11 && < 0.14+                , optparse-applicative >= 0.13 && < 0.14                 , parsers >= 0.9 && < 0.13                 , pretty < 1.2                 , regex-tdfa >= 1.2@@ -313,13 +320,7 @@   if impl(ghc < 7.8.4)      build-depends: tagsoup < 0.14.1 -  Extensions:     MultiParamTypeClasses-                , DeriveFoldable-                , DeriveTraversable-                , FunctionalDependencies-                , FlexibleContexts-                , FlexibleInstances-                , TemplateHaskell+  Default-Language: Haskell2010    ghc-prof-options: -auto-all -caf-all @@ -358,8 +359,9 @@                 , haskeline >= 0.7                 , transformers +  Default-Language: Haskell2010   ghc-prof-options: -auto-all -caf-all-  ghc-options:      -threaded -rtsopts -funbox-strict-fields+  ghc-options:      -threaded -rtsopts -funbox-strict-fields -with-rtsopts=-I0  Test-suite regression-and-feature-tests   Type:           exitcode-stdio-1.0@@ -382,10 +384,9 @@                , tasty-rerun >= 1.0.0                , bytestring                , transformers-  if impl(ghc < 7.10)-    Extensions: DeriveDataTypeable  +  Default-Language: Haskell2010   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -with-rtsopts=-N -funbox-strict-fields @@ -399,6 +400,7 @@                 , haskeline >= 0.7                 , transformers +  Default-Language: Haskell2010   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -funbox-strict-fields @@ -412,6 +414,7 @@                 , haskeline >= 0.7                 , transformers +  Default-Language: Haskell2010   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -funbox-strict-fields @@ -425,5 +428,6 @@                 , haskeline >= 0.7                 , transformers +  Default-Language: Haskell2010   ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -funbox-strict-fields
− jsrts/Runtime-browser.js 
@@ -1,17 +0,0 @@-var i$getLine = function() {-    return prompt("Prelude.getLine");-}--var i$putStr = function(s) {-  console.log(s);-};--var i$systemInfo = function(index) {-  switch(index) {-    case 0:-      return "javascript";-    case 1:-      return navigator.platform;-  }-  return "";-}
jsrts/Runtime-common.js view
@@ -1,117 +1,22 @@-/** @constructor */-var i$VM = function() {-  this.valstack = {};-  this.valstack_top = 0;-  this.valstack_base = 0;--  this.ret = null;--  this.callstack = [];-}--var i$vm;-var i$valstack;-var i$valstack_top;-var i$valstack_base;-var i$ret;-var i$callstack;--var i$Int = {};-var i$String = {};-var i$Integer = {};-var i$Float = {};-var i$Char = {};-var i$Ptr = {};-var i$Forgot = {};--/** @constructor */-var i$CON = function(tag,args,app,ev) {-  this.tag = tag;-  this.args = args;-  this.app = app;-  this.ev = ev;-}--/** @constructor */-var i$POINTER = function(addr) {-  this.addr = addr;-}--var i$SCHED = function(vm) {-  i$vm = vm;-  i$valstack = vm.valstack;-  i$valstack_top = vm.valstack_top;-  i$valstack_base = vm.valstack_base;-  i$ret = vm.ret;-  i$callstack = vm.callstack;-}--var i$SLIDE = function(args) {-  for (var i = 0; i < args; ++i)-    i$valstack[i$valstack_base + i] = i$valstack[i$valstack_top + i];-}--var i$PROJECT = function(val,loc,arity) {-  for (var i = 0; i < arity; ++i)-    i$valstack[i$valstack_base + i + loc] = val.args[i];-}--var i$CALL = function(fun,args) {-  i$callstack.push(args);-  i$callstack.push(fun);-}--var i$ffiWrap = function(fid,oldbase,myoldbase) {-  return function() {-    var oldstack = i$callstack;-    i$callstack = [];--    var res = fid;--    for(var i = 0; i < (arguments.length ? arguments.length : 1); ++i) {-      while (res instanceof i$CON) {-        i$valstack_top += 1;-        i$valstack[i$valstack_top] = res;-        i$valstack[i$valstack_top + 1] = arguments[i];-        i$SLIDE(2);-        i$valstack_top = i$valstack_base + 2;-        i$CALL(_idris__123_APPLY0_125_,[oldbase])-        while (i$callstack.length) {-          var func = i$callstack.pop();-          var args = i$callstack.pop();-          func.apply(this,args);+const $JSRTS = {+    throw: function (x) {+        throw x;+    },+    Lazy: function (e) {+        this.js_idris_lazy_calc = e;+        this.js_idris_lazy_val = void 0;+    },+    force: function (x) {+        if (x === undefined || x.js_idris_lazy_calc === undefined) {+            return x+        } else {+            if (x.js_idris_lazy_val === undefined) {+                x.js_idris_lazy_val = x.js_idris_lazy_calc()+            }+            return x.js_idris_lazy_val         }-        res = i$ret;-      }+    },+    prim_strSubstr: function (offset, len, str) {+        return str.substr(Math.max(0, offset), Math.max(0, len))     }--    i$callstack = oldstack;--    return i$ret;-  }-}--var i$charCode = function(str) {-  if (typeof str == "string")-    return str.charCodeAt(0);-  else-    return str;-}--var i$fromCharCode = function(chr) {-  if (typeof chr == "string")-    return chr;-  else-    return String.fromCharCode(chr);-}--var i$RUN = function () {-  for (var i = 0; i < 10000 && i$callstack.length; i++) {-    var func = i$callstack.pop();-    var args = i$callstack.pop();-    func.apply(this,args);-  };--  if (i$callstack.length)-    setTimeout(i$RUN, 0);-}+};
+ jsrts/Runtime-javascript.js view
@@ -0,0 +1,11 @@+$JSRTS.prim_systemInfo = function (index) {+    switch (index) {+        case 0:+            return "javascript";+        case 1:+            return navigator.platform;+    }+    return "";+};+$JSRTS.prim_writeStr = function (x) { return console.log(x) }+$JSRTS.prim_readStr = function () { return prompt('Prelude.getLine') };
jsrts/Runtime-node.js view
@@ -1,42 +1,31 @@-var i$putStr = (function() {-  var fs = require('fs');-  return function(s) {-    fs.writeSync(1,s);-  };-})();--var i$getLine = (function() {-  var fs = require( "fs" )--  return function() {-    var ret = "";+$JSRTS.os = require('os');+$JSRTS.fs = require('fs');+$JSRTS.prim_systemInfo = function (index) {+    switch (index) {+        case 0:+            return "node";+        case 1:+            return $JSRTS.os.platform();+    }+    return "";+};+$JSRTS.prim_writeStr = function (x) { return process.stdout.write(x) }+$JSRTS.prim_readStr = function () {+    var ret = '';     var b = new Buffer(1024);     var i = 0;-    while(true) {-      fs.readSync(0, b, i, 1 )-      if (b[i] == 10) {-        ret = b.toString('utf8', 0, i);-        break;-      }-      i++;-      if (i == b.length) {-        nb = new Buffer (b.length*2);-        b.copy(nb)-        b = nb;-      }+    while (true) {+        $JSRTS.fs.readSync(0, b, i, 1)+        if (b[i] == 10) {+            ret = b.toString('utf8', 0, i);+            break;+        }+        i++;+        if (i == b.length) {+            nb = new Buffer(b.length * 2);+            b.copy(nb)+            b = nb;+        }     }-     return ret;-  };-})();--var i$systemInfo = function(index) {-  var os = require('os')-    switch(index) {-      case 0:-        return "node";-      case 1:-        return os.platform();-    }-  return "";-}+};
+ jsrts/jsbn/jsbn-browser.js view
@@ -0,0 +1,1353 @@+$JSRTS.jsbn = (function () {++  // Copyright (c) 2005  Tom Wu+  // All Rights Reserved.+  // See "LICENSE" for details.++  // Basic JavaScript BN library - subset useful for RSA encryption.++  // Bits per digit+  var dbits;++  // JavaScript engine analysis+  var canary = 0xdeadbeefcafe;+  var j_lm = ((canary & 0xffffff) == 0xefcafe);++  // (public) Constructor+  function BigInteger(a, b, c) {+    if (a != null)+      if ("number" == typeof a) this.fromNumber(a, b, c);+      else if (b == null && "string" != typeof a) this.fromString(a, 256);+      else this.fromString(a, b);+  }++  // return new, unset BigInteger+  function nbi() { return new BigInteger(null); }++  // am: Compute w_j += (x*this_i), propagate carries,+  // c is initial carry, returns final carry.+  // c < 3*dvalue, x < 2*dvalue, this_i < dvalue+  // We need to select the fastest one that works in this environment.++  // am1: use a single mult and divide to get the high bits,+  // max digit bits should be 26 because+  // max internal value = 2*dvalue^2-2*dvalue (< 2^53)+  function am1(i, x, w, j, c, n) {+    while (--n >= 0) {+      var v = x * this[i++] + w[j] + c;+      c = Math.floor(v / 0x4000000);+      w[j++] = v & 0x3ffffff;+    }+    return c;+  }+  // am2 avoids a big mult-and-extract completely.+  // Max digit bits should be <= 30 because we do bitwise ops+  // on values up to 2*hdvalue^2-hdvalue-1 (< 2^31)+  function am2(i, x, w, j, c, n) {+    var xl = x & 0x7fff, xh = x >> 15;+    while (--n >= 0) {+      var l = this[i] & 0x7fff;+      var h = this[i++] >> 15;+      var m = xh * l + h * xl;+      l = xl * l + ((m & 0x7fff) << 15) + w[j] + (c & 0x3fffffff);+      c = (l >>> 30) + (m >>> 15) + xh * h + (c >>> 30);+      w[j++] = l & 0x3fffffff;+    }+    return c;+  }+  // Alternately, set max digit bits to 28 since some+  // browsers slow down when dealing with 32-bit numbers.+  function am3(i, x, w, j, c, n) {+    var xl = x & 0x3fff, xh = x >> 14;+    while (--n >= 0) {+      var l = this[i] & 0x3fff;+      var h = this[i++] >> 14;+      var m = xh * l + h * xl;+      l = xl * l + ((m & 0x3fff) << 14) + w[j] + c;+      c = (l >> 28) + (m >> 14) + xh * h;+      w[j++] = l & 0xfffffff;+    }+    return c;+  }+  var inBrowser = typeof navigator !== "undefined";+  if (inBrowser && j_lm && (navigator.appName == "Microsoft Internet Explorer")) {+    BigInteger.prototype.am = am2;+    dbits = 30;+  }+  else if (inBrowser && j_lm && (navigator.appName != "Netscape")) {+    BigInteger.prototype.am = am1;+    dbits = 26;+  }+  else { // Mozilla/Netscape seems to prefer am3+    BigInteger.prototype.am = am3;+    dbits = 28;+  }++  BigInteger.prototype.DB = dbits;+  BigInteger.prototype.DM = ((1 << dbits) - 1);+  BigInteger.prototype.DV = (1 << dbits);++  var BI_FP = 52;+  BigInteger.prototype.FV = Math.pow(2, BI_FP);+  BigInteger.prototype.F1 = BI_FP - dbits;+  BigInteger.prototype.F2 = 2 * dbits - BI_FP;++  // Digit conversions+  var BI_RM = "0123456789abcdefghijklmnopqrstuvwxyz";+  var BI_RC = new Array();+  var rr, vv;+  rr = "0".charCodeAt(0);+  for (vv = 0; vv <= 9; ++vv) BI_RC[rr++] = vv;+  rr = "a".charCodeAt(0);+  for (vv = 10; vv < 36; ++vv) BI_RC[rr++] = vv;+  rr = "A".charCodeAt(0);+  for (vv = 10; vv < 36; ++vv) BI_RC[rr++] = vv;++  function int2char(n) { return BI_RM.charAt(n); }+  function intAt(s, i) {+    var c = BI_RC[s.charCodeAt(i)];+    return (c == null) ? -1 : c;+  }++  // (protected) copy this to r+  function bnpCopyTo(r) {+    for (var i = this.t - 1; i >= 0; --i) r[i] = this[i];+    r.t = this.t;+    r.s = this.s;+  }++  // (protected) set from integer value x, -DV <= x < DV+  function bnpFromInt(x) {+    this.t = 1;+    this.s = (x < 0) ? -1 : 0;+    if (x > 0) this[0] = x;+    else if (x < -1) this[0] = x + this.DV;+    else this.t = 0;+  }++  // return bigint initialized to value+  function nbv(i) { var r = nbi(); r.fromInt(i); return r; }++  // (protected) set from string and radix+  function bnpFromString(s, b) {+    var k;+    if (b == 16) k = 4;+    else if (b == 8) k = 3;+    else if (b == 256) k = 8; // byte array+    else if (b == 2) k = 1;+    else if (b == 32) k = 5;+    else if (b == 4) k = 2;+    else { this.fromRadix(s, b); return; }+    this.t = 0;+    this.s = 0;+    var i = s.length, mi = false, sh = 0;+    while (--i >= 0) {+      var x = (k == 8) ? s[i] & 0xff : intAt(s, i);+      if (x < 0) {+        if (s.charAt(i) == "-") mi = true;+        continue;+      }+      mi = false;+      if (sh == 0)+        this[this.t++] = x;+      else if (sh + k > this.DB) {+        this[this.t - 1] |= (x & ((1 << (this.DB - sh)) - 1)) << sh;+        this[this.t++] = (x >> (this.DB - sh));+      }+      else+        this[this.t - 1] |= x << sh;+      sh += k;+      if (sh >= this.DB) sh -= this.DB;+    }+    if (k == 8 && (s[0] & 0x80) != 0) {+      this.s = -1;+      if (sh > 0) this[this.t - 1] |= ((1 << (this.DB - sh)) - 1) << sh;+    }+    this.clamp();+    if (mi) BigInteger.ZERO.subTo(this, this);+  }++  // (protected) clamp off excess high words+  function bnpClamp() {+    var c = this.s & this.DM;+    while (this.t > 0 && this[this.t - 1] == c)--this.t;+  }++  // (public) return string representation in given radix+  function bnToString(b) {+    if (this.s < 0) return "-" + this.negate().toString(b);+    var k;+    if (b == 16) k = 4;+    else if (b == 8) k = 3;+    else if (b == 2) k = 1;+    else if (b == 32) k = 5;+    else if (b == 4) k = 2;+    else return this.toRadix(b);+    var km = (1 << k) - 1, d, m = false, r = "", i = this.t;+    var p = this.DB - (i * this.DB) % k;+    if (i-- > 0) {+      if (p < this.DB && (d = this[i] >> p) > 0) { m = true; r = int2char(d); }+      while (i >= 0) {+        if (p < k) {+          d = (this[i] & ((1 << p) - 1)) << (k - p);+          d |= this[--i] >> (p += this.DB - k);+        }+        else {+          d = (this[i] >> (p -= k)) & km;+          if (p <= 0) { p += this.DB; --i; }+        }+        if (d > 0) m = true;+        if (m) r += int2char(d);+      }+    }+    return m ? r : "0";+  }++  // (public) -this+  function bnNegate() { var r = nbi(); BigInteger.ZERO.subTo(this, r); return r; }++  // (public) |this|+  function bnAbs() { return (this.s < 0) ? this.negate() : this; }++  // (public) return + if this > a, - if this < a, 0 if equal+  function bnCompareTo(a) {+    var r = this.s - a.s;+    if (r != 0) return r;+    var i = this.t;+    r = i - a.t;+    if (r != 0) return (this.s < 0) ? -r : r;+    while (--i >= 0) if ((r = this[i] - a[i]) != 0) return r;+    return 0;+  }++  // returns bit length of the integer x+  function nbits(x) {+    var r = 1, t;+    if ((t = x >>> 16) != 0) { x = t; r += 16; }+    if ((t = x >> 8) != 0) { x = t; r += 8; }+    if ((t = x >> 4) != 0) { x = t; r += 4; }+    if ((t = x >> 2) != 0) { x = t; r += 2; }+    if ((t = x >> 1) != 0) { x = t; r += 1; }+    return r;+  }++  // (public) return the number of bits in "this"+  function bnBitLength() {+    if (this.t <= 0) return 0;+    return this.DB * (this.t - 1) + nbits(this[this.t - 1] ^ (this.s & this.DM));+  }++  // (protected) r = this << n*DB+  function bnpDLShiftTo(n, r) {+    var i;+    for (i = this.t - 1; i >= 0; --i) r[i + n] = this[i];+    for (i = n - 1; i >= 0; --i) r[i] = 0;+    r.t = this.t + n;+    r.s = this.s;+  }++  // (protected) r = this >> n*DB+  function bnpDRShiftTo(n, r) {+    for (var i = n; i < this.t; ++i) r[i - n] = this[i];+    r.t = Math.max(this.t - n, 0);+    r.s = this.s;+  }++  // (protected) r = this << n+  function bnpLShiftTo(n, r) {+    var bs = n % this.DB;+    var cbs = this.DB - bs;+    var bm = (1 << cbs) - 1;+    var ds = Math.floor(n / this.DB), c = (this.s << bs) & this.DM, i;+    for (i = this.t - 1; i >= 0; --i) {+      r[i + ds + 1] = (this[i] >> cbs) | c;+      c = (this[i] & bm) << bs;+    }+    for (i = ds - 1; i >= 0; --i) r[i] = 0;+    r[ds] = c;+    r.t = this.t + ds + 1;+    r.s = this.s;+    r.clamp();+  }++  // (protected) r = this >> n+  function bnpRShiftTo(n, r) {+    r.s = this.s;+    var ds = Math.floor(n / this.DB);+    if (ds >= this.t) { r.t = 0; return; }+    var bs = n % this.DB;+    var cbs = this.DB - bs;+    var bm = (1 << bs) - 1;+    r[0] = this[ds] >> bs;+    for (var i = ds + 1; i < this.t; ++i) {+      r[i - ds - 1] |= (this[i] & bm) << cbs;+      r[i - ds] = this[i] >> bs;+    }+    if (bs > 0) r[this.t - ds - 1] |= (this.s & bm) << cbs;+    r.t = this.t - ds;+    r.clamp();+  }++  // (protected) r = this - a+  function bnpSubTo(a, r) {+    var i = 0, c = 0, m = Math.min(a.t, this.t);+    while (i < m) {+      c += this[i] - a[i];+      r[i++] = c & this.DM;+      c >>= this.DB;+    }+    if (a.t < this.t) {+      c -= a.s;+      while (i < this.t) {+        c += this[i];+        r[i++] = c & this.DM;+        c >>= this.DB;+      }+      c += this.s;+    }+    else {+      c += this.s;+      while (i < a.t) {+        c -= a[i];+        r[i++] = c & this.DM;+        c >>= this.DB;+      }+      c -= a.s;+    }+    r.s = (c < 0) ? -1 : 0;+    if (c < -1) r[i++] = this.DV + c;+    else if (c > 0) r[i++] = c;+    r.t = i;+    r.clamp();+  }++  // (protected) r = this * a, r != this,a (HAC 14.12)+  // "this" should be the larger one if appropriate.+  function bnpMultiplyTo(a, r) {+    var x = this.abs(), y = a.abs();+    var i = x.t;+    r.t = i + y.t;+    while (--i >= 0) r[i] = 0;+    for (i = 0; i < y.t; ++i) r[i + x.t] = x.am(0, y[i], r, i, 0, x.t);+    r.s = 0;+    r.clamp();+    if (this.s != a.s) BigInteger.ZERO.subTo(r, r);+  }++  // (protected) r = this^2, r != this (HAC 14.16)+  function bnpSquareTo(r) {+    var x = this.abs();+    var i = r.t = 2 * x.t;+    while (--i >= 0) r[i] = 0;+    for (i = 0; i < x.t - 1; ++i) {+      var c = x.am(i, x[i], r, 2 * i, 0, 1);+      if ((r[i + x.t] += x.am(i + 1, 2 * x[i], r, 2 * i + 1, c, x.t - i - 1)) >= x.DV) {+        r[i + x.t] -= x.DV;+        r[i + x.t + 1] = 1;+      }+    }+    if (r.t > 0) r[r.t - 1] += x.am(i, x[i], r, 2 * i, 0, 1);+    r.s = 0;+    r.clamp();+  }++  // (protected) divide this by m, quotient and remainder to q, r (HAC 14.20)+  // r != q, this != m.  q or r may be null.+  function bnpDivRemTo(m, q, r) {+    var pm = m.abs();+    if (pm.t <= 0) return;+    var pt = this.abs();+    if (pt.t < pm.t) {+      if (q != null) q.fromInt(0);+      if (r != null) this.copyTo(r);+      return;+    }+    if (r == null) r = nbi();+    var y = nbi(), ts = this.s, ms = m.s;+    var nsh = this.DB - nbits(pm[pm.t - 1]);   // normalize modulus+    if (nsh > 0) { pm.lShiftTo(nsh, y); pt.lShiftTo(nsh, r); }+    else { pm.copyTo(y); pt.copyTo(r); }+    var ys = y.t;+    var y0 = y[ys - 1];+    if (y0 == 0) return;+    var yt = y0 * (1 << this.F1) + ((ys > 1) ? y[ys - 2] >> this.F2 : 0);+    var d1 = this.FV / yt, d2 = (1 << this.F1) / yt, e = 1 << this.F2;+    var i = r.t, j = i - ys, t = (q == null) ? nbi() : q;+    y.dlShiftTo(j, t);+    if (r.compareTo(t) >= 0) {+      r[r.t++] = 1;+      r.subTo(t, r);+    }+    BigInteger.ONE.dlShiftTo(ys, t);+    t.subTo(y, y);  // "negative" y so we can replace sub with am later+    while (y.t < ys) y[y.t++] = 0;+    while (--j >= 0) {+      // Estimate quotient digit+      var qd = (r[--i] == y0) ? this.DM : Math.floor(r[i] * d1 + (r[i - 1] + e) * d2);+      if ((r[i] += y.am(0, qd, r, j, 0, ys)) < qd) {   // Try it out+        y.dlShiftTo(j, t);+        r.subTo(t, r);+        while (r[i] < --qd) r.subTo(t, r);+      }+    }+    if (q != null) {+      r.drShiftTo(ys, q);+      if (ts != ms) BigInteger.ZERO.subTo(q, q);+    }+    r.t = ys;+    r.clamp();+    if (nsh > 0) r.rShiftTo(nsh, r); // Denormalize remainder+    if (ts < 0) BigInteger.ZERO.subTo(r, r);+  }++  // (public) this mod a+  function bnMod(a) {+    var r = nbi();+    this.abs().divRemTo(a, null, r);+    if (this.s < 0 && r.compareTo(BigInteger.ZERO) > 0) a.subTo(r, r);+    return r;+  }++  // Modular reduction using "classic" algorithm+  function Classic(m) { this.m = m; }+  function cConvert(x) {+    if (x.s < 0 || x.compareTo(this.m) >= 0) return x.mod(this.m);+    else return x;+  }+  function cRevert(x) { return x; }+  function cReduce(x) { x.divRemTo(this.m, null, x); }+  function cMulTo(x, y, r) { x.multiplyTo(y, r); this.reduce(r); }+  function cSqrTo(x, r) { x.squareTo(r); this.reduce(r); }++  Classic.prototype.convert = cConvert;+  Classic.prototype.revert = cRevert;+  Classic.prototype.reduce = cReduce;+  Classic.prototype.mulTo = cMulTo;+  Classic.prototype.sqrTo = cSqrTo;++  // (protected) return "-1/this % 2^DB"; useful for Mont. reduction+  // justification:+  //         xy == 1 (mod m)+  //         xy =  1+km+  //   xy(2-xy) = (1+km)(1-km)+  // x[y(2-xy)] = 1-k^2m^2+  // x[y(2-xy)] == 1 (mod m^2)+  // if y is 1/x mod m, then y(2-xy) is 1/x mod m^2+  // should reduce x and y(2-xy) by m^2 at each step to keep size bounded.+  // JS multiply "overflows" differently from C/C++, so care is needed here.+  function bnpInvDigit() {+    if (this.t < 1) return 0;+    var x = this[0];+    if ((x & 1) == 0) return 0;+    var y = x & 3;       // y == 1/x mod 2^2+    y = (y * (2 - (x & 0xf) * y)) & 0xf; // y == 1/x mod 2^4+    y = (y * (2 - (x & 0xff) * y)) & 0xff;   // y == 1/x mod 2^8+    y = (y * (2 - (((x & 0xffff) * y) & 0xffff))) & 0xffff;    // y == 1/x mod 2^16+    // last step - calculate inverse mod DV directly;+    // assumes 16 < DB <= 32 and assumes ability to handle 48-bit ints+    y = (y * (2 - x * y % this.DV)) % this.DV;       // y == 1/x mod 2^dbits+    // we really want the negative inverse, and -DV < y < DV+    return (y > 0) ? this.DV - y : -y;+  }++  // Montgomery reduction+  function Montgomery(m) {+    this.m = m;+    this.mp = m.invDigit();+    this.mpl = this.mp & 0x7fff;+    this.mph = this.mp >> 15;+    this.um = (1 << (m.DB - 15)) - 1;+    this.mt2 = 2 * m.t;+  }++  // xR mod m+  function montConvert(x) {+    var r = nbi();+    x.abs().dlShiftTo(this.m.t, r);+    r.divRemTo(this.m, null, r);+    if (x.s < 0 && r.compareTo(BigInteger.ZERO) > 0) this.m.subTo(r, r);+    return r;+  }++  // x/R mod m+  function montRevert(x) {+    var r = nbi();+    x.copyTo(r);+    this.reduce(r);+    return r;+  }++  // x = x/R mod m (HAC 14.32)+  function montReduce(x) {+    while (x.t <= this.mt2) // pad x so am has enough room later+      x[x.t++] = 0;+    for (var i = 0; i < this.m.t; ++i) {+      // faster way of calculating u0 = x[i]*mp mod DV+      var j = x[i] & 0x7fff;+      var u0 = (j * this.mpl + (((j * this.mph + (x[i] >> 15) * this.mpl) & this.um) << 15)) & x.DM;+      // use am to combine the multiply-shift-add into one call+      j = i + this.m.t;+      x[j] += this.m.am(0, u0, x, i, 0, this.m.t);+      // propagate carry+      while (x[j] >= x.DV) { x[j] -= x.DV; x[++j]++; }+    }+    x.clamp();+    x.drShiftTo(this.m.t, x);+    if (x.compareTo(this.m) >= 0) x.subTo(this.m, x);+  }++  // r = "x^2/R mod m"; x != r+  function montSqrTo(x, r) { x.squareTo(r); this.reduce(r); }++  // r = "xy/R mod m"; x,y != r+  function montMulTo(x, y, r) { x.multiplyTo(y, r); this.reduce(r); }++  Montgomery.prototype.convert = montConvert;+  Montgomery.prototype.revert = montRevert;+  Montgomery.prototype.reduce = montReduce;+  Montgomery.prototype.mulTo = montMulTo;+  Montgomery.prototype.sqrTo = montSqrTo;++  // (protected) true iff this is even+  function bnpIsEven() { return ((this.t > 0) ? (this[0] & 1) : this.s) == 0; }++  // (protected) this^e, e < 2^32, doing sqr and mul with "r" (HAC 14.79)+  function bnpExp(e, z) {+    if (e > 0xffffffff || e < 1) return BigInteger.ONE;+    var r = nbi(), r2 = nbi(), g = z.convert(this), i = nbits(e) - 1;+    g.copyTo(r);+    while (--i >= 0) {+      z.sqrTo(r, r2);+      if ((e & (1 << i)) > 0) z.mulTo(r2, g, r);+      else { var t = r; r = r2; r2 = t; }+    }+    return z.revert(r);+  }++  // (public) this^e % m, 0 <= e < 2^32+  function bnModPowInt(e, m) {+    var z;+    if (e < 256 || m.isEven()) z = new Classic(m); else z = new Montgomery(m);+    return this.exp(e, z);+  }++  // protected+  BigInteger.prototype.copyTo = bnpCopyTo;+  BigInteger.prototype.fromInt = bnpFromInt;+  BigInteger.prototype.fromString = bnpFromString;+  BigInteger.prototype.clamp = bnpClamp;+  BigInteger.prototype.dlShiftTo = bnpDLShiftTo;+  BigInteger.prototype.drShiftTo = bnpDRShiftTo;+  BigInteger.prototype.lShiftTo = bnpLShiftTo;+  BigInteger.prototype.rShiftTo = bnpRShiftTo;+  BigInteger.prototype.subTo = bnpSubTo;+  BigInteger.prototype.multiplyTo = bnpMultiplyTo;+  BigInteger.prototype.squareTo = bnpSquareTo;+  BigInteger.prototype.divRemTo = bnpDivRemTo;+  BigInteger.prototype.invDigit = bnpInvDigit;+  BigInteger.prototype.isEven = bnpIsEven;+  BigInteger.prototype.exp = bnpExp;++  // public+  BigInteger.prototype.toString = bnToString;+  BigInteger.prototype.negate = bnNegate;+  BigInteger.prototype.abs = bnAbs;+  BigInteger.prototype.compareTo = bnCompareTo;+  BigInteger.prototype.bitLength = bnBitLength;+  BigInteger.prototype.mod = bnMod;+  BigInteger.prototype.modPowInt = bnModPowInt;++  // "constants"+  BigInteger.ZERO = nbv(0);+  BigInteger.ONE = nbv(1);++  // Copyright (c) 2005-2009  Tom Wu+  // All Rights Reserved.+  // See "LICENSE" for details.++  // Extended JavaScript BN functions, required for RSA private ops.++  // Version 1.1: new BigInteger("0", 10) returns "proper" zero+  // Version 1.2: square() API, isProbablePrime fix++  // (public)+  function bnClone() { var r = nbi(); this.copyTo(r); return r; }++  // (public) return value as integer+  function bnIntValue() {+    if (this.s < 0) {+      if (this.t == 1) return this[0] - this.DV;+      else if (this.t == 0) return -1;+    }+    else if (this.t == 1) return this[0];+    else if (this.t == 0) return 0;+    // assumes 16 < DB < 32+    return ((this[1] & ((1 << (32 - this.DB)) - 1)) << this.DB) | this[0];+  }++  // (public) return value as byte+  function bnByteValue() { return (this.t == 0) ? this.s : (this[0] << 24) >> 24; }++  // (public) return value as short (assumes DB>=16)+  function bnShortValue() { return (this.t == 0) ? this.s : (this[0] << 16) >> 16; }++  // (protected) return x s.t. r^x < DV+  function bnpChunkSize(r) { return Math.floor(Math.LN2 * this.DB / Math.log(r)); }++  // (public) 0 if this == 0, 1 if this > 0+  function bnSigNum() {+    if (this.s < 0) return -1;+    else if (this.t <= 0 || (this.t == 1 && this[0] <= 0)) return 0;+    else return 1;+  }++  // (protected) convert to radix string+  function bnpToRadix(b) {+    if (b == null) b = 10;+    if (this.signum() == 0 || b < 2 || b > 36) return "0";+    var cs = this.chunkSize(b);+    var a = Math.pow(b, cs);+    var d = nbv(a), y = nbi(), z = nbi(), r = "";+    this.divRemTo(d, y, z);+    while (y.signum() > 0) {+      r = (a + z.intValue()).toString(b).substr(1) + r;+      y.divRemTo(d, y, z);+    }+    return z.intValue().toString(b) + r;+  }++  // (protected) convert from radix string+  function bnpFromRadix(s, b) {+    this.fromInt(0);+    if (b == null) b = 10;+    var cs = this.chunkSize(b);+    var d = Math.pow(b, cs), mi = false, j = 0, w = 0;+    for (var i = 0; i < s.length; ++i) {+      var x = intAt(s, i);+      if (x < 0) {+        if (s.charAt(i) == "-" && this.signum() == 0) mi = true;+        continue;+      }+      w = b * w + x;+      if (++j >= cs) {+        this.dMultiply(d);+        this.dAddOffset(w, 0);+        j = 0;+        w = 0;+      }+    }+    if (j > 0) {+      this.dMultiply(Math.pow(b, j));+      this.dAddOffset(w, 0);+    }+    if (mi) BigInteger.ZERO.subTo(this, this);+  }++  // (protected) alternate constructor+  function bnpFromNumber(a, b, c) {+    if ("number" == typeof b) {+      // new BigInteger(int,int,RNG)+      if (a < 2) this.fromInt(1);+      else {+        this.fromNumber(a, c);+        if (!this.testBit(a - 1))    // force MSB set+          this.bitwiseTo(BigInteger.ONE.shiftLeft(a - 1), op_or, this);+        if (this.isEven()) this.dAddOffset(1, 0); // force odd+        while (!this.isProbablePrime(b)) {+          this.dAddOffset(2, 0);+          if (this.bitLength() > a) this.subTo(BigInteger.ONE.shiftLeft(a - 1), this);+        }+      }+    }+    else {+      // new BigInteger(int,RNG)+      var x = new Array(), t = a & 7;+      x.length = (a >> 3) + 1;+      b.nextBytes(x);+      if (t > 0) x[0] &= ((1 << t) - 1); else x[0] = 0;+      this.fromString(x, 256);+    }+  }++  // (public) convert to bigendian byte array+  function bnToByteArray() {+    var i = this.t, r = new Array();+    r[0] = this.s;+    var p = this.DB - (i * this.DB) % 8, d, k = 0;+    if (i-- > 0) {+      if (p < this.DB && (d = this[i] >> p) != (this.s & this.DM) >> p)+        r[k++] = d | (this.s << (this.DB - p));+      while (i >= 0) {+        if (p < 8) {+          d = (this[i] & ((1 << p) - 1)) << (8 - p);+          d |= this[--i] >> (p += this.DB - 8);+        }+        else {+          d = (this[i] >> (p -= 8)) & 0xff;+          if (p <= 0) { p += this.DB; --i; }+        }+        if ((d & 0x80) != 0) d |= -256;+        if (k == 0 && (this.s & 0x80) != (d & 0x80))++k;+        if (k > 0 || d != this.s) r[k++] = d;+      }+    }+    return r;+  }++  function bnEquals(a) { return (this.compareTo(a) == 0); }+  function bnMin(a) { return (this.compareTo(a) < 0) ? this : a; }+  function bnMax(a) { return (this.compareTo(a) > 0) ? this : a; }++  // (protected) r = this op a (bitwise)+  function bnpBitwiseTo(a, op, r) {+    var i, f, m = Math.min(a.t, this.t);+    for (i = 0; i < m; ++i) r[i] = op(this[i], a[i]);+    if (a.t < this.t) {+      f = a.s & this.DM;+      for (i = m; i < this.t; ++i) r[i] = op(this[i], f);+      r.t = this.t;+    }+    else {+      f = this.s & this.DM;+      for (i = m; i < a.t; ++i) r[i] = op(f, a[i]);+      r.t = a.t;+    }+    r.s = op(this.s, a.s);+    r.clamp();+  }++  // (public) this & a+  function op_and(x, y) { return x & y; }+  function bnAnd(a) { var r = nbi(); this.bitwiseTo(a, op_and, r); return r; }++  // (public) this | a+  function op_or(x, y) { return x | y; }+  function bnOr(a) { var r = nbi(); this.bitwiseTo(a, op_or, r); return r; }++  // (public) this ^ a+  function op_xor(x, y) { return x ^ y; }+  function bnXor(a) { var r = nbi(); this.bitwiseTo(a, op_xor, r); return r; }++  // (public) this & ~a+  function op_andnot(x, y) { return x & ~y; }+  function bnAndNot(a) { var r = nbi(); this.bitwiseTo(a, op_andnot, r); return r; }++  // (public) ~this+  function bnNot() {+    var r = nbi();+    for (var i = 0; i < this.t; ++i) r[i] = this.DM & ~this[i];+    r.t = this.t;+    r.s = ~this.s;+    return r;+  }++  // (public) this << n+  function bnShiftLeft(n) {+    var r = nbi();+    if (n < 0) this.rShiftTo(-n, r); else this.lShiftTo(n, r);+    return r;+  }++  // (public) this >> n+  function bnShiftRight(n) {+    var r = nbi();+    if (n < 0) this.lShiftTo(-n, r); else this.rShiftTo(n, r);+    return r;+  }++  // return index of lowest 1-bit in x, x < 2^31+  function lbit(x) {+    if (x == 0) return -1;+    var r = 0;+    if ((x & 0xffff) == 0) { x >>= 16; r += 16; }+    if ((x & 0xff) == 0) { x >>= 8; r += 8; }+    if ((x & 0xf) == 0) { x >>= 4; r += 4; }+    if ((x & 3) == 0) { x >>= 2; r += 2; }+    if ((x & 1) == 0)++r;+    return r;+  }++  // (public) returns index of lowest 1-bit (or -1 if none)+  function bnGetLowestSetBit() {+    for (var i = 0; i < this.t; ++i)+      if (this[i] != 0) return i * this.DB + lbit(this[i]);+    if (this.s < 0) return this.t * this.DB;+    return -1;+  }++  // return number of 1 bits in x+  function cbit(x) {+    var r = 0;+    while (x != 0) { x &= x - 1; ++r; }+    return r;+  }++  // (public) return number of set bits+  function bnBitCount() {+    var r = 0, x = this.s & this.DM;+    for (var i = 0; i < this.t; ++i) r += cbit(this[i] ^ x);+    return r;+  }++  // (public) true iff nth bit is set+  function bnTestBit(n) {+    var j = Math.floor(n / this.DB);+    if (j >= this.t) return (this.s != 0);+    return ((this[j] & (1 << (n % this.DB))) != 0);+  }++  // (protected) this op (1<<n)+  function bnpChangeBit(n, op) {+    var r = BigInteger.ONE.shiftLeft(n);+    this.bitwiseTo(r, op, r);+    return r;+  }++  // (public) this | (1<<n)+  function bnSetBit(n) { return this.changeBit(n, op_or); }++  // (public) this & ~(1<<n)+  function bnClearBit(n) { return this.changeBit(n, op_andnot); }++  // (public) this ^ (1<<n)+  function bnFlipBit(n) { return this.changeBit(n, op_xor); }++  // (protected) r = this + a+  function bnpAddTo(a, r) {+    var i = 0, c = 0, m = Math.min(a.t, this.t);+    while (i < m) {+      c += this[i] + a[i];+      r[i++] = c & this.DM;+      c >>= this.DB;+    }+    if (a.t < this.t) {+      c += a.s;+      while (i < this.t) {+        c += this[i];+        r[i++] = c & this.DM;+        c >>= this.DB;+      }+      c += this.s;+    }+    else {+      c += this.s;+      while (i < a.t) {+        c += a[i];+        r[i++] = c & this.DM;+        c >>= this.DB;+      }+      c += a.s;+    }+    r.s = (c < 0) ? -1 : 0;+    if (c > 0) r[i++] = c;+    else if (c < -1) r[i++] = this.DV + c;+    r.t = i;+    r.clamp();+  }++  // (public) this + a+  function bnAdd(a) { var r = nbi(); this.addTo(a, r); return r; }++  // (public) this - a+  function bnSubtract(a) { var r = nbi(); this.subTo(a, r); return r; }++  // (public) this * a+  function bnMultiply(a) { var r = nbi(); this.multiplyTo(a, r); return r; }++  // (public) this^2+  function bnSquare() { var r = nbi(); this.squareTo(r); return r; }++  // (public) this / a+  function bnDivide(a) { var r = nbi(); this.divRemTo(a, r, null); return r; }++  // (public) this % a+  function bnRemainder(a) { var r = nbi(); this.divRemTo(a, null, r); return r; }++  // (public) [this/a,this%a]+  function bnDivideAndRemainder(a) {+    var q = nbi(), r = nbi();+    this.divRemTo(a, q, r);+    return new Array(q, r);+  }++  // (protected) this *= n, this >= 0, 1 < n < DV+  function bnpDMultiply(n) {+    this[this.t] = this.am(0, n - 1, this, 0, 0, this.t);+    ++this.t;+    this.clamp();+  }++  // (protected) this += n << w words, this >= 0+  function bnpDAddOffset(n, w) {+    if (n == 0) return;+    while (this.t <= w) this[this.t++] = 0;+    this[w] += n;+    while (this[w] >= this.DV) {+      this[w] -= this.DV;+      if (++w >= this.t) this[this.t++] = 0;+      ++this[w];+    }+  }++  // A "null" reducer+  function NullExp() { }+  function nNop(x) { return x; }+  function nMulTo(x, y, r) { x.multiplyTo(y, r); }+  function nSqrTo(x, r) { x.squareTo(r); }++  NullExp.prototype.convert = nNop;+  NullExp.prototype.revert = nNop;+  NullExp.prototype.mulTo = nMulTo;+  NullExp.prototype.sqrTo = nSqrTo;++  // (public) this^e+  function bnPow(e) { return this.exp(e, new NullExp()); }++  // (protected) r = lower n words of "this * a", a.t <= n+  // "this" should be the larger one if appropriate.+  function bnpMultiplyLowerTo(a, n, r) {+    var i = Math.min(this.t + a.t, n);+    r.s = 0; // assumes a,this >= 0+    r.t = i;+    while (i > 0) r[--i] = 0;+    var j;+    for (j = r.t - this.t; i < j; ++i) r[i + this.t] = this.am(0, a[i], r, i, 0, this.t);+    for (j = Math.min(a.t, n); i < j; ++i) this.am(0, a[i], r, i, 0, n - i);+    r.clamp();+  }++  // (protected) r = "this * a" without lower n words, n > 0+  // "this" should be the larger one if appropriate.+  function bnpMultiplyUpperTo(a, n, r) {+    --n;+    var i = r.t = this.t + a.t - n;+    r.s = 0; // assumes a,this >= 0+    while (--i >= 0) r[i] = 0;+    for (i = Math.max(n - this.t, 0); i < a.t; ++i)+      r[this.t + i - n] = this.am(n - i, a[i], r, 0, 0, this.t + i - n);+    r.clamp();+    r.drShiftTo(1, r);+  }++  // Barrett modular reduction+  function Barrett(m) {+    // setup Barrett+    this.r2 = nbi();+    this.q3 = nbi();+    BigInteger.ONE.dlShiftTo(2 * m.t, this.r2);+    this.mu = this.r2.divide(m);+    this.m = m;+  }++  function barrettConvert(x) {+    if (x.s < 0 || x.t > 2 * this.m.t) return x.mod(this.m);+    else if (x.compareTo(this.m) < 0) return x;+    else { var r = nbi(); x.copyTo(r); this.reduce(r); return r; }+  }++  function barrettRevert(x) { return x; }++  // x = x mod m (HAC 14.42)+  function barrettReduce(x) {+    x.drShiftTo(this.m.t - 1, this.r2);+    if (x.t > this.m.t + 1) { x.t = this.m.t + 1; x.clamp(); }+    this.mu.multiplyUpperTo(this.r2, this.m.t + 1, this.q3);+    this.m.multiplyLowerTo(this.q3, this.m.t + 1, this.r2);+    while (x.compareTo(this.r2) < 0) x.dAddOffset(1, this.m.t + 1);+    x.subTo(this.r2, x);+    while (x.compareTo(this.m) >= 0) x.subTo(this.m, x);+  }++  // r = x^2 mod m; x != r+  function barrettSqrTo(x, r) { x.squareTo(r); this.reduce(r); }++  // r = x*y mod m; x,y != r+  function barrettMulTo(x, y, r) { x.multiplyTo(y, r); this.reduce(r); }++  Barrett.prototype.convert = barrettConvert;+  Barrett.prototype.revert = barrettRevert;+  Barrett.prototype.reduce = barrettReduce;+  Barrett.prototype.mulTo = barrettMulTo;+  Barrett.prototype.sqrTo = barrettSqrTo;++  // (public) this^e % m (HAC 14.85)+  function bnModPow(e, m) {+    var i = e.bitLength(), k, r = nbv(1), z;+    if (i <= 0) return r;+    else if (i < 18) k = 1;+    else if (i < 48) k = 3;+    else if (i < 144) k = 4;+    else if (i < 768) k = 5;+    else k = 6;+    if (i < 8)+      z = new Classic(m);+    else if (m.isEven())+      z = new Barrett(m);+    else+      z = new Montgomery(m);++    // precomputation+    var g = new Array(), n = 3, k1 = k - 1, km = (1 << k) - 1;+    g[1] = z.convert(this);+    if (k > 1) {+      var g2 = nbi();+      z.sqrTo(g[1], g2);+      while (n <= km) {+        g[n] = nbi();+        z.mulTo(g2, g[n - 2], g[n]);+        n += 2;+      }+    }++    var j = e.t - 1, w, is1 = true, r2 = nbi(), t;+    i = nbits(e[j]) - 1;+    while (j >= 0) {+      if (i >= k1) w = (e[j] >> (i - k1)) & km;+      else {+        w = (e[j] & ((1 << (i + 1)) - 1)) << (k1 - i);+        if (j > 0) w |= e[j - 1] >> (this.DB + i - k1);+      }++      n = k;+      while ((w & 1) == 0) { w >>= 1; --n; }+      if ((i -= n) < 0) { i += this.DB; --j; }+      if (is1) {    // ret == 1, don't bother squaring or multiplying it+        g[w].copyTo(r);+        is1 = false;+      }+      else {+        while (n > 1) { z.sqrTo(r, r2); z.sqrTo(r2, r); n -= 2; }+        if (n > 0) z.sqrTo(r, r2); else { t = r; r = r2; r2 = t; }+        z.mulTo(r2, g[w], r);+      }++      while (j >= 0 && (e[j] & (1 << i)) == 0) {+        z.sqrTo(r, r2); t = r; r = r2; r2 = t;+        if (--i < 0) { i = this.DB - 1; --j; }+      }+    }+    return z.revert(r);+  }++  // (public) gcd(this,a) (HAC 14.54)+  function bnGCD(a) {+    var x = (this.s < 0) ? this.negate() : this.clone();+    var y = (a.s < 0) ? a.negate() : a.clone();+    if (x.compareTo(y) < 0) { var t = x; x = y; y = t; }+    var i = x.getLowestSetBit(), g = y.getLowestSetBit();+    if (g < 0) return x;+    if (i < g) g = i;+    if (g > 0) {+      x.rShiftTo(g, x);+      y.rShiftTo(g, y);+    }+    while (x.signum() > 0) {+      if ((i = x.getLowestSetBit()) > 0) x.rShiftTo(i, x);+      if ((i = y.getLowestSetBit()) > 0) y.rShiftTo(i, y);+      if (x.compareTo(y) >= 0) {+        x.subTo(y, x);+        x.rShiftTo(1, x);+      }+      else {+        y.subTo(x, y);+        y.rShiftTo(1, y);+      }+    }+    if (g > 0) y.lShiftTo(g, y);+    return y;+  }++  // (protected) this % n, n < 2^26+  function bnpModInt(n) {+    if (n <= 0) return 0;+    var d = this.DV % n, r = (this.s < 0) ? n - 1 : 0;+    if (this.t > 0)+      if (d == 0) r = this[0] % n;+      else for (var i = this.t - 1; i >= 0; --i) r = (d * r + this[i]) % n;+    return r;+  }++  // (public) 1/this % m (HAC 14.61)+  function bnModInverse(m) {+    var ac = m.isEven();+    if ((this.isEven() && ac) || m.signum() == 0) return BigInteger.ZERO;+    var u = m.clone(), v = this.clone();+    var a = nbv(1), b = nbv(0), c = nbv(0), d = nbv(1);+    while (u.signum() != 0) {+      while (u.isEven()) {+        u.rShiftTo(1, u);+        if (ac) {+          if (!a.isEven() || !b.isEven()) { a.addTo(this, a); b.subTo(m, b); }+          a.rShiftTo(1, a);+        }+        else if (!b.isEven()) b.subTo(m, b);+        b.rShiftTo(1, b);+      }+      while (v.isEven()) {+        v.rShiftTo(1, v);+        if (ac) {+          if (!c.isEven() || !d.isEven()) { c.addTo(this, c); d.subTo(m, d); }+          c.rShiftTo(1, c);+        }+        else if (!d.isEven()) d.subTo(m, d);+        d.rShiftTo(1, d);+      }+      if (u.compareTo(v) >= 0) {+        u.subTo(v, u);+        if (ac) a.subTo(c, a);+        b.subTo(d, b);+      }+      else {+        v.subTo(u, v);+        if (ac) c.subTo(a, c);+        d.subTo(b, d);+      }+    }+    if (v.compareTo(BigInteger.ONE) != 0) return BigInteger.ZERO;+    if (d.compareTo(m) >= 0) return d.subtract(m);+    if (d.signum() < 0) d.addTo(m, d); else return d;+    if (d.signum() < 0) return d.add(m); else return d;+  }++  var lowprimes = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, 127, 131, 137, 139, 149, 151, 157, 163, 167, 173, 179, 181, 191, 193, 197, 199, 211, 223, 227, 229, 233, 239, 241, 251, 257, 263, 269, 271, 277, 281, 283, 293, 307, 311, 313, 317, 331, 337, 347, 349, 353, 359, 367, 373, 379, 383, 389, 397, 401, 409, 419, 421, 431, 433, 439, 443, 449, 457, 461, 463, 467, 479, 487, 491, 499, 503, 509, 521, 523, 541, 547, 557, 563, 569, 571, 577, 587, 593, 599, 601, 607, 613, 617, 619, 631, 641, 643, 647, 653, 659, 661, 673, 677, 683, 691, 701, 709, 719, 727, 733, 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, 811, 821, 823, 827, 829, 839, 853, 857, 859, 863, 877, 881, 883, 887, 907, 911, 919, 929, 937, 941, 947, 953, 967, 971, 977, 983, 991, 997];+  var lplim = (1 << 26) / lowprimes[lowprimes.length - 1];++  // (public) test primality with certainty >= 1-.5^t+  function bnIsProbablePrime(t) {+    var i, x = this.abs();+    if (x.t == 1 && x[0] <= lowprimes[lowprimes.length - 1]) {+      for (i = 0; i < lowprimes.length; ++i)+        if (x[0] == lowprimes[i]) return true;+      return false;+    }+    if (x.isEven()) return false;+    i = 1;+    while (i < lowprimes.length) {+      var m = lowprimes[i], j = i + 1;+      while (j < lowprimes.length && m < lplim) m *= lowprimes[j++];+      m = x.modInt(m);+      while (i < j) if (m % lowprimes[i++] == 0) return false;+    }+    return x.millerRabin(t);+  }++  // (protected) true if probably prime (HAC 4.24, Miller-Rabin)+  function bnpMillerRabin(t) {+    var n1 = this.subtract(BigInteger.ONE);+    var k = n1.getLowestSetBit();+    if (k <= 0) return false;+    var r = n1.shiftRight(k);+    t = (t + 1) >> 1;+    if (t > lowprimes.length) t = lowprimes.length;+    var a = nbi();+    for (var i = 0; i < t; ++i) {+      //Pick bases at random, instead of starting at 2+      a.fromInt(lowprimes[Math.floor(Math.random() * lowprimes.length)]);+      var y = a.modPow(r, this);+      if (y.compareTo(BigInteger.ONE) != 0 && y.compareTo(n1) != 0) {+        var j = 1;+        while (j++ < k && y.compareTo(n1) != 0) {+          y = y.modPowInt(2, this);+          if (y.compareTo(BigInteger.ONE) == 0) return false;+        }+        if (y.compareTo(n1) != 0) return false;+      }+    }+    return true;+  }++  // protected+  BigInteger.prototype.chunkSize = bnpChunkSize;+  BigInteger.prototype.toRadix = bnpToRadix;+  BigInteger.prototype.fromRadix = bnpFromRadix;+  BigInteger.prototype.fromNumber = bnpFromNumber;+  BigInteger.prototype.bitwiseTo = bnpBitwiseTo;+  BigInteger.prototype.changeBit = bnpChangeBit;+  BigInteger.prototype.addTo = bnpAddTo;+  BigInteger.prototype.dMultiply = bnpDMultiply;+  BigInteger.prototype.dAddOffset = bnpDAddOffset;+  BigInteger.prototype.multiplyLowerTo = bnpMultiplyLowerTo;+  BigInteger.prototype.multiplyUpperTo = bnpMultiplyUpperTo;+  BigInteger.prototype.modInt = bnpModInt;+  BigInteger.prototype.millerRabin = bnpMillerRabin;++  // public+  BigInteger.prototype.clone = bnClone;+  BigInteger.prototype.intValue = bnIntValue;+  BigInteger.prototype.byteValue = bnByteValue;+  BigInteger.prototype.shortValue = bnShortValue;+  BigInteger.prototype.signum = bnSigNum;+  BigInteger.prototype.toByteArray = bnToByteArray;+  BigInteger.prototype.equals = bnEquals;+  BigInteger.prototype.min = bnMin;+  BigInteger.prototype.max = bnMax;+  BigInteger.prototype.and = bnAnd;+  BigInteger.prototype.or = bnOr;+  BigInteger.prototype.xor = bnXor;+  BigInteger.prototype.andNot = bnAndNot;+  BigInteger.prototype.not = bnNot;+  BigInteger.prototype.shiftLeft = bnShiftLeft;+  BigInteger.prototype.shiftRight = bnShiftRight;+  BigInteger.prototype.getLowestSetBit = bnGetLowestSetBit;+  BigInteger.prototype.bitCount = bnBitCount;+  BigInteger.prototype.testBit = bnTestBit;+  BigInteger.prototype.setBit = bnSetBit;+  BigInteger.prototype.clearBit = bnClearBit;+  BigInteger.prototype.flipBit = bnFlipBit;+  BigInteger.prototype.add = bnAdd;+  BigInteger.prototype.subtract = bnSubtract;+  BigInteger.prototype.multiply = bnMultiply;+  BigInteger.prototype.divide = bnDivide;+  BigInteger.prototype.remainder = bnRemainder;+  BigInteger.prototype.divideAndRemainder = bnDivideAndRemainder;+  BigInteger.prototype.modPow = bnModPow;+  BigInteger.prototype.modInverse = bnModInverse;+  BigInteger.prototype.pow = bnPow;+  BigInteger.prototype.gcd = bnGCD;+  BigInteger.prototype.isProbablePrime = bnIsProbablePrime;++  // JSBN-specific extension+  BigInteger.prototype.square = bnSquare;++  // Expose the Barrett function+  BigInteger.prototype.Barrett = Barrett++  // BigInteger interfaces not implemented in jsbn:++  // BigInteger(int signum, byte[] magnitude)+  // double doubleValue()+  // float floatValue()+  // int hashCode()+  // long longValue()+  // static BigInteger valueOf(long val)++  // Random number generator - requires a PRNG backend, e.g. prng4.js++  // For best results, put code like+  // <body onClick='rng_seed_time();' onKeyPress='rng_seed_time();'>+  // in your main HTML document.++  var rng_state;+  var rng_pool;+  var rng_pptr;++  // Mix in a 32-bit integer into the pool+  function rng_seed_int(x) {+    rng_pool[rng_pptr++] ^= x & 255;+    rng_pool[rng_pptr++] ^= (x >> 8) & 255;+    rng_pool[rng_pptr++] ^= (x >> 16) & 255;+    rng_pool[rng_pptr++] ^= (x >> 24) & 255;+    if (rng_pptr >= rng_psize) rng_pptr -= rng_psize;+  }++  // Mix in the current time (w/milliseconds) into the pool+  function rng_seed_time() {+    rng_seed_int(new Date().getTime());+  }++  // Initialize the pool with junk if needed.+  if (rng_pool == null) {+    rng_pool = new Array();+    rng_pptr = 0;+    var t;+    if (typeof window !== "undefined" && window.crypto) {+      if (window.crypto.getRandomValues) {+        // Use webcrypto if available+        var ua = new Uint8Array(32);+        window.crypto.getRandomValues(ua);+        for (t = 0; t < 32; ++t)+          rng_pool[rng_pptr++] = ua[t];+      }+      else if (navigator.appName == "Netscape" && navigator.appVersion < "5") {+        // Extract entropy (256 bits) from NS4 RNG if available+        var z = window.crypto.random(32);+        for (t = 0; t < z.length; ++t)+          rng_pool[rng_pptr++] = z.charCodeAt(t) & 255;+      }+    }+    while (rng_pptr < rng_psize) {  // extract some randomness from Math.random()+      t = Math.floor(65536 * Math.random());+      rng_pool[rng_pptr++] = t >>> 8;+      rng_pool[rng_pptr++] = t & 255;+    }+    rng_pptr = 0;+    rng_seed_time();+    //rng_seed_int(window.screenX);+    //rng_seed_int(window.screenY);+  }++  function rng_get_byte() {+    if (rng_state == null) {+      rng_seed_time();+      rng_state = prng_newstate();+      rng_state.init(rng_pool);+      for (rng_pptr = 0; rng_pptr < rng_pool.length; ++rng_pptr)+        rng_pool[rng_pptr] = 0;+      rng_pptr = 0;+      //rng_pool = null;+    }+    // TODO: allow reseeding after first request+    return rng_state.next();+  }++  function rng_get_bytes(ba) {+    var i;+    for (i = 0; i < ba.length; ++i) ba[i] = rng_get_byte();+  }++  function SecureRandom() { }++  SecureRandom.prototype.nextBytes = rng_get_bytes;++  // prng4.js - uses Arcfour as a PRNG++  function Arcfour() {+    this.i = 0;+    this.j = 0;+    this.S = new Array();+  }++  // Initialize arcfour context from key, an array of ints, each from [0..255]+  function ARC4init(key) {+    var i, j, t;+    for (i = 0; i < 256; ++i)+      this.S[i] = i;+    j = 0;+    for (i = 0; i < 256; ++i) {+      j = (j + this.S[i] + key[i % key.length]) & 255;+      t = this.S[i];+      this.S[i] = this.S[j];+      this.S[j] = t;+    }+    this.i = 0;+    this.j = 0;+  }++  function ARC4next() {+    var t;+    this.i = (this.i + 1) & 255;+    this.j = (this.j + this.S[this.i]) & 255;+    t = this.S[this.i];+    this.S[this.i] = this.S[this.j];+    this.S[this.j] = t;+    return this.S[(t + this.S[this.i]) & 255];+  }++  Arcfour.prototype.init = ARC4init;+  Arcfour.prototype.next = ARC4next;++  // Plug in your RNG constructor here+  function prng_newstate() {+    return new Arcfour();+  }++  // Pool size must be a multiple of 4 and greater than 32.+  // An array of bytes the size of the pool will be passed to init()+  var rng_psize = 256;++  return {+    BigInteger: BigInteger,+    SecureRandom: SecureRandom+  };++}).call(this);
+ jsrts/jsbn/jsbn-node.js view
@@ -0,0 +1,1 @@+$JSRTS.jsbn = require('jsbn');
− jsrts/jsbn/jsbn.js 
@@ -1,1238 +0,0 @@-var i$bigInt = (function() {-// Copyright (c) 2005  Tom Wu-// All Rights Reserved.-// See "LICENSE" for details.--// Basic JavaScript BN library - subset useful for RSA encryption.--// Bits per digit-var dbits;--// JavaScript engine analysis-var canary = 0xdeadbeefcafe;-var j_lm = ((canary&0xffffff)==0xefcafe);--// (public) Constructor-function BigInteger(a,b,c) {-  if(a != null)-    if("number" == typeof a) this.fromNumber(a,b,c);-    else if(b == null && "string" != typeof a) this.fromString(a,256);-    else this.fromString(a,b);-}--// return new, unset BigInteger-function nbi() { return new BigInteger(null); }--// am: Compute w_j += (x*this_i), propagate carries,-// c is initial carry, returns final carry.-// c < 3*dvalue, x < 2*dvalue, this_i < dvalue-// We need to select the fastest one that works in this environment.--// am1: use a single mult and divide to get the high bits,-// max digit bits should be 26 because-// max internal value = 2*dvalue^2-2*dvalue (< 2^53)-function am1(i,x,w,j,c,n) {-  while(--n >= 0) {-    var v = x*this[i++]+w[j]+c;-    c = Math.floor(v/0x4000000);-    w[j++] = v&0x3ffffff;-  }-  return c;-}-// am2 avoids a big mult-and-extract completely.-// Max digit bits should be <= 30 because we do bitwise ops-// on values up to 2*hdvalue^2-hdvalue-1 (< 2^31)-function am2(i,x,w,j,c,n) {-  var xl = x&0x7fff, xh = x>>15;-  while(--n >= 0) {-    var l = this[i]&0x7fff;-    var h = this[i++]>>15;-    var m = xh*l+h*xl;-    l = xl*l+((m&0x7fff)<<15)+w[j]+(c&0x3fffffff);-    c = (l>>>30)+(m>>>15)+xh*h+(c>>>30);-    w[j++] = l&0x3fffffff;-  }-  return c;-}-// Alternately, set max digit bits to 28 since some-// browsers slow down when dealing with 32-bit numbers.-function am3(i,x,w,j,c,n) {-  var xl = x&0x3fff, xh = x>>14;-  while(--n >= 0) {-    var l = this[i]&0x3fff;-    var h = this[i++]>>14;-    var m = xh*l+h*xl;-    l = xl*l+((m&0x3fff)<<14)+w[j]+c;-    c = (l>>28)+(m>>14)+xh*h;-    w[j++] = l&0xfffffff;-  }-  return c;-}-var in_browser = typeof navigator !== "undefined"-if(in_browser && j_lm && (navigator.appName == "Microsoft Internet Explorer")) {-  BigInteger.prototype.am = am2;-  dbits = 30;-}-else if(in_browser && j_lm && (navigator.appName != "Netscape")) {-  BigInteger.prototype.am = am1;-  dbits = 26;-}-else { // Mozilla/Netscape seems to prefer am3-  BigInteger.prototype.am = am3;-  dbits = 28;-}--BigInteger.prototype.DB = dbits;-BigInteger.prototype.DM = ((1<<dbits)-1);-BigInteger.prototype.DV = (1<<dbits);--var BI_FP = 52;-BigInteger.prototype.FV = Math.pow(2,BI_FP);-BigInteger.prototype.F1 = BI_FP-dbits;-BigInteger.prototype.F2 = 2*dbits-BI_FP;--// Digit conversions-var BI_RM = "0123456789abcdefghijklmnopqrstuvwxyz";-var BI_RC = new Array();-var rr,vv;-rr = "0".charCodeAt(0);-for(vv = 0; vv <= 9; ++vv) BI_RC[rr++] = vv;-rr = "a".charCodeAt(0);-for(vv = 10; vv < 36; ++vv) BI_RC[rr++] = vv;-rr = "A".charCodeAt(0);-for(vv = 10; vv < 36; ++vv) BI_RC[rr++] = vv;--function int2char(n) { return BI_RM.charAt(n); }-function intAt(s,i) {-  var c = BI_RC[s.charCodeAt(i)];-  return (c==null)?-1:c;-}--// (protected) copy this to r-function bnpCopyTo(r) {-  for(var i = this.t-1; i >= 0; --i) r[i] = this[i];-  r.t = this.t;-  r.s = this.s;-}--// (protected) set from integer value x, -DV <= x < DV-function bnpFromInt(x) {-  this.t = 1;-  this.s = (x<0)?-1:0;-  if(x > 0) this[0] = x;-  else if(x < -1) this[0] = x+this.DV;-  else this.t = 0;-}--// return bigint initialized to value-function nbv(i) { var r = nbi(); r.fromInt(i); return r; }--// (protected) set from string and radix-function bnpFromString(s,b) {-  var k;-  if(b == 16) k = 4;-  else if(b == 8) k = 3;-  else if(b == 256) k = 8; // byte array-  else if(b == 2) k = 1;-  else if(b == 32) k = 5;-  else if(b == 4) k = 2;-  else { this.fromRadix(s,b); return; }-  this.t = 0;-  this.s = 0;-  var i = s.length, mi = false, sh = 0;-  while(--i >= 0) {-    var x = (k==8)?s[i]&0xff:intAt(s,i);-    if(x < 0) {-      if(s.charAt(i) == "-") mi = true;-      continue;-    }-    mi = false;-    if(sh == 0)-      this[this.t++] = x;-    else if(sh+k > this.DB) {-      this[this.t-1] |= (x&((1<<(this.DB-sh))-1))<<sh;-      this[this.t++] = (x>>(this.DB-sh));-    }-    else-      this[this.t-1] |= x<<sh;-    sh += k;-    if(sh >= this.DB) sh -= this.DB;-  }-  if(k == 8 && (s[0]&0x80) != 0) {-    this.s = -1;-    if(sh > 0) this[this.t-1] |= ((1<<(this.DB-sh))-1)<<sh;-  }-  this.clamp();-  if(mi) BigInteger.ZERO.subTo(this,this);-}--// (protected) clamp off excess high words-function bnpClamp() {-  var c = this.s&this.DM;-  while(this.t > 0 && this[this.t-1] == c) --this.t;-}--// (public) return string representation in given radix-function bnToString(b) {-  if(this.s < 0) return "-"+this.negate().toString(b);-  var k;-  if(b == 16) k = 4;-  else if(b == 8) k = 3;-  else if(b == 2) k = 1;-  else if(b == 32) k = 5;-  else if(b == 4) k = 2;-  else return this.toRadix(b);-  var km = (1<<k)-1, d, m = false, r = "", i = this.t;-  var p = this.DB-(i*this.DB)%k;-  if(i-- > 0) {-    if(p < this.DB && (d = this[i]>>p) > 0) { m = true; r = int2char(d); }-    while(i >= 0) {-      if(p < k) {-        d = (this[i]&((1<<p)-1))<<(k-p);-        d |= this[--i]>>(p+=this.DB-k);-      }-      else {-        d = (this[i]>>(p-=k))&km;-        if(p <= 0) { p += this.DB; --i; }-      }-      if(d > 0) m = true;-      if(m) r += int2char(d);-    }-  }-  return m?r:"0";-}--// (public) -this-function bnNegate() { var r = nbi(); BigInteger.ZERO.subTo(this,r); return r; }--// (public) |this|-function bnAbs() { return (this.s<0)?this.negate():this; }--// (public) return + if this > a, - if this < a, 0 if equal-function bnCompareTo(a) {-  var r = this.s-a.s;-  if(r != 0) return r;-  var i = this.t;-  r = i-a.t;-  if(r != 0) return (this.s<0)?-r:r;-  while(--i >= 0) if((r=this[i]-a[i]) != 0) return r;-  return 0;-}--// returns bit length of the integer x-function nbits(x) {-  var r = 1, t;-  if((t=x>>>16) != 0) { x = t; r += 16; }-  if((t=x>>8) != 0) { x = t; r += 8; }-  if((t=x>>4) != 0) { x = t; r += 4; }-  if((t=x>>2) != 0) { x = t; r += 2; }-  if((t=x>>1) != 0) { x = t; r += 1; }-  return r;-}--// (public) return the number of bits in "this"-function bnBitLength() {-  if(this.t <= 0) return 0;-  return this.DB*(this.t-1)+nbits(this[this.t-1]^(this.s&this.DM));-}--// (protected) r = this << n*DB-function bnpDLShiftTo(n,r) {-  var i;-  for(i = this.t-1; i >= 0; --i) r[i+n] = this[i];-  for(i = n-1; i >= 0; --i) r[i] = 0;-  r.t = this.t+n;-  r.s = this.s;-}--// (protected) r = this >> n*DB-function bnpDRShiftTo(n,r) {-  for(var i = n; i < this.t; ++i) r[i-n] = this[i];-  r.t = Math.max(this.t-n,0);-  r.s = this.s;-}--// (protected) r = this << n-function bnpLShiftTo(n,r) {-  var bs = n%this.DB;-  var cbs = this.DB-bs;-  var bm = (1<<cbs)-1;-  var ds = Math.floor(n/this.DB), c = (this.s<<bs)&this.DM, i;-  for(i = this.t-1; i >= 0; --i) {-    r[i+ds+1] = (this[i]>>cbs)|c;-    c = (this[i]&bm)<<bs;-  }-  for(i = ds-1; i >= 0; --i) r[i] = 0;-  r[ds] = c;-  r.t = this.t+ds+1;-  r.s = this.s;-  r.clamp();-}--// (protected) r = this >> n-function bnpRShiftTo(n,r) {-  r.s = this.s;-  var ds = Math.floor(n/this.DB);-  if(ds >= this.t) { r.t = 0; return; }-  var bs = n%this.DB;-  var cbs = this.DB-bs;-  var bm = (1<<bs)-1;-  r[0] = this[ds]>>bs;-  for(var i = ds+1; i < this.t; ++i) {-    r[i-ds-1] |= (this[i]&bm)<<cbs;-    r[i-ds] = this[i]>>bs;-  }-  if(bs > 0) r[this.t-ds-1] |= (this.s&bm)<<cbs;-  r.t = this.t-ds;-  r.clamp();-}--// (protected) r = this - a-function bnpSubTo(a,r) {-  var i = 0, c = 0, m = Math.min(a.t,this.t);-  while(i < m) {-    c += this[i]-a[i];-    r[i++] = c&this.DM;-    c >>= this.DB;-  }-  if(a.t < this.t) {-    c -= a.s;-    while(i < this.t) {-      c += this[i];-      r[i++] = c&this.DM;-      c >>= this.DB;-    }-    c += this.s;-  }-  else {-    c += this.s;-    while(i < a.t) {-      c -= a[i];-      r[i++] = c&this.DM;-      c >>= this.DB;-    }-    c -= a.s;-  }-  r.s = (c<0)?-1:0;-  if(c < -1) r[i++] = this.DV+c;-  else if(c > 0) r[i++] = c;-  r.t = i;-  r.clamp();-}--// (protected) r = this * a, r != this,a (HAC 14.12)-// "this" should be the larger one if appropriate.-function bnpMultiplyTo(a,r) {-  var x = this.abs(), y = a.abs();-  var i = x.t;-  r.t = i+y.t;-  while(--i >= 0) r[i] = 0;-  for(i = 0; i < y.t; ++i) r[i+x.t] = x.am(0,y[i],r,i,0,x.t);-  r.s = 0;-  r.clamp();-  if(this.s != a.s) BigInteger.ZERO.subTo(r,r);-}--// (protected) r = this^2, r != this (HAC 14.16)-function bnpSquareTo(r) {-  var x = this.abs();-  var i = r.t = 2*x.t;-  while(--i >= 0) r[i] = 0;-  for(i = 0; i < x.t-1; ++i) {-    var c = x.am(i,x[i],r,2*i,0,1);-    if((r[i+x.t]+=x.am(i+1,2*x[i],r,2*i+1,c,x.t-i-1)) >= x.DV) {-      r[i+x.t] -= x.DV;-      r[i+x.t+1] = 1;-    }-  }-  if(r.t > 0) r[r.t-1] += x.am(i,x[i],r,2*i,0,1);-  r.s = 0;-  r.clamp();-}--// (protected) divide this by m, quotient and remainder to q, r (HAC 14.20)-// r != q, this != m.  q or r may be null.-function bnpDivRemTo(m,q,r) {-  var pm = m.abs();-  if(pm.t <= 0) return;-  var pt = this.abs();-  if(pt.t < pm.t) {-    if(q != null) q.fromInt(0);-    if(r != null) this.copyTo(r);-    return;-  }-  if(r == null) r = nbi();-  var y = nbi(), ts = this.s, ms = m.s;-  var nsh = this.DB-nbits(pm[pm.t-1]);	// normalize modulus-  if(nsh > 0) { pm.lShiftTo(nsh,y); pt.lShiftTo(nsh,r); }-  else { pm.copyTo(y); pt.copyTo(r); }-  var ys = y.t;-  var y0 = y[ys-1];-  if(y0 == 0) return;-  var yt = y0*(1<<this.F1)+((ys>1)?y[ys-2]>>this.F2:0);-  var d1 = this.FV/yt, d2 = (1<<this.F1)/yt, e = 1<<this.F2;-  var i = r.t, j = i-ys, t = (q==null)?nbi():q;-  y.dlShiftTo(j,t);-  if(r.compareTo(t) >= 0) {-    r[r.t++] = 1;-    r.subTo(t,r);-  }-  BigInteger.ONE.dlShiftTo(ys,t);-  t.subTo(y,y);	// "negative" y so we can replace sub with am later-  while(y.t < ys) y[y.t++] = 0;-  while(--j >= 0) {-    // Estimate quotient digit-    var qd = (r[--i]==y0)?this.DM:Math.floor(r[i]*d1+(r[i-1]+e)*d2);-    if((r[i]+=y.am(0,qd,r,j,0,ys)) < qd) {	// Try it out-      y.dlShiftTo(j,t);-      r.subTo(t,r);-      while(r[i] < --qd) r.subTo(t,r);-    }-  }-  if(q != null) {-    r.drShiftTo(ys,q);-    if(ts != ms) BigInteger.ZERO.subTo(q,q);-  }-  r.t = ys;-  r.clamp();-  if(nsh > 0) r.rShiftTo(nsh,r);	// Denormalize remainder-  if(ts < 0) BigInteger.ZERO.subTo(r,r);-}--// (public) this mod a-function bnMod(a) {-  var r = nbi();-  this.abs().divRemTo(a,null,r);-  if(this.s < 0 && r.compareTo(BigInteger.ZERO) > 0) a.subTo(r,r);-  return r;-}--// Modular reduction using "classic" algorithm-function Classic(m) { this.m = m; }-function cConvert(x) {-  if(x.s < 0 || x.compareTo(this.m) >= 0) return x.mod(this.m);-  else return x;-}-function cRevert(x) { return x; }-function cReduce(x) { x.divRemTo(this.m,null,x); }-function cMulTo(x,y,r) { x.multiplyTo(y,r); this.reduce(r); }-function cSqrTo(x,r) { x.squareTo(r); this.reduce(r); }--Classic.prototype.convert = cConvert;-Classic.prototype.revert = cRevert;-Classic.prototype.reduce = cReduce;-Classic.prototype.mulTo = cMulTo;-Classic.prototype.sqrTo = cSqrTo;--// (protected) return "-1/this % 2^DB"; useful for Mont. reduction-// justification:-//         xy == 1 (mod m)-//         xy =  1+km-//   xy(2-xy) = (1+km)(1-km)-// x[y(2-xy)] = 1-k^2m^2-// x[y(2-xy)] == 1 (mod m^2)-// if y is 1/x mod m, then y(2-xy) is 1/x mod m^2-// should reduce x and y(2-xy) by m^2 at each step to keep size bounded.-// JS multiply "overflows" differently from C/C++, so care is needed here.-function bnpInvDigit() {-  if(this.t < 1) return 0;-  var x = this[0];-  if((x&1) == 0) return 0;-  var y = x&3;		// y == 1/x mod 2^2-  y = (y*(2-(x&0xf)*y))&0xf;	// y == 1/x mod 2^4-  y = (y*(2-(x&0xff)*y))&0xff;	// y == 1/x mod 2^8-  y = (y*(2-(((x&0xffff)*y)&0xffff)))&0xffff;	// y == 1/x mod 2^16-  // last step - calculate inverse mod DV directly;-  // assumes 16 < DB <= 32 and assumes ability to handle 48-bit ints-  y = (y*(2-x*y%this.DV))%this.DV;		// y == 1/x mod 2^dbits-  // we really want the negative inverse, and -DV < y < DV-  return (y>0)?this.DV-y:-y;-}--// Montgomery reduction-function Montgomery(m) {-  this.m = m;-  this.mp = m.invDigit();-  this.mpl = this.mp&0x7fff;-  this.mph = this.mp>>15;-  this.um = (1<<(m.DB-15))-1;-  this.mt2 = 2*m.t;-}--// xR mod m-function montConvert(x) {-  var r = nbi();-  x.abs().dlShiftTo(this.m.t,r);-  r.divRemTo(this.m,null,r);-  if(x.s < 0 && r.compareTo(BigInteger.ZERO) > 0) this.m.subTo(r,r);-  return r;-}--// x/R mod m-function montRevert(x) {-  var r = nbi();-  x.copyTo(r);-  this.reduce(r);-  return r;-}--// x = x/R mod m (HAC 14.32)-function montReduce(x) {-  while(x.t <= this.mt2)	// pad x so am has enough room later-    x[x.t++] = 0;-  for(var i = 0; i < this.m.t; ++i) {-    // faster way of calculating u0 = x[i]*mp mod DV-    var j = x[i]&0x7fff;-    var u0 = (j*this.mpl+(((j*this.mph+(x[i]>>15)*this.mpl)&this.um)<<15))&x.DM;-    // use am to combine the multiply-shift-add into one call-    j = i+this.m.t;-    x[j] += this.m.am(0,u0,x,i,0,this.m.t);-    // propagate carry-    while(x[j] >= x.DV) { x[j] -= x.DV; x[++j]++; }-  }-  x.clamp();-  x.drShiftTo(this.m.t,x);-  if(x.compareTo(this.m) >= 0) x.subTo(this.m,x);-}--// r = "x^2/R mod m"; x != r-function montSqrTo(x,r) { x.squareTo(r); this.reduce(r); }--// r = "xy/R mod m"; x,y != r-function montMulTo(x,y,r) { x.multiplyTo(y,r); this.reduce(r); }--Montgomery.prototype.convert = montConvert;-Montgomery.prototype.revert = montRevert;-Montgomery.prototype.reduce = montReduce;-Montgomery.prototype.mulTo = montMulTo;-Montgomery.prototype.sqrTo = montSqrTo;--// (protected) true iff this is even-function bnpIsEven() { return ((this.t>0)?(this[0]&1):this.s) == 0; }--// (protected) this^e, e < 2^32, doing sqr and mul with "r" (HAC 14.79)-function bnpExp(e,z) {-  if(e > 0xffffffff || e < 1) return BigInteger.ONE;-  var r = nbi(), r2 = nbi(), g = z.convert(this), i = nbits(e)-1;-  g.copyTo(r);-  while(--i >= 0) {-    z.sqrTo(r,r2);-    if((e&(1<<i)) > 0) z.mulTo(r2,g,r);-    else { var t = r; r = r2; r2 = t; }-  }-  return z.revert(r);-}--// (public) this^e % m, 0 <= e < 2^32-function bnModPowInt(e,m) {-  var z;-  if(e < 256 || m.isEven()) z = new Classic(m); else z = new Montgomery(m);-  return this.exp(e,z);-}--// protected-BigInteger.prototype.copyTo = bnpCopyTo;-BigInteger.prototype.fromInt = bnpFromInt;-BigInteger.prototype.fromString = bnpFromString;-BigInteger.prototype.clamp = bnpClamp;-BigInteger.prototype.dlShiftTo = bnpDLShiftTo;-BigInteger.prototype.drShiftTo = bnpDRShiftTo;-BigInteger.prototype.lShiftTo = bnpLShiftTo;-BigInteger.prototype.rShiftTo = bnpRShiftTo;-BigInteger.prototype.subTo = bnpSubTo;-BigInteger.prototype.multiplyTo = bnpMultiplyTo;-BigInteger.prototype.squareTo = bnpSquareTo;-BigInteger.prototype.divRemTo = bnpDivRemTo;-BigInteger.prototype.invDigit = bnpInvDigit;-BigInteger.prototype.isEven = bnpIsEven;-BigInteger.prototype.exp = bnpExp;--// public-BigInteger.prototype.toString = bnToString;-BigInteger.prototype.negate = bnNegate;-BigInteger.prototype.abs = bnAbs;-BigInteger.prototype.compareTo = bnCompareTo;-BigInteger.prototype.bitLength = bnBitLength;-BigInteger.prototype.mod = bnMod;-BigInteger.prototype.modPowInt = bnModPowInt;--// "constants"-BigInteger.ZERO = nbv(0);-BigInteger.ONE = nbv(1);--// Copyright (c) 2005-2009  Tom Wu-// All Rights Reserved.-// See "LICENSE" for details.--// Extended JavaScript BN functions, required for RSA private ops.--// Version 1.1: new BigInteger("0", 10) returns "proper" zero-// Version 1.2: square() API, isProbablePrime fix--// (public)-function bnClone() { var r = nbi(); this.copyTo(r); return r; }--// (public) return value as integer-function bnIntValue() {-  if(this.s < 0) {-    if(this.t == 1) return this[0]-this.DV;-    else if(this.t == 0) return -1;-  }-  else if(this.t == 1) return this[0];-  else if(this.t == 0) return 0;-  // assumes 16 < DB < 32-  return ((this[1]&((1<<(32-this.DB))-1))<<this.DB)|this[0];-}--// (public) return value as byte-function bnByteValue() { return (this.t==0)?this.s:(this[0]<<24)>>24; }--// (public) return value as short (assumes DB>=16)-function bnShortValue() { return (this.t==0)?this.s:(this[0]<<16)>>16; }--// (protected) return x s.t. r^x < DV-function bnpChunkSize(r) { return Math.floor(Math.LN2*this.DB/Math.log(r)); }--// (public) 0 if this == 0, 1 if this > 0-function bnSigNum() {-  if(this.s < 0) return -1;-  else if(this.t <= 0 || (this.t == 1 && this[0] <= 0)) return 0;-  else return 1;-}--// (protected) convert to radix string-function bnpToRadix(b) {-  if(b == null) b = 10;-  if(this.signum() == 0 || b < 2 || b > 36) return "0";-  var cs = this.chunkSize(b);-  var a = Math.pow(b,cs);-  var d = nbv(a), y = nbi(), z = nbi(), r = "";-  this.divRemTo(d,y,z);-  while(y.signum() > 0) {-    r = (a+z.intValue()).toString(b).substr(1) + r;-    y.divRemTo(d,y,z);-  }-  return z.intValue().toString(b) + r;-}--// (protected) convert from radix string-function bnpFromRadix(s,b) {-  this.fromInt(0);-  if(b == null) b = 10;-  var cs = this.chunkSize(b);-  var d = Math.pow(b,cs), mi = false, j = 0, w = 0;-  for(var i = 0; i < s.length; ++i) {-    var x = intAt(s,i);-    if(x < 0) {-      if(s.charAt(i) == "-" && this.signum() == 0) mi = true;-      continue;-    }-    w = b*w+x;-    if(++j >= cs) {-      this.dMultiply(d);-      this.dAddOffset(w,0);-      j = 0;-      w = 0;-    }-  }-  if(j > 0) {-    this.dMultiply(Math.pow(b,j));-    this.dAddOffset(w,0);-  }-  if(mi) BigInteger.ZERO.subTo(this,this);-}--// (protected) alternate constructor-function bnpFromNumber(a,b,c) {-  if("number" == typeof b) {-    // new BigInteger(int,int,RNG)-    if(a < 2) this.fromInt(1);-    else {-      this.fromNumber(a,c);-      if(!this.testBit(a-1))	// force MSB set-        this.bitwiseTo(BigInteger.ONE.shiftLeft(a-1),op_or,this);-      if(this.isEven()) this.dAddOffset(1,0); // force odd-      while(!this.isProbablePrime(b)) {-        this.dAddOffset(2,0);-        if(this.bitLength() > a) this.subTo(BigInteger.ONE.shiftLeft(a-1),this);-      }-    }-  }-  else {-    // new BigInteger(int,RNG)-    var x = new Array(), t = a&7;-    x.length = (a>>3)+1;-    b.nextBytes(x);-    if(t > 0) x[0] &= ((1<<t)-1); else x[0] = 0;-    this.fromString(x,256);-  }-}--// (public) convert to bigendian byte array-function bnToByteArray() {-  var i = this.t, r = new Array();-  r[0] = this.s;-  var p = this.DB-(i*this.DB)%8, d, k = 0;-  if(i-- > 0) {-    if(p < this.DB && (d = this[i]>>p) != (this.s&this.DM)>>p)-      r[k++] = d|(this.s<<(this.DB-p));-    while(i >= 0) {-      if(p < 8) {-        d = (this[i]&((1<<p)-1))<<(8-p);-        d |= this[--i]>>(p+=this.DB-8);-      }-      else {-        d = (this[i]>>(p-=8))&0xff;-        if(p <= 0) { p += this.DB; --i; }-      }-      if((d&0x80) != 0) d |= -256;-      if(k == 0 && (this.s&0x80) != (d&0x80)) ++k;-      if(k > 0 || d != this.s) r[k++] = d;-    }-  }-  return r;-}--function bnEquals(a) { return(this.compareTo(a)==0); }-function bnMin(a) { return(this.compareTo(a)<0)?this:a; }-function bnMax(a) { return(this.compareTo(a)>0)?this:a; }--// (protected) r = this op a (bitwise)-function bnpBitwiseTo(a,op,r) {-  var i, f, m = Math.min(a.t,this.t);-  for(i = 0; i < m; ++i) r[i] = op(this[i],a[i]);-  if(a.t < this.t) {-    f = a.s&this.DM;-    for(i = m; i < this.t; ++i) r[i] = op(this[i],f);-    r.t = this.t;-  }-  else {-    f = this.s&this.DM;-    for(i = m; i < a.t; ++i) r[i] = op(f,a[i]);-    r.t = a.t;-  }-  r.s = op(this.s,a.s);-  r.clamp();-}--// (public) this & a-function op_and(x,y) { return x&y; }-function bnAnd(a) { var r = nbi(); this.bitwiseTo(a,op_and,r); return r; }--// (public) this | a-function op_or(x,y) { return x|y; }-function bnOr(a) { var r = nbi(); this.bitwiseTo(a,op_or,r); return r; }--// (public) this ^ a-function op_xor(x,y) { return x^y; }-function bnXor(a) { var r = nbi(); this.bitwiseTo(a,op_xor,r); return r; }--// (public) this & ~a-function op_andnot(x,y) { return x&~y; }-function bnAndNot(a) { var r = nbi(); this.bitwiseTo(a,op_andnot,r); return r; }--// (public) ~this-function bnNot() {-  var r = nbi();-  for(var i = 0; i < this.t; ++i) r[i] = this.DM&~this[i];-  r.t = this.t;-  r.s = ~this.s;-  return r;-}--// (public) this << n-function bnShiftLeft(n) {-  var r = nbi();-  if(n < 0) this.rShiftTo(-n,r); else this.lShiftTo(n,r);-  return r;-}--// (public) this >> n-function bnShiftRight(n) {-  var r = nbi();-  if(n < 0) this.lShiftTo(-n,r); else this.rShiftTo(n,r);-  return r;-}--// return index of lowest 1-bit in x, x < 2^31-function lbit(x) {-  if(x == 0) return -1;-  var r = 0;-  if((x&0xffff) == 0) { x >>= 16; r += 16; }-  if((x&0xff) == 0) { x >>= 8; r += 8; }-  if((x&0xf) == 0) { x >>= 4; r += 4; }-  if((x&3) == 0) { x >>= 2; r += 2; }-  if((x&1) == 0) ++r;-  return r;-}--// (public) returns index of lowest 1-bit (or -1 if none)-function bnGetLowestSetBit() {-  for(var i = 0; i < this.t; ++i)-    if(this[i] != 0) return i*this.DB+lbit(this[i]);-  if(this.s < 0) return this.t*this.DB;-  return -1;-}--// return number of 1 bits in x-function cbit(x) {-  var r = 0;-  while(x != 0) { x &= x-1; ++r; }-  return r;-}--// (public) return number of set bits-function bnBitCount() {-  var r = 0, x = this.s&this.DM;-  for(var i = 0; i < this.t; ++i) r += cbit(this[i]^x);-  return r;-}--// (public) true iff nth bit is set-function bnTestBit(n) {-  var j = Math.floor(n/this.DB);-  if(j >= this.t) return(this.s!=0);-  return((this[j]&(1<<(n%this.DB)))!=0);-}--// (protected) this op (1<<n)-function bnpChangeBit(n,op) {-  var r = BigInteger.ONE.shiftLeft(n);-  this.bitwiseTo(r,op,r);-  return r;-}--// (public) this | (1<<n)-function bnSetBit(n) { return this.changeBit(n,op_or); }--// (public) this & ~(1<<n)-function bnClearBit(n) { return this.changeBit(n,op_andnot); }--// (public) this ^ (1<<n)-function bnFlipBit(n) { return this.changeBit(n,op_xor); }--// (protected) r = this + a-function bnpAddTo(a,r) {-  var i = 0, c = 0, m = Math.min(a.t,this.t);-  while(i < m) {-    c += this[i]+a[i];-    r[i++] = c&this.DM;-    c >>= this.DB;-  }-  if(a.t < this.t) {-    c += a.s;-    while(i < this.t) {-      c += this[i];-      r[i++] = c&this.DM;-      c >>= this.DB;-    }-    c += this.s;-  }-  else {-    c += this.s;-    while(i < a.t) {-      c += a[i];-      r[i++] = c&this.DM;-      c >>= this.DB;-    }-    c += a.s;-  }-  r.s = (c<0)?-1:0;-  if(c > 0) r[i++] = c;-  else if(c < -1) r[i++] = this.DV+c;-  r.t = i;-  r.clamp();-}--// (public) this + a-function bnAdd(a) { var r = nbi(); this.addTo(a,r); return r; }--// (public) this - a-function bnSubtract(a) { var r = nbi(); this.subTo(a,r); return r; }--// (public) this * a-function bnMultiply(a) { var r = nbi(); this.multiplyTo(a,r); return r; }--// (public) this^2-function bnSquare() { var r = nbi(); this.squareTo(r); return r; }--// (public) this / a-function bnDivide(a) { var r = nbi(); this.divRemTo(a,r,null); return r; }--// (public) this % a-function bnRemainder(a) { var r = nbi(); this.divRemTo(a,null,r); return r; }--// (public) [this/a,this%a]-function bnDivideAndRemainder(a) {-  var q = nbi(), r = nbi();-  this.divRemTo(a,q,r);-  return new Array(q,r);-}--// (protected) this *= n, this >= 0, 1 < n < DV-function bnpDMultiply(n) {-  this[this.t] = this.am(0,n-1,this,0,0,this.t);-  ++this.t;-  this.clamp();-}--// (protected) this += n << w words, this >= 0-function bnpDAddOffset(n,w) {-  if(n == 0) return;-  while(this.t <= w) this[this.t++] = 0;-  this[w] += n;-  while(this[w] >= this.DV) {-    this[w] -= this.DV;-    if(++w >= this.t) this[this.t++] = 0;-    ++this[w];-  }-}--// A "null" reducer-function NullExp() {}-function nNop(x) { return x; }-function nMulTo(x,y,r) { x.multiplyTo(y,r); }-function nSqrTo(x,r) { x.squareTo(r); }--NullExp.prototype.convert = nNop;-NullExp.prototype.revert = nNop;-NullExp.prototype.mulTo = nMulTo;-NullExp.prototype.sqrTo = nSqrTo;--// (public) this^e-function bnPow(e) { return this.exp(e,new NullExp()); }--// (protected) r = lower n words of "this * a", a.t <= n-// "this" should be the larger one if appropriate.-function bnpMultiplyLowerTo(a,n,r) {-  var i = Math.min(this.t+a.t,n);-  r.s = 0; // assumes a,this >= 0-  r.t = i;-  while(i > 0) r[--i] = 0;-  var j;-  for(j = r.t-this.t; i < j; ++i) r[i+this.t] = this.am(0,a[i],r,i,0,this.t);-  for(j = Math.min(a.t,n); i < j; ++i) this.am(0,a[i],r,i,0,n-i);-  r.clamp();-}--// (protected) r = "this * a" without lower n words, n > 0-// "this" should be the larger one if appropriate.-function bnpMultiplyUpperTo(a,n,r) {-  --n;-  var i = r.t = this.t+a.t-n;-  r.s = 0; // assumes a,this >= 0-  while(--i >= 0) r[i] = 0;-  for(i = Math.max(n-this.t,0); i < a.t; ++i)-    r[this.t+i-n] = this.am(n-i,a[i],r,0,0,this.t+i-n);-  r.clamp();-  r.drShiftTo(1,r);-}--// Barrett modular reduction-function Barrett(m) {-  // setup Barrett-  this.r2 = nbi();-  this.q3 = nbi();-  BigInteger.ONE.dlShiftTo(2*m.t,this.r2);-  this.mu = this.r2.divide(m);-  this.m = m;-}--function barrettConvert(x) {-  if(x.s < 0 || x.t > 2*this.m.t) return x.mod(this.m);-  else if(x.compareTo(this.m) < 0) return x;-  else { var r = nbi(); x.copyTo(r); this.reduce(r); return r; }-}--function barrettRevert(x) { return x; }--// x = x mod m (HAC 14.42)-function barrettReduce(x) {-  x.drShiftTo(this.m.t-1,this.r2);-  if(x.t > this.m.t+1) { x.t = this.m.t+1; x.clamp(); }-  this.mu.multiplyUpperTo(this.r2,this.m.t+1,this.q3);-  this.m.multiplyLowerTo(this.q3,this.m.t+1,this.r2);-  while(x.compareTo(this.r2) < 0) x.dAddOffset(1,this.m.t+1);-  x.subTo(this.r2,x);-  while(x.compareTo(this.m) >= 0) x.subTo(this.m,x);-}--// r = x^2 mod m; x != r-function barrettSqrTo(x,r) { x.squareTo(r); this.reduce(r); }--// r = x*y mod m; x,y != r-function barrettMulTo(x,y,r) { x.multiplyTo(y,r); this.reduce(r); }--Barrett.prototype.convert = barrettConvert;-Barrett.prototype.revert = barrettRevert;-Barrett.prototype.reduce = barrettReduce;-Barrett.prototype.mulTo = barrettMulTo;-Barrett.prototype.sqrTo = barrettSqrTo;--// (public) this^e % m (HAC 14.85)-function bnModPow(e,m) {-  var i = e.bitLength(), k, r = nbv(1), z;-  if(i <= 0) return r;-  else if(i < 18) k = 1;-  else if(i < 48) k = 3;-  else if(i < 144) k = 4;-  else if(i < 768) k = 5;-  else k = 6;-  if(i < 8)-    z = new Classic(m);-  else if(m.isEven())-    z = new Barrett(m);-  else-    z = new Montgomery(m);--  // precomputation-  var g = new Array(), n = 3, k1 = k-1, km = (1<<k)-1;-  g[1] = z.convert(this);-  if(k > 1) {-    var g2 = nbi();-    z.sqrTo(g[1],g2);-    while(n <= km) {-      g[n] = nbi();-      z.mulTo(g2,g[n-2],g[n]);-      n += 2;-    }-  }--  var j = e.t-1, w, is1 = true, r2 = nbi(), t;-  i = nbits(e[j])-1;-  while(j >= 0) {-    if(i >= k1) w = (e[j]>>(i-k1))&km;-    else {-      w = (e[j]&((1<<(i+1))-1))<<(k1-i);-      if(j > 0) w |= e[j-1]>>(this.DB+i-k1);-    }--    n = k;-    while((w&1) == 0) { w >>= 1; --n; }-    if((i -= n) < 0) { i += this.DB; --j; }-    if(is1) {	// ret == 1, don't bother squaring or multiplying it-      g[w].copyTo(r);-      is1 = false;-    }-    else {-      while(n > 1) { z.sqrTo(r,r2); z.sqrTo(r2,r); n -= 2; }-      if(n > 0) z.sqrTo(r,r2); else { t = r; r = r2; r2 = t; }-      z.mulTo(r2,g[w],r);-    }--    while(j >= 0 && (e[j]&(1<<i)) == 0) {-      z.sqrTo(r,r2); t = r; r = r2; r2 = t;-      if(--i < 0) { i = this.DB-1; --j; }-    }-  }-  return z.revert(r);-}--// (public) gcd(this,a) (HAC 14.54)-function bnGCD(a) {-  var x = (this.s<0)?this.negate():this.clone();-  var y = (a.s<0)?a.negate():a.clone();-  if(x.compareTo(y) < 0) { var t = x; x = y; y = t; }-  var i = x.getLowestSetBit(), g = y.getLowestSetBit();-  if(g < 0) return x;-  if(i < g) g = i;-  if(g > 0) {-    x.rShiftTo(g,x);-    y.rShiftTo(g,y);-  }-  while(x.signum() > 0) {-    if((i = x.getLowestSetBit()) > 0) x.rShiftTo(i,x);-    if((i = y.getLowestSetBit()) > 0) y.rShiftTo(i,y);-    if(x.compareTo(y) >= 0) {-      x.subTo(y,x);-      x.rShiftTo(1,x);-    }-    else {-      y.subTo(x,y);-      y.rShiftTo(1,y);-    }-  }-  if(g > 0) y.lShiftTo(g,y);-  return y;-}--// (protected) this % n, n < 2^26-function bnpModInt(n) {-  if(n <= 0) return 0;-  var d = this.DV%n, r = (this.s<0)?n-1:0;-  if(this.t > 0)-    if(d == 0) r = this[0]%n;-    else for(var i = this.t-1; i >= 0; --i) r = (d*r+this[i])%n;-  return r;-}--// (public) 1/this % m (HAC 14.61)-function bnModInverse(m) {-  var ac = m.isEven();-  if((this.isEven() && ac) || m.signum() == 0) return BigInteger.ZERO;-  var u = m.clone(), v = this.clone();-  var a = nbv(1), b = nbv(0), c = nbv(0), d = nbv(1);-  while(u.signum() != 0) {-    while(u.isEven()) {-      u.rShiftTo(1,u);-      if(ac) {-        if(!a.isEven() || !b.isEven()) { a.addTo(this,a); b.subTo(m,b); }-        a.rShiftTo(1,a);-      }-      else if(!b.isEven()) b.subTo(m,b);-      b.rShiftTo(1,b);-    }-    while(v.isEven()) {-      v.rShiftTo(1,v);-      if(ac) {-        if(!c.isEven() || !d.isEven()) { c.addTo(this,c); d.subTo(m,d); }-        c.rShiftTo(1,c);-      }-      else if(!d.isEven()) d.subTo(m,d);-      d.rShiftTo(1,d);-    }-    if(u.compareTo(v) >= 0) {-      u.subTo(v,u);-      if(ac) a.subTo(c,a);-      b.subTo(d,b);-    }-    else {-      v.subTo(u,v);-      if(ac) c.subTo(a,c);-      d.subTo(b,d);-    }-  }-  if(v.compareTo(BigInteger.ONE) != 0) return BigInteger.ZERO;-  if(d.compareTo(m) >= 0) return d.subtract(m);-  if(d.signum() < 0) d.addTo(m,d); else return d;-  if(d.signum() < 0) return d.add(m); else return d;-}--var lowprimes = [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109,113,127,131,137,139,149,151,157,163,167,173,179,181,191,193,197,199,211,223,227,229,233,239,241,251,257,263,269,271,277,281,283,293,307,311,313,317,331,337,347,349,353,359,367,373,379,383,389,397,401,409,419,421,431,433,439,443,449,457,461,463,467,479,487,491,499,503,509,521,523,541,547,557,563,569,571,577,587,593,599,601,607,613,617,619,631,641,643,647,653,659,661,673,677,683,691,701,709,719,727,733,739,743,751,757,761,769,773,787,797,809,811,821,823,827,829,839,853,857,859,863,877,881,883,887,907,911,919,929,937,941,947,953,967,971,977,983,991,997];-var lplim = (1<<26)/lowprimes[lowprimes.length-1];--// (public) test primality with certainty >= 1-.5^t-function bnIsProbablePrime(t) {-  var i, x = this.abs();-  if(x.t == 1 && x[0] <= lowprimes[lowprimes.length-1]) {-    for(i = 0; i < lowprimes.length; ++i)-      if(x[0] == lowprimes[i]) return true;-    return false;-  }-  if(x.isEven()) return false;-  i = 1;-  while(i < lowprimes.length) {-    var m = lowprimes[i], j = i+1;-    while(j < lowprimes.length && m < lplim) m *= lowprimes[j++];-    m = x.modInt(m);-    while(i < j) if(m%lowprimes[i++] == 0) return false;-  }-  return x.millerRabin(t);-}--// (protected) true if probably prime (HAC 4.24, Miller-Rabin)-function bnpMillerRabin(t) {-  var n1 = this.subtract(BigInteger.ONE);-  var k = n1.getLowestSetBit();-  if(k <= 0) return false;-  var r = n1.shiftRight(k);-  t = (t+1)>>1;-  if(t > lowprimes.length) t = lowprimes.length;-  var a = nbi();-  for(var i = 0; i < t; ++i) {-    //Pick bases at random, instead of starting at 2-    a.fromInt(lowprimes[Math.floor(Math.random()*lowprimes.length)]);-    var y = a.modPow(r,this);-    if(y.compareTo(BigInteger.ONE) != 0 && y.compareTo(n1) != 0) {-      var j = 1;-      while(j++ < k && y.compareTo(n1) != 0) {-        y = y.modPowInt(2,this);-        if(y.compareTo(BigInteger.ONE) == 0) return false;-      }-      if(y.compareTo(n1) != 0) return false;-    }-  }-  return true;-}--// protected-BigInteger.prototype.chunkSize = bnpChunkSize;-BigInteger.prototype.toRadix = bnpToRadix;-BigInteger.prototype.fromRadix = bnpFromRadix;-BigInteger.prototype.fromNumber = bnpFromNumber;-BigInteger.prototype.bitwiseTo = bnpBitwiseTo;-BigInteger.prototype.changeBit = bnpChangeBit;-BigInteger.prototype.addTo = bnpAddTo;-BigInteger.prototype.dMultiply = bnpDMultiply;-BigInteger.prototype.dAddOffset = bnpDAddOffset;-BigInteger.prototype.multiplyLowerTo = bnpMultiplyLowerTo;-BigInteger.prototype.multiplyUpperTo = bnpMultiplyUpperTo;-BigInteger.prototype.modInt = bnpModInt;-BigInteger.prototype.millerRabin = bnpMillerRabin;--// public-BigInteger.prototype.clone = bnClone;-BigInteger.prototype.intValue = bnIntValue;-BigInteger.prototype.byteValue = bnByteValue;-BigInteger.prototype.shortValue = bnShortValue;-BigInteger.prototype.signum = bnSigNum;-BigInteger.prototype.toByteArray = bnToByteArray;-BigInteger.prototype.equals = bnEquals;-BigInteger.prototype.min = bnMin;-BigInteger.prototype.max = bnMax;-BigInteger.prototype.and = bnAnd;-BigInteger.prototype.or = bnOr;-BigInteger.prototype.xor = bnXor;-BigInteger.prototype.andNot = bnAndNot;-BigInteger.prototype.not = bnNot;-BigInteger.prototype.shiftLeft = bnShiftLeft;-BigInteger.prototype.shiftRight = bnShiftRight;-BigInteger.prototype.getLowestSetBit = bnGetLowestSetBit;-BigInteger.prototype.bitCount = bnBitCount;-BigInteger.prototype.testBit = bnTestBit;-BigInteger.prototype.setBit = bnSetBit;-BigInteger.prototype.clearBit = bnClearBit;-BigInteger.prototype.flipBit = bnFlipBit;-BigInteger.prototype.add = bnAdd;-BigInteger.prototype.subtract = bnSubtract;-BigInteger.prototype.multiply = bnMultiply;-BigInteger.prototype.divide = bnDivide;-BigInteger.prototype.remainder = bnRemainder;-BigInteger.prototype.divideAndRemainder = bnDivideAndRemainder;-BigInteger.prototype.modPow = bnModPow;-BigInteger.prototype.modInverse = bnModInverse;-BigInteger.prototype.pow = bnPow;-BigInteger.prototype.gcd = bnGCD;-BigInteger.prototype.isProbablePrime = bnIsProbablePrime;--// JSBN-specific extension-BigInteger.prototype.square = bnSquare;--// BigInteger interfaces not implemented in jsbn:--// BigInteger(int signum, byte[] magnitude)-// double doubleValue()-// float floatValue()-// int hashCode()-// long longValue()-//-BigInteger.prototype.lesser = function(rhs) {-  return this.compareTo(rhs) < 0-}-BigInteger.prototype.lesserOrEquals = function(rhs) {-  return this.compareTo(rhs) <= 0-}-BigInteger.prototype.greater = function(rhs) {-  return this.compareTo(rhs) > 0-}-BigInteger.prototype.greaterOrEquals = function(rhs) {-  return this.compareTo(rhs) >= 0-}--return function(val) {-  return new BigInteger(val);-}-})();--var i$ZERO = i$bigInt("0");-var i$ONE = i$bigInt("1");
libs/base/Control/Catchable.idr view
@@ -1,6 +1,10 @@ module Control.Catchable  import Control.IOExcept+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.RWS+import Control.Monad.Trans  %access public export @@ -32,3 +36,21 @@     catch xs h = xs      throw () = []++||| Adapted from https://hackage.haskell.org/package/mtl-2.2.1/docs/src/Control.Monad.Error.Class.html#line-138+implementation (Monad m, Catchable m t) => Catchable (ReaderT r m) t where+    -- TODO: rewrite this with apply2way combinator when implemented+    catch m h = RD $ \ r => catch (runReaderT m r) (\ e => runReaderT (h e) r)+    -- catch m h = RD $ \ r => catch (runReaderT m r) (\ e => runReaderT (h e) r)++    throw = lift . throw++||| Adapted from https://hackage.haskell.org/package/transformers-0.5.4.0/docs/src/Control.Monad.Trans.Writer.Lazy.html#local-6989586621679059673+implementation (Monad m, Monoid w, Catchable m t) => Catchable (WriterT w m) t where+    catch m h = WR $ runWriterT m `catch` runWriterT . h+    throw = lift . throw++||| Adapted from https://hackage.haskell.org/package/mtl-2.2.1/docs/src/Control.Monad.Error.Class.html#line-138+implementation (Monad m, Monoid w, Catchable m t) => Catchable (RWST r w s m) t where+    catch m h = MkRWST $ \ r, s => runRWST m r s `catch` \ e => runRWST (h e) r s+    throw = lift . throw
libs/base/Control/Monad/RWS.idr view
@@ -14,7 +14,7 @@ record RWST (r : Type) (w : Type) (s : Type) (m : Type -> Type) (a : Type) where   constructor MkRWST   runRWST : r -> s -> m (a, s, w)-  + implementation Monad m => Functor (RWST r w s m) where     map f (MkRWST m) = MkRWST $ \r,s => do  (a, s', w) <- m r s                                             pure (f a, s', w)@@ -47,6 +47,12 @@     put s = MkRWST $ \_,_ => pure ((), s, neutral)  implementation (Monoid w, Monad m) => MonadRWS r w s (RWST r w s m) where {}++||| Adapted from https://hackage.haskell.org/package/transformers-0.5.4.0/docs/src/Control-Monad-Trans-RWS-Lazy.html+implementation Monoid w => MonadTrans (RWST r w s) where+    lift x = MkRWST $ \ _, s => do+        a <- x+        pure (a, s, neutral)  ||| The RWS monad. See the MonadRWS interface RWS : Type -> Type -> Type -> Type -> Type
libs/base/Data/Bits.idr view
@@ -19,8 +19,8 @@       l2x = log2NZ (S x) SIsNotZ  ||| Gets the lowest n for which "8 * 2 ^ n" is larger than or equal to the input.-||| For example, `nextBytes 10 = 16`.-||| Like with nextPow2, the result is not rounded up, so `nextBytes 16 = 16`.+||| For example, `nextBytes 10 = 1`.+||| Like with nextPow2, the result is not rounded up, so `nextBytes 16 = 1`. public export nextBytes : Nat -> Nat nextBytes bits = (nextPow2 (divCeilNZ bits 8 SIsNotZ))@@ -368,6 +368,7 @@                     prim__complB64 (x `prim__shlB64` pad) `prim__lshrB64` pad     | _ = assert_unreachable +||| Reverse all the bits in the argument. complement : %static {n : Nat} -> Bits n -> Bits n complement (MkBits x) = MkBits (complement' x) @@ -386,6 +387,7 @@     | (S (S (S _)), S (S (S _))) = believe_me x     | _ = assert_unreachable +||| Extend the bitstring with zeros, leaving the first n bits unchanged. zeroExtend : %static {n : Nat} -> %static {m : Nat} -> Bits n -> Bits (n+m) zeroExtend (MkBits x) = MkBits (zext' x) @@ -418,7 +420,7 @@ bitsToInt : %static {n : Nat} -> Bits n -> Integer bitsToInt (MkBits x) = bitsToInt' x --- Zero out the high bits of a truncated bitstring+||| Zero out the high bits of a truncated bitstring zeroUnused : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0) @@ -474,10 +476,13 @@     | (S (S (S _)), S (S (S _))) = believe_me x     | _ = assert_unreachable +||| Truncate the high bits of a bitstring. truncate : %static {m : Nat} -> %static {n : Nat} -> Bits (m+n) -> Bits n truncate (MkBits x) = MkBits (zeroUnused (trunc' x)) -bitAt : %static {n : Nat} -> Fin n -> Bits n+||| Create a bitstring of length n with the bit given as an argument set to one+||| and all other bits set to zero.+bitAt : %static {n : Nat} -> (at : Fin n) -> Bits n bitAt n = intToBits 1 `shiftLeft` intToBits (cast n)  getBit : %static {n : Nat} -> Fin n -> Bits n -> Bool
libs/base/Data/List/Views.idr view
@@ -61,22 +61,18 @@                     (lrec : Lazy (SplitRec lefts)) ->                      (rrec : Lazy (SplitRec rights)) -> SplitRec (lefts ++ rights) -total-splitRecFix : (xs : List a) -> ((ys : List a) -> smaller ys xs -> SplitRec ys) -> -              SplitRec xs-splitRecFix xs srec with (split xs)-  splitRecFix [] srec | SplitNil = SplitRecNil-  splitRecFix [x] srec | SplitOne = SplitRecOne-  splitRecFix (x :: (ys ++ (y :: zs))) srec | SplitPair -      = let left = srec (x :: ys) (smallerLeft ys y zs)-            right = srec (y :: zs) (smallerRight ys zs) in-            SplitRecPair left right- ||| Covering function for the `SplitRec` view ||| Constructs the view in O(n lg n)-export total+public export total splitRec : (xs : List a) -> SplitRec xs-splitRec xs = accInd splitRecFix xs (smallerAcc xs)+splitRec xs with (sizeAccessible xs)+  splitRec xs | acc with (split xs)+    splitRec []  | acc | SplitNil = SplitRecNil+    splitRec [x] | acc | SplitOne = SplitRecOne+    splitRec (y :: ys ++ z :: zs) | Access acc | SplitPair+      = SplitRecPair+          (splitRec (y :: ys) | acc _ (smallerLeft ys z zs))+          (splitRec (z :: zs) | acc _ (smallerRight ys zs))  ||| View for traversing a list backwards public export@@ -105,21 +101,21 @@             (rrec : Lazy (Filtered p (filter (\y => not (p y x)) xs))) ->             Filtered p (x :: xs) -filteredLOK : (p : a -> a -> Bool) -> (x : a) -> (xs : List a) -> smaller (filter (\y => p y x) xs) (x :: xs)+filteredLOK : (p : a -> a -> Bool) -> (x : a) -> (xs : List a) -> Smaller (filter (\y => p y x) xs) (x :: xs) filteredLOK p x xs = LTESucc (filterSmaller xs) -filteredROK : (p : a -> a -> Bool) -> (x : a) -> (xs : List a) -> smaller (filter (\y => not (p y x)) xs) (x :: xs)+filteredROK : (p : a -> a -> Bool) -> (x : a) -> (xs : List a) -> Smaller (filter (\y => not (p y x)) xs) (x :: xs) filteredROK p x xs = LTESucc (filterSmaller xs)  ||| Covering function for the `Filtered` view ||| Constructs the view in O(n lg n)-export+public export total filtered : (p : a -> a -> Bool) -> (xs : List a) -> Filtered p xs-filtered p inp with (smallerAcc inp)-  filtered p [] | with_pat = FNil-  filtered p (x :: xs) | (Access xsrec) -      =  FRec (filtered p (filter (\y => p y x) xs) | xsrec _ (filteredLOK p x xs))-              (filtered p (filter (\y => not (p y x)) xs) | xsrec _ (filteredROK p x xs))+filtered p inp with (sizeAccessible inp)+  filtered p [] | _ = FNil+  filtered p (x :: xs) | Access acc+      =  FRec (filtered p (filter (\y => p y x) xs) | acc _ (filteredLOK p x xs))+              (filtered p (filter (\y => not (p y x)) xs) | acc _ (filteredROK p x xs))  lenImpossible : (n = Z) -> (n = ((S k) + right)) -> Void lenImpossible {n = Z} _ Refl impossible
libs/base/Data/Nat/Views.idr view
@@ -22,17 +22,13 @@                                            HalfEven {n=S n}   half (S (n + n)) | HalfEven = HalfOdd -halfRecFix : (n : Nat) -> ((m : Nat) -> LT m n -> HalfRec m) -> HalfRec n-halfRecFix Z hrec = HalfRecZ-halfRecFix (S k) hrec with (half k)-  halfRecFix (S (S (n + n))) hrec | HalfOdd -       = rewrite plusSuccRightSucc (S n) n in -                 HalfRecEven (hrec (S n) (LTESucc (LTESucc (lteAddRight _))))-  halfRecFix (S (n + n)) hrec | HalfEven -       = HalfRecOdd (hrec n (LTESucc (lteAddRight _)))--||| Covering function for the `HalfRec` view-export+public export total halfRec : (n : Nat) -> HalfRec n-halfRec n = accInd halfRecFix n (ltAccessible n)-+halfRec n with (sizeAccessible n)+  halfRec  Z | acc = HalfRecZ+  halfRec (S n) | acc with (half n)+    halfRec' (S (S (k + k))) | Access acc | HalfOdd+      = rewrite plusSuccRightSucc (S k) k+          in HalfRecEven (halfRec' (S k) | acc (S k) (LTESucc (LTESucc (lteAddRight _))))+    halfRec' (S (k + k)) | Access acc | HalfEven+      = HalfRecOdd (halfRec' k | acc k (LTESucc (lteAddRight _)))
− libs/base/Data/SortedSet.idr 
@@ -1,28 +0,0 @@-module Data.SortedSet--import Data.SortedMap---- TODO: add intersection, union, difference--data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ())--empty : SortedSet k-empty = SetWrapper Data.SortedMap.empty--insert : Ord k => k -> SortedSet k -> SortedSet k-insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m)--delete : Ord k => k -> SortedSet k -> SortedSet k-delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m)--contains : Ord k => k -> SortedSet k -> Bool-contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)--fromList : Ord k => List k -> SortedSet k-fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l))--toList : SortedSet k -> List k-toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)--implementation Foldable SortedSet where-  foldr f e xs = foldr f e (Data.SortedSet.toList xs)
libs/base/Data/String.idr view
@@ -49,7 +49,9 @@           then map (\y => negate (fromInteger y)) (parseNumWithoutSign (unpack xs) 0)           else if (x == '+')              then map fromInteger (parseNumWithoutSign (unpack xs) (cast {from=Int} 0))-            else map fromInteger (parseNumWithoutSign (unpack xs) (cast (ord x - ord '0')))+            else if (x >= '0' && x <= '9')+            then map fromInteger (parseNumWithoutSign (unpack xs) (cast (ord x - ord '0')))+              else Nothing   ||| Convert a number string to a Double.
libs/base/Data/Vect/Views.idr view
@@ -61,23 +61,23 @@                     (lrec : Lazy (SplitRec xs)) ->                      (rrec : Lazy (SplitRec ys)) -> SplitRec (xs ++ ys) -smallerPlus : LTE (S (S m)) (S (plus m (S k)))-smallerPlus {m} {k} = rewrite sym (plusSuccRightSucc m k) in +smallerPlusL : LTE (S (S m)) (S (plus m (S k)))+smallerPlusL {m} {k} = rewrite sym (plusSuccRightSucc m k) in                               (LTESucc (LTESucc (lteAddRight _))) -smallerPlus' : LTE (S (S k)) (S (plus m (S k)))-smallerPlus' {m} {k} = rewrite sym (plusSuccRightSucc m k) in +smallerPlusR : LTE (S (S k)) (S (plus m (S k)))+smallerPlusR {m} {k} = rewrite sym (plusSuccRightSucc m k) in                                LTESucc (LTESucc (rewrite plusCommutative m k in (lteAddRight _)))  ||| Covering function for the `SplitRec` view ||| Constructs the view in O(n lg n)-export+public export total splitRec : (xs : Vect n a) -> SplitRec xs-splitRec {n} input with (ltAccessible n)+splitRec {n} input with (sizeAccessible n)   splitRec input | acc with (split input)     splitRec [] | acc | SplitNil = SplitRecNil     splitRec [x] | acc | SplitOne = SplitRecOne-    splitRec (x :: (xs ++ (y :: ys))) | (Access rec) | SplitPair -        = let left = splitRec (x :: xs) | rec _ smallerPlus-              right = splitRec (y :: ys) | rec _ smallerPlus' in-              SplitRecPair left right+    splitRec (x :: (xs ++ (y :: ys))) | Access acc | SplitPair+        = SplitRecPair+            (splitRec (x :: xs) | acc _ smallerPlusL)+            (splitRec (y :: ys) | acc _ smallerPlusR)
libs/base/base.ipkg view
@@ -5,31 +5,43 @@            Debug.Error, Debug.Trace, -          System.Info, +          System.Info,            Language.Reflection.Utils,            Syntax.PreorderReasoning,            Data.Morphisms,-          Data.Bits, Data.Mod2,-          Data.Fin, Data.Vect, Data.Vect.Views,-          Data.HVect, Data.Vect.Quantifiers,+          Data.Bits,+          Data.Mod2,+          Data.Fin,+          Data.Vect,+          Data.Vect.Views,+          Data.Vect.Quantifiers,+          Data.HVect,           Data.Complex,-          Data.Erased, Data.List, Data.List.Views,+          Data.Erased,+          Data.List,+          Data.List.Views,           Data.List.Quantifiers,           Data.Nat.Views,           Data.Primitives.Views,           Data.String.Views,-          Data.So, Data.String, Data.Buffer,+          Data.So,+          Data.String,+          Data.Buffer,            Control.Isomorphism,           Control.Monad.Identity,           Control.Monad.RWS,           Control.Monad.Trans,-          Control.Monad.State, Control.Monad.Writer, Control.Monad.Reader,-          Control.Category, Control.Arrow,-          Control.Catchable, Control.IOExcept,--          System.Concurrency.Raw, System.Concurrency.Channels+          Control.Monad.State,+          Control.Monad.Writer,+          Control.Monad.Reader,+          Control.Category,+          Control.Arrow,+          Control.Catchable,+          Control.IOExcept, +          System.Concurrency.Raw,+          System.Concurrency.Channels
libs/contrib/Control/Algebra/NumericImplementations.idr view
@@ -9,6 +9,8 @@  %access public export +-- Integer+ Semigroup Integer where   (<+>) = (+) @@ -18,7 +20,7 @@ Group Integer where   inverse = (* -1) -AbelianGroup Integer where +AbelianGroup Integer where  Ring Integer where   (<.>) = (*)@@ -26,6 +28,7 @@ RingWithUnity Integer where   unity = 1 +-- Int  Semigroup Int where   (<+>) = (+)@@ -44,6 +47,7 @@ RingWithUnity Int where   unity = 1 +-- Double  Semigroup Double where   (<+>) = (+)@@ -65,30 +69,46 @@ Field Double where   inverseM f _ = 1 / f +-- Nat -Semigroup Nat where+[PlusNatSemi] Semigroup Nat where   (<+>) = (+) -Monoid Nat where+[PlusNatMonoid] Monoid Nat using PlusNatSemi where   neutral = 0 -Semigroup ZZ where+[MultNatSemi] Semigroup Nat where+  (<+>) = (*)++[MultNatMonoid] Monoid Nat using MultNatSemi where+  neutral = 1++-- ZZ++[PlusZZSemi] Semigroup ZZ where   (<+>) = (+) -Monoid ZZ where+[PlusZZMonoid] Monoid ZZ using PlusZZSemi where   neutral = 0 -Group ZZ where+Group ZZ using PlusZZMonoid where   inverse = (* -1)  AbelianGroup ZZ where +[MultZZSemi] Semigroup ZZ where+  (<+>) = (*)++[MultZZMonoid] Monoid ZZ using MultZZSemi where+  neutral = 1+ Ring ZZ where   (<.>) = (*)  RingWithUnity ZZ where   unity = 1 +-- Complex  Semigroup a => Semigroup (Complex a) where   (<+>) (a :+ b) (c :+ d) = (a <+> c) :+ (b <+> d)
+ libs/contrib/Control/Pipeline.idr view
@@ -0,0 +1,26 @@+module Control.Pipeline++infixl 9 |>+infixr 0 <|++%access public export+++||| Pipeline style function application, useful for chaining+||| functions into a series of transformations, reading top+||| to bottom.+|||+||| ```idris example+||| [[1], [2], [3]] |> join |> map (* 2)+||| ```+(|>) : a -> (a -> b) -> b+a |> f = f a+++||| Backwards pipeline style function application, similar to $.+|||+||| ```idris example+||| unpack <| "hello" ++ "world"+||| ```+(<|) : (a -> b) -> a -> b+f <| a = f a
libs/contrib/Control/ST.idr view
@@ -1,6 +1,7 @@ module Control.ST  import Language.Reflection.Utils+import Control.IOExcept  %default total @@ -306,7 +307,7 @@      Split : (lbl : Var) ->              (prf : InState lbl (Composite vars) res) ->              STrans m (VarList vars) res-                   (\ vs => mkRes vs +++                   (\vs => mkRes vs ++                             updateRes res prf (State ()))      Combine : (comp : Var) -> (vs : List Var) ->                (prf : VarsIn (comp :: vs) res) ->@@ -456,7 +457,7 @@ split : (lbl : Var) ->         {auto prf : InState lbl (Composite vars) res} ->         STrans m (VarList vars) res-              (\ vs => mkRes vs +++              (\vs => mkRes vs ++                        updateRes res prf (State ())) split lbl {prf} = Split lbl prf @@ -571,10 +572,18 @@   putStr str = lift (Interactive.putStr str)   getStr = lift Interactive.getLine -  putChar c = lift $ Interactive.putChar c+  putChar c = lift (Interactive.putChar c)   getChar = lift Interactive.getChar  export+ConsoleIO (IOExcept err) where+  putStr str = lift (ioe_lift (Interactive.putStr str))+  getStr = lift (ioe_lift Interactive.getLine)++  putChar c = lift (ioe_lift (Interactive.putChar c))+  getChar = lift (ioe_lift Interactive.getChar)++export run : Applicative m => ST m a [] -> m a run prog = runST [] prog (\res, env' => pure res) @@ -593,15 +602,13 @@ ||| responsibility of an implementation of an interface in IO which uses it ||| to ensure that it isn't duplicated. export-runWith : {resf : _} ->-          Env res -> STrans IO a res (\result => resf result) ->+runWith : Env res -> STrans IO a res resf ->           IO (result ** Env (resf result)) runWith env prog = runST env prog (\res, env' => pure (res ** env'))  export-runWithLoop : {resf : _} ->-          Env res -> Fuel -> STransLoop IO a res (\result => resf result) ->-          IO (Maybe (result ** Env (resf result)))+runWithLoop : Env res -> Fuel -> STransLoop IO a res resf  ->+              IO (Maybe (result ** Env (resf result))) runWithLoop env fuel prog     = runSTLoop fuel env prog (\res, env' => pure (Just (res ** env')))                               (pure Nothing)
libs/contrib/Data/CoList.idr view
@@ -47,7 +47,7 @@ ||| unfoldr (\b => if b == 0 then Nothing else Just (b, b-1)) 10 ||| ``` |||-unfoldr : (a -> Maybe (a, a)) -> a -> CoList a+unfoldr : (a -> Maybe (b, a)) -> a -> CoList b unfoldr f x =   case f x of     Just (y, new_x) => y :: (unfoldr f new_x)
libs/contrib/Data/Heap.idr view
@@ -133,10 +133,6 @@ --------------------------------------------------------------------------------  total-absurdBoolDischarge : False = True -> Void-absurdBoolDischarge Refl impossible--total isEmptySizeZero : (h : MaxiphobicHeap a) -> (isEmpty h = True) -> size h = Z isEmptySizeZero Empty          p = Refl isEmptySizeZero (Node s l e r) Refl impossible
libs/contrib/Data/SortedMap.idr view
@@ -1,6 +1,6 @@ module Data.SortedMap --- TODO: write merge and split+-- TODO: write split  private data Tree : Nat -> (k : Type) -> Type -> Ord k -> Type where@@ -215,6 +215,10 @@     Right t' => (M _ t')  export+insertFrom : Foldable f => f (k, v) -> SortedMap k v -> SortedMap k v+insertFrom = flip $ foldl $ flip $ uncurry insert++export delete : k -> SortedMap k v -> SortedMap k v delete _ Empty = Empty delete k (M Z t) =@@ -235,13 +239,60 @@ toList Empty = [] toList (M _ t) = treeToList t +||| Gets the keys of the map.+export+keys : SortedMap k v -> List k+keys = map fst . toList++||| Gets the values of the map. Could contain duplicates.+export+values : SortedMap k v -> List v+values = map snd . toList+ treeMap : (a -> b) -> Tree n k a o -> Tree n k b o treeMap f (Leaf k v) = Leaf k (f v) treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)-treeMap f (Branch3 t1 k1 t2 k2 t3) +treeMap f (Branch3 t1 k1 t2 k2 t3)     = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3) +export implementation Functor (SortedMap k) where   map _ Empty = Empty   map f (M n t) = M _ (treeMap f t) +||| Merge two maps. When encountering duplicate keys, using a function to combine the values.+||| Uses the ordering of the first map given.+export+mergeWith : (v -> v -> v) -> SortedMap k v -> SortedMap k v -> SortedMap k v+mergeWith f x y = insertFrom inserted x where+  inserted : List (k, v)+  inserted = do+    (k, v) <- toList y+    let v' = (maybe id f $ lookup k x) v+    pure (k, v')++||| Merge two maps using the Semigroup (and by extension, Monoid) operation.+||| Uses mergeWith internally, so the ordering of the left map is kept.+export+merge : Semigroup v => SortedMap k v -> SortedMap k v -> SortedMap k v+merge = mergeWith (<+>)++||| Left-biased merge, also keeps the ordering specified  by the left map.+export+mergeLeft : SortedMap k v -> SortedMap k v -> SortedMap k v+mergeLeft = mergeWith const++-- TODO: is this the right variant of merge to use for this? I think it is, but+-- I could also see the advantages of using `mergeLeft`. The current approach is+-- strictly more powerful I believe, because `mergeLeft` can be emulated with+-- the `First` monoid. However, this does require more code to do the same+-- thing.+export+Semigroup v => Semigroup (SortedMap k v) where+  (<+>) = merge++||| For `neutral <+> y`, y is rebuilt in `Ord k`, so this is not a "strict" Monoid.+||| However, semantically, it should be equal.+export+(Ord k, Semigroup v) => Monoid (SortedMap k v) where+  neutral = empty
libs/contrib/Data/SortedSet.idr view
@@ -2,8 +2,6 @@  import Data.SortedMap --- TODO: add intersection, union, difference- export data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ()) @@ -31,5 +29,38 @@ toList : SortedSet k -> List k toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m) -implementation Foldable SortedSet where+export+Foldable SortedSet where   foldr f e xs = foldr f e (Data.SortedSet.toList xs)++||| Set union. Inserts all elements of x into y+export+union : (x, y : SortedSet k) -> SortedSet k+union x y = foldr insert x y++||| Set difference. Delete all elments in y from x+export+difference : (x, y : SortedSet k) -> SortedSet k+difference x y = foldr delete x y++||| Set symmetric difference. Uses the union of the differences.+export+symDifference : (x, y : SortedSet k) -> SortedSet k+symDifference x y = union (difference x y) (difference y x)++||| Set intersection. Implemented as the difference of the union and the symetric difference.+export+intersection : (x, y : SortedSet k) -> SortedSet k+intersection x y = difference x (difference x y)++export+Ord k => Semigroup (SortedSet k) where+  (<+>) = union++export+Ord k => Monoid (SortedSet k) where+  neutral = empty++export+keySet : SortedMap k v -> SortedSet k+keySet = SetWrapper . map (const ())
libs/contrib/Interfaces/Verified.idr view
@@ -2,7 +2,9 @@  import Control.Algebra import Control.Algebra.Lattice+import Control.Algebra.NumericImplementations import Control.Algebra.VectorSpace+import Data.ZZ  %access public export @@ -19,6 +21,12 @@                        (g1 : a -> b) -> (g2 : b -> c) ->                        map (g2 . g1) x = (map g2 . map g1) x +VerifiedFunctor Maybe where+  functorIdentity Nothing = Refl+  functorIdentity (Just x) = Refl+  functorComposition Nothing g1 g2 = Refl+  functorComposition (Just x) g1 g2 = Refl+ interface (Applicative f, VerifiedFunctor f) => VerifiedApplicative (f : Type -> Type) where   applicativeMap : (x : f a) -> (g : a -> b) ->                    map g x = pure g <*> x@@ -30,6 +38,23 @@   applicativeInterchange : (x : a) -> (g : f (a -> b)) ->                            g <*> pure x = pure (\g' : (a -> b) => g' x) <*> g +VerifiedApplicative Maybe where+  applicativeMap Nothing g = Refl+  applicativeMap (Just x) g = Refl+  applicativeIdentity Nothing = Refl+  applicativeIdentity (Just x) = Refl+  applicativeComposition Nothing Nothing Nothing = Refl+  applicativeComposition Nothing Nothing (Just x) = Refl+  applicativeComposition Nothing (Just x) Nothing = Refl+  applicativeComposition Nothing (Just x) (Just y) = Refl+  applicativeComposition (Just x) Nothing Nothing = Refl+  applicativeComposition (Just x) Nothing (Just y) = Refl+  applicativeComposition (Just x) (Just y) Nothing = Refl+  applicativeComposition (Just x) (Just y) (Just z) = Refl+  applicativeHomomorphism x g = Refl+  applicativeInterchange x Nothing = Refl+  applicativeInterchange x (Just y) = Refl+ interface (Monad m, VerifiedApplicative m) => VerifiedMonad (m : Type -> Type) where   monadApplicative : (mf : m (a -> b)) -> (mx : m a) ->                      mf <*> mx = mf >>= \f =>@@ -40,6 +65,16 @@   monadAssociativity : (mx : m a) -> (f : a -> m b) -> (g : b -> m c) ->                        (mx >>= f) >>= g = mx >>= (\x => f x >>= g) +VerifiedMonad Maybe where+    monadApplicative Nothing Nothing = Refl+    monadApplicative Nothing (Just x) = Refl+    monadApplicative (Just x) Nothing = Refl+    monadApplicative (Just x) (Just y) = Refl+    monadLeftIdentity x f = Refl+    monadRightIdentity Nothing = Refl+    monadRightIdentity (Just x) = Refl+    monadAssociativity Nothing f g = Refl+    monadAssociativity (Just x) f g = Refl  interface Semigroup a => VerifiedSemigroup a where   total semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r@@ -47,18 +82,38 @@ implementation VerifiedSemigroup (List a) where   semigroupOpIsAssociative = appendAssociative ---implementation VerifiedSemigroup Nat where---  semigroupOpIsAssociative = plusAssociative+[PlusNatSemiV] VerifiedSemigroup Nat using PlusNatSemi where+  semigroupOpIsAssociative = plusAssociative +[MultNatSemiV] VerifiedSemigroup Nat using MultNatSemi where+  semigroupOpIsAssociative = multAssociative +[PlusZZSemiV] VerifiedSemigroup ZZ using PlusZZSemi where+  semigroupOpIsAssociative = plusAssociativeZ++[MultZZSemiV] VerifiedSemigroup ZZ using MultZZSemi where+  semigroupOpIsAssociative = multAssociativeZ+ interface (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where   total monoidNeutralIsNeutralL : (l : a) -> l <+> Algebra.neutral = l   total monoidNeutralIsNeutralR : (r : a) -> Algebra.neutral <+> r = r --- implementation VerifiedMonoid Nat where---   monoidNeutralIsNeutralL = plusZeroRightNeutral---   monoidNeutralIsNeutralR = plusZeroLeftNeutral+[PlusNatMonoidV] VerifiedMonoid Nat using PlusNatSemiV, PlusNatMonoid where+   monoidNeutralIsNeutralL = plusZeroRightNeutral+   monoidNeutralIsNeutralR = plusZeroLeftNeutral +[MultNatMonoidV] VerifiedMonoid Nat using MultNatSemiV, MultNatMonoid where+  monoidNeutralIsNeutralL = multOneRightNeutral+  monoidNeutralIsNeutralR = multOneLeftNeutral++[PlusZZMonoidV] VerifiedMonoid ZZ using PlusZZSemiV, PlusZZMonoid where+   monoidNeutralIsNeutralL = plusZeroRightNeutralZ+   monoidNeutralIsNeutralR = plusZeroLeftNeutralZ++[MultZZMonoidV] VerifiedMonoid ZZ using MultZZSemiV, MultZZMonoid where+  monoidNeutralIsNeutralL = multOneRightNeutralZ+  monoidNeutralIsNeutralR = multOneLeftNeutralZ+ implementation VerifiedMonoid (List a) where   monoidNeutralIsNeutralL = appendNilRightNeutral   monoidNeutralIsNeutralR xs = Refl@@ -67,22 +122,39 @@   total groupInverseIsInverseL : (l : a) -> l <+> inverse l = Algebra.neutral   total groupInverseIsInverseR : (r : a) -> inverse r <+> r = Algebra.neutral +VerifiedGroup ZZ using PlusZZMonoidV where+  groupInverseIsInverseL k = rewrite sym $ multCommutativeZ (NegS 0) k in+                             rewrite multNegLeftZ 0 k in+                             rewrite multOneLeftNeutralZ k in+                             plusNegateInverseLZ k+  groupInverseIsInverseR k = rewrite sym $ multCommutativeZ (NegS 0) k in+                             rewrite multNegLeftZ 0 k in+                             rewrite multOneLeftNeutralZ k in+                             plusNegateInverseRZ k+ interface (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where   total abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l +VerifiedAbelianGroup ZZ where+  abelianGroupOpIsCommutative = plusCommutativeZ+ interface (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where   total ringOpIsAssociative   : (l, c, r : a) -> l <.> (c <.> r) = (l <.> c) <.> r   total ringOpIsDistributiveL : (l, c, r : a) -> l <.> (c <+> r) = (l <.> c) <+> (l <.> r)   total ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <.> r = (l <.> r) <+> (c <.> r) +VerifiedRing ZZ where+  ringOpIsAssociative = multAssociativeZ+  ringOpIsDistributiveL = multDistributesOverPlusRightZ+  ringOpIsDistributiveR = multDistributesOverPlusLeftZ+ interface (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where   total ringWithUnityIsUnityL : (l : a) -> l <.> Algebra.unity = l   total ringWithUnityIsUnityR : (r : a) -> Algebra.unity <.> r = r ---interface (VerifiedRingWithUnity a, Field a) => VerifiedField a where---  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-+VerifiedRingWithUnity ZZ where+  ringWithUnityIsUnityL = multOneRightNeutralZ+  ringWithUnityIsUnityR = multOneLeftNeutralZ  interface JoinSemilattice a => VerifiedJoinSemilattice a where   total joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r@@ -93,31 +165,3 @@   total meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r   total meetSemilatticeMeetIsCommutative : (l, r : a)    -> meet l r = meet r l   total meetSemilatticeMeetIsIdempotent  : (e : a)       -> meet e e = e--{- FIXME: Some maintenance required here.-   Algebra.top and Algebra.bottom don't exist!--}-{---interface (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where-  total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e Algebra.bottom = e--interface (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where-  total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e Algebra.top = e--interface (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where-  total latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l-  total latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l--interface (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }-----interface (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) -> 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)----interface (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}---}
libs/contrib/Network/Socket.idr view
@@ -10,6 +10,7 @@ %include C "idris_net.h" %include C "sys/types.h" %include C "sys/socket.h"+%include C "unistd.h" %include C "netdb.h"  %access export
+ libs/contrib/Text/Lexer.idr view
@@ -0,0 +1,238 @@+module Text.Lexer++%default total++||| A language of token recognisers.+||| The `consumes` flag is True is the recogniser is guaranteed to consume+||| at least one character+export+data Recognise : (consumes : Bool) -> Type where+     Empty : Recognise False+     Fail : Recognise c+     Pred : (Char -> Bool) -> Recognise True+     SeqEat : Recognise True -> Inf (Recognise e) -> Recognise True+     SeqEmpty : Recognise e1 -> Recognise e2 -> Recognise (e1 || e2)+     Alt : Recognise e1 -> Recognise e2 -> Recognise (e1 && e2)++||| A token recogniser. Guaranteed to consume at least one character.+public export+Lexer : Type+Lexer = Recognise True++public export+inf : Bool -> Type -> Type+inf True t = Inf t+inf False t = t+  +||| Sequence two recognisers. If either consumes a character, the sequence+||| is guaranteed to consume a character.+export %inline+(<+>) : {c1 : Bool} -> +        Recognise c1 -> inf c1 (Recognise c2) -> Recognise (c1 || c2)+(<+>) {c1 = False} = SeqEmpty+(<+>) {c1 = True} = SeqEat++||| Alternative recognisers. If both consume, the combination is guaranteed+||| to consumer a character.+export+(<|>) : Recognise c1 -> Recognise c2 -> Recognise (c1 && c2)+(<|>) = Alt++||| Recognise a specific character+export+is : Char -> Lexer+is x = Pred (==x)++||| Recognise anything but the given character+export+isNot : Char -> Lexer+isNot x = Pred (/=x)++||| Recognise a sequence of at least one sub-lexers+export+some : Lexer -> Lexer+some l = l <+> (some l <|> Empty)++||| Recognise a sequence of at zero or more sub-lexers. This is not+||| guaranteed to consume input+export+many : Lexer -> Recognise False+many l = some l <|> Empty++||| Recognise any character+export+any : Lexer+any = Pred (const True)++||| Recognise no input (doesn't consume any input)+export+empty : Recognise False+empty = Empty++||| Recognise a character that matches a predicate+export+pred : (Char -> Bool) -> Lexer+pred = Pred++||| Recognise any of the characters in the given string+export+oneOf : String -> Lexer+oneOf cs = pred (\x => x `elem` unpack cs)++data StrLen : Type where+     MkStrLen : String -> Nat -> StrLen++getString : StrLen -> String+getString (MkStrLen str n) = str++strIndex : StrLen -> Nat -> Maybe Char+strIndex (MkStrLen str len) i +    = if i >= len then Nothing+                  else Just (assert_total (prim__strIndex str (cast i)))++mkStr : String -> StrLen+mkStr str = MkStrLen str (length str)++strTail : Nat -> StrLen -> StrLen+strTail start (MkStrLen str len)+    = MkStrLen (substr start len str) (minus len start)++-- If the string is recognised, returns the index at which the token+-- ends+scan : Recognise c -> Nat -> StrLen -> Maybe Nat+scan Empty idx str = pure idx+scan Fail idx str = Nothing+scan (Pred f) idx str +    = do c <- strIndex str idx+         if f c+            then Just (idx + 1)+            else Nothing+scan (SeqEat r1 r2) idx str +    = do idx' <- scan r1 idx str+         -- TODO: Can we prove totality instead by showing idx has increased?+         assert_total (scan r2 idx' str)+scan (SeqEmpty r1 r2) idx str +    = do idx' <- scan r1 idx str+         scan r2 idx' str+scan (Alt r1 r2) idx str +    = case scan r1 idx str of+           Nothing => scan r2 idx str+           Just idx => Just idx++takeToken : Lexer -> StrLen -> Maybe (String, StrLen)+takeToken lex str +    = do i <- scan lex 0 str -- i must be > 0 if successful+         pure (substr 0 i (getString str), strTail i str)++||| Recognise a digit 0-9+export+digits : Lexer+digits = some (Pred isDigit)++||| Recognise a specific string+export+exact : String -> Lexer+exact str with (unpack str)+  exact str | [] = Fail -- Not allowed, Lexer has to consume+  exact str | (x :: xs) +      = foldl SeqEmpty (is x) (map is xs)++||| Recognise a whitespace character+export+space : Lexer+space = some (pred isSpace)++||| Recognise a non-alphanumeric, non-whitespace character+export+symbol : Lexer+symbol = some (pred (\x => not (isAlphaNum x) && not (isSpace x)))++strChar : Lexer+strChar = (is '\\' <+> any) <|> isNot '"'++||| Recognise a string literal, including escaped characters.+||| (Note: doesn't yet handle escape sequences such as \123)+export+stringLit : Lexer+stringLit = is '"' <+> many strChar <+> is '"'++||| Recognise a character literal, including escaped characters.+||| (Note: doesn't yet handle escape sequences such as \123)+export+charLit : Lexer+charLit = is '\'' <+> strChar <+> is '\''++||| Recognise an integer literal (possibly with a '-' prefix)+export+intLit : Lexer+intLit = (is '-' <|> Empty) <+> digits++||| A mapping from lexers to the tokens they produce.+||| This is a list of pairs `(Lexer, String -> tokenType)`+||| For each Lexer in the list, if a substring in the input matches, run+||| the associated function to produce a token of type `tokenType`+public export+TokenMap : (tokenType : Type) -> Type+TokenMap tokenType = List (Lexer, String -> tokenType)++||| A token, and the line and column where it was in the input+public export+record TokenData a where+  constructor MkToken+  line : Int+  col : Int+  tok : a++fspanEnd : Nat -> (Char -> Bool) -> String -> (Nat, String)+fspanEnd k p "" = (k, "")+fspanEnd k p xxs +    = assert_total $ +      let x = prim__strHead xxs+          xs = prim__strTail xxs in+          if p x then fspanEnd (S k) p xs+                 else (k, xxs)++-- Faster version of 'span' from the prelude (avoids unpacking)+export+fspan : (Char -> Bool) -> String -> (String, String)+fspan p xs +    = let (end, rest) = fspanEnd 0 p xs in+          (substr 0 end xs, rest)++tokenise : (line : Int) -> (col : Int) ->+           List (TokenData a) -> TokenMap a -> +           StrLen -> (List (TokenData a), (Int, Int, StrLen))+tokenise line col acc tmap str +    = case getFirstToken tmap str of+           Just (tok, line', col', rest) =>+           -- assert total because getFirstToken must consume something+                assert_total (tokenise line' col' (tok :: acc) tmap rest)+           Nothing => (reverse acc, (line, col, str))+  where+    countNLs : List Char -> Nat+    countNLs str = List.length (filter (== '\n') str)++    getCols : String -> Int -> Int+    getCols x c +         = case fspan (/= '\n') (reverse x) of+                (incol, "") => c + cast (length incol)+                (incol, _) => cast (length incol)++    getFirstToken : TokenMap a -> StrLen -> Maybe (TokenData a, Int, Int, StrLen)+    getFirstToken [] str = Nothing+    getFirstToken ((lex, fn) :: ts) str+        = case takeToken lex str of+               Just (tok, rest) => Just (MkToken line col (fn tok),+                                         line + cast (countNLs (unpack tok)), +                                         getCols tok col, rest)+               Nothing => getFirstToken ts str++||| Given a mapping from lexers to token generating functions (the+||| TokenMap a) and an input string, return a list of recognised tokens,+||| and the line, column, and remainder of the input at the first point in the+||| string where there are no recognised tokens.+export+lex : TokenMap a -> String -> (List (TokenData a), (Int, Int, String))+lex tmap str = let (ts, (l, c, str')) = tokenise 0 0 [] tmap (mkStr str) in+                   (ts, (l, c, getString str'))+
+ libs/contrib/Text/Parser.idr view
@@ -0,0 +1,229 @@+module Text.Parser++%default total++-- TODO: Add some primitives for helping with error messages.+-- e.g. perhaps set a string to state what we're currently trying to +-- parse, or to say what the next expected token is in words++||| Description of a language's grammar. The `tok` parameter is the type+||| of tokens, and the `consumes` flag is True if the language is guaranteed+||| to be non-empty - that is, successfully parsing the language is guaranteed+||| to consume some input.+export+data Grammar : (tok : Type) -> (consumes : Bool) -> Type -> Type where+     Empty : (val : ty) -> Grammar tok False ty+     Terminal : (tok -> Maybe a) -> Grammar tok True a+     NextIs : (tok -> Bool) -> Grammar tok False tok+     EOF : Grammar tok False ()++     Fail : String -> Grammar tok c ty+     Commit : Grammar tok False ()++     SeqEat : Grammar tok True a -> Inf (a -> Grammar tok c2 b) ->+              Grammar tok True b+     SeqEmpty : {c1, c2 : Bool} ->+                Grammar tok c1 a -> (a -> Grammar tok c2 b) ->+                Grammar tok (c1 || c2) b+     Alt : {c1, c2 : Bool} ->+           Grammar tok c1 ty -> Grammar tok c2 ty -> +           Grammar tok (c1 && c2) ty++public export+inf : Bool -> Type -> Type+inf True t = Inf t+inf False t = t+  +||| Sequence two grammars. If either consumes some input, the sequence is+||| guaranteed to consume some input. If the first one consumes input, the+||| second is allowed to be recursive (because it means some input has been+||| consumed and therefore the input is smaller)+export %inline+(>>=) : {c1 : Bool} ->+        Grammar tok c1 a -> inf c1 (a -> Grammar tok c2 b) ->+        Grammar tok (c1 || c2) b+(>>=) {c1 = False} = SeqEmpty+(>>=) {c1 = True} = SeqEat+    +||| Give two alternative grammars. If both consume, the combination is+||| guaranteed to consume.+export+(<|>) : Grammar tok c1 ty -> Grammar tok c2 ty -> +        Grammar tok (c1 && c2) ty+(<|>) = Alt++export+pure : (val : ty) -> Grammar tok False ty+pure = Empty++||| Check whether the next token satisfies a predicate+export+nextIs : (tok -> Bool) -> Grammar tok False tok+nextIs = NextIs++||| Look at the next token in the input+export+peek : Grammar tok False tok+peek = nextIs (const True)++||| Succeeds if running the predicate on the next token returns Just x,+||| returning x. Otherwise fails.+export+terminal : (tok -> Maybe a) -> Grammar tok True a+terminal = Terminal++||| Always fail with a message+export+fail : String -> Grammar tok c ty+fail = Fail++||| Succeed if the input is empty+export+eof : Grammar tok False ()+eof = EOF++||| Commit to an alternative; if the current branch of an alternative +||| fails to parse, no more branches will be tried+export+commit : Grammar tok False ()+commit = Commit++data ParseResult : List tok -> (consumes : Bool) -> Type -> Type where+     Failure : {xs : List tok} -> +               (committed : Bool) ->+               (err : String) -> (rest : List tok) -> ParseResult xs c ty+     EmptyRes : (committed : Bool) ->+                (val : ty) -> (more : List tok) -> ParseResult more False ty+     NonEmptyRes : (committed : Bool) ->+                   (val : ty) -> (more : List tok) ->+                   ParseResult (x :: xs ++ more) c ty ++weakenRes : {whatever, c : Bool} -> {xs : List tok} ->+            ParseResult xs c ty -> ParseResult xs (whatever && c) ty+weakenRes (Failure com msg ts) = Failure com msg ts+weakenRes {whatever=True} (EmptyRes com val xs) = EmptyRes com val xs+weakenRes {whatever=False} (EmptyRes com val xs) = EmptyRes com val xs+weakenRes (NonEmptyRes com val more) = NonEmptyRes com val more++shorter : (more : List tok) -> .(ys : List tok) -> +          LTE (S (length more)) (S (length (ys ++ more)))+shorter more [] = lteRefl+shorter more (x :: xs) = LTESucc (lteSuccLeft (shorter more xs))++doParse : {c : Bool} ->+          (commit : Bool) -> (xs : List tok) -> (act : Grammar tok c ty) -> +          ParseResult xs c ty+doParse com xs act with (sizeAccessible xs)+  doParse com xs (Empty val) | sml = EmptyRes com val xs+  doParse com [] (Fail str) | sml = Failure com str []+  doParse com (x :: xs) (Fail str) | sml = Failure com str (x :: xs)+  doParse com xs Commit | sml = EmptyRes True () xs++  doParse com [] (Terminal f) | sml = Failure com "End of input" []+  doParse com (x :: xs) (Terminal f) | sml +        = maybe+             (Failure com "Unrecognised token" (x :: xs))+             (\a => NonEmptyRes com {xs=[]} a xs)+             (f x)+  doParse com [] EOF | sml = EmptyRes com () []+  doParse com (x :: xs) EOF | sml +        = Failure com "Expected end of input" (x :: xs)+  doParse com [] (NextIs f) | sml = Failure com "End of input" []+  doParse com (x :: xs) (NextIs f) | sml +        = if f x +             then EmptyRes com x (x :: xs)+             else Failure com "Unrecognised token" (x :: xs)+  doParse com xs (Alt x y) | sml with (doParse False xs x | sml)+    doParse com xs (Alt x y) | sml | Failure com' msg ts+          = if com' -- If the alternative had committed, don't try the+                    -- other branch (and reset commit flag)+               then Failure com msg ts+               else weakenRes (doParse False xs y | sml)+    -- Successfully parsed the first option, so use the outer commit flag+    doParse com xs (Alt x y) | sml | (EmptyRes _ val xs) +          = EmptyRes com val xs+    doParse com (z :: (ys ++ more)) (Alt x y) | sml | (NonEmptyRes _ val more) +          = NonEmptyRes com val more+  doParse com xs (SeqEmpty act next) | (Access morerec)+          = case doParse com xs act | Access morerec of+                 Failure com msg ts => Failure com msg ts+                 EmptyRes com val xs => +                       case doParse com xs (next val) | (Access morerec) of+                            Failure com' msg ts => Failure com' msg ts+                            EmptyRes com' val xs => EmptyRes com' val xs+                            NonEmptyRes com' val more => NonEmptyRes com' val more+                 NonEmptyRes {x} {xs=ys} com val more => +                       case (doParse com more (next val) | morerec _ (shorter more ys)) of+                            Failure com' msg ts => Failure com' msg ts+                            EmptyRes com' val _ => NonEmptyRes com' val more+                            NonEmptyRes {x=x1} {xs=xs1} com' val more' =>+                                 rewrite appendAssociative (x :: ys) (x1 :: xs1) more' in+                                         NonEmptyRes com' val more'+  doParse com xs (SeqEat act next) | sml with (doParse com xs act | sml)+    doParse com xs (SeqEat act next) | sml | Failure com' msg ts +         = Failure com' msg ts+    doParse com (x :: (ys ++ more)) (SeqEat act next) | (Access morerec) | (NonEmptyRes com' val more) +         = case doParse com' more (next val) | morerec _ (shorter more ys) of+                Failure com' msg ts => Failure com' msg ts+                EmptyRes com' val _ => NonEmptyRes com' val more+                NonEmptyRes {x=x1} {xs=xs1} com' val more' => +                     rewrite appendAssociative (x :: ys) (x1 :: xs1) more' in+                             NonEmptyRes com' val more'+  -- This next line is not strictly necessary, but it stops the coverage+  -- checker taking a really long time and eating lots of memory...+  doParse _ _ _ | sml = Failure True "Help the coverage checker!" []++public export+data ParseError tok = Error String (List tok)++||| Parse a list of tokens according to the given grammar. If successful,+||| returns a pair of the parse result and the unparsed tokens (the remaining+||| input).+export+parse : (xs : List tok) -> (act : Grammar tok c ty) -> +        Either (ParseError tok) (ty, List tok)+parse xs act+    = case doParse False xs act of+           Failure _ msg ts => Left (Error msg ts)+           EmptyRes _ val rest => pure (val, rest)+           NonEmptyRes _ val rest => pure (val, rest)++||| Parse one or more things+export+some : Grammar tok True a -> +       Grammar tok True (List a)+some p = do x <- p+            (do xs <- some p+                pure (x :: xs)) <|> pure [x]++||| Parse zero or more things (may match the empty input)+export+many : Grammar tok True a -> +       Grammar tok False (List a)+many p = some p+     <|> pure []++||| Parse one or more things, separated by another thing+export+sepBy1 : Grammar tok True () -> Grammar tok True a -> +         Grammar tok True (List a)+sepBy1 sep p = do x <- p+                  (do sep+                      xs <- sepBy1 sep p+                      pure (x :: xs)) <|> pure [x]++||| Parse zero or more things, separated by another thing. May+||| match the empty input.+export+sepBy : Grammar tok True () -> Grammar tok True a -> +        Grammar tok False (List a)+sepBy sep p = sepBy1 sep p <|> pure []++||| Optionally parse a thing, with a default value if the grammar doesn't+||| match. May match the empty input.+export+optional : Grammar tok True a -> (ifNothing : a) ->+           Grammar tok False a+optional p def = p <|> pure def++
+ libs/contrib/Text/PrettyPrint/WL.idr view
@@ -0,0 +1,18 @@+||| A revised Idris port of the Wadler-Leijen pretty-printer.+|||+||| This port of the Wadler-Leijen Pretty-Printer is based upon the+||| port originally created by Shayan Najd [1]. We have changed the+||| render function to be total using a technique based on+||| continuations proposed by gallais [2], and fix minor errors in the+||| original Idris port.+|||+||| [1] https://github.com/shayan-najd/wl-pprint+||| [2] https://gallais.github.io/blog/termination-tricks.html+module Text.PrettyPrint.WL++import public Text.PrettyPrint.WL.Core+import public Text.PrettyPrint.WL.Characters+import public Text.PrettyPrint.WL.Combinators++%default total+%access export
+ libs/contrib/Text/PrettyPrint/WL/Characters.idr view
@@ -0,0 +1,103 @@+||| Commonly used characters+module Text.PrettyPrint.WL.Characters++import Text.PrettyPrint.WL.Core++%default total+%access export++lparen : Doc+lparen = char '('++rparen : Doc+rparen = char ')'++langle : Doc+langle = char '<'++rangle : Doc+rangle = char '>'++lbrace : Doc+lbrace = char '{'++rbrace : Doc+rbrace = char '}'++lbracket : Doc+lbracket = char '['++rbracket : Doc+rbracket = char ']'++squote : Doc+squote = char '\''++dquote : Doc+dquote = char '"'++semi : Doc+semi = char ';'++colon : Doc+colon = char ':'++comma : Doc+comma = char ','++space : Doc+space = char ' '++dot : Doc+dot = char '.'++backslash : Doc+backslash = char '\\'++forwardslash : Doc+forwardslash = char '/'++equals : Doc+equals = char '='++pipe : Doc+pipe = char '|'++bang : Doc+bang = char '!'++tick : Doc+tick = char '`'++tilda : Doc+tilda = char '~'++hash : Doc+hash = char '#'++asterix : Doc+asterix = char '*'++ampersand : Doc+ampersand = char '&'++dash : Doc+dash = char '-'++question : Doc+question = char '?'++dollar : Doc+dollar = char '$'++pound : Doc+pound = char '£'++euro : Doc+euro = char '€'++caret : Doc+caret = char '^'++percent : Doc+percent = char '%'
+ libs/contrib/Text/PrettyPrint/WL/Combinators.idr view
@@ -0,0 +1,259 @@+||| Common combinators.+module Text.PrettyPrint.WL.Combinators++import Text.PrettyPrint.WL.Core+import Text.PrettyPrint.WL.Characters++%default total+%access export++-- --------------------------------------------------- [ Alignment Combinators ]++||| The document `(align x)` renders document `x` with the nesting+||| level set to the current column. It is used for example to+||| implement 'hang'.+align : Doc -> Doc+align d = column (\k => nesting (\i => nest (k - i) d))++||| The hang combinator implements hanging indentation. The document+||| `(hang i x)` renders document `x` with a nesting level set to the+||| current column plus `i`.+hang : Int -> Doc -> Doc+hang i d = align (nest i d)++||| The document `(indent i x)` indents document `x` with `i` spaces.+indent : Int -> Doc -> Doc+indent i d = hang i (text (spaces i) <+> d)++-- -------------------------------------------------- [ High-Level Combinators ]++||| The document `softLine` behaves like `space` if the resulting+||| output fits the page, otherwise it behaves like `line`.+softLine : Doc+softLine = group line++||| The document `softbreak` behaves like `empty` if the resulting+||| output fits the page, otherwise it behaves like 'line'.+softBreak : Doc+softBreak = group breakLine++infixr 5 |/|, |//|, |$|, |$$|+infixr 6 |+|, |++|++private+concatDoc : Doc -> Doc -> Doc -> Doc+concatDoc sep x y = x `beside` (sep `beside` y)++||| The document `(x |+| y)` concatenates document `x` and document+||| `y`. It is an associative operation having 'empty' as a left and+||| right unit.+(|+|) : Doc -> Doc -> Doc+(|+|) = (<+>)++||| The document `(x |++| y)` concatenates document `x` and `y` with a+||| `space` in between.+(|++|) : Doc -> Doc -> Doc+(|++|) = concatDoc space++||| The document `(x |/| y)` concatenates document `x` and `y` with a+||| 'softline' in between. This effectively puts `x` and `y` either+||| next to each other (with a `space` in between) or underneath each+||| other.+(|/|) : Doc -> Doc -> Doc+(|/|) = concatDoc softLine++||| The document `(x |//| y)` concatenates document `x` and `y` with+||| a 'softbreak' in between. This effectively puts `x` and `y` either+||| right next to each other or underneath each other.+(|//|) : Doc -> Doc -> Doc+(|//|) = concatDoc softBreak++||| The document `(x |$| y)` concatenates document `x` and `y` with a+||| `line` in between.+(|$|) : Doc -> Doc -> Doc+(|$|) = concatDoc line++||| The document `(x |$$| y)` concatenates document `x` and `y` with+||| a `linebreak` in between.+(|$$|) : Doc -> Doc -> Doc+(|$$|) = concatDoc breakLine++||| The document `(vsep xs)` concatenates all documents `xs`+||| vertically with `(|$|)`. If a 'group' undoes the line breaks+||| inserted by `vsep`, all documents are separated with a space.+vsep : List Doc -> Doc+vsep = fold (|$|)++||| The document `(sep xs)` concatenates all documents `xs` either+||| horizontally with `(|++|)`, if it fits the page, or vertically with+||| `(|$|)`.+sep : List Doc -> Doc+sep = group . vsep+++||| The document `(fillSep xs)` concatenates documents `xs`+||| horizontally with `(|++|)` as long as its fits the page, than+||| inserts a `line` and continues doing that for all documents in+||| `xs`.+fillSep : List Doc -> Doc+fillSep = fold (|/|)++||| The document `(hsep xs)` concatenates all documents `xs`+||| horizontally with `(|++|)`.+hsep : List Doc -> Doc+hsep = fold (|++|)++||| The document `(hcat xs)` concatenates all documents `xs`+||| horizontally with `(|+|)`.+hcat : List Doc -> Doc+hcat = fold (<+>)++||| The document `(vcat xs)` concatenates all documents `xs`+||| vertically with `(|$$|)`. If a `group` undoes the line breaks+||| inserted by `vcat`, all documents are directly concatenated.+vcat : List Doc -> Doc+vcat = fold (|$$|)++||| The document `(cat xs)` concatenates all documents `xs` either+||| horizontally with `(|+|)`, if it fits the page, or vertically with+||| `(|$$|)`.+cat : List Doc -> Doc+cat = group . vcat++||| The document `(fillCat xs)` concatenates documents `xs`+||| horizontally with `(|+|)` as long as its fits the page, than inserts+||| a `linebreak` and continues doing that for all documents in `xs`.+fillCat : List Doc -> Doc+fillCat = fold (|//|)++||| The document `(enclose l r x)` encloses document `x` between+||| documents `l` and `r` using `(|+|)`.+enclose : Doc -> Doc -> Doc -> Doc+enclose l r x = concatDoc x l r++squotes : Doc -> Doc+squotes = enclose squote squote++dquotes : Doc -> Doc+dquotes = enclose dquote dquote++braces : Doc -> Doc+braces = enclose lbrace rbrace++parens : Doc -> Doc+parens = enclose lparen rparen++angles : Doc -> Doc+angles = enclose langle rangle++brackets : Doc -> Doc+brackets = enclose lbracket rbracket++-- ----------------------------------------------------- [ Lists, Sets, Tuples ]++||| The document `(encloseSep l r sep xs)` concatenates the documents+||| `xs` separated by `sep` and encloses the resulting document by `l`+||| and `r`. The documents are rendered horizontally if that fits the+||| page. Otherwise they are aligned vertically. All separators are put+||| in front of the elements.+encloseSep : (l   : Doc)+          -> (r   : Doc)+          -> (sep : Doc)+          -> (xs  : List Doc)+          -> Doc+encloseSep l r s []  = l <+> r+encloseSep l r s [x] = l <+> x <+> r+encloseSep l r s xs  = align (cat (zipWith (<+>) (l :: replicate (length xs) s) xs) <+> r)++||| The document `(list xs)` comma separates the documents `xs` and+||| encloses them in square brackets. The documents are rendered+||| horizontally if that fits the page. Otherwise they are aligned+||| vertically. All comma separators are put in front of the+||| elements.+list : List Doc -> Doc+list = encloseSep lbracket rbracket comma++||| The document `(tupled xs)` comma separates the documents `xs`+||| and encloses them in parenthesis. The documents are rendered+||| horizontally if that fits the page. Otherwise they are aligned+||| vertically. All comma separators are put in front of the+||| elements.+tupled : List Doc -> Doc+tupled = encloseSep lparen rparen comma++||| The document `(set xs)` separates the documents `xs` with+||| commas and encloses them in braces. The documents are+||| rendered horizontally if that fits the page. Otherwise they are+||| aligned vertically. All comma's are put in front of the+||| elements.+set : List Doc -> Doc+set = encloseSep lbrace rbrace comma++||| The document `(semiBraces xs)` separates the documents `xs` with+||| semi-colon and encloses them in braces. The documents are+||| rendered horizontally if that fits the page. Otherwise they are+||| aligned vertically. All semi-colons's are put in front of the+||| elements.+semiBrace : List Doc -> Doc+semiBrace = encloseSep lbrace rbrace semi++||| `(punctuate p xs)` concatenates all documents in `xs` with+||| document `p` except for the last document.+punctuate : Doc -> List Doc -> List Doc+punctuate p []  = []+punctuate p [x] = [x]+punctuate p (x :: xs) = (x <+> p) :: punctuate p xs++-- ------------------------------------------------------------------- [ Fills ]++width : Doc -> (Int -> Doc) -> Doc+width doc f = column (\k => doc <+> column (\k' => f (k' - k)))++||| The document `(fillBreak i x)` first renders document `x`. It+||| than appends `space`s until the width is equal to `i`. If the+||| width of `x` is already larger than `i`, the nesting level is+||| increased by `i` and a `line` is appended.+fillBreak : (i : Int) -> (x : Doc) -> Doc+fillBreak f x =+  width x (\w => if (w > f)+                  then nest f breakLine+                  else text (spaces (f - w)))++||| The document `(fill i x)` renders document `x`. It than appends+||| `space`s until the width is equal to `i`. If the width of `x` is+||| already larger, nothing is appended. This combinator is quite+||| useful in practice to output a list of bindings.+fill : (i : Int) -> (x : Doc) -> Doc+fill f d =+  width d (\w => if (w >= f)+                    then empty+                    else text (spaces (f - w)))++-- -------------------------------------------------------------- [ Primatives ]++||| The document `(literal s)` concatenates all characters in `s`+||| using `line` for newline characters and `char` for all other+||| characters. It is used instead of 'text' whenever the text contains+||| newline characters.+literal : (str : String) -> Doc+literal str = mkLiteral (unpack str)+  where+    mkLiteral : List Char -> Doc+    mkLiteral Nil         = empty+    mkLiteral ('\n':: ss) = line <+> mkLiteral ss+    mkLiteral (c :: ss)   = char c <+> mkLiteral ss++bool : Bool -> Doc+bool b = text (show b)++nat : Nat -> Doc+nat n = text (show n)++int : Int -> Doc+int i = text (show i)++integer : Integer -> Doc+integer i = text (show i)++double : Double -> Doc+double d = text (show d)
+ libs/contrib/Text/PrettyPrint/WL/Core.idr view
@@ -0,0 +1,225 @@+||| Core definitions and primitives.+module Text.PrettyPrint.WL.Core++%default total+%access export++-- -------------------------------------------------------------------- [ Core ]++||| The abstract data type `Doc` represents pretty documents.+|||+data Doc : Type where+  Empty : Doc+  Chara : (c : Char) -> Doc+  Text  : (len : Int) -> (str : String) -> Doc+  Line : (undone : Bool) -> Doc++  Cat     : (x : Doc) -> (y : Doc) -> Doc+  Nest    : (lvl : Int) -> (x : Doc) -> Doc+  Union   : (x : Doc) -> (y : Doc) -> Doc++  Column  : (f : Int -> Doc) -> Doc+  Nesting : (f : Int -> Doc) -> Doc++-- -------------------------------------------------------------- [ Primitives ]++||| The empty document is, indeed, empty.+empty : Doc+empty = Empty++||| The `line` document advances to the next line and indents to the+||| current nesting level. Document `line` behaves like `(text " ")`+||| if the line break is undone by 'group'.+line : Doc+line = Line False++||| The document `(char c)` contains the literal character `c`. If the+||| character is a newline (`'\n'`) the function returns a line+||| document. Ideally, the function 'line' should be used for line+||| breaks.+char : (c : Char) -> Doc+char '\n' = line+char c    = Chara c++||| The document `(text s)` contains the literal string `s`. The+||| string shouldn't contain any newline (`'\n'`) characters. If the+||| string contains newline characters, the function 'literal' should be+||| used.+text : (str : String) -> Doc+text ""  = empty+text str = Text (cast $ length str) str++||| The `breakLine` document advances to the next line and indents to+||| the current nesting level. Document `breakLine` behaves like+||| 'empty' if the line break is undone by 'group'.+breakLine : Doc+breakLine = Line True++||| Horizontal concatenation of documents+beside : Doc -> Doc -> Doc+beside = Cat++||| The document `(nest lvl x)` renders document `x` with the current+||| indentation level increased by lvl.+nest : (lvl : Int)+    -> (x   : Doc)+    -> Doc+nest = Nest++column : (f : Int -> Doc) -> Doc+column = Column++nesting : (f : Int -> Doc) -> Doc+nesting = Nesting++private %inline+flatten : Doc -> Doc+flatten (Line break)  = if break then Empty else Text 1 " "++flatten (Cat x y)    = Cat (flatten x) (flatten y)+flatten (Nest lvl x) = Nest lvl (flatten x)+flatten (Union x _)  = flatten x+flatten (Column f)   = Column  (\i => flatten $ f i)+flatten (Nesting f)  = Nesting (\i => flatten $ f i)++flatten other = other++||| The `group` combinator is used to specify alternative+||| layouts. The document `(group x)` undoes all line breaks in+||| document `x`. The resulting line is added to the current line if+||| that fits the page. Otherwise, the document `x` is rendered without+||| any changes.+group : Doc -> Doc+group x = Union (flatten x) x++Semigroup Doc where+  (<+>) x y = beside x y++Monoid Doc where+  neutral = empty++fold : (f : Doc -> Doc -> Doc) -> (ds : List Doc) -> Doc+fold _ Nil     = empty+fold f (x::xs) = foldl f x xs++-- --------------------------------------------------------------- [ Renderers ]++namespace PrettyDoc++  ||| The data type `PrettyDoc` represents rendered documents and is+  ||| used by the display functions.+  data PrettyDoc : Type where+    Empty : PrettyDoc+    Chara : (c : Char) -> (rest : PrettyDoc) -> PrettyDoc+    Text  : (len : Int) -> (str : String) -> (rest : PrettyDoc) -> PrettyDoc+    Line  : (lvl : Int) -> (rest : PrettyDoc) -> PrettyDoc++||| Helper function to construct spaces.+spaces : (n : Int) -> String+spaces n = if n <= 0 then "" else pack $ replicate (cast n) ' '++private+indentation : Int -> String+indentation n = spaces n++||| `(showPrettyDoc doc)` takes the output `PrettyDoc` from a+||| rendering function and transforms it to a String for printing.+showPrettyDoc : (doc : PrettyDoc) -> String+showPrettyDoc doc = showPrettyDocS doc ""+  where+    showPrettyDocS : (doc : PrettyDoc) -> (acc : String) -> String+    showPrettyDocS Empty               = id+    showPrettyDocS (Chara c rest)      = strCons c . showPrettyDocS rest+    showPrettyDocS (Text len str rest) = (str ++) . showPrettyDocS rest+    showPrettyDocS (Line lvl rest)     = (('\n' `strCons` indentation lvl) ++) . showPrettyDocS rest++private+fits : (w : Int) -> (x : PrettyDoc) -> Bool+fits w Empty               = if w < 0 then False else True+fits w (Chara c rest)      = if w < 0 then False else fits (w - 1) rest++fits w (Text len str rest) = if w < 0 then False else fits (w - len) rest++fits w (Line _ _)          = if w < 0 then False else True+++||| Use the Wadler-Leijen algorithm to pretty print the `doc`.+||| The algorithm uses a page width of `width` and a ribbon+||| width of `(ribbonfrac * width)` characters. The ribbon width is+||| the maximal amount of non-indentation characters on a line. The+||| parameter `ribbonfrac` should be between `0.0` and `1.0`. If it is+||| lower or higher, the ribbon width will be 0 or `width`+||| respectively.+render : (rfrac : Double)+      -> (width : Int)+      -> (doc : Doc)+      -> PrettyDoc+render rfrac w doc = best w 0 0 doc (const Empty)+  where+    rwidth : Int+    rwidth = max 0 $ min w (cast (cast w * rfrac))++    nicest : (lvl : Int)+          -> (col : Int)+          -> (x : PrettyDoc)+          -> (y : PrettyDoc)+          -> PrettyDoc+    nicest n k x y =+      let width = min (w - k) (rwidth - k + n)+       in if fits width x then x else y++    best : (lvl : Int)+        -> (col : Int)+        -> (curr : Int)+        -> (doc  : Doc)+        -> (k : Int -> PrettyDoc)+        -> PrettyDoc+    best lvl col curr Empty          k = k col+    best lvl col curr (Chara c)      k = Chara c $ k (col + 1)+    best lvl col curr (Text len str) k = Text len str $ k (col + len)+    best lvl col curr (Line undone)  k = Line curr $ k curr++    best lvl col curr (Cat x y) k =+        best lvl col curr x (\curr' => best lvl curr' curr y k)++    best lvl col curr (Nest x y) k = best lvl col (curr+x) y k++    best lvl col curr (Union x y) k =+        nicest lvl col (best lvl col curr x k)+                       (best lvl col curr y k)++    best lvl col curr (Column f)  k = best lvl col curr (f col) k+    best lvl col curr (Nesting f) k = best lvl col curr (f curr) k++||| Print the document to a string using the given ribbon fraction+||| and page width.+toString : (rfrac : Double)+        -> (width : Int)+        -> (doc : Doc)+        -> String+toString rfrac width doc = showPrettyDoc (render rfrac width doc)++writeDoc : (fname : String)+        -> (rfrac : Double)+        -> (width : Int)+        -> (doc : Doc)+        -> IO (Either FileError ())+writeDoc fname rfrac width doc = writeFile fname $ toString rfrac width doc++namespace Default++  ||| Render the document with a default ribbon fraction of 0.4 and page width of 120 characters.+  render : (doc : Doc) -> PrettyDoc+  render = render 0.4 120++  ||| Print the document to a string using a default ribbon fraction+  ||| of 0.4 and page width of 120 characters.+  toString : (doc : Doc) -> String+  toString = toString 0.4 120++  ||| Write the doc to `fname` using a default ribbon fraction of 0.4+  ||| and page width of 120 characters.+  writeDoc : (fname : String)+          -> (doc : Doc)+          -> IO (Either FileError ())+  writeDoc fname doc = writeFile fname $ Default.toString doc
libs/contrib/contrib.ipkg view
@@ -8,6 +8,7 @@           Control.Algebra.NumericImplementations,           Control.Isomorphism.Primitives,           Control.Partial,+          Control.Pipeline,           Control.ST, Control.ST.ImplicitCall, Control.ST.Exception,            Interfaces.Verified,@@ -28,5 +29,12 @@           Network.Cgi, Network.Socket.Data, Network.Socket.Raw, Network.Socket,            System.Concurrency.Process,++          Text.Lexer, Text.Parser,++          Text.PrettyPrint.WL,+          Text.PrettyPrint.WL.Core,+          Text.PrettyPrint.WL.Characters,+          Text.PrettyPrint.WL.Combinators,            Data.Fin.Extra
libs/effects/Effect/System.idr view
@@ -6,6 +6,7 @@ import Effects import System import Control.IOExcept+import public Data.So  %access public export @@ -14,18 +15,21 @@      Time : sig System Integer      GetEnv : String -> sig System (Maybe String)      CSystem : String -> sig System Int+     Usleep : (i : Int) -> (inbounds : So (i >= 0 && i <= 1000000)) -> sig System ()  implementation Handler System IO where     handle () Args k = do x <- getArgs; k x ()     handle () Time k = do x <- time; k x ()     handle () (GetEnv s) k = do x <- getEnv s; k x ()     handle () (CSystem s) k = do x <- system s; k x ()+    handle () (Usleep i prf) k = do usleep i; k () ()  implementation Handler System (IOExcept a) where     handle () Args k = do x <- ioe_lift getArgs; k x ()     handle () Time k = do x <- ioe_lift time; k x ()     handle () (GetEnv s) k = do x <- ioe_lift $ getEnv s; k x ()     handle () (CSystem s) k = do x <- ioe_lift $ system s; k x ()+    handle () (Usleep i prf) k = do ioe_lift $ usleep i; k () ()  --- The Effect and associated functions @@ -43,3 +47,6 @@  system : String -> Eff Int [SYSTEM] system s = call $ CSystem s++usleep : (i : Int) -> { auto prf : So (i >= 0 && i <= 1000000) } -> Eff () [SYSTEM]+usleep i {prf} = call $ Usleep i prf
libs/prelude/Decidable/Equality.idr view
@@ -8,19 +8,11 @@ import Prelude.List import Prelude.Nat import Prelude.Maybe+import Prelude.Uninhabited  %access public export  ----------------------------------------------------------------------------------- Utility lemmas-----------------------------------------------------------------------------------||| The negation of equality is symmetric (follows from symmetry of equality)-total negEqSym : {a : t} -> {b : t} -> (a = b -> Void) -> (b = a -> Void)-negEqSym p h = p (sym h)----------------------------------------------------------------------------------- -- Decidable equality -------------------------------------------------------------------------------- @@ -28,6 +20,20 @@ interface DecEq t where   ||| Decide whether two elements of `t` are propositionally equal   total decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2)++--------------------------------------------------------------------------------+-- Utility lemmas+--------------------------------------------------------------------------------++||| The negation of equality is symmetric (follows from symmetry of equality)+total negEqSym : {a : t} -> {b : t} -> (a = b -> Void) -> (b = a -> Void)+negEqSym p h = p (sym h)++||| Everything is decidably equal to itself+total decEqSelfIsYes : DecEq a => {x : a} -> decEq x x = Yes Refl+decEqSelfIsYes {x} with (decEq x x)+  | Yes Refl = Refl+  | No contra = absurd $ contra Refl  -------------------------------------------------------------------------------- --- Unit
libs/prelude/Prelude/Bool.idr view
@@ -35,3 +35,12 @@ not True = False not False = True +--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++Uninhabited (True = False) where+  uninhabited Refl impossible++Uninhabited (False = True) where+  uninhabited Refl impossible
libs/prelude/Prelude/Cast.idr view
@@ -7,7 +7,7 @@  ||| Interface for transforming an instance of a data type to another type. interface Cast from to where-    ||| Perform a cast operation.+    ||| Perform a (potentially lossy!) cast operation.     |||     ||| @orig The original type.     cast : (orig : from) -> to
libs/prelude/Prelude/Doubles.idr view
@@ -21,6 +21,9 @@ log : Double -> Double log x = prim__floatLog x +pow : Double -> Double -> Double+pow x y = exp (y * log x) + sin : Double -> Double sin x = prim__floatSin x
libs/prelude/Prelude/Functor.idr view
@@ -1,5 +1,6 @@ module Prelude.Functor +import Builtins import Prelude.Basics  %access public export@@ -22,3 +23,5 @@ (<$>) : Functor f => (func : a -> b) -> f a -> f b func <$> x = map func x +Functor (Pair a) where+  map f (x, y) = (x, f y)
libs/prelude/Prelude/Monad.idr view
@@ -6,6 +6,7 @@ import Prelude.Functor import public Prelude.Applicative import Prelude.Basics+import Prelude.Foldable import IO  %access public export@@ -33,6 +34,11 @@ flatten = join %deprecate flatten "Please use `join`, which is the standard name." +||| Similar to `foldl`, but uses a function wrapping its result in a `Monad`.+||| Consequently, the final value is wrapped in the same `Monad`.+foldlM : (Foldable t, Monad m) => (funcM: a -> b -> m a) -> (init: a) -> (input: t b) -> m a+foldlM fm a0 = foldl (\ma,b => ma >>= flip fm b) (pure a0)+ -- Annoyingly, these need to be here, so that we can use them in other -- Prelude modules other than the top level. @@ -48,4 +54,3 @@  Monad (IO' ffi) where     b >>= k = io_bind b k-
libs/prelude/Prelude/Nat.idr view
@@ -191,13 +191,10 @@ maximum (S n) Z = S n maximum (S n) (S m) = S (maximum n m) -||| Tail recursive cast Nat to Int+||| Cast Nat to Int ||| Note that this can overflow toIntNat : Nat -> Int-toIntNat n = toIntNat' n 0 where-	toIntNat' : Nat -> Int -> Int-	toIntNat' Z     x = x-	toIntNat' (S n) x = toIntNat' n (x + 1)+toIntNat n = prim__truncBigInt_Int (toIntegerNat n)  (-) : (m : Nat) -> (n : Nat) -> {auto smaller : LTE n m} -> Nat (-) m n {smaller} = minus m n
libs/prelude/Prelude/Strings.idr view
@@ -37,7 +37,7 @@ (++) = prim__concat  ||| A preallocated buffer for building a String. This allows a function (in IO)-||| to allocate enough space for a stirng which will be build from smaller+||| to allocate enough space for a string which will be built from smaller ||| pieces without having to allocate at every step. ||| To build a string using a `StringBuffer`, see `newStringBuffer`, ||| `addToStringBuffer` and `getStringFromBuffer`.@@ -247,7 +247,7 @@ split : (Char -> Bool) -> String -> List String split p xs = map pack (split p (unpack xs)) -||| Removes whitespace (determined with 'isSpace') from+||| Removes whitespace (determined by 'isSpace') from ||| the start of the string. ||| ||| ```idris example@@ -262,7 +262,7 @@     ltrim (strCons x xs) | StrCons _ _         = if (isSpace x) then assert_total (ltrim xs) else (strCons x xs) -||| Removes whitespace (determined with 'isSpace') from+||| Removes whitespace (determined by 'isSpace') from ||| the start and end of the string. ||| ||| ```idris example@@ -371,7 +371,7 @@ ||| Uppercases all characters in the string. ||| ||| ```idris example-||| toLower "aBc12!"+||| toUpper "aBc12!" ||| ``` toUpper : String -> String toUpper x with (strM x)
libs/prelude/Prelude/WellFounded.idr view
@@ -85,28 +85,46 @@         (x : a) -> P x wfInd {rel} step x = accInd step x (wellFounded {rel} x) --- Some basic useful relations+||| Interface of types with sized values.+||| The size is used for proofs of termination via accessibility.+|||+||| @ a the type whose elements can be mapped to Nat+interface Sized a where+  size : a -> Nat -||| LT is a well-founded relation on numbers-ltAccessible : (n : Nat) -> Accessible LT n-ltAccessible n = Access (\v, prf => ltAccessible' {n'=v} n prf)-  where-    ltAccessible' : (m : Nat) -> LT n' m -> Accessible LT n'-    ltAccessible' Z x = absurd x -    ltAccessible' (S k) (LTESucc x) -        = Access (\val, p => ltAccessible' k (lteTransitive p x))+Smaller : Sized a => a -> a -> Type+Smaller x y = size x `LT` size y --- First list is smaller than the second-smaller : List a -> List a -> Type-smaller xs ys = LT (length xs) (length ys)+SizeAccessible : Sized a => a -> Type+SizeAccessible = Accessible Smaller -||| `smaller` is a well-founded relation on lists-smallerAcc : (xs : List a) -> Accessible WellFounded.smaller xs-smallerAcc xs = Access (\v, prf => smallerAcc' {xs'=v} xs prf)+||| Proof of well-foundedness of `Smaller`.+||| Constructs accessibility for any given element of `a`, provided `Sized a`.+sizeAccessible : Sized a => (x : a) -> SizeAccessible x+sizeAccessible x = Access (acc $ size x)   where-    smallerAcc' : (ys : List a) -> smaller xs' ys -> Accessible smaller xs'-    smallerAcc' [] x = absurd x-    smallerAcc' (y :: ys) (LTESucc x) -       = Access (\val, p => smallerAcc' ys (lteTransitive p x))+    acc : (sizeX : Nat) -> (y : a) -> (size y `LT` sizeX) -> SizeAccessible y+    acc (S x') y (LTESucc yLEx')+        = Access (\z, zLTy => acc x' z (lteTransitive zLTy yLEx')) +||| Strong induction principle for sized types.+sizeInd : Sized a+  => {P : a -> Type}+  -> (step : (x : a) -> ((y : a) -> Smaller y x -> P y) -> P x)+  -> (z : a)+  -> P z+sizeInd step z = accInd step z (sizeAccessible z) +||| Strong recursion principle for sized types.+sizeRec : Sized a+  => (step : (x : a) -> ((y : a) -> Smaller y x -> b) -> b)+  -> (z : a)+  -> b+sizeRec step z = accRec step z (sizeAccessible z)+++implementation Sized Nat where+  size = \x => x++implementation Sized (List a) where+  size = length
main/Main.hs view
@@ -11,6 +11,7 @@ import Idris.Error import Idris.Info.Show import Idris.Main+import Idris.Options import Idris.Package  import Util.System (setupBundledCC)
rts/idris_buffer.c view
@@ -3,7 +3,7 @@  typedef struct {     int size;-    uint8_t* data;+    uint8_t data[0]; } Buffer;  void* idris_newBuffer(int bytes) {@@ -13,7 +13,6 @@     }      buf->size = bytes;-    buf->data = (uint8_t*)(buf+1);     memset(buf->data, 0, bytes);      return buf;@@ -25,7 +24,7 @@     Buffer* bto = to;      if (loc >= 0 && loc+len <= bto->size) {-        memcpy((bto->data)+loc, (bfrom->data)+start, len);+        memcpy(bto->data + loc, bfrom->data + start, len);     } }
rts/idris_gc.c view
@@ -24,7 +24,7 @@         cl = MKFLOATc(vm, x->info.f);         break;     case CT_STRING:-        cl = MKSTRc(vm, x->info.str);+        cl = MKSTRclen(vm, x->info.str.str, x->info.str.len);         break;     case CT_STROFFSET:         cl = MKSTROFFc(vm, x->info.str_offset);
rts/idris_gmp.h view
@@ -7,6 +7,8 @@ #include "mini-gmp.h" #endif +#include "idris_rts.h"+ // Set memory allocation functions void init_gmpalloc(void);
rts/idris_main.c view
@@ -3,6 +3,7 @@ #include "idris_rts.h" #include "idris_stats.h" +void _idris__123_runMain_95_0_125_(VM* vm, VAL* oldbase); #if defined(WIN32) || defined(__WIN32) || defined(__WIN32__) #include <Windows.h> int win32_get_argv_utf8(int *argc_ptr, char ***argv_ptr)
rts/idris_rts.c view
@@ -285,21 +285,29 @@     Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) +                            sizeof(char)*len, 0);     SETTY(cl, CT_STRING);-    cl -> info.str = (char*)cl + sizeof(Closure);+    cl->info.str.str = (char*)cl + sizeof(Closure);     if (str == NULL) {-        cl->info.str = NULL;+        cl->info.str.str = NULL;     } else {-        strcpy(cl -> info.str, str);+        strcpy(cl->info.str.str, str);     }+    cl->info.str.len = len > 0 ? len : 0;     return cl; }  char* GETSTROFF(VAL stroff) {     // Assume STROFF     StrOffset* root = stroff->info.str_offset;-    return (root->str->info.str + root->offset);+    return (root->str->info.str.str + root->offset); } +size_t GETSTROFFLEN(VAL stroff) {+    // Assume STROFF+    // we're working in char* here so no worries about utf8 char length+    StrOffset* root = stroff->info.str_offset;+    return (root->str->info.str.len - root->offset);+}+ VAL MKCDATA(VM* vm, CHeapItem * item) {     c_heap_insert_if_needed(vm, &vm->c_heap, item);     Closure* cl = allocate(sizeof(Closure), 0);@@ -342,15 +350,29 @@ }  VAL MKSTRc(VM* vm, char* str) {+    int len = strlen(str);+     Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) +-                           sizeof(char)*strlen(str)+1, 1);+                           sizeof(char)*len+1, 1);     SETTY(cl, CT_STRING);-    cl -> info.str = (char*)cl + sizeof(Closure);+    cl -> info.str.str = (char*)cl + sizeof(Closure); -    strcpy(cl -> info.str, str);+    strcpy(cl->info.str.str, str);+    cl->info.str.len = len;     return cl; } +VAL MKSTRclen(VM* vm, char* str, int len) {+    Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) ++                           sizeof(char)*len+1, 1);+    SETTY(cl, CT_STRING);+    cl -> info.str.str = (char*)cl + sizeof(Closure);++    strcpy(cl->info.str.str, str);+    cl->info.str.len = len;+    return cl;+}+ VAL MKPTRc(VM* vm, void* ptr) {     Closure* cl = allocate(sizeof(Closure), 1);     SETTY(cl, CT_PTR);@@ -397,6 +419,13 @@     return cl; } +void idris_trace(VM* vm, const char* func, int line) {+    printf("At %s:%d\n", func, line);+    dumpStack(vm);+    puts("");+    fflush(stdout);+}+ void dumpStack(VM* vm) {     int i = 0;     VAL* root;@@ -404,7 +433,8 @@     for (root = vm->valstack; root < vm->valstack_top; ++root, ++i) {         printf("%d: ", i);         dumpVal(*root);-        if (*root >= (VAL)(vm->heap.heap) && *root < (VAL)(vm->heap.end)) { printf("OK"); }+        if (*root >= (VAL)(vm->heap.heap) && *root < (VAL)(vm->heap.end)) { printf(" OK"); }+        if (root == vm->valstack_base) { printf(" <--- base"); }         printf("\n");     }     printf("RET: ");@@ -428,7 +458,7 @@         printf("] ");         break;     case CT_STRING:-        printf("STR[%s]", v->info.str);+        printf("STR[%s]", v->info.str.str);         break;     case CT_FWD:         printf("CT_FWD ");@@ -490,8 +520,9 @@     int x = (int) GETINT(i);     Closure* cl = allocate(sizeof(Closure) + sizeof(char)*16, 0);     SETTY(cl, CT_STRING);-    cl -> info.str = (char*)cl + sizeof(Closure);-    sprintf(cl -> info.str, "%d", x);+    cl->info.str.str = (char*)cl + sizeof(Closure);+    sprintf(cl->info.str.str, "%d", x);+    cl->info.str.len = strlen(cl->info.str.str);     return cl; } @@ -503,32 +534,33 @@     case CT_BITS8:         // max length 8 bit unsigned int str 3 chars (256)         cl = allocate(sizeof(Closure) + sizeof(char)*4, 0);-        cl->info.str = (char*)cl + sizeof(Closure);-        sprintf(cl->info.str, "%" PRIu8, (uint8_t)i->info.bits8);+        cl->info.str.str = (char*)cl + sizeof(Closure);+        sprintf(cl->info.str.str, "%" PRIu8, (uint8_t)i->info.bits8);         break;     case CT_BITS16:         // max length 16 bit unsigned int str 5 chars (65,535)         cl = allocate(sizeof(Closure) + sizeof(char)*6, 0);-        cl->info.str = (char*)cl + sizeof(Closure);-        sprintf(cl->info.str, "%" PRIu16, (uint16_t)i->info.bits16);+        cl->info.str.str = (char*)cl + sizeof(Closure);+        sprintf(cl->info.str.str, "%" PRIu16, (uint16_t)i->info.bits16);         break;     case CT_BITS32:         // max length 32 bit unsigned int str 10 chars (4,294,967,295)         cl = allocate(sizeof(Closure) + sizeof(char)*11, 0);-        cl->info.str = (char*)cl + sizeof(Closure);-        sprintf(cl->info.str, "%" PRIu32, (uint32_t)i->info.bits32);+        cl->info.str.str = (char*)cl + sizeof(Closure);+        sprintf(cl->info.str.str, "%" PRIu32, (uint32_t)i->info.bits32);         break;     case CT_BITS64:         // max length 64 bit unsigned int str 20 chars (18,446,744,073,709,551,615)         cl = allocate(sizeof(Closure) + sizeof(char)*21, 0);-        cl->info.str = (char*)cl + sizeof(Closure);-        sprintf(cl->info.str, "%" PRIu64, (uint64_t)i->info.bits64);+        cl->info.str.str = (char*)cl + sizeof(Closure);+        sprintf(cl->info.str.str, "%" PRIu64, (uint64_t)i->info.bits64);         break;     default:         fprintf(stderr, "Fatal Error: ClosureType %d, not an integer type", ty);         exit(EXIT_FAILURE);     } +    cl->info.str.len = strlen(cl->info.str.str);     SETTY(cl, CT_STRING);     return cl; }@@ -545,8 +577,10 @@ VAL idris_castFloatStr(VM* vm, VAL i) {     Closure* cl = allocate(sizeof(Closure) + sizeof(char)*32, 0);     SETTY(cl, CT_STRING);-    cl -> info.str = (char*)cl + sizeof(Closure);-    snprintf(cl -> info.str, 32, "%.16g", GETFLOAT(i));+    cl->info.str.str = (char*)cl + sizeof(Closure);+    snprintf(cl->info.str.str, 32, "%.16g", GETFLOAT(i));++    cl->info.str.len = strlen(cl->info.str.str);     return cl; } @@ -559,11 +593,13 @@     char *ls = GETSTR(l);     // dumpVal(l);     // printf("\n");-    Closure* cl = allocate(sizeof(Closure) + strlen(ls) + strlen(rs) + 1, 0);+    Closure* cl = allocate(sizeof(Closure) + GETSTRLEN(l) + GETSTRLEN(r) + 1, 0);     SETTY(cl, CT_STRING);-    cl -> info.str = (char*)cl + sizeof(Closure);-    strcpy(cl -> info.str, ls);-    strcat(cl -> info.str, rs);+    cl->info.str.str = (char*)cl + sizeof(Closure);+    strcpy(cl->info.str.str, ls);+    strcat(cl->info.str.str, rs);++    cl->info.str.len = GETSTRLEN(l) + GETSTRLEN(r);     return cl; } @@ -670,21 +706,26 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs) {     char *xstr = GETSTR(xs);     int xval = GETINT(x);+    int xlen = GETSTRLEN(xs);+     if ((xval & 0x80) == 0) { // ASCII char         Closure* cl = allocate(sizeof(Closure) +-                               strlen(xstr) + 2, 0);+                               xlen + 2, 0);         SETTY(cl, CT_STRING);-        cl -> info.str = (char*)cl + sizeof(Closure);-        cl -> info.str[0] = (char)(GETINT(x));-        strcpy(cl -> info.str+1, xstr);+        cl->info.str.str = (char*)cl + sizeof(Closure);+        cl->info.str.str[0] = (char)(GETINT(x));+        strcpy(cl->info.str.str+1, xstr);+        cl->info.str.len = xlen + 1;          return cl;     } else {         char *init = idris_utf8_fromChar(xval);-        Closure* cl = allocate(sizeof(Closure) + strlen(init) + strlen(xstr) + 1, 0);+        int newlen = strlen(init) + xlen;+        Closure* cl = allocate(sizeof(Closure) + newlen + 1, 0);         SETTY(cl, CT_STRING);-        cl -> info.str = (char*)cl + sizeof(Closure);-        strcpy(cl -> info.str, init);-        strcat(cl -> info.str, xstr);+        cl->info.str.str = (char*)cl + sizeof(Closure);+        strcpy(cl->info.str.str, init);+        strcat(cl->info.str.str, xstr);+        cl->info.str.len = newlen;         free(init);         return cl;     }@@ -701,7 +742,7 @@     char* str_val = GETSTR(str);      // If the substring is a suffix, use idris_strShift to avoid reallocating-    if (offset_val + length_val >= strlen(str_val)) {+    if (offset_val + length_val >= GETSTRLEN(str)) {         return idris_strShift(vm, str, offset_val);     }     else {@@ -709,20 +750,23 @@         char *end = idris_utf8_advance(start, length_val);         Closure* newstr = allocate(sizeof(Closure) + (end - start) +1, 0);         SETTY(newstr, CT_STRING);-        newstr -> info.str = (char*)newstr + sizeof(Closure);-        memcpy(newstr -> info.str, start, end - start);-        *(newstr -> info.str + (end - start) + 1) = '\0';+        newstr->info.str.str = (char*)newstr + sizeof(Closure);+        memcpy(newstr->info.str.str, start, end - start);+        *(newstr->info.str.str + (end - start) + 1) = '\0';+        newstr->info.str.len = strlen(newstr->info.str.str);         return newstr;     } }  VAL idris_strRev(VM* vm, VAL str) {     char *xstr = GETSTR(str);-    Closure* cl = allocate(sizeof(Closure) +-                           strlen(xstr) + 1, 0);+    int xlen = GETSTRLEN(str);++    Closure* cl = allocate(sizeof(Closure) + xlen + 1, 0);     SETTY(cl, CT_STRING);-    cl->info.str = (char*)cl + sizeof(Closure);-    idris_utf8_rev(xstr, cl->info.str);+    cl->info.str.str = (char*)cl + sizeof(Closure);+    cl->info.str.len = xlen;+    idris_utf8_rev(xstr, cl->info.str.str);     return cl; } @@ -832,7 +876,7 @@         cl = MKFLOATc(vm, x->info.f);         break;     case CT_STRING:-        cl = MKSTRc(vm, x->info.str);+        cl = MKSTRc(vm, x->info.str.str);         break;     case CT_BIGINT:         cl = MKBIGMc(vm, x->info.ptr);
rts/idris_rts.h view
@@ -42,6 +42,11 @@     size_t offset; } StrOffset; +typedef struct {+    char* str;+    size_t len; // Cached strlen (we do 'strlen' a lot)+} String;+ // A foreign pointer, managed by the idris GC typedef struct {     size_t size;@@ -59,7 +64,7 @@         con c;         int i;         double f;-        char* str;+        String str;         StrOffset* str_offset;         void* ptr;         uint8_t bits8;@@ -182,7 +187,8 @@ #define ALIGN(__p, __alignment) ((__p + __alignment - 1) & ~(__alignment - 1))  // Retrieving values-#define GETSTR(x) (ISSTR(x) ? (((VAL)(x))->info.str) : GETSTROFF(x))+#define GETSTR(x) (ISSTR(x) ? (((VAL)(x))->info.str.str) : GETSTROFF(x))+#define GETSTRLEN(x) (ISSTR(x) ? (((VAL)(x))->info.str.len) : GETSTROFFLEN(x)) #define GETPTR(x) (((VAL)(x))->info.ptr) #define GETMPTR(x) (((VAL)(x))->info.mptr->data) #define GETFLOAT(x) (((VAL)(x))->info.f)@@ -229,7 +235,15 @@  // Stack management -#define INITFRAME VAL* myoldbase+#ifdef IDRIS_TRACE+#define TRACE idris_trace(vm, __FUNCTION__, __LINE__);+#else+#define TRACE +#endif++#define INITFRAME TRACE\+                  VAL* myoldbase+ #define REBASE vm->valstack_base = oldbase #define RESERVE(x) if (vm->valstack_top+(x) > vm->stack_max) { stackOverflow(); } \                    else { memset(vm->valstack_top, 0, (x)*sizeof(VAL)); }@@ -255,11 +269,13 @@ VAL MKFLOATc(VM* vm, double val); VAL MKSTROFFc(VM* vm, StrOffset* off); VAL MKSTRc(VM* vm, char* str);+VAL MKSTRclen(VM* vm, char* str, int len); VAL MKPTRc(VM* vm, void* ptr); VAL MKMPTRc(VM* vm, void* ptr, size_t size); VAL MKCDATAc(VM* vm, CHeapItem * item);  char* GETSTROFF(VAL stroff);+size_t GETSTROFFLEN(VAL stroff);  // #define SETTAG(x, a) (x)->info.c.tag = (a) #define SETARG(x, i, a) ((x)->info.c.args)[i] = ((VAL)(a))@@ -340,6 +356,7 @@ int idris_getChannel(Msg* msg); void idris_freeMsg(Msg* msg); +void idris_trace(VM* vm, const char* func, int line); void dumpVal(VAL r); void dumpStack(VM* vm);
rts/idris_stdfgn.c view
@@ -61,7 +61,7 @@  int idris_writeStr(void* h, char* str) {     FILE* f = (FILE*)h;-    if (fputs(str, f)) {+    if (fputs(str, f) >= 0) {         return 0;     } else {         return -1;
+ scripts/runidris view
@@ -0,0 +1,18 @@+#!/bin/sh++# This is a script that runs an idris program, suitable for use+# in a shebang line. We cache the executables by naming them after+# the SHA hash of the idris source and looking for it before+# compiling+RUNIDRIS_DIR="${TEMP:-/tmp}/runidris"+if [ ! -d $RUNIDRIS_DIR ]; then+    mkdir $RUNIDRIS_DIR+    chmod 700 $RUNIDRIS_DIR+fi+TEMP_NAME="runidris-`sha1sum $1 | cut -c1-40`"+FP="$RUNIDRIS_DIR/$TEMP_NAME"+if [ ! -e $FP ]; then+    "${IDRIS:-idris}" $1 --ibcsubdir "$RUNIDRIS_DIR" -i "." -o $FP+fi+shift+"$FP" "$@"
+ scripts/runidris-node view
@@ -0,0 +1,18 @@+#!/bin/sh++# This is a script that runs an idris program, suitable for use+# in a shebang line. We cache the executables by naming them after+# the SHA hash of the idris source and looking for it before+# compiling. This is the node version.+RUNIDRIS_DIR="${TEMP:-/tmp}/runidris-node"+if [ ! -d $RUNIDRIS_DIR ]; then+    mkdir $RUNIDRIS_DIR+    chmod 700 $RUNIDRIS_DIR+fi+TEMP_NAME="runidris-`sha1sum $1 | cut -c1-40`.js"+FP="$RUNIDRIS_DIR/$TEMP_NAME"+if [ ! -e $FP ]; then+    "${IDRIS:-idris}" --codegen node --ibcsubdir "$RUNIDRIS_DIR" -i "." $1 -o $FP+fi+shift+node "$FP" "$@"
src/IRTS/CodegenC.hs view
@@ -5,9 +5,11 @@ License     : BSD3 Maintainer  : The Idris Community. -}+{-# LANGUAGE FlexibleContexts #-}+ module IRTS.CodegenC (codegenC) where -import Idris.AbsSyntax+import Idris.AbsSyntax hiding (getBC) import Idris.Core.TT import IRTS.Bytecode import IRTS.CodegenCommon@@ -19,10 +21,12 @@ import Util.System  import Control.Monad+import Control.Monad+import Control.Monad.RWS import Data.Bits import Data.Char-import Data.List (intercalate, nubBy)-import Debug.Trace+import Data.List (find, intercalate, nubBy, partition)+import qualified Data.Text as T import Numeric import System.Directory import System.Exit@@ -30,6 +34,8 @@ import System.IO import System.Process +import Debug.Trace+ codegenC :: CodeGenerator codegenC ci = do codegenC' (simpleDecls ci)                            (outputFile ci)@@ -64,7 +70,9 @@          let bc = map toBC defs          let wrappers = genWrappers bc          let h = concatMap toDecl (map fst bc)-         let cc = concatMap (uncurry toC) bc+         let (state, cc) = execRWS (generateSrc bc) 0+                                         (CS { fnName = Nothing,+                                                level = 1 })          let hi = concatMap ifaceC (concatMap getExp exports)          d <- getIdrisCRTSDir          mprog <- readFile (d </> "idris_main" <.> "c")@@ -134,13 +142,18 @@ toDecl :: Name -> String toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n" -toC :: Name -> [BC] -> String-toC f code-    = -- "/* " ++ show code ++ "*/\n\n" ++-      "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++-                 indent 1 ++ "INITFRAME;\n" ++-                 concatMap (bcc 1) code ++ "}\n\n"+generateSrc :: [(Name, [BC])] -> RWS Int String CState ()+generateSrc bc = mapM_ toC bc +toC :: (Name, [BC]) -> RWS Int String CState ()+toC (f, code) = do+    modify (\s -> s { fnName = Just f })+    s <- get+    tell $ "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n"+    tell $  indent (level s) ++ "INITFRAME;\n"+    bcc code+    tell $ "}\n\n"+ showCStr :: String -> String showCStr s = '"' : foldr ((++) . showChar) "\"" s   where@@ -151,34 +164,46 @@         -- Note: we need the double quotes around the codes because otherwise         -- "\n3" would get encoded as "\x0a3", which is incorrect.         -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.-        | ord c < 0x10  = "\"\"\\x0" ++ showHex (ord c) "\"\""-        | ord c < 0x20  = "\"\"\\x"  ++ showHex (ord c) "\"\""+        | ord c < 0x20  = showUTF8 (ord c)         | ord c < 0x7f  = [c]    -- 0x7f = \DEL         | otherwise = showHexes (utf8bytes (ord c)) +    showUTF8 c = "\"\"\\x" ++ pad (showHex c "") ++ "\"\""+    showHexes = foldr ((++) . showUTF8) ""+     utf8bytes :: Int -> [Int]-    utf8bytes x = let (h : bytes) = split [] x in-                      headHex h (length bytes) : map toHex bytes+    utf8bytes x+        | x <= 0x7f     = [x]+        | x <= 0x7ff    = let (y : ys) = split [] 2 x in (y .|. 0xc0) : map (.|. 0x80) ys+        | x <= 0xffff   = let (y : ys) = split [] 3 x in (y .|. 0xe0) : map (.|. 0x80) ys+        | x <= 0x10ffff = let (y : ys) = split [] 4 x in (y .|. 0xf0) : map (.|. 0x80) ys+        | otherwise = error $ "Invalid Unicode code point U+" ++ showHex x ""       where-        split acc 0 = acc-        split acc x = let xbits = x .&. 0x3f-                          xrest = shiftR x 6 in-                          split (xbits : acc) xrest+        split acc 1 x = x : acc+        split acc i x = split (x .&. 0x3f : acc) (i - 1) (shiftR x 6) -        headHex h 1 = h + 0xc0-        headHex h 2 = h + 0xe0-        headHex h 3 = h + 0xf0-        headHex h n = error "Can't happen: Invalid UTF8 character"+    pad :: String -> String+    pad s = case length s of+                 1 -> "0" ++ s+                 2 -> s+                 _ -> error $ "Can't happen: String of invalid length " ++ show s -        toHex i = i + 0x80+data CState = CS {+    fnName :: Maybe Name,+    level :: Int+} -    showHexes = foldr ((++) . showUTF8) ""-    showUTF8 c = "\"\"\\x" ++ showHex c "\"\"" -bcc :: Int -> BC -> String-bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"-bcc i (ASSIGNCONST l c)-    = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"+bcc :: [BC] -> RWS Int String CState ()+bcc [] = return ()+bcc ((ASSIGN l r):xs) = do+    i <- get+    tell $ indent (level i) ++ creg l ++ " = " ++ creg r ++ ";\n"+    bcc xs+bcc ((ASSIGNCONST l c):xs) = do+    i <- get+    tell $ indent (level i) ++ creg l ++ " = " ++ mkConst c ++ ";\n"+    bcc xs   where     mkConst (I i) = "MKINT(" ++ show i ++ ")"     mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"@@ -196,16 +221,21 @@     mkConst c | isTypeConst c = "MKINT(42424242)"     mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented" -bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"-bcc i (MKCON l loc tag []) | tag < 256-    = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"-bcc i (MKCON l loc tag args)-    = indent i ++ alloc loc tag ++-      indent i ++ setArgs 0 args ++ "\n" ++-      indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"----         "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++---         show (length args) ++ concatMap showArg args ++ ");\n"+bcc ((UPDATE l r):xs) = do+    i <- get+    tell $ indent (level i) ++ creg l ++ " = " ++ creg r ++ ";\n"+    bcc xs+bcc ((MKCON l loc tag []):xs) | tag < 256 = do+    i <- get+    tell $ indent (level i) ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"+    bcc xs+bcc ((MKCON l loc tag args):xs) = do+    i <- get+    let tab = indent (level i)+    tell $ tab ++ alloc loc tag +++           tab ++ setArgs 0 args ++ "\n" +++           tab ++ creg l ++ " = " ++ creg Tmp ++ ";\n"+    bcc xs   where showArg r = ", " ++ creg r         setArgs i [] = ""         setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++@@ -217,52 +247,94 @@             = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++                     show (length args) ++ ");\n" -bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++-                                      ", " ++ show a ++ ");\n"-bcc i (PROJECTINTO r t idx)-    = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"-bcc i (CASE True r code def)-    | length code < 4 = showCase i def code+bcc ((PROJECT l loc a):xs) = do+    i <- get+    tell $ indent (level i) ++ "PROJECT(vm, " ++ creg l ++ ", "+                ++ show loc ++ ", " ++ show a ++ ");\n"+    bcc xs+bcc ((PROJECTINTO r t idx):xs) = do+    i <- get+    tell $ indent (level i) ++ creg r ++ " = GETARG(" ++ creg t+            ++ ", " ++ show idx ++ ");\n"+    bcc xs+bcc ((CASE True r code def):xs)+    | length code < 4 = do+        showCases def code+        bcc xs   where-    showCode :: Int -> [BC] -> String-    showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++-                    indent i ++ "}\n"+    showCode bc = do+        w <- getBC bc xs+        i <- get+        tell $ "{\n" ++ w ++ indent (level i) ++ "}\n" -    showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String-    showCase i Nothing [(t, c)] = indent i ++ showCode i c-    showCase i (Just def) [] = indent i ++ showCode i def-    showCase i def ((t, c) : cs)-        = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c-           ++ indent i ++ "else\n" ++ showCase i def cs+    showCases Nothing [(t, c)] = do+        i <- get+        tell $ indent (level i)+        showCode c+    showCases (Just def) [] = do+        i <- get+        tell $ indent (level i)+        showCode def+    showCases def ((t, c) : cs) = do+        i <- get+        tell $ indent (level i) ++ "if (CTAG(" ++ creg r ++ ") == "+               ++ show t ++ ") "+        showCode c+        tell $ indent (level i) ++ "else\n"+        showCases def cs -bcc i (CASE safe r code def)-    = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++-      concatMap (showCase i) code ++-      showDef i def ++-      indent i ++ "}\n"+bcc ((CASE safe r code def):xs) = do+    i <- get+    tell $ indent (level i) ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n"+    mapM showCase code+    showDef def+    tell $ indent (level i) ++ "}\n"+    bcc xs   where     ctag True = "CTAG"     ctag False = "TAG" -    showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"-                         ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"-    showDef i Nothing = ""-    showDef i (Just c) = indent i ++ "default:\n"-                         ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"-bcc i (CONSTCASE r code def)+    showCase (t, bc) = do+        w <- getBC bc xs+        is <- get+        let i = level is+        tell $ indent i ++ "case " ++ show t ++ ":\n"+                ++ w ++ indent (i + 1) ++ "break;\n"+    showDef Nothing = return $ ()+    showDef (Just c) = do+        w <- getBC c xs+        is <- get+        let i = level is+        tell $ indent i ++ "default:\n" ++ w ++ indent (i + 1) ++ "break;\n"++bcc ((CONSTCASE r code def):xs)    | intConsts code---      = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++---        concatMap (showCase i) code ++---        showDef i def ++---        indent i ++ "}\n"-     = concatMap (iCase (creg r)) code ++-       indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"+     = do+         is <- get+         let i = level is+         codes <- mapM getCode code+         defs <- showDefS def+         tell $ concatMap (iCase i (creg r)) codes+         tell $ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"+         bcc xs    | strConsts code-     = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++-       indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"+     = do+         is <- get+         let i = level is+         codes <- mapM getCode code+         defs <- showDefS def+         tell $ concatMap (strCase i ("GETSTR(" ++ creg r ++ ")")) codes+             ++ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"+         bcc xs    | bigintConsts code-     = concatMap (biCase (creg r)) code ++-       indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"+     = do+         is <- get+         let i = level is+         codes <- mapM getCode code+         defs <- showDefS def+         tell $ concatMap (biCase i (creg r)) codes +++            indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"+         bcc xs    | otherwise = error $ "Can't happen: Can't compile const case " ++ show code   where     intConsts ((I _, _ ) : _) = True@@ -279,71 +351,118 @@     strConsts ((Str _, _ ) : _) = True     strConsts _ = False -    strCase sv (s, bc) =+    getCode (x, code) = do+        c <- getBC code xs+        return (x, c)++    strCase i sv (s, bc) =         indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++-           concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"-    biCase bv (BI b, bc) =+            bc ++ indent i ++ "} else\n"+    biCase i bv (BI b, bc) =         indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"-           ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"-    iCase v (I b, bc) =+           ++  bc ++ indent i ++ "} else\n"+    iCase i v (I b, bc) =         indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"-           ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"-    iCase v (Ch b, bc) =+           ++ bc ++ indent i ++ "} else\n"+    iCase i 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) =+           ++ bc ++ indent i ++ "} else\n"+    iCase i 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) =+           ++ bc ++ indent i ++ "} else\n"+    iCase i 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) =+           ++ bc ++ indent i ++ "} else\n"+    iCase i 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) =+           ++ bc ++ indent i ++ "} else\n"+    iCase i 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"-    showDef i Nothing = ""-    showDef i (Just c) = indent i ++ "default:\n"-                         ++ concatMap (bcc (i+1)) c ++-                            indent (i + 1) ++ "break;\n"-    showDefS i Nothing = ""-    showDefS i (Just c) = concatMap (bcc (i+1)) c+           ++ bc ++ indent i ++ "} else\n" -bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"-bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"-bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"-bcc i REBASE = indent i ++ "REBASE;\n"-bcc i (RESERVE 0) = ""-bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"-bcc i (ADDTOP 0) = ""-bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"-bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"-bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"-bcc i STOREOLD = indent i ++ "STOREOLD;\n"-bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"-bcc i (FOREIGNCALL l rty (FStr fn@('&':name)) [])-      = indent i ++-        c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"-bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%wrapper"-      = indent i ++-        c_irts (toFType rty) (creg l ++ " = ")+    showDefS Nothing = return ""+    showDefS (Just c) = getBC c xs++bcc (CALL n:xs) = do+    i <- get+    tell $ indent (level i) ++ "CALL(" ++ cname n ++ ");\n"+    bcc xs+bcc (TAILCALL n:xs) = do+    i <- get+    tell $ indent (level i) ++ "TAILCALL(" ++ cname n ++ ");\n"+    bcc xs+bcc ((SLIDE n):xs) = do+    i <- get+    tell $ indent (level i) ++ "SLIDE(vm, " ++ show n ++ ");\n"+    bcc xs+bcc (REBASE:xs) = do+    i <- get+    tell $ indent (level i)++ "REBASE;\n"+    bcc xs+bcc ((RESERVE 0):xs) = bcc xs+bcc ((RESERVE n):xs) = do+    i <- get+    tell $ indent (level i) ++ "RESERVE(" ++ show n ++ ");\n"+    bcc xs+bcc ((ADDTOP 0):xs) = bcc xs+bcc ((ADDTOP n):xs) = do+    i <- get+    tell $ indent (level i) ++ "ADDTOP(" ++ show n ++ ");\n"+    bcc xs+bcc ((TOPBASE n):xs) = do+    i <- get+    tell $ indent (level i) ++ "TOPBASE(" ++ show n ++ ");\n"+    bcc xs+bcc ((BASETOP n):xs) = do+    i <- get+    tell $ indent (level i) ++ "BASETOP(" ++ show n ++ ");\n"+    bcc xs+bcc (STOREOLD:xs) = do+    i <- get+    tell $ indent (level i) ++ "STOREOLD;\n"+    bcc xs+bcc ((OP l fn args):xs) = do+    i <- get+    tell $ indent (level i) ++ doOp (creg l ++ " = ") fn args ++ ";\n"+    bcc xs+bcc ((FOREIGNCALL l rty (FStr fn@('&':name)) []):xs) = do+    i <- get+    tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"+    bcc xs+bcc ((FOREIGNCALL l rty (FStr fn) (x:xs)):zs) | fn == "%wrapper"+      = do+          i <- get+          tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")             ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"-bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%dynamic"-      = indent i ++ c_irts (toFType rty) (creg l ++ " = ")+          bcc zs+bcc ((FOREIGNCALL l rty (FStr fn) (x:xs)):zs) | fn == "%dynamic"+      = do+          i <- get+          tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")             ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" ++              "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n"-bcc i (FOREIGNCALL l rty (FStr fn) args)-      = indent i ++-        c_irts (toFType rty) (creg l ++ " = ")-                   (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"-bcc i (FOREIGNCALL l rty _ args) = error "Foreign Function calls cannot be partially applied, without being inlined."-bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed-bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"+          bcc zs+bcc ((FOREIGNCALL l rty (FStr fn) args):xs) = do+    i <- get+    tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")+                 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"+    bcc xs+bcc ((FOREIGNCALL l rty _ args):_) = error "Foreign Function calls cannot be partially applied, without being inlined."+bcc ((NULL r):xs) = do+    i <- get+    tell $ indent (level i) ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed+    bcc xs+bcc ((ERROR str):xs) = do+    i <- get+    tell $ indent (level i) ++ "fprintf(stderr, "+        ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"+    bcc xs -- bcc i c = error (show c) -- indent i ++ "// not done yet\n"++getBC code xs = do+    i <- get+    let (a, s, w) = runRWS (bcc code) 0 (i { level = level i + 1 })+    return w  fcall (t, arg) = irts_c (toFType t) (creg arg) -- Deconstruct the Foreign type in the defunctionalised expression and build
src/IRTS/CodegenJavaScript.hs view
@@ -11,1311 +11,59 @@                              , JSTarget(..)                              ) where -import Idris.AbsSyntax hiding (TypeCase)-import Idris.Core.TT-import IRTS.Bytecode-import IRTS.CodegenCommon-import IRTS.Defunctionalise-import IRTS.Exports-import IRTS.JavaScript.AST-import IRTS.Lang-import IRTS.Simplified-import IRTS.System-import Util.System--import Control.Applicative (pure, (<$>), (<*>))-import Control.Arrow-import Control.Monad (mapM)-import Control.Monad.RWS hiding (mapM)-import Control.Monad.State-import Data.Char-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import qualified Data.Text as T-import qualified Data.Text.IO as TIO-import Data.Traversable hiding (mapM)-import Data.Word-import Numeric-import System.Directory-import System.FilePath-import System.IO---data CompileInfo = CompileInfo { compileInfoApplyCases  :: [Int]-                               , compileInfoEvalCases   :: [Int]-                               , compileInfoNeedsBigInt :: Bool-                               }---initCompileInfo :: [(Name, [BC])] -> CompileInfo-initCompileInfo bc =-  CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc) (lookupBigInt bc)-  where-    lookupBigInt :: [(Name, [BC])] -> Bool-    lookupBigInt = any (needsBigInt . snd)-      where-        needsBigInt :: [BC] -> Bool-        needsBigInt bc = any testBCForBigInt bc-          where-            testBCForBigInt :: BC -> Bool-            testBCForBigInt (ASSIGNCONST _ c)  =-              testConstForBigInt c--            testBCForBigInt (CONSTCASE _ c d) =-                 maybe False needsBigInt d-              || any (needsBigInt . snd) c-              || any (testConstForBigInt . fst) c--            testBCForBigInt (CASE _ _ c d) =-                 maybe False needsBigInt d-              || any (needsBigInt . snd) c--            testBCForBigInt _ = False--            testConstForBigInt :: Const -> Bool-            testConstForBigInt (BI _)  = True-            testConstForBigInt (B64 _) = True-            testConstForBigInt _       = False---    collectCases :: String ->  [(Name, [BC])] -> [Int]-    collectCases fun bc = getCases $ findFunction fun bc--    findFunction :: String -> [(Name, [BC])] -> [BC]-    findFunction f ((MN 0 fun, bc):_)-      | fun == txt f = bc-    findFunction f (_:bc) = findFunction f bc--    getCases :: [BC] -> [Int]-    getCases = concatMap analyze-      where-        analyze :: BC -> [Int]-        analyze (CASE _ _ b _) = map fst b-        analyze _              = []---data JSTarget = Node | JavaScript deriving Eq---codegenJavaScript :: CodeGenerator-codegenJavaScript ci =-  codegenJS_all JavaScript (simpleDecls ci)-    (includes ci) [] (outputFile ci) (exportDecls ci) (outputType ci)--codegenNode :: CodeGenerator-codegenNode ci =-  codegenJS_all Node (simpleDecls ci)-    (includes ci) (compileLibs ci) (outputFile ci) (exportDecls ci) (outputType ci)--codegenJS_all-  :: JSTarget-  -> [(Name, SDecl)]-  -> [FilePath]-  -> [String]-  -> FilePath-  -> [ExportIFace]-  -> OutputType-  -> IO ()-codegenJS_all target definitions includes libs filename exports outputType = do-  let bytecode      = map toBC definitions-  let info          = initCompileInfo bytecode-  let js            = concatMap (translateDecl info) bytecode-  let full          = concatMap processFunction js-  let exportedNames = map translateName ((getExpNames exports) ++ [sUN "call__IO"])-  let code          = deadCodeElim exportedNames full-  let ext           = takeExtension filename-  let isHtml        = target == JavaScript && ext == ".html"-  let htmlPrologue  = T.pack "<!doctype html><html><head><script>\n"-  let htmlEpilogue  = T.pack "\n</script></head><body></body></html>"-  let (cons, opt)   = optimizeConstructors code-  let (header, rt)   = case target of-                          Node       -> ("#!/usr/bin/env node\n", "-node")-                          JavaScript -> ("", "-browser")--  included   <- concat <$> getIncludes includes-  path       <- getIdrisJSRTSDir-  idrRuntime <- readFile $ path </> "Runtime-common.js"-  tgtRuntime <- readFile $ path </> concat ["Runtime", rt, ".js"]-  jsbn       <- if compileInfoNeedsBigInt info-                   then readFile $ path </> "jsbn/jsbn.js"-                   else return ""-  let runtime = (  header-                ++ includeLibs libs-                ++ included-                ++ jsbn-                ++ idrRuntime-                ++ tgtRuntime-                )-  let jsSource = T.pack runtime-                 `T.append` T.concat (map compileJS opt)-                 `T.append` T.concat (map compileJS cons)-                 `T.append` T.concat (map compileJS (map genInterface (concatMap getExps exports)))-                 `T.append` main-                 `T.append` invokeMain-  let source = if isHtml-                    then htmlPrologue `T.append` jsSource `T.append` htmlEpilogue-                    else jsSource-  writeSourceText filename source-  setPermissions filename (emptyPermissions { readable   = True-                                            , executable = target == Node-                                            , writable   = True-                                            })-    where-      deadCodeElim :: [String] -> [JS] -> [JS]-      deadCodeElim exports js = concatMap (collectFunctions exports) js-        where-          collectFunctions :: [String] -> JS -> [JS]-          collectFunctions _ fun@(JSAlloc name _)-            | name == translateName (sMN 0 "runMain") = [fun]--          collectFunctions exports fun@(JSAlloc name _)-            | name `elem` exports = [fun]--          collectFunctions _ fun@(JSAlloc name (Just (JSFunction _ body))) =-            let invokations = sum $ map (-                    \x -> execState (countInvokations name x) 0-                  ) js-             in if invokations == 0-                   then []-                   else [fun]--          countInvokations :: String -> JS -> State Int ()-          countInvokations name (JSAlloc _ (Just (JSFunction _ body))) =-            countInvokations name body--          countInvokations name (JSSeq seq) =-            void $ traverse (countInvokations name) seq--          countInvokations name (JSAssign _ rhs) =-            countInvokations name rhs--          countInvokations name (JSCond conds) =-            void $ traverse (-                runKleisli $ arr id *** Kleisli (countInvokations name)-              ) conds--          countInvokations name (JSSwitch _ conds def) =-            void $ traverse (-              runKleisli $ arr id *** Kleisli (countInvokations name)-            ) conds >> traverse (countInvokations name) def--          countInvokations name (JSApp lhs rhs) =-            void $ countInvokations name lhs >> traverse (countInvokations name) rhs--          countInvokations name (JSNew _ args) =-            void $ traverse (countInvokations name) args--          countInvokations name (JSArray args) =-            void $ traverse (countInvokations name) args--          countInvokations name (JSIdent name')-            | name == name' = get >>= put . (+1)-            | otherwise     = return ()--          countInvokations _ _ = return ()--      processFunction :: JS -> [JS]-      processFunction =-        collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)--      includeLibs :: [String] -> String-      includeLibs =-        concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")--      getIncludes :: [FilePath] -> IO [String]-      getIncludes = mapM readFile--      main :: T.Text-      main =-        compileJS $ JSAlloc "main" (Just $-          JSFunction [] (-            case target of-                 Node       -> mainFun-                 JavaScript -> jsMain-          )-        )--      jsMain :: JS-      jsMain =-        JSCond [ (exists document `jsAnd` isReady, mainFun)-               , (exists window, windowMainFun)-               , (JSTrue, mainFun)-               ]-        where-          exists :: JS -> JS-          exists js = jsTypeOf js `jsNotEq` JSString "undefined"--          window :: JS-          window = JSIdent "window"--          document :: JS-          document = JSIdent "document"--          windowMainFun :: JS-          windowMainFun =-            jsMeth window "addEventListener" [ JSString "DOMContentLoaded"-                                             , JSFunction [] ( mainFun )-                                             , JSFalse-                                             ]--          isReady :: JS-          isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"--          readyState :: JS-          readyState = JSProj (JSIdent "document") "readyState"--      mainFun :: JS-      mainFun =-        JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])-              , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]-              , JSApp (-                  JSIdent (translateName (sMN 0 "runMain"))-                ) [JSNew "i$POINTER" [JSNum (JSInt 0)]]-              , JSApp (JSIdent "i$RUN") []-              ]--      invokeMain :: T.Text-      invokeMain = compileJS $ JSApp (JSIdent "main") []-      getExps (Export _ _ exp) = exp--optimizeConstructors :: [JS] -> ([JS], [JS])-optimizeConstructors js =-    let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in-        (map (allocCon . snd) (M.toList cons), js')-  where-    allocCon :: (String, JS) -> JS-    allocCon (name, con) = JSAlloc name (Just con)--    newConstructor :: Int -> String-    newConstructor n = "i$CON$" ++ show n--    optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS-    optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)-                                           , JSArray []-                                           , a-                                           , e-                                           ]) = do-      s <- get-      case M.lookup tag s of-           Just (i, c) -> return $ JSIdent i-           Nothing     -> do let n = newConstructor tag-                             put $ M.insert tag (n, js) s-                             return $ JSIdent n--    optimizeConstructor' (JSSeq seq) =-      JSSeq <$> traverse optimizeConstructor' seq--    optimizeConstructor' (JSSwitch reg cond def) = do-      cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond-      def'  <- traverse optimizeConstructor' def-      return $ JSSwitch reg cond' def'--    optimizeConstructor' (JSCond cond) =-      JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond--    optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do-      body' <- optimizeConstructor' body-      return $ JSAlloc fun (Just (JSFunction args body'))--    optimizeConstructor' (JSAssign lhs rhs) = do-      lhs' <- optimizeConstructor' lhs-      rhs' <- optimizeConstructor' rhs-      return $ JSAssign lhs' rhs'--    optimizeConstructor' js = return js--collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]-collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]-  where-    generateSplitFunction :: (Int,JS) -> JS-    generateSplitFunction (depth, JSAlloc name fun) =-      JSAlloc (name ++ "$" ++ show depth) fun--splitFunction :: JS -> RWS () [(Int,JS)] Int JS-splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do-  body' <- splitSequence body-  return $ JSAlloc name (Just (JSFunction args body'))-    where-      splitCondition :: JS -> RWS () [(Int,JS)] Int JS-      splitCondition js-        | JSCond branches <- js =-            JSCond <$> processBranches branches-        | JSSwitch cond branches def <- js =-            JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)-        | otherwise = return js-        where-          processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]-          processBranches =-            traverse (runKleisli (arr id *** Kleisli splitSequence))--      splitSequence :: JS -> RWS () [(Int, JS)] Int JS-      splitSequence js@(JSSeq seq) =-        let (pre,post) = break isBranch seq in-            case post of-                 [_] -> JSSeq <$> traverse splitCondition seq-                 [call@(JSCond _),rest@(JSApp _ _)]     -> do-                   rest' <- splitCondition rest-                   call' <- splitCondition call-                   return $ JSSeq (pre ++ [rest', call'])-                 [call@(JSSwitch _ _ _),rest@(JSApp _ _)] -> do-                   rest' <- splitCondition rest-                   call' <- splitCondition call-                   return $ JSSeq (pre ++ [rest', call'])-                 (call:rest) -> do-                   depth <- get-                   put (depth + 1)-                   new <- splitFunction (newFun rest)-                   tell [(depth, new)]-                   call' <- splitCondition call-                   return $ JSSeq (pre ++ (newCall depth : [call']))-                 _ -> JSSeq <$> traverse splitCondition seq--      splitSequence js = return js--      isBranch :: JS -> Bool-      isBranch (JSApp (JSIdent "i$CALL") _) = True-      isBranch (JSCond _)                   = True-      isBranch (JSSwitch _ _ _)             = True-      isBranch _                            = False--      newCall :: Int -> JS-      newCall depth =-        JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth-                                 , JSArray [jsOLDBASE, jsMYOLDBASE]-                                 ]--      newFun :: [JS] -> JS-      newFun seq =-        JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))--splitFunction js = return js--translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]-translateDecl info (name@(MN 0 fun), bc)-  | txt "APPLY" == fun =-         allocCaseFunctions (snd body)-      ++ [ JSAlloc (-               translateName name-           ) (Just $ JSFunction ["oldbase"] (-               JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [-                 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")-                          , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]-                          )-                          , ( JSNoop-                            , JSSeq $ map (translateBC info) (defaultCase (snd body))-                            )-                        ]-               ]-             )-           )-         ]--  | txt "EVAL" == fun =-         allocCaseFunctions (snd body)-      ++ [ JSAlloc (-               translateName name-           ) (Just $ JSFunction ["oldbase"] (-               JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [-                 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")-                          , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]-                          )-                          , ( JSNoop-                            , JSSeq $ map (translateBC info) (defaultCase (snd body))-                            )-                        ]-               ]-             )-           )-         ]-  where-    body :: ([BC], [BC])-    body = break isCase bc--    isCase :: BC -> Bool-    isCase bc-      | CASE {} <- bc = True-      | otherwise          = False--    defaultCase :: [BC] -> [BC]-    defaultCase ((CASE _ _ _ (Just d)):_) = d--    caseReg :: [BC] -> Reg-    caseReg ((CASE _ r _ _):_) = r--    allocCaseFunctions :: [BC] -> [JS]-    allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c-    allocCaseFunctions _                  = []--    splitBranches :: [(Int, [BC])] -> [JS]-    splitBranches = map prepBranch--    prepBranch :: (Int, [BC]) -> JS-    prepBranch (tag, code) =-      JSAlloc (-        translateName name ++ "$" ++ show tag-      ) (Just $ JSFunction ["oldbase", "myoldbase"] (-          JSSeq $ map (translateBC info) code-        )-      )--translateDecl info (name, bc) =-  [ JSAlloc (-       translateName name-     ) (Just $ JSFunction ["oldbase"] (-         JSSeq $ jsFUNPRELUDE ++ map (translateBC info)bc-       )-     )-  ]--jsFUNPRELUDE :: [JS]-jsFUNPRELUDE = [jsALLOCMYOLDBASE]--jsALLOCMYOLDBASE :: JS-jsALLOCMYOLDBASE = JSAlloc "myoldbase" (Just $ JSNew "i$POINTER" [])--translateReg :: Reg -> JS-translateReg reg-  | RVal <- reg = jsRET-  | Tmp  <- reg = JSRaw "//TMPREG"-  | L n  <- reg = jsLOC n-  | T n  <- reg = jsTOP n--translateConstant :: Const -> JS-translateConstant (I i)                    = JSNum (JSInt i)-translateConstant (Fl f)                   = JSNum (JSFloat f)-translateConstant (Ch c)                   = JSString $ translateChar c-translateConstant (Str s)                  = JSString $ concatMap translateChar s-translateConstant (AType (ATInt ITNative)) = JSType JSIntTy-translateConstant StrType                  = JSType JSStringTy-translateConstant (AType (ATInt ITBig))    = JSType JSIntegerTy-translateConstant (AType ATFloat)          = JSType JSFloatTy-translateConstant (AType (ATInt ITChar))   = JSType JSCharTy-translateConstant Forgot                   = JSType JSForgotTy-translateConstant (BI 0)                   = JSNum (JSInteger JSBigZero)-translateConstant (BI 1)                   = JSNum (JSInteger JSBigOne)-translateConstant (BI i)                   = jsBigInt (JSString $ show i)-translateConstant (B8 b)                   = JSWord (JSWord8 b)-translateConstant (B16 b)                  = JSWord (JSWord16 b)-translateConstant (B32 b)                  = JSWord (JSWord32 b)-translateConstant (B64 b)                  = JSWord (JSWord64 b)-translateConstant c =-  JSError $ "Unimplemented Constant: " ++ show c---translateChar :: Char -> String-translateChar ch-  | '\a'   <- ch       = "\\u0007"-  | '\b'   <- ch       = "\\b"-  | '\f'   <- ch       = "\\f"-  | '\n'   <- ch       = "\\n"-  | '\r'   <- ch       = "\\r"-  | '\t'   <- ch       = "\\t"-  | '\v'   <- ch       = "\\v"-  | '\SO'  <- ch       = "\\u000E"-  | '\DEL' <- ch       = "\\u007F"-  | '\\'   <- ch       = "\\\\"-  | '\"'   <- ch       = "\\\""-  | '\''   <- ch       = "\\\'"-  | ch `elem` asciiTab = "\\u" ++ fill (showHex (ord ch) "")-  | ord ch > 255       = "\\u" ++ fill (showHex (ord ch) "")-  | otherwise          = [ch]-  where-    fill :: String -> String-    fill s = case length s of-                  1 -> "000" ++ s-                  2 -> "00"  ++ s-                  3 -> "0"   ++ s-                  _ ->          s--    asciiTab =-      ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',-       '\BS',  '\HT',  '\LF',  '\VT',  '\FF',  '\CR',  '\SO',  '\SI',-       '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',-       '\CAN', '\EM',  '\SUB', '\ESC', '\FS',  '\GS',  '\RS',  '\US']--translateName :: Name -> String-translateName n = "_idris_" ++ concatMap cchar (showCG n)-  where cchar x | isAlphaNum x = [x]-                | otherwise    = "_" ++ show (fromEnum x) ++ "_"--jsASSIGN :: CompileInfo -> Reg -> Reg -> JS-jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)--jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS-jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)--jsCALL :: CompileInfo -> Name -> JS-jsCALL _ n =-  JSApp (-    JSIdent "i$CALL"-  ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]--jsTAILCALL :: CompileInfo -> Name -> JS-jsTAILCALL _ n =-  JSApp (-    JSIdent "i$CALL"-  ) [JSIdent (translateName n), JSArray [jsOLDBASE]]--jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS-jsFOREIGN _ reg n args-  | n == "isNull"-  , [(FPtr, arg)] <- args =-      JSAssign (-        translateReg reg-      ) (-        JSBinOp "==" (translateReg arg) JSNull-      )--  | n == "idris_eqPtr"-  , [(_, lhs),(_, rhs)] <- args =-      JSAssign (-        translateReg reg-      ) (-        JSBinOp "==" (translateReg lhs) (translateReg rhs)-      )-  | otherwise =-     JSAssign (-       translateReg reg-     ) (-       JSFFI n (map generateWrapper args)-     )-    where-      generateWrapper :: (FType, Reg) -> JS-      generateWrapper (ty, reg)-        | FFunction   <- ty =-            JSApp (JSIdent "i$ffiWrap") [ translateReg reg-                                        , JSIdent "oldbase"-                                        , JSIdent "myoldbase"-                                        ]-        | FFunctionIO <- ty =-            JSApp (JSIdent "i$ffiWrap") [ translateReg reg-                                        , JSIdent "oldbase"-                                        , JSIdent "myoldbase"-                                        ]--      generateWrapper (_, reg) =-        translateReg reg--jsREBASE :: CompileInfo -> JS-jsREBASE _ = JSAssign jsSTACKBASE (JSProj jsOLDBASE "addr")--jsSTOREOLD :: CompileInfo ->JS-jsSTOREOLD _ = JSAssign (JSProj jsMYOLDBASE "addr") jsSTACKBASE--jsADDTOP :: CompileInfo -> Int -> JS-jsADDTOP info n-  | 0 <- n    = JSNoop-  | otherwise =-      JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))--jsTOPBASE :: CompileInfo -> Int -> JS-jsTOPBASE _ 0  = JSAssign jsSTACKTOP jsSTACKBASE-jsTOPBASE _ n  = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))---jsBASETOP :: CompileInfo -> Int -> JS-jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP-jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))--jsNULL :: CompileInfo -> Reg -> JS-jsNULL _ r = JSClear (translateReg r)--jsERROR :: CompileInfo -> String -> JS-jsERROR _ = JSError--jsSLIDE :: CompileInfo -> Int -> JS-jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)-jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]--jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS-jsMKCON info r t rs =-  JSAssign (translateReg r) (-    JSNew "i$CON" [ JSNum (JSInt t)-                  , JSArray (map translateReg rs)-                  , if t `elem` compileInfoApplyCases info-                       then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t-                       else JSNull-                  , if t `elem` compileInfoEvalCases info-                       then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t-                       else JSNull-                  ]-  )--jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS-jsCASE info safe reg cases def =-  JSSwitch (tag safe $ translateReg reg) (-    map ((JSNum . JSInt) *** prepBranch) cases-  ) (fmap prepBranch def)-    where-      tag :: Bool -> JS -> JS-      tag True  = jsCTAG-      tag False = jsTAG--      prepBranch :: [BC] -> JS-      prepBranch bc = JSSeq $ map (translateBC info) bc--      jsTAG :: JS -> JS-      jsTAG js =-        (JSTernary (js `jsInstanceOf` "i$CON") (-          JSProj js "tag"-        ) (JSNum (JSInt $ negate 1)))--      jsCTAG :: JS -> JS-      jsCTAG js = JSProj js "tag"---jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS-jsCONSTCASE info reg cases def =-  JSCond $ (-    map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases-  ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)-    where-      prepBranch :: [BC] -> JS-      prepBranch bc = JSSeq $ map (translateBC info) bc--jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS-jsPROJECT _ reg loc 0  = JSNoop-jsPROJECT _ reg loc 1  =-  JSAssign (jsLOC loc) (-    JSIndex (-      JSProj (translateReg reg) "args"-    ) (-      JSNum (JSInt 0)-    )-  )-jsPROJECT _ reg loc ar =-  JSApp (JSIdent "i$PROJECT") [ translateReg reg-                              , JSNum (JSInt loc)-                              , JSNum (JSInt ar)-                              ]--jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS-jsOP _ reg op args = JSAssign (translateReg reg) jsOP'-  where-    jsOP' :: JS-    jsOP'-      | LNoOp <- op = translateReg (last args)--      | LWriteStr <- op,-        (_:str:_) <- args = JSApp (JSIdent "i$putStr") [translateReg str]--      | LReadStr <- op  = JSApp (JSIdent "i$getLine") []--      | (LZExt (ITFixed IT8) ITNative)  <- op = jsUnPackBits $ translateReg (last args)-      | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)-      | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)--      | (LZExt _ ITBig)        <- op = jsBigInt $ JSApp  (JSIdent "String") [translateReg (last args)]-      | (LPlus (ATInt ITBig))  <- op-      , (lhs:rhs:_)            <- args = invokeMeth lhs "add" [rhs]-      | (LMinus (ATInt ITBig)) <- op-      , (lhs:rhs:_)            <- args = invokeMeth lhs "subtract" [rhs]-      | (LTimes (ATInt ITBig)) <- op-      , (lhs:rhs:_)            <- args = invokeMeth lhs "multiply" [rhs]-      | (LSDiv (ATInt ITBig))  <- op-      , (lhs:rhs:_)            <- args = invokeMeth lhs "divide" [rhs]-      | (LSRem (ATInt ITBig))  <- op-      , (lhs:rhs:_)            <- args = invokeMeth lhs "mod" [rhs]-      | (LEq (ATInt ITBig))    <- op-      , (lhs:rhs:_)            <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]-      | (LSLt (ATInt ITBig))   <- op-      , (lhs:rhs:_)            <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]-      | (LSLe (ATInt ITBig))   <- op-      , (lhs:rhs:_)            <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]-      | (LSGt (ATInt ITBig))   <- op-      , (lhs:rhs:_)            <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]-      | (LSGe (ATInt ITBig))   <- op-      , (lhs:rhs:_)            <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]--      | (LPlus ATFloat)  <- op-      , (lhs:rhs:_)      <- args = translateBinaryOp "+" lhs rhs-      | (LMinus ATFloat) <- op-      , (lhs:rhs:_)      <- args = translateBinaryOp "-" lhs rhs-      | (LTimes ATFloat) <- op-      , (lhs:rhs:_)      <- args = translateBinaryOp "*" lhs rhs-      | (LSDiv ATFloat)  <- op-      , (lhs:rhs:_)      <- args = translateBinaryOp "/" lhs rhs-      | (LEq ATFloat)    <- op-      , (lhs:rhs:_)      <- args = translateCompareOp "==" lhs rhs-      | (LSLt ATFloat)   <- op-      , (lhs:rhs:_)      <- args = translateCompareOp "<" lhs rhs-      | (LSLe ATFloat)   <- op-      , (lhs:rhs:_)      <- args = translateCompareOp "<=" lhs rhs-      | (LSGt ATFloat)   <- op-      , (lhs:rhs:_)      <- args = translateCompareOp ">" lhs rhs-      | (LSGe ATFloat)   <- op-      , (lhs:rhs:_)      <- args = translateCompareOp ">=" lhs rhs--      | (LPlus (ATInt ITChar)) <- op-      , (lhs:rhs:_)            <- args =-          jsCall "i$fromCharCode" [-            JSBinOp "+" (-              jsCall "i$charCode" [translateReg lhs]-            ) (-              jsCall "i$charCode" [translateReg rhs]-            )-          ]--      | (LTrunc (ITFixed _from) (ITFixed IT8)) <- op-      , (arg:_)                               <- args =-          jsPackUBits8 (-            JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))-          )--      | (LTrunc (ITFixed _from) (ITFixed IT16)) <- op-      , (arg:_)                                <- args =-          jsPackUBits16 (-            JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))-          )--      | (LTrunc (ITFixed _from) (ITFixed IT32)) <- op-      , (arg:_)                                <- args =-          jsPackUBits32 (-            jsMeth (jsMeth (translateReg arg) "and" [-              jsBigInt (JSString $ show 0xFFFFFFFF)-            ]) "intValue" []-          )--      | (LTrunc ITBig (ITFixed IT64)) <- op-      , (arg:_)                       <- args =-          jsMeth (translateReg arg) "and" [-            jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)-          ]--      | (LLSHR (ITFixed IT8)) <- op-      , (lhs:rhs:_)           <- args = jsPackUBits8 $ bitsBinaryOp ">>" lhs rhs--      | (LLSHR (ITFixed IT16)) <- op-      , (lhs:rhs:_)            <- args = jsPackUBits16 $ bitsBinaryOp ">>" lhs rhs--      | (LLSHR (ITFixed IT32)) <- op-      , (lhs:rhs:_)            <- args = jsPackUBits32 $ bitsBinaryOp ">>" lhs rhs--      | (LLSHR (ITFixed IT64)) <- op-      , (lhs:rhs:_)            <- args =-          jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]--      | (LSHL (ITFixed IT8)) <- op-      , (lhs:rhs:_)          <- args = jsPackUBits8 $ bitsBinaryOp "<<" lhs rhs--      | (LSHL (ITFixed IT16)) <- op-      , (lhs:rhs:_)           <- args = jsPackUBits16 $ bitsBinaryOp "<<" lhs rhs--      | (LSHL (ITFixed IT32)) <- op-      , (lhs:rhs:_)           <- args = jsPackUBits32 $ bitsBinaryOp "<<" lhs rhs--      | (LSHL (ITFixed IT64)) <- op-      , (lhs:rhs:_)           <- args =-          jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [-            jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)-          ]--      | (LAnd (ITFixed IT8)) <- op-      , (lhs:rhs:_)          <- args = jsPackUBits8 $ bitsBinaryOp "&" lhs rhs--      | (LAnd (ITFixed IT16)) <- op-      , (lhs:rhs:_)           <- args = jsPackUBits16 $ bitsBinaryOp "&" lhs rhs--      | (LAnd (ITFixed IT32)) <- op-      , (lhs:rhs:_)           <- args = jsPackUBits32 $ bitsBinaryOp "&" lhs rhs--      | (LAnd (ITFixed IT64)) <- op-      , (lhs:rhs:_)           <- args =-          jsMeth (translateReg lhs) "and" [translateReg rhs]--      | (LOr (ITFixed IT8)) <- op-      , (lhs:rhs:_)         <- args = jsPackUBits8 $ bitsBinaryOp "|" lhs rhs--      | (LOr (ITFixed IT16)) <- op-      , (lhs:rhs:_)          <- args = jsPackUBits16 $ bitsBinaryOp "|" lhs rhs--      | (LOr (ITFixed IT32)) <- op-      , (lhs:rhs:_)          <- args = jsPackUBits32 $ bitsBinaryOp "|" lhs rhs--      | (LOr (ITFixed IT64)) <- op-      , (lhs:rhs:_)          <- args =-          jsMeth (translateReg lhs) "or" [translateReg rhs]--      | (LXOr (ITFixed IT8)) <- op-      , (lhs:rhs:_)          <- args = jsPackUBits8 $ bitsBinaryOp "^" lhs rhs--      | (LXOr (ITFixed IT16)) <- op-      , (lhs:rhs:_)           <- args = jsPackUBits16 $ bitsBinaryOp "^" lhs rhs--      | (LXOr (ITFixed IT32)) <- op-      , (lhs:rhs:_)           <- args = jsPackUBits32 $ bitsBinaryOp "^" lhs rhs--      | (LXOr (ITFixed IT64)) <- op-      , (lhs:rhs:_)           <- args =-          jsMeth (translateReg lhs) "xor" [translateReg rhs]--      | (LPlus (ATInt (ITFixed IT8))) <- op-      , (lhs:rhs:_)                   <- args = jsPackUBits8 $ bitsBinaryOp "+" lhs rhs--      | (LPlus (ATInt (ITFixed IT16))) <- op-      , (lhs:rhs:_)                    <- args = jsPackUBits16 $ bitsBinaryOp "+" lhs rhs--      | (LPlus (ATInt (ITFixed IT32))) <- op-      , (lhs:rhs:_)                    <- args = jsPackUBits32 $ bitsBinaryOp "+" lhs rhs--      | (LPlus (ATInt (ITFixed IT64))) <- op-      , (lhs:rhs:_)                    <- args =-          jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [-            jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)-          ]--      | (LMinus (ATInt (ITFixed IT8))) <- op-      , (lhs:rhs:_)                    <- args = jsPackUBits8 $ bitsBinaryOp "-" lhs rhs--      | (LMinus (ATInt (ITFixed IT16))) <- op-      , (lhs:rhs:_)                     <- args = jsPackUBits16 $ bitsBinaryOp "-" lhs rhs--      | (LMinus (ATInt (ITFixed IT32))) <- op-      , (lhs:rhs:_)                     <- args = jsPackUBits32 $ bitsBinaryOp "-" lhs rhs--      | (LMinus (ATInt (ITFixed IT64))) <- op-      , (lhs:rhs:_)                     <- args =-          jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [-            jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)-          ]--      | (LTimes (ATInt (ITFixed IT8))) <- op-      , (lhs:rhs:_)                    <- args = jsPackUBits8 $ bitsBinaryOp "*" lhs rhs--      | (LTimes (ATInt (ITFixed IT16))) <- op-      , (lhs:rhs:_)                     <- args = jsPackUBits16 $ bitsBinaryOp "*" lhs rhs--      | (LTimes (ATInt (ITFixed IT32))) <- op-      , (lhs:rhs:_)                     <- args = jsPackUBits32 $ bitsBinaryOp "*" lhs rhs--      | (LTimes (ATInt (ITFixed IT64))) <- op-      , (lhs:rhs:_)                     <- args =-          jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [-            jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)-          ]--      | (LEq (ATInt (ITFixed IT8))) <- op-      , (lhs:rhs:_)                 <- args = bitsCompareOp "==" lhs rhs--      | (LEq (ATInt (ITFixed IT16))) <- op-      , (lhs:rhs:_)                  <- args = bitsCompareOp "==" lhs rhs--      | (LEq (ATInt (ITFixed IT32))) <- op-      , (lhs:rhs:_)                  <- args = bitsCompareOp "==" lhs rhs--      | (LEq (ATInt (ITFixed IT64))) <- op-      , (lhs:rhs:_)                  <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]--      | (LLt (ITFixed IT8)) <- op-      , (lhs:rhs:_)         <- args = bitsCompareOp "<" lhs rhs--      | (LLt (ITFixed IT16)) <- op-      , (lhs:rhs:_)          <- args = bitsCompareOp "<" lhs rhs--      | (LLt (ITFixed IT32)) <- op-      , (lhs:rhs:_)          <- args = bitsCompareOp "<" lhs rhs--      | (LLt (ITFixed IT64)) <- op-      , (lhs:rhs:_)          <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]--      | (LLe (ITFixed IT8)) <- op-      , (lhs:rhs:_)         <- args = bitsCompareOp "<=" lhs rhs--      | (LLe (ITFixed IT16)) <- op-      , (lhs:rhs:_)          <- args = bitsCompareOp "<=" lhs rhs--      | (LLe (ITFixed IT32)) <- op-      , (lhs:rhs:_)          <- args = bitsCompareOp "<=" lhs rhs--      | (LLe (ITFixed IT64)) <- op-      , (lhs:rhs:_)          <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]--      | (LGt (ITFixed IT8)) <- op-      , (lhs:rhs:_)         <- args = bitsCompareOp ">" lhs rhs--      | (LGt (ITFixed IT16)) <- op-      , (lhs:rhs:_)          <- args = bitsCompareOp ">" lhs rhs-      | (LGt (ITFixed IT32)) <- op-      , (lhs:rhs:_)          <- args = bitsCompareOp ">" lhs rhs--      | (LGt (ITFixed IT64)) <- op-      , (lhs:rhs:_)          <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]--      | (LGe (ITFixed IT8)) <- op-      , (lhs:rhs:_)         <- args = bitsCompareOp ">=" lhs rhs--      | (LGe (ITFixed IT16)) <- op-      , (lhs:rhs:_)          <- args = bitsCompareOp ">=" lhs rhs-      | (LGe (ITFixed IT32)) <- op-      , (lhs:rhs:_)          <- args = bitsCompareOp ">=" lhs rhs--      | (LGe (ITFixed IT64)) <- op-      , (lhs:rhs:_)          <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]--      | (LUDiv (ITFixed IT8)) <- op-      , (lhs:rhs:_)           <- args =-          jsPackUBits8 (-            JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))-          )--      | (LUDiv (ITFixed IT16)) <- op-      , (lhs:rhs:_)            <- args =-          jsPackUBits16 (-            JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))-          )--      | (LUDiv (ITFixed IT32)) <- op-      , (lhs:rhs:_)            <- args =-          jsPackUBits32 (-            JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))-          )--      | (LUDiv (ITFixed IT64)) <- op-      , (lhs:rhs:_)            <- args = invokeMeth lhs "divide" [rhs]--      | (LSDiv (ATInt (ITFixed IT8))) <- op-      , (lhs:rhs:_)                   <- args =-          jsPackSBits8 (-            JSBinOp "/" (-              jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)-            ) (-              jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)-            )-          )--      | (LSDiv (ATInt (ITFixed IT16))) <- op-      , (lhs:rhs:_)                    <- args =-          jsPackSBits16 (-            JSBinOp "/" (-              jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)-            ) (-              jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)-            )-          )--      | (LSDiv (ATInt (ITFixed IT32))) <- op-      , (lhs:rhs:_)                    <- args =-          jsPackSBits32 (-            JSBinOp "/" (-              jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)-            ) (-              jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)-            )-          )--      | (LSDiv (ATInt (ITFixed IT64))) <- op-      , (lhs:rhs:_)                    <- args = invokeMeth lhs "divide" [rhs]--      | (LSRem (ATInt (ITFixed IT8))) <- op-      , (lhs:rhs:_)                   <- args =-          jsPackSBits8 (-            JSBinOp "%" (-              jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)-            ) (-              jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)-            )-          )--      | (LSRem (ATInt (ITFixed IT16))) <- op-      , (lhs:rhs:_)                    <- args =-          jsPackSBits16 (-            JSBinOp "%" (-              jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)-            ) (-              jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)-            )-          )--      | (LSRem (ATInt (ITFixed IT32))) <- op-      , (lhs:rhs:_)                    <- args =-          jsPackSBits32 (-            JSBinOp "%" (-              jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)-            ) (-              jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)-            )-          )--      | (LSRem (ATInt (ITFixed IT64))) <- op-      , (lhs:rhs:_)                    <- args = invokeMeth lhs "mod" [rhs]--      | (LCompl (ITFixed IT8)) <- op-      , (arg:_)                <- args =-          jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)--      | (LCompl (ITFixed IT16)) <- op-      , (arg:_)                 <- args =-          jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)--      | (LCompl (ITFixed IT32)) <- op-      , (arg:_)                 <- args =-          jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)--      | (LCompl (ITFixed IT64)) <- op-      , (arg:_)                 <- args = invokeMeth arg "not" []--      | (LPlus _)   <- op-      , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs-      | (LMinus _)  <- op-      , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs-      | (LTimes _)  <- op-      , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs-      | (LSDiv _)   <- op-      , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs-      | (LSRem _)   <- op-      , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs-      | (LEq _)     <- op-      , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs-      | (LSLt _)    <- op-      , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs-      | (LSLe _)    <- op-      , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs-      | (LSGt _)    <- op-      , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs-      | (LSGe _)    <- op-      , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs-      | (LAnd _)    <- op-      , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs-      | (LOr _)     <- op-      , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs-      | (LXOr _)    <- op-      , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs-      | (LSHL _)    <- op-      , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs-      | (LASHR _)   <- op-      , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs-      | (LCompl _)  <- op-      , (arg:_)     <- args = JSPreOp "~" (translateReg arg)--      | LStrConcat  <- op-      , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs-      | LStrEq      <- op-      , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs-      | LStrLt      <- op-      , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs-      | LStrLen     <- op-      , (arg:_)     <- args = JSProj (translateReg arg) "length"-      | (LStrInt ITNative)      <- op-      , (arg:_)                 <- args = jsCall "parseInt" [translateReg arg]-      | (LIntStr ITNative)      <- op-      , (arg:_)                 <- args = jsCall "String" [translateReg arg]-      | (LSExt ITNative ITBig)  <- op-      , (arg:_)                 <- args = jsBigInt $ jsCall "String" [translateReg arg]-      | (LTrunc ITBig ITNative) <- op-      , (arg:_)                 <- args = jsMeth (translateReg arg) "intValue" []-      | (LIntStr ITBig)         <- op-      , (arg:_)                 <- args = jsMeth (translateReg arg) "toString" []-      | (LStrInt ITBig)         <- op-      , (arg:_)                 <- args = jsBigInt $ translateReg arg-      | LFloatStr               <- op-      , (arg:_)                 <- args = jsCall "String" [translateReg arg]-      | LStrFloat               <- op-      , (arg:_)                 <- args = jsCall "parseFloat" [translateReg arg]-      | (LIntFloat ITNative)    <- op-      , (arg:_)                 <- args = translateReg arg-      | (LIntFloat ITBig)       <- op-      , (arg:_)                 <- args = jsMeth (translateReg arg) "intValue" []-      | (LFloatInt ITNative)    <- op-      , (arg:_)                 <- args = translateReg arg-      | (LChInt ITNative)       <- op-      , (arg:_)                 <- args = jsCall "i$charCode" [translateReg arg]-      | (LIntCh ITNative)       <- op-      , (arg:_)                 <- args = jsCall "i$fromCharCode" [translateReg arg]--      | LFExp       <- op-      , (arg:_)     <- args = jsCall "Math.exp" [translateReg arg]-      | LFLog       <- op-      , (arg:_)     <- args = jsCall "Math.log" [translateReg arg]-      | LFSin       <- op-      , (arg:_)     <- args = jsCall "Math.sin" [translateReg arg]-      | LFCos       <- op-      , (arg:_)     <- args = jsCall "Math.cos" [translateReg arg]-      | LFTan       <- op-      , (arg:_)     <- args = jsCall "Math.tan" [translateReg arg]-      | LFASin      <- op-      , (arg:_)     <- args = jsCall "Math.asin" [translateReg arg]-      | LFACos      <- op-      , (arg:_)     <- args = jsCall "Math.acos" [translateReg arg]-      | LFATan      <- op-      , (arg:_)     <- args = jsCall "Math.atan" [translateReg arg]-      | LFSqrt      <- op-      , (arg:_)     <- args = jsCall "Math.sqrt" [translateReg arg]-      | LFFloor     <- op-      , (arg:_)     <- args = jsCall "Math.floor" [translateReg arg]-      | LFCeil      <- op-      , (arg:_)     <- args = jsCall "Math.ceil" [translateReg arg]-      | LFNegate    <- op-      , (arg:_)     <- args = JSPreOp "-" (translateReg arg)--      | LStrCons    <- op-      , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]-      | LStrHead    <- op-      , (arg:_)     <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))-      | LStrRev     <- op-      , (arg:_)     <- args = JSProj (translateReg arg) "split('').reverse().join('')"-      | LStrIndex   <- op-      , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)-      | LStrTail    <- op-      , (arg:_)     <- args =-          let v = translateReg arg in-              JSApp (JSProj v "substr") [-                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]-      | LExternal nul <- op-      , nul == sUN "prim__null"-      , _ <- args = JSNull-      | LExternal ex <- op-      , ex == sUN "prim__eqPtr"-      , [lhs, rhs] <- args = translateCompareOp "==" lhs rhs-      | otherwise = JSError $ "Not implemented: " ++ show op-        where-          translateBinaryOp :: String -> Reg -> Reg -> JS-          translateBinaryOp op lhs rhs =-            JSBinOp op (translateReg lhs) (translateReg rhs)--          translateCompareOp :: String -> Reg -> Reg -> JS-          translateCompareOp op lhs rhs =-            JSPreOp "+" $ translateBinaryOp op lhs rhs--          bitsBinaryOp :: String -> Reg -> Reg -> JS-          bitsBinaryOp op lhs rhs =-            JSBinOp op (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))--          bitsCompareOp :: String -> Reg -> Reg -> JS-          bitsCompareOp op lhs rhs =-            JSPreOp "+" $ bitsBinaryOp op lhs rhs--          invokeMeth :: Reg -> String -> [Reg] -> JS-          invokeMeth obj meth args =-            JSApp (JSProj (translateReg obj) meth) $ map translateReg args---jsRESERVE :: CompileInfo -> Int -> JS-jsRESERVE _ _ = JSNoop--jsSTACK :: JS-jsSTACK = JSIdent "i$valstack"--jsCALLSTACK :: JS-jsCALLSTACK = JSIdent "i$callstack"--jsSTACKBASE :: JS-jsSTACKBASE = JSIdent "i$valstack_base"--jsSTACKTOP :: JS-jsSTACKTOP = JSIdent "i$valstack_top"--jsOLDBASE :: JS-jsOLDBASE = JSIdent "oldbase"--jsMYOLDBASE :: JS-jsMYOLDBASE = JSIdent "myoldbase"--jsRET :: JS-jsRET = JSIdent "i$ret"--jsLOC :: Int -> JS-jsLOC 0 = JSIndex jsSTACK jsSTACKBASE-jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))--jsTOP :: Int -> JS-jsTOP 0 = JSIndex jsSTACK jsSTACKTOP-jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))--jsPUSH :: [JS] -> JS-jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args--jsPOP :: JS-jsPOP = JSApp (JSProj jsCALLSTACK "pop") []--genInterface :: Export -> JS-genInterface (ExportData name) = JSNoop-genInterface (ExportFun name (FStr jsName) ret args) = JSAlloc jsName-        (Just (JSFunction [] (JSSeq  $-            jsFUNPRELUDE ++-            pushArgs nargs ++-            [jsSTOREOLD d,-             jsBASETOP d 0,-             jsADDTOP d nargs,-             jsCALL d name] ++-            retval ret)))-    where-        nargs = length args-        d = CompileInfo [] [] False-        pushArg n = JSAssign (jsTOP n) (JSIndex (JSIdent "arguments") (JSNum (JSInt n)))-        pushArgs 0 = []-        pushArgs n = (pushArg (n-1)):pushArgs (n-1)-        retval (FIO t) = [JSApp (JSIdent "i$RUN") [],-                          JSAssign (jsTOP 0) JSNull,-                          JSAssign (jsTOP 1) JSNull,-                          JSAssign (jsTOP 2) (translateReg RVal),-                          jsSTOREOLD d,-                          jsBASETOP d 0,-                          jsADDTOP d 3,-                          jsCALL d (sUN "call__IO")] ++ retval t-        retval t = [JSApp (JSIdent "i$RUN") [], JSReturn (translateReg RVal)]--translateBC :: CompileInfo -> BC -> JS-translateBC info bc-  | ASSIGN r1 r2          <- bc = jsASSIGN info r1 r2-  | ASSIGNCONST r c       <- bc = jsASSIGNCONST info r c-  | UPDATE r1 r2          <- bc = jsASSIGN info r1 r2-  | ADDTOP n              <- bc = jsADDTOP info n-  | NULL r                <- bc = jsNULL info r-  | CALL n                <- bc = jsCALL info n-  | TAILCALL n            <- bc = jsTAILCALL info n-  | FOREIGNCALL r _ (FStr n) args-                          <- bc = jsFOREIGN info r n (map fcall args)-  | FOREIGNCALL _ _ _ _   <- bc = error "JS FFI call not statically known"-  | TOPBASE n             <- bc = jsTOPBASE info n-  | BASETOP n             <- bc = jsBASETOP info n-  | STOREOLD              <- bc = jsSTOREOLD info-  | SLIDE n               <- bc = jsSLIDE info n-  | REBASE                <- bc = jsREBASE info-  | RESERVE n             <- bc = jsRESERVE info n-  | MKCON r _ t rs        <- bc = jsMKCON info r t rs-  | CASE s r c d          <- bc = jsCASE info s r c d-  | CONSTCASE r c d       <- bc = jsCONSTCASE info r c d-  | PROJECT r l a         <- bc = jsPROJECT info r l a-  | OP r o a              <- bc = jsOP info r o a-  | ERROR e               <- bc = jsERROR info e-  | otherwise                   = JSRaw $ "//" ++ show bc- where fcall (t, arg) = (toFType t, arg)--toAType (FCon i)-    | i == sUN "JS_IntChar" = ATInt ITChar-    | i == sUN "JS_IntNative" = ATInt ITNative-toAType t = error (show t ++ " not defined in toAType")--toFnType (FApp c [_,_,s,t])-    | c == sUN "JS_Fn" = toFnType t-toFnType (FApp c [_,_,r])-    | c == sUN "JS_FnIO" = FFunctionIO-toFnType (FApp c [_,r])-    | c == sUN "JS_FnBase" = FFunction-toFnType t = error (show t ++ " not defined in toFnType")--toFType (FCon c)-    | c == sUN "JS_Str" = FString-    | c == sUN "JS_Float" = FArith ATFloat-    | c == sUN "JS_Ptr" = FPtr-    | c == sUN "JS_Unit" = FUnit-toFType (FApp c [_,ity])-    | c == sUN "JS_IntT" = FArith (toAType ity)-toFType (FApp c [_,fty])-    | c == sUN "JS_FnT" = toFnType fty-toFType t = error (show t ++ " not yet defined in toFType")+import Data.Char+import Data.Text (Text)+import qualified Data.Text as T+import IRTS.CodegenCommon+import IRTS.JavaScript.Codegen+import System.Directory+import System.FilePath+++data JSTarget = Node | JavaScript deriving Eq+++htmlHeader :: Text+htmlHeader =+  T.concat [ "<html>\n"+           , " <head>\n"+           , "  <meta charset='utf-8'>\n"+           , " </head>\n"+           , " <body>\n"+           , "  <script type='text/javascript'>\n"+           ]++htmlFooter :: Text+htmlFooter =+  T.concat [ "\n  </script>\n"+           , " </body>\n"+           , "</html>"+           ]++codegenJavaScript :: CodeGenerator+codegenJavaScript ci =+  let (h, f) = if (map toLower $ takeExtension $ outputFile ci) == ".html" then+                  (htmlHeader, htmlFooter)+                  else ("","")+  in codegenJs (CGConf { header = h+                       , footer = f+                       , jsbnPath = "jsbn/jsbn-browser.js"+                       , extraRunTime = "Runtime-javascript.js"+                       }+               )+               ci++codegenNode :: CodeGenerator+codegenNode ci =+  do+    codegenJs (CGConf { header = "#!/usr/bin/env node\n"+                      , footer = ""+                      , jsbnPath = "jsbn/jsbn-browser.js"+                      , extraRunTime = "Runtime-node.js"+                      }+              )+              ci+    setPermissions (outputFile ci) (emptyPermissions { readable   = True+                                                     , executable = True+                                                     , writable   = True+                                                     })
src/IRTS/Compiler.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE CPP, PatternGuards, TypeSynonymInstances #-}+{-# LANGUAGE CPP, FlexibleContexts, PatternGuards, TypeSynonymInstances #-}  module IRTS.Compiler(compile, generate) where @@ -17,6 +17,7 @@ import Idris.Core.TT import Idris.Erasure import Idris.Error+import Idris.Options import Idris.Output import IRTS.CodegenC import IRTS.CodegenCommon
src/IRTS/Defunctionalise.hs view
@@ -19,7 +19,7 @@ 8. Add explicit EVAL to case, primitives, and foreign calls  -}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts, PatternGuards #-} module IRTS.Defunctionalise(module IRTS.Defunctionalise                           , module IRTS.Lang                           ) where
src/IRTS/JavaScript/AST.hs view
@@ -1,409 +1,285 @@ {-| Module      : IRTS.JavaScript.AST-Description : Data structures and functions used with the JavaScript codegen.+Description : The JavaScript AST. Copyright   : License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE OverloadedStrings, PatternGuards #-}-module IRTS.JavaScript.AST where -import Data.Char (isDigit)-import qualified Data.Text as T-import Data.Word--data JSType = JSIntTy-            | JSStringTy-            | JSIntegerTy-            | JSFloatTy-            | JSCharTy-            | JSPtrTy-            | JSForgotTy-            deriving Eq---data JSInteger = JSBigZero-               | JSBigOne-               | JSBigInt Integer-               | JSBigIntExpr JS-               deriving Eq---data JSNum = JSInt Int-           | JSFloat Double-           | JSInteger JSInteger-           deriving Eq---data JSWord = JSWord8 Word8-            | JSWord16 Word16-            | JSWord32 Word32-            | JSWord64 Word64-            deriving Eq---data JSAnnotation = JSConstructor deriving Eq---instance Show JSAnnotation where-  show JSConstructor = "constructor"+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, PatternGuards #-} +module IRTS.JavaScript.AST+  ( JsExpr(..)+  , JsStmt(..)+  , jsAst2Text+  , jsStmt2Text+  , jsLazy+  , jsCurryLam+  , jsCurryApp+  , jsAppN+  , jsExpr2Stmt+  , jsStmt2Expr+  , jsSetVar+  ) where -data JS = JSRaw String-        | JSIdent String-        | JSFunction [String] JS-        | JSType JSType-        | JSSeq [JS]-        | JSReturn JS-        | JSApp JS [JS]-        | JSNew String [JS]-        | JSError String-        | JSBinOp String JS JS-        | JSPreOp String JS-        | JSPostOp String JS-        | JSProj JS String-        | JSNull-        | JSUndefined-        | JSThis-        | JSTrue-        | JSFalse-        | JSArray [JS]-        | JSString String-        | JSNum JSNum-        | JSWord JSWord-        | JSAssign JS JS-        | JSAlloc String (Maybe JS)-        | JSIndex JS JS-        | JSSwitch JS [(JS, JS)] (Maybe JS)-        | JSCond [(JS, JS)]-        | JSTernary JS JS JS-        | JSParens JS-        | JSWhile JS JS-        | JSFFI String [JS]-        | JSAnnotation JSAnnotation JS-        | JSDelete JS-        | JSClear JS-        | JSNoop-        deriving Eq+import Data.Char+import Data.Data+import Data.Text (Text)+import qualified Data.Text as T+import Numeric +data JsStmt+  = JsEmpty+  | JsComment Text+  | JsExprStmt JsExpr+  | JsFun Text+          [Text]+          JsStmt+  | JsSeq JsStmt+          JsStmt+  | JsReturn JsExpr+  | JsDecVar Text+             JsExpr+  | JsDecConst Text+               JsExpr+  | JsDecLet Text+             JsExpr+  | JsSet JsExpr+          JsExpr+  | JsIf JsExpr+         JsStmt+         (Maybe JsStmt)+  | JsSwitchCase JsExpr+                 [(JsExpr, JsStmt)]+                 (Maybe JsStmt)+  | JsError JsExpr+  | JsForever JsStmt+  | JsContinue+  | JsBreak+  deriving (Show, Eq, Data, Typeable) -data FFI = FFICode Char | FFIArg Int | FFIError String+data JsExpr+  = JsNull+  | JsUndefined+  | JsThis+  | JsLambda [Text]+             JsStmt+  | JsApp JsExpr+          [JsExpr]+  | JsNew JsExpr+          [JsExpr]+  | JsPart JsExpr+           Text+  | JsMethod JsExpr+             Text+             [JsExpr]+  | JsVar Text+  | JsArrayProj JsExpr+                JsExpr+  | JsObj [(Text, JsExpr)]+  | JsProp JsExpr+           Text+  | JsInt Int+  | JsBool Bool+  | JsInteger Integer+  | JsDouble Double+  | JsStr String+  | JsArray [JsExpr]+  | JsErrorExp JsExpr+  | JsUniOp Text+            JsExpr+  | JsBinOp Text+            JsExpr+            JsExpr+  | JsForeign Text+              [JsExpr]+  | JsB2I JsExpr+  | JsForce JsExpr+  deriving (Show, Eq, Data, Typeable) -ffi :: String -> [String] -> T.Text-ffi code args = let parsed = ffiParse code in-                    case ffiError parsed of-                         Just err -> error err-                         Nothing  -> renderFFI parsed args+translateChar :: Char -> String+translateChar ch+  | '\b'   <- ch       = "\\b"+  | '\f'   <- ch       = "\\f"+  | '\n'   <- ch       = "\\n"+  | '\r'   <- ch       = "\\r"+  | '\t'   <- ch       = "\\t"+  | '\v'   <- ch       = "\\v"+  | '\\'   <- ch       = "\\\\"+  | '\"'   <- ch       = "\\\""+  | '\''   <- ch       = "\\\'"+  | ord ch < 0x20      = "\\x" ++ pad 2 (showHex (ord ch) "")+  | ord ch < 0x7f      = [ch]  -- 0x7f '\DEL'+  | ord ch <= 0xff     = "\\x" ++ pad 2 (showHex (ord ch) "")+  | ord ch <= 0xffff   = "\\u" ++ pad 4 (showHex (ord ch) "")+  | ord ch <= 0x10ffff = "\\u{" ++ showHex (ord ch) "}"+  | otherwise          = error $ "Invalid Unicode code point U+" ++ showHex (ord ch) ""   where-    ffiParse :: String -> [FFI]-    ffiParse ""           = []-    ffiParse ['%']        = [FFIError "FFI - Invalid positional argument"]-    ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss-    ffiParse ('%':s:ss)-      | isDigit s =-         FFIArg (-           read $ s : takeWhile isDigit ss-          ) : ffiParse (dropWhile isDigit ss)-      | otherwise =-          [FFIError "FFI - Invalid positional argument"]-    ffiParse (s:ss) = FFICode s : ffiParse ss---    ffiError :: [FFI] -> Maybe String-    ffiError []                 = Nothing-    ffiError ((FFIError s):xs)  = Just s-    ffiError (x:xs)             = ffiError xs---    renderFFI :: [FFI] -> [String] -> T.Text-    renderFFI [] _ = ""-    renderFFI (FFICode c : fs) args = c `T.cons` renderFFI fs args-    renderFFI (FFIArg i : fs) args-      | i < length args && i >= 0 =-            T.pack (args !! i)-          `T.append` renderFFI fs args-      | otherwise = error "FFI - Argument index out of bounds"--compileJS :: JS -> T.Text-compileJS = compileJS' 0--compileJS' :: Int -> JS -> T.Text-compileJS' indent JSNoop = ""--compileJS' indent (JSAnnotation annotation js) =-    "/** @"-  `T.append` T.pack (show annotation)-  `T.append` " */\n"-  `T.append` compileJS' indent js--compileJS' indent (JSDelete js) =-  "delete " `T.append` compileJS' 0 js--compileJS' indent (JSClear js) =-   compileJS' 0 js `T.append` " = undefined"--compileJS' indent (JSFFI raw args) =-  ffi raw (map (T.unpack . compileJS' indent) args)--compileJS' indent (JSRaw code) =-  T.pack code--compileJS' indent (JSIdent ident) =-  T.pack ident--compileJS' indent (JSFunction args body) =-      T.replicate indent " " `T.append` "function("-   `T.append` T.intercalate "," (map T.pack args)-   `T.append` "){\n"-   `T.append` compileJS' (indent + 2) body-   `T.append` "\n}\n"--compileJS' indent (JSType ty)-  | JSIntTy     <- ty = "i$Int"-  | JSStringTy  <- ty = "i$String"-  | JSIntegerTy <- ty = "i$Integer"-  | JSFloatTy   <- ty = "i$Float"-  | JSCharTy    <- ty = "i$Char"-  | JSPtrTy     <- ty = "i$Ptr"-  | JSForgotTy  <- ty = "i$Forgot"--compileJS' indent (JSSeq seq) =-  T.intercalate ";\n" (-    map (-      (T.replicate indent " " `T.append`) . (compileJS' indent)-    ) $ filter (/= JSNoop) seq-  ) `T.append` ";"--compileJS' indent (JSReturn val) =-  "return " `T.append` compileJS' indent val--compileJS' indent (JSApp lhs rhs)-  | JSFunction {} <- lhs =-    T.concat ["(", compileJS' indent lhs, ")(", args, ")"]-  | otherwise =-    T.concat [compileJS' indent lhs, "(", args, ")"]-  where args :: T.Text-        args = T.intercalate "," $ map (compileJS' 0) rhs--compileJS' indent (JSNew name args) =-    "new "-  `T.append` T.pack name-  `T.append` "("-  `T.append` T.intercalate "," (map (compileJS' 0) args)-  `T.append` ")"--compileJS' indent (JSError exc) =-  "(function(){throw new Error(\"" `T.append` T.pack exc `T.append` "\")})()"--compileJS' indent (JSBinOp op lhs rhs) =-    compileJS' indent lhs-  `T.append` " "-  `T.append` T.pack op-  `T.append` " "-  `T.append` compileJS' indent rhs--compileJS' indent (JSPreOp op val) =-  T.pack op `T.append` "(" `T.append` compileJS' indent val `T.append` ")"--compileJS' indent (JSProj obj field)-  | JSFunction {} <- obj =-    T.concat ["(", compileJS' indent obj, ").", T.pack field]-  | JSAssign {} <- obj =-    T.concat ["(", compileJS' indent obj, ").", T.pack field]-  | otherwise =-    compileJS' indent obj `T.append` ('.' `T.cons` T.pack field)--compileJS' indent JSNull =-  "null"--compileJS' indent JSUndefined =-  "undefined"--compileJS' indent JSThis =-  "this"--compileJS' indent JSTrue =-  "true"--compileJS' indent JSFalse =-  "false"--compileJS' indent (JSArray elems) =-  "[" `T.append` T.intercalate "," (map (compileJS' 0) elems) `T.append` "]"--compileJS' indent (JSString str) =-  "\"" `T.append` T.pack str `T.append` "\""--compileJS' indent (JSNum num)-  | JSInt i                    <- num = T.pack (show i)-  | JSFloat f                  <- num = T.pack (show f)-  | JSInteger JSBigZero        <- num = T.pack "i$ZERO"-  | JSInteger JSBigOne         <- num = T.pack "i$ONE"-  | JSInteger (JSBigInt i)     <- num = T.pack (show i)-  | JSInteger (JSBigIntExpr e) <- num =-      "i$bigInt(" `T.append` compileJS' indent e `T.append` ")"--compileJS' indent (JSAssign lhs rhs) =-  compileJS' indent lhs `T.append` " = " `T.append` compileJS' indent rhs+    pad :: Int -> String -> String+    pad n s = replicate (n - length s) '0' ++ s -compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =-    "var "-  `T.append` T.pack name-  `T.append` " = "-  `T.append` compileJS' 0 val-  `T.append` ";\n"+indent :: Text -> Text+indent x =+  let l = T.lines x+      il = map (\y -> T.replicate 4 " " `T.append` y) l+  in T.unlines il -compileJS' indent (JSAlloc name val) =-    "var "-  `T.append` T.pack name-  `T.append` maybe "" ((" = " `T.append`) . compileJS' indent) val+jsCurryLam :: [Text] -> JsExpr -> JsExpr+jsCurryLam [] body = body+jsCurryLam (x:xs) body = JsLambda [x] $ JsReturn $ jsCurryLam xs body -compileJS' indent (JSIndex lhs rhs) =-    compileJS' indent lhs-  `T.append` "["-  `T.append` compileJS' indent rhs-  `T.append` "]"+jsCurryApp :: JsExpr -> [JsExpr] -> JsExpr+jsCurryApp fn [] = fn+jsCurryApp fn args = foldl (\ff aa -> JsApp ff [aa]) fn args -compileJS' indent (JSCond branches) =-  T.intercalate " else " $ map createIfBlock branches-  where-    createIfBlock (JSNoop, e@(JSSeq _)) =-         "{\n"-      `T.append` compileJS' (indent + 2) e-      `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"-    createIfBlock (JSNoop, e) =-         "{\n"-      `T.append` compileJS' (indent + 2) e-      `T.append` ";\n" `T.append` T.replicate indent " " `T.append` "}"-    createIfBlock (cond, e@(JSSeq _)) =-         "if (" `T.append` compileJS' indent cond `T.append`") {\n"-      `T.append` compileJS' (indent + 2) e-      `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"-    createIfBlock (cond, e) =-         "if (" `T.append` compileJS' indent cond `T.append`") {\n"-      `T.append` T.replicate (indent + 2) " "-      `T.append` compileJS' (indent + 2) e-      `T.append` ";\n"-      `T.append` T.replicate indent " "-      `T.append` "}"+jsAppN :: Text -> [JsExpr] -> JsExpr+jsAppN fn args = JsApp (JsVar fn) args -compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =-  let (h,t) = splitAt 1 seq in-         (T.concat (map (compileJS' indent) h) `T.append` ";\n")-      `T.append` (-        T.intercalate ";\n" $ map (-          (T.replicate indent " " `T.append`) . compileJS' indent-        ) t-      )+jsSetVar :: Text -> JsExpr -> JsStmt+jsSetVar n x = JsSet (JsVar n) x -compileJS' indent (JSSwitch val branches def) =-     "switch(" `T.append` compileJS' indent val `T.append` "){\n"-  `T.append` T.concat (map mkBranch branches)-  `T.append` mkDefault def-  `T.append` T.replicate indent " " `T.append` "}"+jsStmt2Text :: JsStmt -> Text+jsStmt2Text JsEmpty = ""+jsStmt2Text (JsComment c) = T.unlines $ map ("// " `T.append`) $ T.lines c+jsStmt2Text (JsExprStmt e) = T.concat [jsAst2Text e, ";"]+jsStmt2Text (JsReturn x) = T.concat ["return ", jsAst2Text x, ";"]+jsStmt2Text (JsDecVar name exp) =+  T.concat ["var ", name, " = ", jsAst2Text exp, ";"]+jsStmt2Text (JsDecConst name exp) =+  T.concat ["const ", name, " = ", jsAst2Text exp, ";"]+jsStmt2Text (JsDecLet name exp) =+  T.concat ["let ", name, " = ", jsAst2Text exp, ";"]+jsStmt2Text (JsFun name args body) =+  T.concat+    [ "function "+    , name+    , "("+    , T.intercalate ", " args+    , "){\n"+    , indent $ jsStmt2Text body+    , "}\n"+    ]+jsStmt2Text (JsIf cond conseq (Just next@(JsIf _ _ _))) =+  T.concat+    [ "if("+    , jsAst2Text cond+    , ") {\n"+    , indent $ jsStmt2Text conseq+    , "} else "+    , jsStmt2Text next+    ]+jsStmt2Text (JsIf cond conseq (Just alt)) =+  T.concat+    [ "if("+    , jsAst2Text cond+    , ") {\n"+    , indent $ jsStmt2Text conseq+    , "} else {\n"+    , indent $ jsStmt2Text alt+    , "}\n"+    ]+jsStmt2Text (JsIf cond conseq Nothing) =+  T.concat ["if(", jsAst2Text cond, ") {\n", indent $ jsStmt2Text conseq, "}\n"]+jsStmt2Text (JsSwitchCase exp l d) =+  T.concat+    [ "switch("+    , jsAst2Text exp+    , "){\n"+    , indent $ T.concat $ map case2Text l+    , indent $ default2Text d+    , "}\n"+    ]   where-    mkBranch :: (JS, JS) -> T.Text-    mkBranch (tag, code) =-         T.replicate (indent + 2) " "-      `T.append` "case "-      `T.append` compileJS' indent tag-      `T.append` ":\n"-      `T.append` compileJS' (indent + 4) code-      `T.append` "\n"-      `T.append` (T.replicate (indent + 4) " " `T.append` "break;\n")--    mkDefault :: Maybe JS -> T.Text-    mkDefault Nothing = ""-    mkDefault (Just def) =-         T.replicate (indent + 2) " " `T.append` "default:\n"-      `T.append` compileJS' (indent + 4)def-      `T.append` "\n"---compileJS' indent (JSTernary cond true false) =-  let c = compileJS' indent cond-      t = compileJS' indent true-      f = compileJS' indent false in-        "("-      `T.append` c-      `T.append` ")?("-      `T.append` t-      `T.append` "):("-      `T.append` f-      `T.append` ")"--compileJS' indent (JSParens js) =-  "(" `T.append` compileJS' indent js `T.append` ")"--compileJS' indent (JSWhile cond body) =-     "while (" `T.append` compileJS' indent cond `T.append` ") {\n"-  `T.append` compileJS' (indent + 2) body-  `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"--compileJS' indent (JSWord word)-  | JSWord8  b <- word =-      "new Uint8Array([" `T.append` T.pack (show b) `T.append` "])"-  | JSWord16 b <- word =-      "new Uint16Array([" `T.append` T.pack (show b) `T.append` "])"-  | JSWord32 b <- word =-      "new Uint32Array([" `T.append` T.pack (show b) `T.append` "])"-  | JSWord64 b <- word =-      "i$bigInt(\"" `T.append` T.pack (show b) `T.append` "\")"--jsInstanceOf :: JS -> String -> JS-jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)--jsOr :: JS -> JS -> JS-jsOr lhs rhs = JSBinOp "||" lhs rhs--jsAnd :: JS -> JS -> JS-jsAnd lhs rhs = JSBinOp "&&" lhs rhs--jsMeth :: JS -> String -> [JS] -> JS-jsMeth obj meth args = JSApp (JSProj obj meth) args--jsCall :: String -> [JS] -> JS-jsCall fun args = JSApp (JSIdent fun) args--jsTypeOf :: JS -> JS-jsTypeOf js = JSPreOp "typeof " js--jsEq :: JS -> JS -> JS-jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]-jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]-jsEq lhs rhs = JSBinOp "==" lhs rhs--jsNotEq :: JS -> JS -> JS-jsNotEq lhs rhs = JSBinOp "!=" lhs rhs--jsIsNumber :: JS -> JS-jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")--jsIsNull :: JS -> JS-jsIsNull js = JSBinOp "==" js JSNull--jsBigInt :: JS -> JS-jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)-jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)-jsBigInt js             = JSNum $ JSInteger $ JSBigIntExpr js--jsUnPackBits :: JS -> JS-jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)--jsPackUBits8 :: JS -> JS-jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]--jsPackUBits16 :: JS -> JS-jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]+    case2Text :: (JsExpr, JsStmt) -> Text+    case2Text (x, y) =+      T.concat+        [ "case "+        , jsAst2Text x+        , ":\n"+        , indent $ T.concat [jsStmt2Text y, ";\nbreak;\n"]+        ]+    default2Text :: Maybe JsStmt -> Text+    default2Text Nothing = ""+    default2Text (Just z) =+      T.concat ["default:\n", indent $ T.concat [jsStmt2Text z, ";\nbreak;\n"]]+jsStmt2Text (JsError t) = T.concat ["throw new Error(  ", jsAst2Text t, ");"]+jsStmt2Text (JsForever x) =+  T.concat ["for(;;) {\n", indent $ jsStmt2Text x, "}\n"]+jsStmt2Text JsContinue = "continue;"+jsStmt2Text JsBreak = "break;"+jsStmt2Text (JsSeq JsEmpty y) = jsStmt2Text y+jsStmt2Text (JsSeq x JsEmpty) = jsStmt2Text x+jsStmt2Text (JsSeq x y) = T.concat [jsStmt2Text x, "\n", jsStmt2Text y]+jsStmt2Text (JsSet term exp) =+  T.concat [jsAst2Text term, " = ", jsAst2Text exp, ";"] -jsPackUBits32 :: JS -> JS-jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]+jsAst2Text :: JsExpr -> Text+jsAst2Text JsNull = "null"+jsAst2Text JsUndefined = "(void 0)"+jsAst2Text JsThis = "this"+jsAst2Text (JsLambda args body) =+  T.concat+    [ "(function"+    , "("+    , T.intercalate ", " args+    , "){\n"+    , indent $ jsStmt2Text body+    , "})"+    ]+jsAst2Text (JsApp fn args) =+  T.concat [jsAst2Text fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"]+jsAst2Text (JsNew fn args) =+  T.concat ["new ", jsAst2Text fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"]+jsAst2Text (JsMethod obj name args) =+  T.concat+    [ jsAst2Text obj+    , "."+    , name+    , "("+    , T.intercalate ", " $ map jsAst2Text args+    , ")"+    ]+jsAst2Text (JsPart obj name) =+  T.concat [jsAst2Text obj, "[", T.pack (show name), "]"]+jsAst2Text (JsVar x) = x+jsAst2Text (JsObj props) =+  T.concat+    [ "({"+    , T.intercalate+        ", "+        (map (\(name, val) -> T.concat [name, ": ", jsAst2Text val]) props)+    , "})"+    ]+jsAst2Text (JsProp object name) = T.concat [jsAst2Text object, ".", name]+jsAst2Text (JsArrayProj i exp) =+  T.concat [jsAst2Text exp, "[", jsAst2Text i, "]"]+jsAst2Text (JsInt i) = T.pack $ show i+jsAst2Text (JsBool True) = T.pack "true"+jsAst2Text (JsBool False) = T.pack "false"+jsAst2Text (JsDouble d) = T.pack $ show d+jsAst2Text (JsInteger i) = T.pack $ show i+jsAst2Text (JsStr s) =   "\"" `T.append` T.pack (concatMap translateChar s) `T.append` "\""+jsAst2Text (JsArray l) =+  T.concat ["[", T.intercalate ", " (map jsAst2Text l), "]"]+jsAst2Text (JsErrorExp t) =+  T.concat ["$JSRTS.throw(new Error(  ", jsAst2Text t, "))"]+jsAst2Text (JsBinOp op a1 a2) =+  T.concat ["(", jsAst2Text a1, " ", op, " ", jsAst2Text a2, ")"]+jsAst2Text (JsUniOp op a) = T.concat ["(", op, jsAst2Text a, ")"]+jsAst2Text (JsForeign code args) =+  let args_repl c i [] = c+      args_repl c i (t:r) =+        args_repl (T.replace ("%" `T.append` T.pack (show i)) (T.concat ["(", t, ")"]) c) (i + 1) r+  in T.concat ["(", args_repl code 0 (map jsAst2Text args), ")"]+jsAst2Text (JsB2I x) = jsAst2Text $ JsBinOp "+" x (JsInt 0)+jsAst2Text (JsForce e) = T.concat ["$JSRTS.force(", jsAst2Text e, ")"] -jsPackSBits8 :: JS -> JS-jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]+jsLazy :: JsExpr -> JsExpr+jsLazy e = JsNew (JsProp (JsVar "$JSRTS") "Lazy") [(JsLambda [] $ JsReturn e)] -jsPackSBits16 :: JS -> JS-jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]+jsExpr2Stmt :: JsExpr -> JsStmt+jsExpr2Stmt = JsExprStmt -jsPackSBits32 :: JS -> JS-jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]+jsStmt2Expr :: JsStmt -> JsExpr+jsStmt2Expr (JsExprStmt x) = x+jsStmt2Expr x = JsApp (JsLambda [] x) []
+ src/IRTS/JavaScript/Codegen.hs view
@@ -0,0 +1,609 @@+{-|+Module      : IRTS.JavaScript.Codegen+Description : The JavaScript common code generator.+Copyright   :+License     : BSD3+Maintainer  : The Idris Community.+-}+{-# LANGUAGE OverloadedStrings #-}++module IRTS.JavaScript.Codegen( codegenJs+                              , CGConf(..)+                              , CGStats(..)+                              ) where++import Idris.Core.TT+import IRTS.CodegenCommon+import IRTS.JavaScript.AST+import IRTS.JavaScript.LangTransforms+import IRTS.JavaScript.Name+import IRTS.JavaScript.PrimOp+import IRTS.JavaScript.Specialize+import IRTS.Lang+import IRTS.LangOpts+import IRTS.System++import Control.Monad+import Control.Monad.Trans.State+import Data.List (nub)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromJust)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import System.Directory (doesFileExist)+import System.Environment+import System.FilePath++import Control.Applicative (pure, (<$>))+import Data.Char+import Data.Data+import Data.Generics.Uniplate.Data+import Data.List+import GHC.Generics (Generic)++data CGStats = CGStats { usedBigInt :: Bool+                       , partialApplications :: Set Partial+                       , hiddenClasses :: Set HiddenClass+                       }++emptyStats :: CGStats+emptyStats = CGStats { partialApplications = Set.empty+                     , hiddenClasses = Set.empty+                     , usedBigInt = False+                     }++data CGConf = CGConf { header :: Text+                     , footer :: Text+                     , jsbnPath :: String+                     , extraRunTime :: String+                     }+++getInclude :: FilePath -> IO Text+getInclude p =+  do+    libs <- getIdrisLibDir+    let libPath = libs </> p+    exitsInLib <- doesFileExist libPath+    if exitsInLib then+      TIO.readFile libPath+      else TIO.readFile p++getIncludes :: [FilePath] -> IO Text+getIncludes l = do+  incs <- mapM getInclude l+  return $ T.intercalate "\n\n" incs++includeLibs :: [String] -> String+includeLibs =+  let+    repl '\\' = '_'+    repl '/' = '_'+    repl '.' = '_'+    repl c   = c+  in+    concatMap (\lib -> "var " ++ (repl <$> lib) ++ " = require(\"" ++ lib ++"\");\n")++isYes :: Maybe String -> Bool+isYes (Just "Y") = True+isYes (Just "y") = True+isYes _ = False+++codegenJs :: CGConf -> CodeGenerator+codegenJs conf ci =+  do+    debug <- isYes <$> lookupEnv "IDRISJS_DEBUG"+    let defs' = Map.fromList $ liftDecls ci+    let defs = globlToCon defs'+    let used = Map.elems $ removeDeadCode defs [sMN 0 "runMain"]+    if debug then+      do+        writeFile (outputFile ci ++ ".LDeclsDebug") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"+        putStrLn $ "Finished calculating used"+      else pure ()++    let (out, stats) = doCodegen conf defs used++    path <- getIdrisJSRTSDir+    jsbn <- if usedBigInt stats+              then TIO.readFile $ path </> jsbnPath conf+              else return ""++    runtimeCommon <- TIO.readFile $ path </> "Runtime-common.js"+    extraRT <- TIO.readFile $ path </> (extraRunTime conf)++    includes <- getIncludes $ includes ci+    let libs = T.pack $ includeLibs $ compileLibs ci+    TIO.writeFile (outputFile ci) $ T.concat [ header conf+                                             , "\"use strict\";\n\n"+                                             , "(function(){\n\n"+                                             -- rts+                                             , runtimeCommon, "\n"+                                             , extraRT, "\n"+                                             , jsbn, "\n"+                                             -- external libraries+                                             , includes, "\n"+                                             , libs, "\n"+                                             -- user code+                                             , doPartials (partialApplications stats), "\n"+                                             , doHiddenClasses (hiddenClasses stats), "\n"+                                             , out, "\n"+                                             , jsName (sMN 0 "runMain"), "();\n"+                                             , "}.call(this))"+                                             , footer conf+                                             ]++doPartials :: Set Partial -> Text+doPartials x =+  T.intercalate "\n" (map f $ Set.toList x)+  where+      f p@(Partial n i j) =+        let vars1 = map (T.pack . ("x"++) . show) [1..i]+            vars2 = map (T.pack . ("x"++) . show) [(i+1)..j]+        in jsStmt2Text $+             JsFun (jsNamePartial p) vars1 $ JsReturn $+               jsCurryLam vars2 (jsAppN (jsName n) (map JsVar (vars1 ++ vars2)) )++doHiddenClasses :: Set HiddenClass -> Text+doHiddenClasses x =+  T.intercalate "\n" (map f $ Set.toList x)+  where+      f p@(HiddenClass n id 0) = jsStmt2Text $ JsDecConst (jsNameHiddenClass p) $ JsObj [("type", JsInt id)]+      f p@(HiddenClass n id arity) =+        let vars = map dataPartName $ take arity [1..]+        in jsStmt2Text $+             JsFun (jsNameHiddenClass p) vars $ JsSeq (JsSet (JsProp JsThis "type") (JsInt id)) $ seqJs+               $ map (\tv -> JsSet (JsProp JsThis tv) (JsVar tv)) vars++doCodegen :: CGConf -> Map Name LDecl -> [LDecl] -> (Text, CGStats)+doCodegen conf defs decls =+  let xs = map (doCodegenDecl conf defs) decls+      groupCGStats x y = CGStats { partialApplications = partialApplications x `Set.union` partialApplications y+                                 , hiddenClasses = hiddenClasses x `Set.union` hiddenClasses y+                                 , usedBigInt = usedBigInt x || usedBigInt y+                                 }+  in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )++doCodegenDecl :: CGConf -> Map Name LDecl -> LDecl -> (Text, CGStats)+doCodegenDecl conf defs (LFun _ n args def) =+  let (ast, stats) = cgFun conf defs n args def+  in (T.concat [jsStmt2Text (JsComment $ T.pack $ show n), "\n", jsStmt2Text ast], stats)+doCodegenDecl conf defs (LConstructor n i sz) = ("", emptyStats)++seqJs :: [JsStmt] -> JsStmt+seqJs [] = JsEmpty+seqJs (x:xs) = JsSeq x (seqJs xs)+++data CGBodyState = CGBodyState { defs :: Map Name LDecl+                               , lastIntName :: Int+                               , reWrittenNames :: Map.Map Name JsExpr+                               , currentFnNameAndArgs :: (Text, [Text])+                               , usedArgsTailCallOptim :: Set (Text, Text)+                               , isTailRec :: Bool+                               , conf :: CGConf+                               , usedITBig :: Bool+                               , partialApps :: Set Partial+                               , hiddenCls :: Set HiddenClass+                               }++getNewCGName :: State CGBodyState Text+getNewCGName =+  do+    st <- get+    let v = lastIntName st + 1+    put $ st {lastIntName = v}+    return $ jsNameGenerated v++addPartial :: Partial -> State CGBodyState ()+addPartial p =+  modify (\s -> s {partialApps = Set.insert p (partialApps s) })++addHiddenClass :: HiddenClass -> State CGBodyState ()+addHiddenClass p =+  modify (\s -> s {hiddenCls = Set.insert p (hiddenCls s) })++addUsedArgsTailCallOptim :: Set (Text, Text) -> State CGBodyState ()+addUsedArgsTailCallOptim p =+  modify (\s -> s {usedArgsTailCallOptim = Set.union p (usedArgsTailCallOptim s) })++getNewCGNames :: Int -> State CGBodyState [Text]+getNewCGNames n =+  mapM (\_ -> getNewCGName) [1..n]++getConsId :: Name -> State CGBodyState (Int, Int)+getConsId n =+    do+      st <- get+      case Map.lookup n (defs st) of+        Just (LConstructor _ conId arity) -> pure (conId, arity)+        _ -> error $ "Internal JS Backend error " ++ showCG n ++ " is not a constructor."++getArgList :: Name -> State CGBodyState (Maybe [Name])+getArgList n =+  do+    st <- get+    case Map.lookup n (defs st) of+      Just (LFun _ _ a _) -> pure $ Just a+      _ -> pure Nothing++data BodyResTarget = ReturnBT+                   | DecBT Text+                   | SetBT Text+                   | DecConstBT Text+                   | GetExpBT++cgFun :: CGConf -> Map Name LDecl -> Name -> [Name] -> LExp -> (JsStmt, CGStats)+cgFun cnf dfs n args def = do+  let fnName = jsName n+  let argNames = map jsName args+  let ((decs, res),st) = runState+                          (cgBody ReturnBT def)+                          (CGBodyState { defs = dfs+                                       , lastIntName = 0+                                       , reWrittenNames = Map.empty+                                       , currentFnNameAndArgs = (fnName, argNames)+                                       , usedArgsTailCallOptim = Set.empty+                                       , isTailRec = False+                                       , conf = cnf+                                       , usedITBig = False+                                       , partialApps = Set.empty+                                       , hiddenCls = Set.empty+                                       }+                          )+  let body = if isTailRec st then JsSeq (declareUsedOptimArgs $ usedArgsTailCallOptim st) (JsForever ((seqJs decs) `JsSeq` res)) else (seqJs decs) `JsSeq` res+  let fn = JsFun fnName argNames body+  let state' = CGStats { partialApplications = partialApps st+                       , hiddenClasses = hiddenCls st+                       , usedBigInt = usedITBig st+                       }+  (fn, state')++getSwitchJs :: JsExpr -> [LAlt] -> JsExpr+getSwitchJs x alts =+  if any conCase alts then JsArrayProj (JsInt 0) x+    else if any constBigIntCase alts then JsForeign "%0.toString()" [x]+            else x+  where conCase (LConCase _ _ _ _) = True+        conCase _ = False+        constBigIntCase (LConstCase (BI _) _) = True+        constBigIntCase _ = False++addRT :: BodyResTarget -> JsExpr -> JsStmt+addRT ReturnBT x = JsReturn x+addRT (DecBT n) x = JsDecLet n x+addRT (DecConstBT n) x = JsDecConst n x+addRT (SetBT n) x = JsSet (JsVar n) x+addRT GetExpBT x = JsExprStmt x++declareUsedOptimArgs :: Set (Text, Text) -> JsStmt+declareUsedOptimArgs x = seqJs $ map (\(x,y) -> JsDecLet x (JsVar y) ) (Set.toList x)++tailCallOptimRefreshArgs :: [(Text, JsExpr)] -> Set Text -> ((JsStmt, JsStmt), Set (Text, Text))+tailCallOptimRefreshArgs [] s = ((JsEmpty, JsEmpty), Set.empty)+tailCallOptimRefreshArgs ((n,x):r) s =+  let ((y1,y2), y3) = tailCallOptimRefreshArgs r (Set.insert n s) --+  in if Set.null $ (Set.fromList [ z | z <- universeBi x ]) `Set.intersection` s then+      ((y1, jsSetVar n x `JsSeq` y2), y3)+      else+        let n' = jsTailCallOptimName n+        in ((jsSetVar n' x `JsSeq` y1, jsSetVar n (JsVar n') `JsSeq` y2), Set.insert (n',n) y3)++cgName :: Name -> State CGBodyState JsExpr+cgName b = do+  st <- get+  case Map.lookup b (reWrittenNames st) of+    Just e -> pure e+    _ -> pure $ JsVar $ jsName b++cgBody :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)+cgBody rt expr =+  case expr of+    (LCase _ (LOp oper [x, y]) [LConstCase (I 0) (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])])+      | (ff == qualifyN "Prelude.Bool" "False" &&+         tt == qualifyN "Prelude.Bool" "True") ->+        case (Map.lookup oper primDB) of+          Just (needBI, pti, c) | pti == PTBool -> do+            z <- mapM (cgBody GetExpBT) [x, y]+            when needBI setUsedITBig+            let res = jsPrimCoerce pti PTBool $ c $ map (jsStmt2Expr . snd) z+            pure $ (concat $ map fst z, addRT rt res)+          _ -> cgBody' rt expr+    (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LDefaultCase (LCon _ _ ff [])])+      | (ff == qualifyN "Prelude.Bool" "False" &&+         tt == qualifyN "Prelude.Bool" "True") -> do+           (d, v) <- cgBody GetExpBT e+           test <- formConTest n (jsStmt2Expr v)+           pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)+    (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LConCase _ _ _ (LCon _ _ ff [])])+      | (ff == qualifyN "Prelude.Bool" "False" &&+         tt == qualifyN "Prelude.Bool" "True") -> do+           (d, v) <- cgBody GetExpBT e+           test <- formConTest n (jsStmt2Expr v)+           pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)+    (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])])+      | (ff == qualifyN "Prelude.Bool" "False" &&+         tt == qualifyN "Prelude.Bool" "True") -> do+           (d, v) <- cgBody GetExpBT e+           test <- formConTest n (jsStmt2Expr v)+           pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)+    (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LConCase _ _ _ (LCon _ _ tt [])])+      | (ff == qualifyN "Prelude.Bool" "False" &&+         tt == qualifyN "Prelude.Bool" "True") -> do+           (d, v) <- cgBody GetExpBT e+           test <- formConTest n (jsStmt2Expr v)+           pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)+    (LCase f e [LConCase nf ff [] alt, LConCase nt tt [] conseq])+      | (ff == qualifyN "Prelude.Bool" "False" &&+         tt == qualifyN "Prelude.Bool" "True") ->+        cgBody' rt $ LCase f e [LConCase nt tt [] conseq, LConCase nf ff [] alt]+    expr -> cgBody' rt expr++cgBody' :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)+cgBody' rt (LV (Glob n)) =+  do+    argsFn <- getArgList n+    case argsFn of+      Just a -> cgBody' rt (LApp False (LV (Glob n)) [])+      Nothing -> do+        n' <- cgName n+        pure $ ([], addRT rt n')+cgBody' rt (LApp tailcall (LV (Glob fn)) args) =+  do+    let fname = jsName fn+    st <- get+    let (currFn, argN) = currentFnNameAndArgs st+    z <- mapM (cgBody GetExpBT) args+    let argVals = map (jsStmt2Expr . snd) z+    let preDecs = concat $ map fst z+    case (fname == currFn && (length args) == (length argN), rt) of+      (True, ReturnBT) ->+        do+          modify (\x-> x {isTailRec = True})+          let ((y1,y2), y3) = tailCallOptimRefreshArgs (zip argN argVals) Set.empty+          addUsedArgsTailCallOptim y3+          pure (preDecs, y1 `JsSeq` y2)+      _ -> do+        app <- formApp fn argVals+        pure (preDecs, addRT rt app)++cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)+cgBody' rt (LLazyApp n args) =+  do+    (d,v) <- cgBody ReturnBT (LApp False (LV (Glob n)) args)+    pure ([], addRT rt $ jsLazy $ jsStmt2Expr $ JsSeq (seqJs d) v)+cgBody' rt (LForce e) =+  do+    (d,v) <- cgBody GetExpBT e+    pure (d, addRT rt $ JsForce $ jsStmt2Expr v)+cgBody' rt (LLet n v sc) =+  do+    (d1, v1) <- cgBody (DecConstBT $ jsName n) v+    (d2, v2) <- cgBody rt sc+    pure $ ((d1 ++ v1 : d2), v2)+cgBody' rt (LProj e i) =+  do+    (d, v) <- cgBody GetExpBT e+    pure $ (d, addRT rt $ JsArrayProj (JsInt $ i+1) $ jsStmt2Expr v)+cgBody' rt (LCon _  conId n args) =+  do+    z <- mapM (cgBody GetExpBT) args+    con <- formCon n (map (jsStmt2Expr . snd) z)+    pure $ (concat $ map fst z, addRT rt con)+cgBody' rt (LCase _ e alts) = do+  (d, v) <- cgBody GetExpBT e+  resName <- getNewCGName+  (decSw, entry) <-+    case (all altHasNoProj alts && length alts <= 2, v) of+      (True, _) -> pure (JsEmpty, jsStmt2Expr v)+      (False, JsExprStmt (JsVar n)) -> pure (JsEmpty, jsStmt2Expr v)+      _ -> do+        swName <- getNewCGName+        pure (JsDecConst swName $ jsStmt2Expr v, JsVar swName)+  sw' <- cgIfTree rt resName entry alts+  let sw =+        case sw' of+          (Just x) -> x+          Nothing -> JsExprStmt JsNull+  case rt of+    ReturnBT -> pure (d ++ [decSw], sw)+    (DecBT nvar) -> pure (d ++ [decSw, JsDecLet nvar JsNull], sw)+    (DecConstBT nvar) -> pure (d ++ [decSw, JsDecLet nvar JsNull], sw)+    (SetBT nvar) -> pure (d ++ [decSw], sw)+    GetExpBT ->+      pure+        (d ++ [decSw, JsDecLet resName JsNull, sw], JsExprStmt $ JsVar resName)+cgBody' rt (LConst c) =+  do+     cst <- cgConst c+     pure ([], (addRT rt) $ cst)+cgBody' rt (LOp op args) =+  do+    z <- mapM (cgBody GetExpBT) args+    res <- cgOp op (map (jsStmt2Expr . snd) z)+    pure $ (concat $ map fst z, addRT rt $ res)+cgBody' rt LNothing = pure ([], addRT rt JsNull)+cgBody' rt (LError x) = pure ([], JsError $ JsStr x)+cgBody' rt x@(LForeign dres (FStr code) args ) =+  do+    z <- mapM (cgBody GetExpBT) (map snd args)+    jsArgs <- sequence $ map cgForeignArg (zip (map fst args) (map (jsStmt2Expr . snd) z))+    jsDres <- cgForeignRes dres $ JsForeign (T.pack code) jsArgs+    pure $ (concat $ map fst z, addRT rt $ jsDres)+cgBody' _ x = error $ "Instruction " ++ show x ++ " not compilable yet"++altsRT :: Text -> BodyResTarget -> BodyResTarget+altsRT rn ReturnBT = ReturnBT+altsRT rn (DecBT n) = SetBT n+altsRT rn (SetBT n) = SetBT n+altsRT rn (DecConstBT n) = SetBT n+altsRT rn GetExpBT = SetBT rn++altHasNoProj :: LAlt -> Bool+altHasNoProj (LConCase _ _ args _) = args == []+altHasNoProj _ = True++formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr+formApp fn argVals = case specialCall fn of+  Just (arity, g) | arity == length argVals -> pure $ g argVals+  _ -> do+    argsFn <- getArgList fn+    fname <- cgName fn+    case argsFn of+      Nothing -> pure $ jsCurryApp fname argVals+      Just agFn -> do+        let lenAgFn = length agFn+        let lenArgs = length argVals+        case compare lenAgFn lenArgs of+          EQ -> pure $ JsApp fname argVals+          LT -> pure $ jsCurryApp (JsApp fname (take lenAgFn argVals)) (drop lenAgFn argVals)+          GT -> do+            let part = Partial fn lenArgs lenAgFn+            addPartial part+            pure $ jsAppN (jsNamePartial part) argVals++formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr+formCon n args = do+  case specialCased n of+    Just (ctor, test, match) -> pure $ ctor args+    Nothing -> do+      (conId, arity) <- getConsId n+      let hc = HiddenClass n conId arity+      addHiddenClass hc+      pure $ if (arity > 0)+        then JsNew (JsVar $ jsNameHiddenClass hc) args+        else JsVar $ jsNameHiddenClass hc++formConTest :: Name -> JsExpr -> State CGBodyState JsExpr+formConTest n x = do+  case specialCased n of+    Just (ctor, test, match) -> pure $ test x+    Nothing -> do+      (conId, arity) <- getConsId n+      pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)+      -- if (arity > 0)+      --   then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)+      --   else pure $ JsBinOp "===" x (JsInt conId)++formProj :: Name -> JsExpr -> Int -> JsExpr+formProj n v i =+  case specialCased n of+    Just (ctor, test, proj) -> proj v i+    Nothing -> JsProp v (dataPartName i)++smartif :: JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt+smartif cond conseq (Just alt) = JsIf cond conseq (Just alt)+smartif cond conseq Nothing = conseq++formConstTest :: JsExpr -> Const -> State CGBodyState JsExpr+formConstTest scrvar t = case t of+  BI _ -> do+    t' <- cgConst t+    cgOp' PTBool (LEq (ATInt ITBig)) [scrvar, t']+  _ -> do+    t' <- cgConst t+    pure $ JsBinOp "===" scrvar t'++cgIfTree :: BodyResTarget+         -> Text+         -> JsExpr+         -> [LAlt]+         -> State CGBodyState (Maybe JsStmt)+cgIfTree _ _ _ [] = pure Nothing+cgIfTree rt resName scrvar ((LConstCase t exp):r) = do+  (d, v) <- cgBody (altsRT resName rt) exp+  alternatives <- cgIfTree rt resName scrvar r+  test <- formConstTest scrvar t+  pure $ Just $+    smartif test (JsSeq (seqJs d) v) alternatives+cgIfTree rt resName scrvar ((LDefaultCase exp):r) = do+  (d, v) <- cgBody (altsRT resName rt) exp+  pure $ Just $ JsSeq (seqJs d) v+cgIfTree rt resName scrvar ((LConCase _ n args exp):r) = do+  alternatives <- cgIfTree rt resName scrvar r+  test <- formConTest n scrvar+  st <- get+  let rwn = reWrittenNames st+  put $+    st+    { reWrittenNames =+        foldl+          (\m (n, j) -> Map.insert n (formProj n scrvar j) m)+          rwn+          (zip args [1 ..])+    }+  (d, v) <- cgBody (altsRT resName rt) exp+  st1 <- get+  put $ st1 {reWrittenNames = rwn}+  let branchBody = JsSeq (seqJs d) v+  pure $ Just $ smartif test branchBody alternatives+++cgForeignArg :: (FDesc, JsExpr) -> State CGBodyState JsExpr+cgForeignArg (FApp (UN "JS_IntT") _, v) = pure v+cgForeignArg (FCon (UN "JS_Str"), v) = pure v+cgForeignArg (FCon (UN "JS_Ptr"), v) = pure v+cgForeignArg (FCon (UN "JS_Unit"), v) = pure v+cgForeignArg (FCon (UN "JS_Float"), v) = pure v+cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnBase") [_,b]]], f) =+  pure f+cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnIO") [_,_, b]]], f) =+  do+    jsx <- cgForeignArg (a, JsVar "x")+    jsres <- cgForeignRes b $ jsCurryApp (jsCurryApp f [jsx]) [JsNull]+    pure $ JsLambda ["x"] $ JsReturn jsres+cgForeignArg (desc, _) =+  do+    st <- get+    error $ "Foreign arg type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)++cgForeignRes :: FDesc -> JsExpr -> State CGBodyState JsExpr+cgForeignRes (FApp (UN "JS_IntT") _) x = pure x+cgForeignRes (FCon (UN "JS_Unit")) x = pure x+cgForeignRes (FCon (UN "JS_Str")) x = pure x+cgForeignRes (FCon (UN "JS_Ptr")) x = pure x+cgForeignRes (FCon (UN "JS_Float")) x = pure x+cgForeignRes desc val =+  do+    st <- get+    error $ "Foreign return type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)++setUsedITBig :: State CGBodyState ()+setUsedITBig =   modify (\s -> s {usedITBig = True})+++cgConst :: Const -> State CGBodyState JsExpr+cgConst (I i) = pure $ JsInt i+cgConst (BI i) =+  do+    setUsedITBig+    pure $ JsForeign "new $JSRTS.jsbn.BigInteger(%0)" [JsStr $ show i]+cgConst (Ch c) = pure $ JsStr [c]+cgConst (Str s) = pure $ JsStr s+cgConst (Fl f) = pure $ JsDouble f+cgConst (B8 x) = pure $ JsForeign (T.pack $ show x ++ " & 0xFF") []+cgConst (B16 x) = pure $ JsForeign (T.pack $ show x ++ " & 0xFFFF") []+cgConst (B32 x) = pure $ JsForeign (T.pack $ show x ++ "|0" ) []+cgConst (B64 x) =+  do+    setUsedITBig+    pure $ JsForeign "new $JSRTS.jsbn.BigInteger(%0).and(new $JSRTS.jsbn.BigInteger(%1))" [JsStr $ show x, JsStr $ show 0xFFFFFFFFFFFFFFFF]+cgConst x | isTypeConst x = pure $ JsInt 0+cgConst x = error $ "Constant " ++ show x ++ " not compilable yet"++cgOp :: PrimFn -> [JsExpr] -> State CGBodyState JsExpr+cgOp = cgOp' PTAny++cgOp' :: JsPrimTy -> PrimFn -> [JsExpr] -> State CGBodyState JsExpr+cgOp' pt (LExternal name) _ | name == sUN "prim__null" = pure JsNull+cgOp' pt (LExternal name) [l,r] | name == sUN "prim__eqPtr" = pure $ JsBinOp "==" l r+cgOp' pt op exps = case Map.lookup op primDB of+  Just (useBigInt, pti, combinator) -> do+    when useBigInt setUsedITBig+    pure $ jsPrimCoerce pti pt $ combinator exps+  Nothing -> error ("Operator " ++ show (op, exps) ++ " not implemented")
+ src/IRTS/JavaScript/LangTransforms.hs view
@@ -0,0 +1,109 @@+{-|+Module      : IRTS.JavaScript.LangTransforms+Description : The JavaScript LDecl Transformations.+Copyright   :+License     : BSD3+Maintainer  : The Idris Community.+-}+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-}++module IRTS.JavaScript.LangTransforms( removeDeadCode+                                     , globlToCon+                                     ) where+++import Control.DeepSeq+import Control.Monad.Trans.State+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Idris.Core.CaseTree+import Idris.Core.TT+import IRTS.Lang++import Data.Data+import Data.Generics.Uniplate.Data+import GHC.Generics (Generic)++deriving instance Typeable FDesc+deriving instance Data FDesc+deriving instance Typeable LVar+deriving instance Data LVar+deriving instance Typeable PrimFn+deriving instance Data PrimFn+deriving instance Typeable CaseType+deriving instance Data CaseType+deriving instance Typeable LExp+deriving instance Data LExp+deriving instance Typeable LDecl+deriving instance Data LDecl+deriving instance Typeable LOpt+deriving instance Data LOpt+++restrictKeys :: Ord k => Map k a -> Set k -> Map k a+restrictKeys m s = Map.filterWithKey (\k _ -> k `Set.member` s) m++mapMapListKeys :: Ord k => (a->a) -> [k] -> Map k a -> Map k a+mapMapListKeys _ [] x = x+mapMapListKeys f (t:r) x = mapMapListKeys f r $ Map.adjust f t x+++extractGlobs :: Map Name LDecl -> LDecl -> [Name]+extractGlobs defs (LConstructor _ _ _) = []+extractGlobs defs (LFun _ _ _ e) =+  let f (LV (Glob x)) = Just x+      f (LLazyApp x _) = Just x+      f _ = Nothing+  in [x | Just x <- map f $ universe e, Map.member x defs]++usedFunctions :: Map Name LDecl -> Set Name -> [Name] -> [Name]+usedFunctions _ _ [] = []+usedFunctions alldefs done names =+  let decls = catMaybes $ map (\x -> Map.lookup x alldefs) names+      used_names = (nub $ concat $ map (extractGlobs alldefs) decls) \\ names+      new_names = filter (\x -> not $ Set.member x done) used_names+  in  used_names ++ usedFunctions alldefs (Set.union done $ Set.fromList new_names) new_names+++usedDecls :: Map Name LDecl -> [Name] -> Map Name LDecl+usedDecls dcls start =+  let used = reverse $ start ++ usedFunctions dcls (Set.fromList start) start+  in restrictKeys dcls (Set.fromList used)++getUsedConstructors :: Map Name LDecl -> Set Name+getUsedConstructors x = Set.fromList [ n | LCon _ _ n _ <- universeBi x]++removeUnusedBranches :: Set Name -> Map Name LDecl -> Map Name LDecl+removeUnusedBranches used x =+  transformBi f x+  where+    f :: [LAlt] -> [LAlt]+    f ((LConCase x n y z):r) =+      if Set.member n used then ((LConCase x n y z):r)+        else r+    f x = x++removeDeadCode :: Map Name LDecl -> [Name] -> Map Name LDecl+removeDeadCode dcls start =+  let used = usedDecls dcls start+      remCons = removeUnusedBranches (getUsedConstructors used) used+  in if Map.keys remCons == Map.keys dcls then remCons+        else removeDeadCode remCons start+++globlToCon :: Map Name LDecl -> Map Name LDecl+globlToCon x =+  transformBi (f x) x+  where+    f :: Map Name LDecl -> LExp -> LExp+    f y x@(LV (Glob n)) =+      case Map.lookup n y of+        Just (LConstructor _ conId arity) -> LCon Nothing conId n []+        _ -> x+    f y x = x
+ src/IRTS/JavaScript/Name.hs view
@@ -0,0 +1,60 @@+{-|+Module      : IRTS.JavaScript.Name+Description : The JavaScript name mangler.+Copyright   :+License     : BSD3+Maintainer  : The Idris Community.+-}++{-# LANGUAGE OverloadedStrings, PatternGuards #-}++module IRTS.JavaScript.Name+  ( jsName+  , jsNameGenerated+  , Partial(..)+  , jsNamePartial+  , jsTailCallOptimName+  , HiddenClass(..)+  , jsNameHiddenClass+  , dataPartName+  ) where++import Data.Char+import Data.List+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Idris.Core.TT+import IRTS.JavaScript.AST++jsEscape :: String -> String+jsEscape = concatMap jschar+  where+    jschar x+      | isAlpha x || isDigit x = [x]+      | x == '.' = "__"+      | otherwise = "_" ++ show (fromEnum x) ++ "_"++jsName :: Name -> Text+jsName (MN i u) = T.concat ["$_", T.pack (show i), "_", T.pack $ jsEscape $ T.unpack u]+jsName n = T.pack $ jsEscape $ showCG n++jsNameGenerated :: Int -> Text+jsNameGenerated v = T.pack $ "$cg$" ++ show v++data Partial = Partial Name Int Int deriving (Eq, Ord)++jsNamePartial :: Partial -> Text+jsNamePartial (Partial n i j) = T.concat ["$partial_", T.pack $ show i, "_", T.pack $ show j, "$" , jsName n]++jsTailCallOptimName :: Text -> Text+jsTailCallOptimName x = T.concat ["$tco$", x]+++data HiddenClass = HiddenClass Name Int Int deriving (Eq, Ord)++jsNameHiddenClass :: HiddenClass -> Text+jsNameHiddenClass (HiddenClass n id arity) = T.concat ["$HC_", T.pack $ show arity, "_", T.pack $ show id,"$", jsName n]++dataPartName :: Int -> Text+dataPartName i = T.pack $ "$" ++ show i
+ src/IRTS/JavaScript/PrimOp.hs view
@@ -0,0 +1,247 @@+{-|+Module      : IRTS.JavaScript.PrimOp+Description : The JavaScript primitive operations.+Copyright   :+License     : BSD3+Maintainer  : The Idris Community.+-}++{-# LANGUAGE OverloadedStrings, PatternGuards, StandaloneDeriving #-}++module IRTS.JavaScript.PrimOp+  ( PrimF+  , PrimDec+  , JsPrimTy(..)+  , primDB+  , jsPrimCoerce+  ) where++import Data.Char+import Data.List+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Idris.Core.TT+import IRTS.JavaScript.AST+import IRTS.Lang++data JsPrimTy = PTBool | PTAny deriving (Eq, Ord)++type PrimF = [JsExpr] -> JsExpr+type PrimDec = (Bool, JsPrimTy, PrimF) -- the bool indicates if bigint library is used or not++deriving instance Ord PrimFn++primDB :: Map.Map PrimFn PrimDec+primDB =+  Map.fromList [+    item (LPlus ATFloat) False PTAny $ binop "+"+  , item (LPlus (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) + %1.charCodeAt(0))"+  , item (LPlus (ATInt ITNative)) False PTAny $ binop "+"+  , item (LPlus (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 + %1 & 0xFF"+  , item (LPlus (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 + %1 & 0xFFFF"+  , item (LPlus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0+%1|0"+  , item (LPlus (ATInt ITBig)) True PTAny $ method "add"+  , item (LPlus (ATInt (ITFixed IT64))) True PTAny $+    \[l, r] -> JsForeign "%0.add(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]+  , item (LMinus ATFloat) False PTAny $ binop "-"+  , item (LMinus (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) - %1.charCodeAt(0))"+  , item (LMinus (ATInt ITNative)) False PTAny $ binop "-"+  , item (LMinus (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 - %1 & 0xFF"+  , item (LMinus (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 - %1 & 0xFFFF"+  , item (LMinus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0-%1|0"+  , item (LMinus (ATInt ITBig)) True PTAny $ method "subtract"+  , item (LMinus (ATInt (ITFixed IT64))) True PTAny $+    \[l, r] -> JsForeign "%0.subtract(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]+  , item (LTimes ATFloat) False PTAny $ binop "*"+  , item (LTimes (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) * %1.charCodeAt(0))"+  , item (LTimes (ATInt ITNative)) False PTAny $ binop "*"+  , item (LTimes (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 * %1 & 0xFF"+  , item (LTimes (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 * %1 & 0xFFFF"+  , item (LTimes (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0*%1|0"+  , item (LTimes (ATInt ITBig)) True PTAny $ method "multiply"+  , item (LTimes (ATInt (ITFixed IT64))) True PTAny $+    \[l, r] -> JsForeign "%0.multiply(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]+  , item (LUDiv (ITFixed IT8)) False PTAny $ JsForeign "%0 / %1"+  , item (LUDiv (ITFixed IT16)) False PTAny $ JsForeign "%0 / %1"+  , item (LUDiv (ITFixed IT32)) False PTAny $ JsForeign "(%0>>>0)  / (%1>>>0) |0"+  , item (LUDiv (ITFixed IT64)) True PTAny $ JsForeign "%0.divide(%1)"+  , item (LSDiv ATFloat) False PTAny $ binop "/"+  , item (LSDiv (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 / %1"+  , item (LSDiv (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 / %1"+  , item (LSDiv (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0  / %1 |0"+  , item (LSDiv (ATInt (ITFixed IT64))) True PTAny $ JsForeign "%0.divide(%1)"+  , item (LSDiv (ATInt ITNative)) False PTAny $ JsForeign "%0/%1|0" -- we need "|0" in this+  , item (LSDiv (ATInt ITBig)) True PTAny $ method "divide"+  , item (LURem (ITFixed IT8)) False PTAny $ JsForeign "%0 % %1"+  , item (LURem (ITFixed IT16)) False PTAny $ JsForeign "%0 % %1"+  , item (LURem (ITFixed IT32)) False PTAny $ JsForeign "(%0>>>0) % (%1>>>0) |0"+  , item (LURem (ITFixed IT64)) True PTAny $ method "remainder"+  , item (LSRem ATFloat) False PTAny $ binop "%"+  , item (LSRem (ATInt ITNative)) False PTAny $ binop "%"+  , item (LSRem (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 % %1"+  , item (LSRem (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 % %1"+  , item (LSRem (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0 % %1 |0"+  , item (LSRem (ATInt (ITFixed IT64))) True PTAny $ method "remainder"+  , item (LSRem (ATInt ITBig)) True PTAny $ method "remainder"+  , item (LAnd ITNative) False PTAny $ JsForeign "%0 & %1"+  , item (LAnd (ITFixed IT8)) False PTAny $ JsForeign "%0 & %1"+  , item (LAnd (ITFixed IT16)) False PTAny $ JsForeign "%0 & %1"+  , item (LAnd (ITFixed IT32)) False PTAny $ JsForeign "%0  & %1"+  , item (LAnd (ITFixed IT64)) True PTAny $ method "and"+  , item (LAnd ITBig) True PTAny $ method "and"+  , item (LOr ITNative) False PTAny $ JsForeign "%0 | %1"+  , item (LOr (ITFixed IT8)) False PTAny $ JsForeign "%0 | %1"+  , item (LOr (ITFixed IT16)) False PTAny $ JsForeign "%0 | %1"+  , item (LOr (ITFixed IT32)) False PTAny $ JsForeign "%0 | %1"+  , item (LOr (ITFixed IT64)) True PTAny $ method "or"+  , item (LOr ITBig) True PTAny $ method "or"+  , item (LXOr ITNative) False PTAny $ JsForeign "%0 ^ %1"+  , item (LXOr (ITFixed IT8)) False PTAny $ JsForeign "%0 ^ %1"+  , item (LXOr (ITFixed IT16)) False PTAny $ JsForeign "%0 ^ %1"+  , item (LXOr (ITFixed IT32)) False PTAny $ JsForeign "%0 ^ %1"+  , item (LXOr (ITFixed IT64)) True PTAny $ method "xor"+  , item (LXOr ITBig) True PTAny $ method "xor"+  , item (LSHL ITNative) False PTAny $ JsForeign "%0 << %1 |0"+  , item (LSHL (ITFixed IT8)) False PTAny $ JsForeign "%0 << %1 & 0xFF"+  , item (LSHL (ITFixed IT16)) False PTAny $ JsForeign "%0 << %1 & 0xFFFF"+  , item (LSHL (ITFixed IT32)) False PTAny $ JsForeign "%0 << %1 | 0"+  , item (LSHL (ITFixed IT64)) True PTAny $+    \[l, r] -> JsForeign "%0.shiftLeft(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]+  , item (LSHL ITBig) True PTAny $ method "shiftLeft"+  , item (LLSHR ITNative) False PTAny $ JsForeign "%0 >> %1 |0"+  , item (LLSHR (ITFixed IT8)) False PTAny $ JsForeign "%0 >> %1"+  , item (LLSHR (ITFixed IT16)) False PTAny $ JsForeign "%0 >> %1"+  , item (LLSHR (ITFixed IT32)) False PTAny $ JsForeign "%0 >> %1|0"+  , item (LLSHR (ITFixed IT64)) True PTAny $ JsForeign "%0.shiftRight(%1)"+  , item (LASHR ITNative) False PTAny $ JsForeign "%0 >> %1 |0"+  , item (LASHR (ITFixed IT8)) False PTAny $ JsForeign "%0 >> %1"+  , item (LASHR (ITFixed IT16)) False PTAny $ JsForeign "%0 >> %1"+  , item (LASHR (ITFixed IT32)) False PTAny $ JsForeign "%0 >> %1|0"+  , item (LASHR (ITFixed IT64)) True PTAny $ JsForeign "%0.shiftRight(%1)"+  , item (LEq ATFloat) False PTBool $ binop "==="+  , item (LEq (ATInt ITNative)) False PTBool $ binop "==="+  , item (LEq (ATInt ITChar)) False PTBool $ binop "==="+  , item (LEq (ATInt ITBig)) True PTBool $ method "equals"+  , item (LEq (ATInt (ITFixed IT8))) False PTBool $ binop "==="+  , item (LEq (ATInt (ITFixed IT16))) False PTBool $ binop "==="+  , item (LEq (ATInt (ITFixed IT32))) False PTBool $ binop "==="+  , item (LEq (ATInt (ITFixed IT64))) True PTBool $ method "equals"+  , item (LLt (ITFixed IT8)) False PTBool $ JsForeign "%0 < %1"+  , item (LLt (ITFixed IT16)) False PTBool $ JsForeign "%0 < %1"+  , item (LLt (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) < (%1>>>0)"+  , item (LLt (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) < 0"+  , item (LLe (ITFixed IT8)) False PTBool $ JsForeign "%0 <= %1"+  , item (LLe (ITFixed IT16)) False PTBool $ JsForeign "%0 <= %1"+  , item (LLe (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) <= (%1>>>0)"+  , item (LLe (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"+  , item (LGt (ITFixed IT8)) False PTBool $ JsForeign "%0 > %1"+  , item (LGt (ITFixed IT16)) False PTBool $ JsForeign "%0 > %1"+  , item (LGt (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) > (%1>>>0)"+  , item (LGt (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) > 0"+  , item (LGe (ITFixed IT8)) False PTBool $ JsForeign "%0 >= %1"+  , item (LGe (ITFixed IT16)) False PTBool $ JsForeign "%0 >= %1"+  , item (LGe (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) >= (%1>>>0)"+  , item (LGe (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"+  , item (LSLt ATFloat) False PTBool $ binop "<"+  , item (LSLt (ATInt ITChar)) False PTBool $ binop "<"+  , item (LSLt (ATInt ITNative)) False PTBool $ binop "<"+  , item (LSLt (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) < 0"+  , item (LSLt (ATInt (ITFixed IT8))) False PTBool $ binop "<"+  , item (LSLt (ATInt (ITFixed IT16))) False PTBool $ binop "<"+  , item (LSLt (ATInt (ITFixed IT32))) False PTBool $ binop "<"+  , item (LSLt (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) < 0"+  , item (LSLe ATFloat) False PTBool $ binop "<="+  , item (LSLe (ATInt ITNative)) False PTBool $ binop "<="+  , item (LSLe (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"+  , item (LSLe (ATInt (ITFixed IT8))) False PTBool $ binop "<="+  , item (LSLe (ATInt (ITFixed IT16))) False PTBool $ binop "<="+  , item (LSLe (ATInt (ITFixed IT32))) False PTBool $ binop "<="+  , item (LSLe (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"+  , item (LSGt ATFloat) False PTBool $ binop ">"+  , item (LSGt (ATInt ITNative)) False PTBool $ binop ">"+  , item (LSGt (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) > 0"+  , item (LSGt (ATInt (ITFixed IT8))) False PTBool $ binop ">"+  , item (LSGt (ATInt (ITFixed IT16))) False PTBool $ binop ">"+  , item (LSGt (ATInt (ITFixed IT32))) False PTBool $ binop ">"+  , item (LSGt (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) > 0"+  , item (LSGe ATFloat) False PTBool $ binop ">="+  , item (LSGe (ATInt ITNative)) False PTBool $ binop ">="+  , item (LSGe (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"+  , item (LSGe (ATInt (ITFixed IT8))) False PTBool $ binop ">="+  , item (LSGe (ATInt (ITFixed IT16))) False PTBool $ binop ">="+  , item (LSGe (ATInt (ITFixed IT32))) False PTBool $ binop ">="+  , item (LSGe (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"+  , item (LSExt ITNative ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"+  , item (LZExt (ITFixed IT8) ITNative) False PTAny $ head+  , item (LZExt (ITFixed IT16) ITNative) False PTAny $ head+  , item (LZExt (ITFixed IT32) ITNative) False PTAny $ head+  , item (LZExt ITNative ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"+  , item (LZExt (ITFixed IT8) ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"+  , item (LZExt (ITFixed IT16) ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"+  , item (LZExt (ITFixed IT32) ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"+  , item (LZExt (ITFixed IT64) ITBig) True PTAny $ head+  , item (LTrunc ITBig ITNative) True PTAny $ JsForeign "%0.intValue()|0"+  , item (LTrunc ITBig (ITFixed IT8)) True PTAny $ JsForeign "%0.intValue() & 0xFF"+  , item (LTrunc ITBig (ITFixed IT16)) True PTAny $ JsForeign "%0.intValue() & 0xFFFF"+  , item (LTrunc ITBig (ITFixed IT32)) True PTAny $ JsForeign "%0.intValue() & 0xFFFFFFFF"+  , item (LTrunc ITBig (ITFixed IT64)) True PTAny $+    \[x] -> JsForeign "%0.and(new $JSRTS.jsbn.BigInteger(%1))" [x, JsStr $ show 0xFFFFFFFFFFFFFFFF]+  , item (LTrunc (ITFixed IT16) (ITFixed IT8)) False PTAny $ JsForeign "%0 & 0xFF"+  , item (LTrunc (ITFixed IT32) (ITFixed IT8)) False PTAny $ JsForeign "%0 & 0xFF"+  , item (LTrunc (ITFixed IT64) (ITFixed IT8)) True PTAny $ JsForeign "%0.intValue() & 0xFF"+  , item (LTrunc (ITFixed IT32) (ITFixed IT16)) False PTAny $ JsForeign "%0 & 0xFFFF"+  , item (LTrunc (ITFixed IT64) (ITFixed IT16)) True PTAny $ JsForeign "%0.intValue() & 0xFFFF"+  , item (LTrunc (ITFixed IT64) (ITFixed IT32)) True PTAny $ JsForeign "%0.intValue() & 0xFFFFFFFF"+  , item LStrConcat False PTAny $ binop "+"+  , item LStrLt False PTBool $ binop "<"+  , item LStrEq False PTBool $ binop "=="+  , item LStrLen False PTAny $ JsForeign "%0.length"+  , item (LIntFloat ITNative) False PTAny $ head+  , item (LIntFloat ITBig) True PTAny $ JsForeign "%0.intValue()"+  , item (LFloatInt ITNative) False PTAny $ JsForeign "%0|0"+  , item (LFloatInt ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(Math.trunc(%0)+ '')"+  , item (LIntStr ITNative) False PTAny $ JsForeign "''+%0"+  , item (LIntStr ITBig) True PTAny $ JsForeign "%0.toString()"+  , item (LStrInt ITNative) False PTAny $ JsForeign "parseInt(%0)|0"+  , item (LStrInt ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(%0)"+  , item (LFloatStr) False PTAny $ JsForeign "''+%0"+  , item (LStrFloat) False PTAny $ jsAppN "parseFloat"+  , item (LChInt ITNative) False PTAny $ JsForeign "%0.charCodeAt(0)|0"+  , item (LIntCh ITNative) False PTAny $ jsAppN "String.fromCharCode"+  , item LFExp False PTAny $ jsAppN "Math.exp"+  , item LFLog False PTAny $ jsAppN "Math.log"+  , item LFSin False PTAny $ jsAppN "Math.sin"+  , item LFCos False PTAny $ jsAppN "Math.cos"+  , item LFTan False PTAny $ jsAppN "Math.tan"+  , item LFASin False PTAny $ jsAppN "Math.asin"+  , item LFACos False PTAny $ jsAppN "Math.acos"+  , item LFATan False PTAny $ jsAppN "Math.atan"+  , item LFSqrt False PTAny $ jsAppN "Math.sqrt"+  , item LFFloor False PTAny $ jsAppN "Math.floor"+  , item LFCeil False PTAny $ jsAppN "Math.ceil"+  , item LFNegate False PTAny $ JsForeign "-%0"+  , item LStrHead False PTAny $ \[x] -> JsArrayProj (JsInt 0) x+  , item LStrTail False PTAny $ \[x] -> JsMethod x "slice" [JsInt 1]+  , item LStrCons False PTAny $ JsForeign "%0+%1"+  , item LStrIndex False PTAny $ \[x, y] -> JsArrayProj y x+  , item LStrRev False PTAny $ JsForeign "%0.split('').reverse().join('')"+  , item LStrSubstr False PTAny $ JsForeign "$JSRTS.prim_strSubstr(%0, %1, %2)"+  , item LSystemInfo False PTAny $ JsApp (JsProp (JsVar "$JSRTS") "prim_systemInfo")+  , item LCrash False PTAny $ \[l] -> JsErrorExp l+  , item LReadStr False PTAny $ \[_] -> JsApp (JsProp (JsVar "$JSRTS") "prim_readStr") []+  , item LWriteStr False PTAny $ \[_, str] -> JsApp (JsProp (JsVar "$JSRTS") "prim_writeStr") [str]+  , item LNoOp False PTAny $ head+  ]+  where+    item :: PrimFn -> Bool -> JsPrimTy -> PrimF -> (PrimFn, PrimDec)+    item fn ubi pty c = (fn, (ubi, pty, c))+    binop op [l, r] = JsBinOp op l r+    method op (l:r) = JsMethod l op r++jsB2I :: JsExpr -> JsExpr+jsB2I x = JsForeign "%0 ? 1|0 : 0|0" [x]++jsPrimCoerce :: JsPrimTy -> JsPrimTy -> JsExpr -> JsExpr+jsPrimCoerce PTBool PTAny x = jsB2I x+jsPrimCoerce _ _ x = x
+ src/IRTS/JavaScript/Specialize.hs view
@@ -0,0 +1,123 @@+{-|+Module      : IRTS.JavaScript.Specialize+Description : The JavaScript specializer.+Copyright   :+License     : BSD3+Maintainer  : The Idris Community.+-}++{-# LANGUAGE OverloadedStrings, PatternGuards #-}++module IRTS.JavaScript.Specialize+  ( SCtor+  , STest+  , SProj+  , specialCased+  , specialCall+  , qualifyN+  ) where++import Data.Char+import Data.List+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Idris.Core.TT+import IRTS.JavaScript.AST++split :: Char -> String -> [String]+split c "" = [""]+split c (x:xs)+  | c == x = "" : split c xs+  | otherwise =+    let ~(h:t) = split c xs+    in ((x : h) : t)++qualify :: String -> Name -> Name+qualify "" n = n+qualify ns n = sNS n (reverse $ split '.' ns)++qualifyN :: String -> String -> Name+qualifyN ns n = qualify ns $ sUN n++-- special-cased constructors+type SCtor = [JsExpr] -> JsExpr++type STest = JsExpr -> JsExpr++type SProj = JsExpr -> Int -> JsExpr++constructorOptimizeDB :: Map.Map Name (SCtor, STest, SProj)+constructorOptimizeDB =+  Map.fromList+    [ item "Prelude.Bool" "True" (const $ JsBool True) trueTest cantProj+    , item "Prelude.Bool" "False" (const $ JsBool False) falseTest cantProj+    , item "Prelude.Interfaces" "LT" (const $ JsInt (0-1)) ltTest cantProj+    , item "Prelude.Interfaces" "EQ" (const $ JsInt 0) eqTest cantProj+    , item "Prelude.Interfaces" "GT" (const $ JsInt 1) gtTest cantProj+    -- , item "Prelude.List" "::" cons fillList uncons+    -- , item "Prelude.List" "Nil" nil emptyList cantProj+    -- , item "Prelude.Maybe" "Just" (\[x] -> x) notNoneTest justProj+    -- , item "Prelude.Maybe" "Nothing" (const $ JsUndefined) noneTest cantProj+    ]+    -- constructors+  where+    nil = const $ JsArray []+    cons [h, t] = JsMethod (JsArray [h]) "concat" [t]+    -- tests+    --trueTest e = JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") e+    trueTest = id+    falseTest e = JsUniOp (T.pack "!") e+    emptyList e = JsBinOp "===" (JsProp e "length") (JsInt 0)+    fillList e = JsBinOp ">" (JsProp e "length") (JsInt 0)+    ltTest e = JsBinOp "<" e (JsInt 0)+    eqTest e = JsBinOp "===" e (JsInt 0)+    gtTest e = JsBinOp ">" e (JsInt 0)+    noneTest e = JsBinOp "===" e JsUndefined+    notNoneTest e = JsBinOp "!==" e JsUndefined+    -- projections+    justProj x n = x+    uncons x 1 = JsArrayProj (JsInt 0) x+    uncons x 2 = JsMethod x "slice" [JsInt 1]+    cantProj x j = error $ "This type should be projected"+    item :: String+         -> String+         -> SCtor+         -> STest+         -> SProj+         -> (Name, (SCtor, STest, SProj))+    item ns n ctor test match = (qualifyN ns n, (ctor, test, match))++specialCased :: Name -> Maybe (SCtor, STest, SProj)+specialCased n = Map.lookup n constructorOptimizeDB++-- special functions+type SSig = (Int, [JsExpr] -> JsExpr)++callSpecializeDB :: Map.Map Name (SSig)+callSpecializeDB =+  Map.fromList+    [ qb "Eq" "Int" "==" "==="+    , qb "Ord" "Int" "<" "<"+    , qb "Ord" "Int" ">" ">"+    , qb "Ord" "Int" "<=" "<="+    , qb "Ord" "Int" ">=" ">="+    , qb "Eq" "Double" "==" "==="+    , qb "Ord" "Double" "<" "<"+    , qb "Ord" "Double" ">" ">"+    , qb "Ord" "Double" "<=" "<="+    , qb "Ord" "Double" ">=" ">="+    ]+  where+    qb intf ty op jsop =+      ( qualify "Prelude.Interfaces" $+        SN $+        WhereN+          0+          (qualify "Prelude.Interfaces" $+           SN $ ImplementationN (qualifyN "Prelude.Interfaces" intf) [ty])+          (SN $ MethodN $ UN op)+      , (2, \[x, y] -> JsBinOp jsop x y))++specialCall :: Name -> Maybe SSig+specialCall n = Map.lookup n callSpecializeDB
src/IRTS/Lang.hs view
@@ -5,7 +5,8 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE DeriveFunctor, DeriveGeneric, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric, FlexibleContexts,+             PatternGuards #-}  module IRTS.Lang where @@ -14,7 +15,9 @@  import Control.Applicative hiding (Const) import Control.Monad.State hiding (lift)+import Data.Data (Data) import Data.List+import Data.Typeable (Typeable) import Debug.Trace import GHC.Generics (Generic) @@ -117,7 +120,7 @@ data LAlt' e = LConCase Int Name [Name] e              | LConstCase Const e              | LDefaultCase e-  deriving (Show, Eq, Functor)+  deriving (Show, Eq, Functor, Data, Typeable)  type LAlt = LAlt' LExp
src/IRTS/Portable.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-} module IRTS.Portable (writePortable) where  import Idris.Core.CaseTree@@ -144,6 +144,8 @@     toJSON (LTimes aty) = object ["LTimes" .= aty]     toJSON (LUDiv aty) = object ["LUDiv" .= aty]     toJSON (LSDiv aty) = object ["LSDiv" .= aty]+    toJSON (LURem ity) = object ["LURem" .= ity]+    toJSON (LSRem aty) = object ["LSRem" .= aty]     toJSON (LAnd ity) = object ["LAnd" .= ity]     toJSON (LOr ity) = object ["LOr" .= ity]     toJSON (LXOr ity) = object ["LXOr" .= ity]@@ -200,11 +202,8 @@     toJSON LFork = object ["LFork" .= Null]     toJSON LPar = object ["LPar" .= Null]     toJSON (LExternal name) = object ["LExternal" .= name]+    toJSON LCrash = object ["LCrash" .= Null]     toJSON LNoOp = object ["LNoOp" .= Null]----  instance ToJSON DDecl where     toJSON (DFun name args exp) = object ["DFun" .= (name, args, exp)]
src/IRTS/Simplified.hs view
@@ -5,6 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}+{-# LANGUAGE FlexibleContexts #-} module IRTS.Simplified(simplifyDefs, SDecl(..), SExp(..), SAlt(..)) where  import Idris.Core.CaseTree
src/IRTS/System.hs view
@@ -30,7 +30,8 @@ import Data.List.Split import Data.Maybe (fromMaybe) import System.Environment-import System.FilePath (addTrailingPathSeparator, (</>))+import System.FilePath (addTrailingPathSeparator, dropTrailingPathSeparator,+                        (</>))   getIdrisDataDir :: IO String@@ -81,7 +82,7 @@ #endif  getLibFlags = do dir <- getIdrisCRTSDir-                 return $ ["-L" ++ dir,+                 return $ ["-L" ++ dropTrailingPathSeparator dir,                            "-lidris_rts"] ++ extraLib ++ gmpLib ++ ["-lpthread"]  getIdrisLibDir = addTrailingPathSeparator <$> overrideIdrisSubDirWith "libs" "IDRIS_LIBRARY_PATH"@@ -97,4 +98,4 @@   return $ addTrailingPathSeparator (ddir </> "rts")  getIncFlags = do dir <- getIdrisCRTSDir-                 return $ ("-I" ++ dir) : extraInclude+                 return $ ("-I" ++ dropTrailingPathSeparator dir) : extraInclude
src/Idris/ASTUtils.hs view
@@ -48,6 +48,7 @@ import Idris.AbsSyntaxTree import Idris.Core.Evaluate import Idris.Core.TT+import Idris.Options  import Prelude hiding (id, (.))
src/Idris/AbsSyntax.hs view
@@ -6,7 +6,7 @@ Maintainer  : The Idris Community. -} -{-# LANGUAGE DeriveFunctor, PatternGuards #-}+{-# LANGUAGE DeriveFunctor, FlexibleContexts, PatternGuards #-}  module Idris.AbsSyntax(     module Idris.AbsSyntax@@ -19,6 +19,7 @@ import Idris.Core.TT import Idris.Docstrings import Idris.IdeMode hiding (Opt(..))+import Idris.Options import IRTS.CodegenCommon  import System.Directory (canonicalizePath, doesFileExist)@@ -2602,126 +2603,4 @@    mkUniq ql nmap tm = descendM (mkUniq ql nmap) tm -getFile :: Opt -> Maybe String-getFile (Filename s) = Just s-getFile _ = Nothing -getBC :: Opt -> Maybe String-getBC (BCAsm s) = Just s-getBC _ = Nothing--getOutput :: Opt -> Maybe String-getOutput (Output s) = Just s-getOutput _ = Nothing--getIBCSubDir :: Opt -> Maybe String-getIBCSubDir (IBCSubDir s) = Just s-getIBCSubDir _ = Nothing--getImportDir :: Opt -> Maybe String-getImportDir (ImportDir s) = Just s-getImportDir _ = Nothing--getSourceDir :: Opt -> Maybe String-getSourceDir (SourceDir s) = Just s-getSourceDir _ = Nothing--getPkgDir :: Opt -> Maybe String-getPkgDir (Pkg s) = Just s-getPkgDir _ = Nothing--getPkg :: Opt -> Maybe (Bool, String)-getPkg (PkgBuild s)   = Just (False, s)-getPkg (PkgInstall s) = Just (True, s)-getPkg _ = Nothing--getPkgClean :: Opt -> Maybe String-getPkgClean (PkgClean s) = Just s-getPkgClean _ = Nothing--getPkgREPL :: Opt -> Maybe String-getPkgREPL (PkgREPL s) = Just s-getPkgREPL _ = Nothing--getPkgCheck :: Opt -> Maybe String-getPkgCheck (PkgCheck s) = Just s-getPkgCheck _              = Nothing---- | Returns None if given an Opt which is not PkgMkDoc---   Otherwise returns Just x, where x is the contents of PkgMkDoc-getPkgMkDoc :: Opt                  -- ^ Opt to extract-            -> Maybe (Bool, String) -- ^ Result-getPkgMkDoc (PkgDocBuild  str)  = Just (False,str)-getPkgMkDoc (PkgDocInstall str) = Just (True,str)-getPkgMkDoc _              = Nothing--getPkgTest :: Opt          -- ^ the option to extract-           -> Maybe String -- ^ the package file to test-getPkgTest (PkgTest f) = Just f-getPkgTest _ = Nothing--getCodegen :: Opt -> Maybe Codegen-getCodegen (UseCodegen x) = Just x-getCodegen _ = Nothing--getCodegenArgs :: Opt -> Maybe String-getCodegenArgs (CodegenArgs args) = Just args-getCodegenArgs _ = Nothing--getConsoleWidth :: Opt -> Maybe ConsoleWidth-getConsoleWidth (UseConsoleWidth x) = Just x-getConsoleWidth _ = Nothing--getExecScript :: Opt -> Maybe String-getExecScript (InterpretScript expr) = Just expr-getExecScript _ = Nothing--getPkgIndex :: Opt -> Maybe FilePath-getPkgIndex (PkgIndex file) = Just file-getPkgIndex _ = Nothing--getEvalExpr :: Opt -> Maybe String-getEvalExpr (EvalExpr expr) = Just expr-getEvalExpr _ = Nothing--getOutputTy :: Opt -> Maybe OutputType-getOutputTy (OutputTy t) = Just t-getOutputTy _ = Nothing--getLanguageExt :: Opt -> Maybe LanguageExt-getLanguageExt (Extension e) = Just e-getLanguageExt _ = Nothing--getTriple :: Opt -> Maybe String-getTriple (TargetTriple x) = Just x-getTriple _ = Nothing--getCPU :: Opt -> Maybe String-getCPU (TargetCPU x) = Just x-getCPU _ = Nothing--getOptLevel :: Opt -> Maybe Int-getOptLevel (OptLevel x) = Just x-getOptLevel _ = Nothing--getOptimisation :: Opt -> Maybe (Bool,Optimisation)-getOptimisation (AddOpt p)    = Just (True,  p)-getOptimisation (RemoveOpt p) = Just (False, p)-getOptimisation _             = Nothing--getColour :: Opt -> Maybe Bool-getColour (ColourREPL b) = Just b-getColour _ = Nothing--getClient :: Opt -> Maybe String-getClient (Client x) = Just x-getClient _ = Nothing---- Get the first valid port-getPort :: [Opt] -> Maybe REPLPort-getPort []            = Nothing-getPort (Port p : _ ) = Just p-getPort (_      : xs) = getPort xs--opt :: (Opt -> Maybe a) -> [Opt] -> [a]-opt = mapMaybe
src/Idris/AbsSyntaxTree.hs view
@@ -6,7 +6,9 @@ Maintainer  : The Idris Community. -} -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric,+             DeriveTraversable, FlexibleContexts, FlexibleInstances,+             MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}  module Idris.AbsSyntaxTree where @@ -14,6 +16,7 @@ import Idris.Core.Evaluate import Idris.Core.TT import Idris.Docstrings+import Idris.Options import IRTS.CodegenCommon import IRTS.Lang import Util.DynamicLinker@@ -146,9 +149,8 @@   , ppopt_depth       :: Maybe Int   } deriving (Show) -data Optimisation = PETransform -- ^ partial eval and associated transforms-  deriving (Show, Eq, Generic) + defaultOptimise :: [Optimisation] defaultOptimise = [] @@ -183,21 +185,12 @@ ppOptionIst :: IState -> PPOption ppOptionIst = ppOption . idris_options -data LanguageExt = TypeProviders | ErrorReflection | UniquenessTypes-                 | DSLNotation   | ElabReflection  | FCReflection-                 | LinearTypes-  deriving (Show, Eq, Read, Ord, Generic)  -- | The output mode in use data OutputMode = RawOutput Handle       -- ^ Print user output directly to the handle                 | IdeMode Integer Handle -- ^ Send IDE output for some request ID to the handle                 deriving Show --- | How wide is the console?-data ConsoleWidth = InfinitelyWide -- ^ Have pretty-printer assume that lines should not be broken-                  | ColsWide Int   -- ^ Manually specified - must be positive-                  | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise-   deriving (Show, Eq, Generic)  -- | If a function has no totality annotation, what do we assume? data DefaultTotality = DefaultCheckingTotal    -- ^ Total@@ -434,55 +427,9 @@  -- Commands in the REPL -data Codegen = Via IRFormat String-             | Bytecode-    deriving (Show, Eq, Generic) -data IRFormat = IBCFormat | JSONFormat deriving (Show, Eq, Generic) -data HowMuchDocs = FullDocs | OverviewDocs -data OutputFmt = HTMLOutput | LaTeXOutput---- | Recognised logging categories for the Idris compiler.------ @TODO add in sub categories.-data LogCat = IParse-            | IElab-            | ICodeGen-            | IErasure-            | ICoverage-            | IIBC-            deriving (Show, Eq, Ord, Generic)--strLogCat :: LogCat -> String-strLogCat IParse    = "parser"-strLogCat IElab     = "elab"-strLogCat ICodeGen  = "codegen"-strLogCat IErasure  = "erasure"-strLogCat ICoverage = "coverage"-strLogCat IIBC      = "ibc"--codegenCats :: [LogCat]-codegenCats =  [ICodeGen]--parserCats :: [LogCat]-parserCats = [IParse]--elabCats :: [LogCat]-elabCats = [IElab]--loggingCatsStr :: String-loggingCatsStr = unlines-    [ (strLogCat IParse)-    , (strLogCat IElab)-    , (strLogCat ICodeGen)-    , (strLogCat IErasure)-    , (strLogCat ICoverage)-    , (strLogCat IIBC)-    ]-- data ElabShellCmd = EQED                   | EAbandon                   | EUndo@@ -494,84 +441,9 @@                   | EDocStr (Either Name Const)   deriving (Show, Eq) -data Opt = Filename String-         | Quiet-         | NoBanner-         | ColourREPL Bool-         | Idemode-         | IdemodeSocket-         | IndentWith Int-         | IndentClause Int-         | ShowAll-         | ShowLibs-         | ShowLibDir-         | ShowDocDir-         | ShowIncs-         | ShowPkgs-         | ShowLoggingCats-         | NoBasePkgs-         | NoPrelude-         | NoBuiltins -- only for the really primitive stuff!-         | NoREPL-         | OLogging Int-         | OLogCats [LogCat]-         | Output String-         | Interface-         | TypeCase-         | TypeInType-         | DefaultTotal-         | DefaultPartial-         | WarnPartial-         | WarnReach-         | AuditIPkg-         | EvalTypes-         | NoCoverage-         | ErrContext-         | ShowImpl-         | Verbose Int-         | Port REPLPort -- ^ REPL TCP port-         | IBCSubDir String-         | ImportDir String-         | SourceDir String-         | PkgBuild String-         | PkgInstall String-         | PkgClean String-         | PkgCheck String-         | PkgREPL String-         | PkgDocBuild String -- IdrisDoc-         | PkgDocInstall String-         | PkgTest String-         | PkgIndex FilePath-         | WarnOnly-         | Pkg String-         | BCAsm String-         | DumpDefun String-         | DumpCases String-         | UseCodegen Codegen-         | CodegenArgs String-         | OutputTy OutputType-         | Extension LanguageExt-         | InterpretScript String-         | EvalExpr String-         | TargetTriple String-         | TargetCPU String-         | OptLevel Int-         | AddOpt Optimisation-         | RemoveOpt Optimisation-         | Client String-         | ShowOrigErr-         | AutoWidth -- ^ Automatically adjust terminal width-         | AutoSolve -- ^ Automatically issue "solve" tactic in old-style interactive prover-         | UseConsoleWidth ConsoleWidth-         | DumpHighlights-         | DesugarNats-         | NoElimDeprecationWarnings      -- ^ Don't show deprecation warnings for %elim-         | NoOldTacticDeprecationWarnings -- ^ Don't show deprecation warnings for old-style tactics-    deriving (Show, Eq, Generic) -data REPLPort = DontListen | ListenPort PortNumber-  deriving (Eq, Generic, Show) + -- Parsed declarations  data Fixity = Infixl  { prec :: Int }@@ -1177,6 +1049,7 @@           DoBindP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (map (\(l,r)-> (mapPTermFC f g l, mapPTermFC f g r)) alts)         mapPDoFC (DoLet fc n nfc t1 t2) = DoLet (f fc) n (g nfc) (mapPTermFC f g t1) (mapPTermFC f g t2)         mapPDoFC (DoLetP fc t1 t2) = DoLetP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2)+        mapPDoFC (DoRewrite fc h) = DoRewrite (f fc) (mapPTermFC f g h) mapPTermFC f g (PIdiom fc t)                  = PIdiom (f fc) (mapPTermFC f g t) mapPTermFC f g (PMetavar fc n)                = PMetavar (g fc) n mapPTermFC f g (PProof tacs)                  = PProof (map (fmap (mapPTermFC f g)) tacs)@@ -1301,6 +1174,7 @@             | DoBindP FC t t [(t,t)]             | DoLet  FC Name FC t t   -- ^ second FC is precise name location             | DoLetP FC t t+            | DoRewrite FC t          -- rewrite in do block     deriving (Eq, Ord, Functor, Data, Generic, Typeable) {-! deriving instance Binary PDo'@@ -1312,6 +1186,7 @@   size (DoBindP fc l r alts)  = 1 + size fc + size l  + size r   + size alts   size (DoLet fc nm nfc l r)  = 1 + size fc + size nm + size l   + size r   size (DoLetP fc l r)        = 1 + size fc + size l  + size r+  size (DoRewrite fc h)       = 1 + size fc + size h  type PDo = PDo' PTerm @@ -1407,6 +1282,7 @@     getDoFC (DoBindP fc l r alts) = fc     getDoFC (DoLet fc nm nfc l r) = fc     getDoFC (DoLetP fc l r)       = fc+    getDoFC (DoRewrite fc h)      = fc  highestFC (PIdiom fc _)           = Just fc highestFC (PMetavar fc _)         = Just fc@@ -2079,6 +1955,9 @@                 group (align (hang 2 (prettySe (decD d) startPrec bnd v)))) :                ppdo ((ln, False):bnd) dos              ppdo bnd (DoLetP _ _ _ : dos) = -- ok because never made by delab+               text "no pretty printer for pattern-matching do binding" :+               ppdo bnd dos+             ppdo bnd (DoRewrite _ _ : dos) = -- ok because never made by delab                text "no pretty printer for pattern-matching do binding" :                ppdo bnd dos              ppdo _ [] = []
src/Idris/Apropos.hs view
@@ -5,6 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}+{-# LANGUAGE FlexibleInstances #-} module Idris.Apropos (apropos, aproposModules) where  import Idris.AbsSyntax
src/Idris/CaseSplit.hs view
@@ -17,7 +17,7 @@ names over '_', patterns over names, etc. -} -{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts, PatternGuards #-}  module Idris.CaseSplit(     splitOnLine, replaceSplits
src/Idris/Chaser.hs view
@@ -5,6 +5,8 @@ License     : BSD3 Maintainer  : The Idris Community. -}+{-# LANGUAGE FlexibleContexts #-}+ module Idris.Chaser(     buildTree, getImports   , getModuleFiles
src/Idris/CmdOptions.hs view
@@ -16,11 +16,8 @@   , getPkgREPL, getPkgTest, getPort, getIBCSubDir   ) where -import Idris.AbsSyntax (getClient, getIBCSubDir, getPkg, getPkgCheck,-                        getPkgClean, getPkgMkDoc, getPkgREPL, getPkgTest,-                        getPort, opt)-import Idris.AbsSyntaxTree import Idris.Info (getIdrisVersion)+import Idris.Options import IRTS.CodegenCommon  import Control.Monad.Trans (lift)@@ -28,9 +25,7 @@ import Control.Monad.Trans.Reader (ask) import Data.Char import Data.Maybe-#if MIN_VERSION_optparse_applicative(0,13,0) import Data.Monoid ((<>))-#endif import Options.Applicative import Options.Applicative.Arrows import Options.Applicative.Types (ReadM(..))
src/Idris/Core/Binary.hs view
@@ -5,6 +5,8 @@ License     : BSD3 Maintainer  : The Idris Community. -}+{-# LANGUAGE FlexibleInstances #-}+ {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Core.Binary where
src/Idris/Core/CaseTree.hs view
@@ -18,8 +18,8 @@ in order to allow for better optimisation opportunities.  -}-{-# LANGUAGE DeriveFunctor, DeriveGeneric, PatternGuards, TypeSynonymInstances-             #-}+{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances,+             PatternGuards, TypeSynonymInstances #-}  module Idris.Core.CaseTree (     CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..), ErasureInfo
src/Idris/Core/DeepSeq.hs view
@@ -5,7 +5,8 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE BangPatterns, ViewPatterns #-}+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, TypeSynonymInstances,+             ViewPatterns #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}  module Idris.Core.DeepSeq where@@ -27,7 +28,9 @@  instance NFData NameOutput instance NFData TextFormatting+#if !(MIN_VERSION_base(4,10,0)) instance NFData Ordering+#endif instance NFData OutputAnnotation instance NFData SpecialName instance NFData Universe
src/Idris/Core/Evaluate.hs view
@@ -78,6 +78,7 @@  canonical :: Value -> Bool canonical (VP (DCon _ _ _) _ _) = True+canonical (VP (TCon _ _) _ _) = True canonical (VApp f a) = canonical f canonical (VConstant _) = True canonical (VType _) = True
src/Idris/Core/Execute.hs view
@@ -36,6 +36,8 @@ import Data.Traversable (forM) import Debug.Trace import System.IO+import System.IO.Error+import System.IO.Unsafe  #ifdef IDRIS_FFI import Foreign.C.String@@ -73,6 +75,27 @@              | EHandle Handle              | EStringBuf (IORef String) +fileError :: IORef ExecVal+{-# NOINLINE fileError #-}+fileError = unsafePerformIO $ newIORef $ operationNotPermitted++operationNotPermitted =+  ioWrap $ mkRaw $ EApp (EP (DCon 0 1 False)+                            (sNS (sUN "GenericFileError") ["File", "Prelude"])+                            EErased)+                        (EConstant (I 1))++namedFileError name =+  ioWrap $ mkRaw $ (EP (DCon 0 0 False)+                       (sNS (sUN name) ["File", "Prelude"])+                       EErased)++mapError :: IOError -> ExecVal+mapError e+  | (isDoesNotExistError e) = namedFileError "FileNotFound"+  | (isPermissionError e)   = namedFileError "PermissionDenied"+  | otherwise               = operationNotPermitted+ mkRaw :: ExecVal -> ExecVal mkRaw arg = EApp (EApp (EP (DCon 0 1 False) (sNS (sUN "MkRaw") ["FFI_C"]) EErased)                        EErased) arg@@ -325,7 +348,11 @@                 ch <- execIO $ fmap (ioWrap . EConstant . I . fromEnum) getChar                 execApp env ctxt ch xs     | Just (FFun "idris_time" _ _) <- foreignFromTT arity ty fn xs-           = do execIO $ fmap (ioWrap . EConstant . I . round) getPOSIXTime+           = do execIO $ fmap (ioWrap . mkRaw . EConstant . I . round) getPOSIXTime+    | Just (FFun "idris_showerror" _ _) <- foreignFromTT arity ty fn xs+           = do execIO $ return $ ioWrap $ EConstant $ Str "Operation not permitted"+    | Just (FFun "idris_mkFileError" _ _) <- foreignFromTT arity ty fn xs+           = do execIO $ readIORef fileError     | Just (FFun "fileOpen" [(_,fileStr), (_,modeStr)] _) <- foreignFromTT arity ty fn xs            = case (fileStr, modeStr) of                (EConstant (Str f), EConstant (Str mode)) ->@@ -343,8 +370,8 @@                                                    hSetBinaryMode h' True                                                    return $ Right (ioWrap (EHandle h'), drop arity xs)                                      Left err -> return $ Left err)-                               (\e -> let _ = ( e::SomeException)-                                      in return $ Right (ioWrap (EPtr nullPtr), drop arity xs))+                               (\e -> do writeIORef fileError $ mapError e+                                         return $ Right (ioWrap (EPtr nullPtr), drop arity xs))                     case f of                       Left err -> execFail . Msg $ err                       Right (res, rest) -> execApp env ctxt res rest@@ -497,7 +524,7 @@ getOp fn (_ : _ : x : xs) | fn == pbm = Just (return x, xs) getOp fn (_ : EConstant (Str n) : xs)     | fn == pws =-              Just (do execIO $ putStr n+              Just (do execIO $ putStr n >> hFlush stdout                        return (EConstant (I 0)), xs) getOp fn (_:xs)     | fn == prs =@@ -505,7 +532,7 @@                        return (EConstant (Str line)), xs) getOp fn (_ : EP _ fn' _ : EConstant (Str n) : xs)     | fn == pwf && fn' == pstdout =-              Just (do execIO $ putStr n+              Just (do execIO $ putStr n >> hFlush stdout                        return (EConstant (I 0)), xs) getOp fn (_ : EP _ fn' _ : xs)     | fn == prf && fn' == pstdin =@@ -513,7 +540,7 @@                        return (EConstant (Str line)), xs) getOp fn (_ : EHandle h : EConstant (Str n) : xs)     | fn == pwf =-              Just (do execIO $ hPutStr h n+              Just (do execIO $ hPutStr h n >> hFlush h                        return (EConstant (I 0)), xs) getOp fn (_ : EHandle h : xs)     | fn == prf =
src/Idris/Core/ProofState.hs view
@@ -10,7 +10,8 @@ evaluation/checking inside the proof system, etc. -} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,+             PatternGuards #-} module Idris.Core.ProofState(     ProofState(..), newProof, envAtFocus, goalAtFocus   , Tactic(..), Goal(..), processTactic, nowElaboratingPS
src/Idris/Core/TT.hs view
@@ -22,8 +22,10 @@    * We have a simple collection of tactics which we use to elaborate source      programs with implicit syntax into fully explicit terms. -}-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric, FlexibleContexts,-             FunctionalDependencies, MultiParamTypeClasses, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric,+             DeriveTraversable, FlexibleContexts, FlexibleInstances,+             FunctionalDependencies, MultiParamTypeClasses, PatternGuards,+             TypeSynonymInstances #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Core.TT(     AppStatus(..), ArithTy(..), Binder(..), Const(..), Ctxt(..)
src/Idris/Core/Typecheck.hs view
@@ -6,8 +6,8 @@ Maintainer  : The Idris Community. -} -{-# LANGUAGE DeriveFunctor, FlexibleInstances, MultiParamTypeClasses,-             PatternGuards #-}+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances,+             MultiParamTypeClasses, PatternGuards #-}  module Idris.Core.Typecheck where
src/Idris/Core/Unify.hs view
@@ -11,7 +11,7 @@ a list of things which need to be injective.  -}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts, PatternGuards #-}  module Idris.Core.Unify(     match_unify, unify
src/Idris/Core/WHNF.hs view
@@ -6,7 +6,7 @@ Maintainer  : The Idris Community. -} -{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts, PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Core.WHNF(whnf, whnfArgs, WEnv) where
src/Idris/Coverage.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts, PatternGuards #-} module Idris.Coverage(genClauses, validCoverageCase, recoverableCoverage,                       mkPatTm) where @@ -410,31 +410,43 @@ -- with checkRec :: Term -> Term -> State [(Name, Term)] Bool checkRec (P Bound x _) tm-   | (P yt _ _, _) <- unApply tm,-     conType yt = do nmap <- get-                     case lookup x nmap of-                          Nothing -> do put ((x, tm) : nmap)-                                        return True-                          Just y' -> checkRec tm y'+   | isCon tm = do nmap <- get+                   case lookup x nmap of+                        Nothing -> do put ((x, tm) : nmap)+                                      return True+                        Just y' -> checkRec tm y'  where+   isCon tm+       | (P yt _ _, _) <- unApply tm,+         conType yt = True+   isCon (Constant _) = True+   isCon _ = False+    conType (DCon _ _ _) = True    conType (TCon _ _) = True    conType _ = False  checkRec tm (P Bound y _)-   | (P xt _ _, _) <- unApply tm,-     conType xt = do nmap <- get-                     case lookup y nmap of-                          Nothing -> do put ((y, tm) : nmap)-                                        return True-                          Just x' -> checkRec tm x'+   | isCon tm = do nmap <- get+                   case lookup y nmap of+                        Nothing -> do put ((y, tm) : nmap)+                                      return True+                        Just x' -> checkRec tm x'  where+   isCon tm+       | (P yt _ _, _) <- unApply tm,+         conType yt = True+   isCon (Constant _) = True+   isCon _ = False+    conType (DCon _ _ _) = True    conType (TCon _ _) = True    conType _ = False  checkRec (App _ f a) p@(P _ _ _) = checkRec f p+checkRec (App _ f a) p@(Constant _) = checkRec f p checkRec p@(P _ _ _) (App _ f a) = checkRec p f+checkRec p@(Constant _) (App _ f a) = checkRec p f checkRec fa@(App _ _ _) fa'@(App _ _ _)     | (f, as) <- unApply fa,       (f', as') <- unApply fa'@@ -454,6 +466,7 @@                                      return (aok && asok)     conType (P (DCon _ _ _) _ _) = True     conType (P (TCon _ _) _ _) = True+    conType (Constant _) = True     conType _ = False  checkRec (P xt x _) (P yt y _)@@ -469,4 +482,8 @@               | Bound <- x = True               | Bound <- y = True               | otherwise = False -- name is different, unrecoverable+-- A function reference against a constant might be recoverable if we get to+-- reduce the function+checkRec (P Ref _ _) (Constant _) = return True+checkRec (Constant _) (P Ref _ _) = return True checkRec _ _ = return False
src/Idris/DSL.hs view
@@ -109,6 +109,8 @@         = PLet fc n nfc ty tm (block b rest)     block b (DoLetP fc p tm : rest)         = PCase fc tm [(p, block b rest)]+    block b (DoRewrite fc h : rest)+        = PRewrite fc Nothing h (block b rest) Nothing     block b (DoExp fc tm : rest)         = PApp fc b             [pexp tm,
src/Idris/DataOpts.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleInstances, PatternGuards #-}  module Idris.DataOpts(applyOpts) where
src/Idris/DeepSeq.hs view
@@ -18,6 +18,7 @@ import Idris.Core.TT import Idris.Docstrings import qualified Idris.Docstrings as D+import Idris.Options import IRTS.CodegenCommon (OutputType(..)) import IRTS.Lang (PrimFn(..))
src/Idris/Docs.hs view
@@ -15,7 +15,7 @@   , FunDoc, FunDoc'(..), Docs, Docs'(..)   ) where -import Idris.AbsSyntax (FixDecl(..), Fixity, HowMuchDocs(..), IState(..), Idris,+import Idris.AbsSyntax (FixDecl(..), Fixity, IState(..), Idris,                         InterfaceInfo(..), PArg'(..), PDecl'(..), PPOption(..),                         PTerm(..), Plicity(..), RecordInfo(..), basename,                         getIState, modDocName, ppOptionIst, pprintPTerm,@@ -26,6 +26,7 @@ import Idris.Docstrings (DocTerm, Docstring, emptyDocstring, noDocs,                          nullDocstring, overview, renderDocTerm,                          renderDocstring)+import Idris.Options (HowMuchDocs(..))  import Util.Pretty
src/Idris/Docstrings.hs view
@@ -6,7 +6,8 @@ Maintainer  : The Idris Community. -} -{-# LANGUAGE DeriveFunctor, DeriveGeneric, ScopedTypeVariables #-}+{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable,+             ScopedTypeVariables #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Docstrings (     Docstring(..), Block(..), Inline(..), parseDocstring, renderDocstring
src/Idris/Elab/Clause.hs view
@@ -31,6 +31,7 @@ import Idris.Error import Idris.Imports import Idris.Inliner+import Idris.Options import Idris.Output (iRenderResult, iWarn, iputStrLn, pshow, sendHighlighting) import Idris.PartialEval import Idris.Primitives@@ -836,7 +837,7 @@          let rhs' = rhsElab -        when (not (null defer)) $ logElab 1 $ "DEFERRED " +++        when (not (null defer)) $ logElab 2 $ "DEFERRED " ++                     show (map (\ (n, (_,_,t,_)) -> (n, t)) defer)          -- If there's holes, set the metavariables as undefinable
src/Idris/Elab/Provider.hs view
@@ -30,6 +30,7 @@ import Idris.Error import Idris.Imports import Idris.Inliner+import Idris.Options import Idris.Output (iWarn, iputStrLn, pshow) import Idris.PartialEval import Idris.Primitives
src/Idris/Elab/Quasiquote.hs view
@@ -75,6 +75,7 @@        (b', ex2) <- extractUnquotes d b        return (DoLet fc n nfc v' b', ex1 ++ ex2) extractDoUnquotes d (DoLetP fc t t') = fail "Pattern-matching lets cannot be quasiquoted"+extractDoUnquotes d (DoRewrite fc h) = fail "Rewrites in Do block cannot be quasiquoted"   extractUnquotes :: Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)])
src/Idris/Elab/Term.hs view
@@ -27,6 +27,7 @@ import Idris.Elab.Utils import Idris.Error import Idris.ErrReverse (errReverse)+import Idris.Options import Idris.Output (pshow) import Idris.ProofSearch import Idris.Reflection@@ -2658,9 +2659,11 @@                                     concat (intersperse ", " (map show handlers))                          let reports = map (\n -> RApp (Var n) (reflectErr err)) handlers -                         -- Typecheck error handlers - if this fails, then something else was wrong earlier!+                         -- Typecheck error handlers - if this fails, most+                         -- likely something which is needed by it has not+                         -- been imported, so keep the original error.                          handlers <- case mapM (check (tt_ctxt ist) []) reports of-                                       Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e+                                       Error _ -> return [] -- ierror $ ReflectionFailed "Type error while constructing reflected error" e                                        OK hs   -> return hs                           -- Normalize error handler terms to produce the new messages
src/Idris/Elab/Type.hs view
@@ -32,6 +32,7 @@ import Idris.Error import Idris.Imports import Idris.Inliner+import Idris.Options import Idris.Output (iWarn, iputStrLn, pshow, sendHighlighting) import Idris.PartialEval import Idris.Primitives
src/Idris/Elab/Utils.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts, PatternGuards #-} module Idris.Elab.Utils where  import Idris.AbsSyntax@@ -449,9 +449,12 @@      = mapM_ displayImpWarning (implicit_warnings est)   where     displayImpWarning :: (FC, Name) -> Idris ()-    displayImpWarning (fc, n) =-       iputStrLn $ show fc ++ ":WARNING: " ++ show (nsroot n) ++ " is bound as an implicit\n"-                   ++ "\tDid you mean to refer to " ++ show n ++ "?"+    displayImpWarning (fc, n) = do+        ist <- getIState+        let msg = show (nsroot n)+               ++ " is bound as an implicit\n"+               ++ "\tDid you mean to refer to " ++ show n ++ "?"+        iWarn fc (pprintErr ist (Msg msg))  propagateParams :: IState -> [Name] -> Type -> [Name] -> PTerm -> PTerm propagateParams i ps t bound tm@(PApp _ (PRef fc hls n) args)@@ -767,5 +770,3 @@      collectConstraints env tcs t          | (V i, _) <- unApply t = (Just (env !! i), tcs)          | otherwise = (Nothing, tcs)--
src/Idris/Elab/Value.hs view
@@ -123,13 +123,16 @@                                             else Checked tm           | otherwise                   = Unchecked --- | Try running the term directly (as IO ()), then printing it as an Integer--- (as a default numeric tye), then printing it as any Showable thing+-- | Try running the term directly (as IO ()) or with >>= printLn appended+-- (for other IO _), then printing it as an Integer (as a default numeric+-- type), then printing it as any Showable thing elabExec :: FC -> PTerm -> PTerm elabExec fc tm = runtm (PAlternative [] FirstSuccess                    [printtm (PApp fc (PRef fc [] (sUN "the"))                      [pexp (PConstant NoFC (AType (ATInt ITBig))), pexp tm]),                     tm,+                    PApp fc (PRef fc [] (sUN ">>="))+                     [pexp tm, pexp (PRef fc [] (sUN "printLn"))],                     printtm tm                     ])   where
src/Idris/ElabDecls.hs view
@@ -41,6 +41,7 @@ import Idris.Error import Idris.Imports import Idris.Inliner+import Idris.Options import Idris.Output (iWarn, iputStrLn, pshow, sendHighlighting) import Idris.PartialEval import Idris.Primitives
src/Idris/Erasure.hs view
@@ -15,6 +15,7 @@ import Idris.Core.Evaluate import Idris.Core.TT import Idris.Error+import Idris.Options import Idris.Primitives  import Prelude hiding (id, (.))
src/Idris/Error.hs view
@@ -138,6 +138,7 @@                                    mapM_ (\(x,y) -> warnDisamb ist x >> warnDisamb ist y) cs         wStep (DoLet _ _ _ x y) = warnDisamb ist x >> warnDisamb ist y         wStep (DoLetP _ x y) = warnDisamb ist x >> warnDisamb ist y+        wStep (DoRewrite _ h) = warnDisamb ist h warnDisamb ist (PIdiom _ x) = warnDisamb ist x warnDisamb ist (PMetavar _ _) = return () warnDisamb ist (PProof tacs) = mapM_ (Foldable.mapM_ (warnDisamb ist)) tacs
src/Idris/IBC.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}  module Idris.IBC (loadIBC, loadPkgIndex,@@ -23,6 +23,7 @@ import qualified Idris.Docstrings as D import Idris.Error import Idris.Imports+import Idris.Options import Idris.Output import IRTS.System (getIdrisLibDir) @@ -47,7 +48,7 @@ import System.FilePath  ibcVersion :: Word16-ibcVersion = 160+ibcVersion = 161  -- | When IBC is being loaded - we'll load different things (and omit -- different structures/definitions) depending on which phase we're in.@@ -223,7 +224,7 @@ writeIBC :: FilePath -> FilePath -> Idris () writeIBC src f     = do-         logIBC  1 $ "Writing IBC for: " ++ show f+         logIBC  2 $ "Writing IBC for: " ++ show f          iReport 2 $ "Writing IBC for: " ++ show f          i <- getIState --          case (Data.List.map fst (idris_metavars i)) \\ primDefs of@@ -233,8 +234,8 @@          ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })          idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)                         writeArchive f ibcf-                        logIBC 1 "Written")-            (\c -> do logIBC 1 $ "Failed " ++ pshow i c)+                        logIBC 2 "Written")+            (\c -> do logIBC 2 $ "Failed " ++ pshow i c)          return ()  -- | Write a package index containing all the imports in the current@@ -244,14 +245,14 @@ writePkgIndex f     = do i <- getIState          let imps = map (\ (x, y) -> (True, x)) $ idris_imported i-         logIBC 1 $ "Writing package index " ++ show f ++ " including\n" +++         logIBC 2 $ "Writing package index " ++ show f ++ " including\n" ++                 show (map snd imps)          resetNameIdx          let ibcf = initIBC { ibc_imports = imps }          idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)                         writeArchive f ibcf-                        logIBC 1 "Written")-            (\c -> do logIBC 1 $ "Failed " ++ pshow i c)+                        logIBC 2 "Written")+            (\c -> do logIBC 2 $ "Failed " ++ pshow i c)          return ()  mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile@@ -369,7 +370,7 @@ process reexp phase archive fn = do                 ver <- getEntry 0 "ver" archive                 when (ver /= ibcVersion) $ do-                                    logIBC 1 "ibc out of date"+                                    logIBC 2 "ibc out of date"                                     let e = if ver < ibcVersion                                             then "an earlier" else "a later"                                     ldir <- runIO $ getIdrisLibDir@@ -524,10 +525,10 @@                          p -> p         case fp of             LIDR fn -> do-                logIBC 1 $ "Failed at " ++ fn+                logIBC 2 $ "Failed at " ++ fn                 ifail "Must be an ibc"             IDR fn -> do-                logIBC 1 $ "Failed at " ++ fn+                logIBC 2 $ "Failed at " ++ fn                 ifail "Must be an ibc"             IBC fn src -> loadIBC (reexp && re) phase' fn) fs @@ -650,7 +651,7 @@             case d' of                 TyDecl _ _ -> return ()                 _ -> do-                    logIBC 1 $ "SOLVING " ++ show n+                    logIBC 2 $ "SOLVING " ++ show n                     solveDeferred emptyFC n             updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })) ds     where@@ -749,9 +750,9 @@          if (not reexp)             then do-                logIBC 1 $ "Not exporting " ++ show n+                logIBC 2 $ "Not exporting " ++ show n                 setAccessibility n Hidden-            else logIBC 1 $ "Exporting " ++ show n+            else logIBC 2 $ "Exporting " ++ show n         -- Everything should be available at the REPL from         -- things imported publicly         when (phase == IBC_REPL True) $ setAccessibility n Public) ds@@ -2292,6 +2293,9 @@                                       put x1                                       put x2                                       put x3+                DoRewrite x1 x2 -> do putWord8 5+                                      put x1+                                      put x2         get           = do i <- getWord8                case i of@@ -2318,6 +2322,10 @@                            x2 <- get                            x3 <- get                            return (DoLetP x1 x2 x3)+                   5 -> do+                           x1 <- get+                           x2 <- get+                           return (DoRewrite x1 x2)                    _ -> error "Corrupted binary data for PDo'"
src/Idris/IdeMode.hs view
@@ -128,7 +128,8 @@  instance SExpable OutputAnnotation where   toSExp (AnnName n ty d t) = toSExp $ [(SymbolAtom "name", StringAtom (show n)),-                                        (SymbolAtom "implicit", BoolAtom False)] +++                                        (SymbolAtom "implicit", BoolAtom False),+                                        (SymbolAtom "key", StringAtom (encodeName n))] ++                                        maybeProps [("decor", ty)] ++                                        maybeProps [("doc-overview", d), ("type", t)] ++                                        maybeProps [("namespace", namespaceOf n)]@@ -171,6 +172,12 @@              maybeProps [("source-file", file)]   toSExp AnnQuasiquote = toSExp [(SymbolAtom "quasiquotation", True)]   toSExp AnnAntiquote = toSExp [(SymbolAtom "antiquotation", True)]++encodeName :: Name -> String+encodeName n = UTF8.toString . Base64.encode . Lazy.toStrict . Binary.encode $ n++decodeName :: String -> Name+decodeName = Binary.decode . Lazy.fromStrict . Base64.decodeLenient . UTF8.fromString  encodeTerm :: [(Name, Bool)] -> Term -> String encodeTerm bnd tm = UTF8.toString . Base64.encode . Lazy.toStrict . Binary.encode $
src/Idris/IdrisDoc.hs view
@@ -18,6 +18,7 @@ import Idris.Docs import Idris.Docstrings (nullDocstring) import qualified Idris.Docstrings as Docstrings+import Idris.Options import Idris.Parser.Helpers (opChars) import IRTS.System (getIdrisDataFileByName) @@ -343,6 +344,7 @@                                    in  concatMap extract (p1 : p2 : ps') extractPDo (DoLet   _ n _ p1 p2) = n : concatMap extract [p1, p2] extractPDo (DoLetP  _ p1 p2)     = concatMap extract [p1, p2]+extractPDo (DoRewrite  _ p)      = extract p  -- | Helper function for extractPTermNames extractPTactic :: PTactic -> [Name]
src/Idris/Info.hs view
@@ -25,8 +25,8 @@   , getIdrisDataFileByName   ) where -import Idris.AbsSyntax (loggingCatsStr) import Idris.Imports (installedPackages)+import Idris.Options (loggingCatsStr) import qualified IRTS.System as S  import Paths_idris
src/Idris/Interactive.hs view
@@ -37,7 +37,7 @@  caseSplitAt :: FilePath -> Bool -> Int -> Name -> Idris () caseSplitAt fn updatefile l n-   = do src <- runIO $ readSource fn+   = do src <- runIO $ readSourceStrict fn         (ok, res) <- splitOnLine l n fn         logLvl 1 (showSep "\n" (map show res))         let (before, (ap : later)) = splitAt (l-1) (lines src)@@ -61,7 +61,7 @@     case metavars of       Nothing -> addMissing fn updatefile l n       Just _ -> do-        src <- runIO $ readSource fn+        src <- runIO $ readSourceStrict fn         let (before, tyline : later) = splitAt (l-1) (lines src)         let indent = getIndent 0 (show n) tyline         cl <- getClause l fulln n fn@@ -88,7 +88,7 @@  addProofClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris () addProofClauseFrom fn updatefile l n-   = do src <- runIO $ readSource fn+   = do src <- runIO $ readSourceStrict fn         let (before, tyline : later) = splitAt (l-1) (lines src)         let indent = getIndent 0 (show n) tyline         cl <- getProofClause l n fn@@ -109,9 +109,9 @@  addMissing :: FilePath -> Bool -> Int -> Name -> Idris () addMissing fn updatefile l n-   = do src <- runIO $ readSource fn+   = do src <- runIO $ readSourceStrict fn         let (before, tyline : later) = splitAt (l-1) (lines src)-        let indent = getIndent 0 (show n) tyline+        let indent = getIndent tyline         i <- getIState         cl <- getInternalApp fn l         let n' = getAppName cl@@ -124,10 +124,10 @@         if updatefile           then do let fb = fn ++ "~"                   runIO $ writeSource fb (unlines (before ++ nonblank)-                                        ++ extras ++-                                           (if null extras then ""-                                                    else "\n" ++ unlines rest))-                  runIO $ copyFile fb fn+                                        ++ extras+                                        ++ (if null extras then "" else "\n")+                                        ++ unlines rest)+                  runIO $ (length src `seq` copyFile fb fn)           else iPrintResult extras     where showPat = show . stripNS           stripNS tm = mapPT dens tm where@@ -155,14 +155,12 @@                                          "\n" ++ rest))           showNew nm i _ [] = return "" -          getIndent i n [] = 0-          getIndent i n xs | take (length n) xs == n = i-          getIndent i n (x : xs) = getIndent (i + 1) n xs+          getIndent s = length (takeWhile isSpace s)   makeWith :: FilePath -> Bool -> Int -> Name -> Idris () makeWith fn updatefile l n = do-  src <- runIO $ readSource fn+  src <- runIO $ readSourceStrict fn   i <- getIState   indentWith <- getIndentWith   let (before, tyline : later) = splitAt (l-1) (lines src)@@ -186,7 +184,7 @@ -- block, using a _ for the scrutinee makeCase :: FilePath -> Bool -> Int -> Name -> Idris () makeCase fn updatefile l n-   = do src <- runIO $ readSource fn+   = do src <- runIO $ readSourceStrict fn         let (before, tyline : later) = splitAt (l-1) (lines src)         let newcase = addCaseSkel (show n) tyline @@ -226,7 +224,7 @@ doProofSearch fn updatefile rec l n hints Nothing     = doProofSearch fn updatefile rec l n hints (Just 20) doProofSearch fn updatefile rec l n hints (Just depth)-    = do src <- runIO $ readSource fn+    = do src <- runIO $ readSourceStrict fn          let (before, tyline : later) = splitAt (l-1) (lines src)          ctxt <- getContext          mn <- case lookupNames n ctxt of@@ -321,7 +319,7 @@  makeLemma :: FilePath -> Bool -> Int -> Name -> Idris () makeLemma fn updatefile l n-   = do src <- runIO $ readSource fn+   = do src <- runIO $ readSourceStrict fn         let (before, tyline : later) = splitAt (l-1) (lines src)          -- if the name is in braces, rather than preceded by a ?, treat it
src/Idris/Main.hs view
@@ -22,6 +22,7 @@ import Idris.IBC import Idris.Info import Idris.ModeCommon+import Idris.Options import Idris.Output import Idris.Parser hiding (indent) import Idris.REPL
src/Idris/ModeCommon.hs view
@@ -15,6 +15,7 @@ import Idris.IBC import Idris.Imports import Idris.Info+import Idris.Options import Idris.Output import Idris.Parser hiding (indent) import IRTS.Exports
+ src/Idris/Options.hs view
@@ -0,0 +1,283 @@+{-|+Module      : Idris.Options+Description : Compiler options for Idris.+Copyright   :+License     : BSD3+Maintainer  : The Idris Community.+-}+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric, PatternGuards #-}++module Idris.Options where++import Data.Maybe+import GHC.Generics (Generic)+import IRTS.CodegenCommon (OutputType)+import Network.Socket (PortNumber)++data Opt = Filename String+         | Quiet+         | NoBanner+         | ColourREPL Bool+         | Idemode+         | IdemodeSocket+         | IndentWith Int+         | IndentClause Int+         | ShowAll+         | ShowLibs+         | ShowLibDir+         | ShowDocDir+         | ShowIncs+         | ShowPkgs+         | ShowLoggingCats+         | NoBasePkgs+         | NoPrelude+         | NoBuiltins -- only for the really primitive stuff!+         | NoREPL+         | OLogging Int+         | OLogCats [LogCat]+         | Output String+         | Interface+         | TypeCase+         | TypeInType+         | DefaultTotal+         | DefaultPartial+         | WarnPartial+         | WarnReach+         | AuditIPkg+         | EvalTypes+         | NoCoverage+         | ErrContext+         | ShowImpl+         | Verbose Int+         | Port REPLPort -- ^ REPL TCP port+         | IBCSubDir String+         | ImportDir String+         | SourceDir String+         | PkgBuild String+         | PkgInstall String+         | PkgClean String+         | PkgCheck String+         | PkgREPL String+         | PkgDocBuild String -- IdrisDoc+         | PkgDocInstall String+         | PkgTest String+         | PkgIndex FilePath+         | WarnOnly+         | Pkg String+         | BCAsm String+         | DumpDefun String+         | DumpCases String+         | UseCodegen Codegen+         | CodegenArgs String+         | OutputTy OutputType+         | Extension LanguageExt+         | InterpretScript String+         | EvalExpr String+         | TargetTriple String+         | TargetCPU String+         | OptLevel Int+         | AddOpt Optimisation+         | RemoveOpt Optimisation+         | Client String+         | ShowOrigErr+         | AutoWidth -- ^ Automatically adjust terminal width+         | AutoSolve -- ^ Automatically issue "solve" tactic in old-style interactive prover+         | UseConsoleWidth ConsoleWidth+         | DumpHighlights+         | DesugarNats+         | NoElimDeprecationWarnings      -- ^ Don't show deprecation warnings for %elim+         | NoOldTacticDeprecationWarnings -- ^ Don't show deprecation warnings for old-style tactics+    deriving (Show, Eq, Generic)+++data REPLPort = DontListen | ListenPort PortNumber+  deriving (Eq, Generic, Show)+++data Codegen = Via IRFormat String+             | Bytecode+    deriving (Show, Eq, Generic)+++data LanguageExt = TypeProviders | ErrorReflection | UniquenessTypes+                 | DSLNotation   | ElabReflection  | FCReflection+                 | LinearTypes+  deriving (Show, Eq, Read, Ord, Generic)++data IRFormat = IBCFormat | JSONFormat deriving (Show, Eq, Generic)+++-- | How wide is the console?+data ConsoleWidth = InfinitelyWide -- ^ Have pretty-printer assume that lines should not be broken+                  | ColsWide Int   -- ^ Manually specified - must be positive+                  | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise+   deriving (Show, Eq, Generic)++data HowMuchDocs = FullDocs | OverviewDocs++data OutputFmt = HTMLOutput | LaTeXOutput++data Optimisation = PETransform -- ^ partial eval and associated transforms+  deriving (Show, Eq, Generic)++-- | Recognised logging categories for the Idris compiler.+--+-- @TODO add in sub categories.+data LogCat = IParse+            | IElab+            | ICodeGen+            | IErasure+            | ICoverage+            | IIBC+            deriving (Show, Eq, Ord, Generic)++strLogCat :: LogCat -> String+strLogCat IParse    = "parser"+strLogCat IElab     = "elab"+strLogCat ICodeGen  = "codegen"+strLogCat IErasure  = "erasure"+strLogCat ICoverage = "coverage"+strLogCat IIBC      = "ibc"++codegenCats :: [LogCat]+codegenCats =  [ICodeGen]++parserCats :: [LogCat]+parserCats = [IParse]++elabCats :: [LogCat]+elabCats = [IElab]++loggingCatsStr :: String+loggingCatsStr = unlines+    [ (strLogCat IParse)+    , (strLogCat IElab)+    , (strLogCat ICodeGen)+    , (strLogCat IErasure)+    , (strLogCat ICoverage)+    , (strLogCat IIBC)+    ]++getFile :: Opt -> Maybe String+getFile (Filename s) = Just s+getFile _ = Nothing++getBC :: Opt -> Maybe String+getBC (BCAsm s) = Just s+getBC _ = Nothing++getOutput :: Opt -> Maybe String+getOutput (Output s) = Just s+getOutput _ = Nothing++getIBCSubDir :: Opt -> Maybe String+getIBCSubDir (IBCSubDir s) = Just s+getIBCSubDir _ = Nothing++getImportDir :: Opt -> Maybe String+getImportDir (ImportDir s) = Just s+getImportDir _ = Nothing++getSourceDir :: Opt -> Maybe String+getSourceDir (SourceDir s) = Just s+getSourceDir _ = Nothing++getPkgDir :: Opt -> Maybe String+getPkgDir (Pkg s) = Just s+getPkgDir _ = Nothing++getPkg :: Opt -> Maybe (Bool, String)+getPkg (PkgBuild s)   = Just (False, s)+getPkg (PkgInstall s) = Just (True, s)+getPkg _ = Nothing++getPkgClean :: Opt -> Maybe String+getPkgClean (PkgClean s) = Just s+getPkgClean _ = Nothing++getPkgREPL :: Opt -> Maybe String+getPkgREPL (PkgREPL s) = Just s+getPkgREPL _ = Nothing++getPkgCheck :: Opt -> Maybe String+getPkgCheck (PkgCheck s) = Just s+getPkgCheck _              = Nothing++-- | Returns None if given an Opt which is not PkgMkDoc+--   Otherwise returns Just x, where x is the contents of PkgMkDoc+getPkgMkDoc :: Opt                  -- ^ Opt to extract+            -> Maybe (Bool, String) -- ^ Result+getPkgMkDoc (PkgDocBuild  str)  = Just (False,str)+getPkgMkDoc (PkgDocInstall str) = Just (True,str)+getPkgMkDoc _              = Nothing++getPkgTest :: Opt          -- ^ the option to extract+           -> Maybe String -- ^ the package file to test+getPkgTest (PkgTest f) = Just f+getPkgTest _ = Nothing++getCodegen :: Opt -> Maybe Codegen+getCodegen (UseCodegen x) = Just x+getCodegen _ = Nothing++getCodegenArgs :: Opt -> Maybe String+getCodegenArgs (CodegenArgs args) = Just args+getCodegenArgs _ = Nothing++getConsoleWidth :: Opt -> Maybe ConsoleWidth+getConsoleWidth (UseConsoleWidth x) = Just x+getConsoleWidth _ = Nothing++getExecScript :: Opt -> Maybe String+getExecScript (InterpretScript expr) = Just expr+getExecScript _ = Nothing++getPkgIndex :: Opt -> Maybe FilePath+getPkgIndex (PkgIndex file) = Just file+getPkgIndex _ = Nothing++getEvalExpr :: Opt -> Maybe String+getEvalExpr (EvalExpr expr) = Just expr+getEvalExpr _ = Nothing++getOutputTy :: Opt -> Maybe OutputType+getOutputTy (OutputTy t) = Just t+getOutputTy _ = Nothing++getLanguageExt :: Opt -> Maybe LanguageExt+getLanguageExt (Extension e) = Just e+getLanguageExt _ = Nothing++getTriple :: Opt -> Maybe String+getTriple (TargetTriple x) = Just x+getTriple _ = Nothing++getCPU :: Opt -> Maybe String+getCPU (TargetCPU x) = Just x+getCPU _ = Nothing++getOptLevel :: Opt -> Maybe Int+getOptLevel (OptLevel x) = Just x+getOptLevel _ = Nothing++getOptimisation :: Opt -> Maybe (Bool,Optimisation)+getOptimisation (AddOpt p)    = Just (True,  p)+getOptimisation (RemoveOpt p) = Just (False, p)+getOptimisation _             = Nothing++getColour :: Opt -> Maybe Bool+getColour (ColourREPL b) = Just b+getColour _ = Nothing++getClient :: Opt -> Maybe String+getClient (Client x) = Just x+getClient _ = Nothing++-- Get the first valid port+getPort :: [Opt] -> Maybe REPLPort+getPort []            = Nothing+getPort (Port p : _ ) = Just p+getPort (_      : xs) = getPort xs++opt :: (Opt -> Maybe a) -> [Opt] -> [a]+opt = mapMaybe
src/Idris/Output.hs view
@@ -6,6 +6,7 @@ Maintainer  : The Idris Community. -} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}  module Idris.Output where@@ -17,6 +18,7 @@ import Idris.Delaborate import Idris.Docstrings import Idris.IdeMode+import Idris.Options  import Util.Pretty import Util.ScreenSize (getScreenWidth)
src/Idris/Package.hs view
@@ -35,7 +35,7 @@ import Idris.IdrisDoc import Idris.Imports import Idris.Main (idris, idrisMain)-import Idris.Output (pshow)+import Idris.Options import Idris.Output import Idris.Parser (loadModule) import Idris.REPL
src/Idris/Package/Common.hs view
@@ -6,8 +6,8 @@ -} module Idris.Package.Common where -import Idris.AbsSyntaxTree (Opt(..)) import Idris.Core.TT (Name)+import Idris.Options (Opt(..))  -- | Description of an Idris package. data PkgDesc = PkgDesc {
src/Idris/Package/Parser.hs view
@@ -5,10 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE CPP, ConstraintKinds #-}-#if !(MIN_VERSION_base(4,8,0))-{-# LANGUAGE OverlappingInstances #-}-#endif+{-# LANGUAGE CPP, ConstraintKinds, FlexibleInstances, TypeSynonymInstances #-} module Idris.Package.Parser where  import Idris.AbsSyntaxTree@@ -24,7 +21,9 @@ import Control.Monad.State.Strict import Data.List (union) import Data.Maybe (fromJust, isNothing)-import System.FilePath (isValid, takeFileName)+import System.Directory (doesFileExist)+import System.Exit+import System.FilePath (isValid, takeExtension, takeFileName) import qualified Text.PrettyPrint.ANSI.Leijen as PP import Text.Trifecta hiding (char, charLiteral, natural, span, string, symbol,                       whiteSpace)@@ -48,20 +47,25 @@   {-# INLINE restOfLine #-} #endif -#if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} TokenParsing PParser where-#else-instance TokenParsing PParser where-#endif   someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()   parseDesc :: FilePath -> IO PkgDesc parseDesc fp = do-    p <- readFile fp-    case runparser pPkg defaultPkg fp p of-      Failure (ErrInfo err _) -> fail (show $ PP.plain err)-      Success x -> return x+    when (not $ takeExtension fp == ".ipkg") $ do+        putStrLn $ unwords ["The presented iPKG file does not have a '.ipkg' extension:", show fp]+        exitWith (ExitFailure 1)+    res <- doesFileExist fp+    if res+      then do+        p <- readFile fp+        case runparser pPkg defaultPkg fp p of+          Failure (ErrInfo err _) -> fail (show $ PP.plain err)+          Success x -> return x+      else do+        putStrLn $ unwords [ "The presented iPKG file does not exist:", show fp]+        exitWith (ExitFailure 1)  pPkg :: PParser PkgDesc pPkg = do
src/Idris/Parser.hs view
@@ -5,7 +5,8 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, PatternGuards #-}+{-# LANGUAGE ConstraintKinds, FlexibleContexts, GeneralizedNewtypeDeriving,+             PatternGuards #-} {-# OPTIONS_GHC -O0 #-} module Idris.Parser(module Idris.Parser,                     module Idris.Parser.Expr,@@ -26,6 +27,7 @@ import Idris.Error import Idris.IBC import Idris.Imports+import Idris.Options import Idris.Output import Idris.Parser.Data import Idris.Parser.Expr@@ -1568,7 +1570,8 @@                                  [ImportInfo],                                  Maybe Delta),                                 [(FC, OutputAnnotation)], IState)-        imports = do whiteSpace+        imports = do optional shebang+                     whiteSpace                      (mdoc, mname, annots) <- moduleHeader                      ps_exp        <- many import_                      mrk           <- mark@@ -1592,6 +1595,9 @@         addPath ((fc, AnnNamespace ns Nothing) : annots) path =            (fc, AnnNamespace ns (Just path)) : addPath annots path         addPath (annot:annots) path = annot : addPath annots path++        shebang :: IdrisParser ()+        shebang = string "#!" *> many (satisfy $ not . isEol) *> eol *> pure ()  -- | There should be a better way of doing this... findFC :: Doc -> (FC, String)
src/Idris/Parser/Data.hs view
@@ -13,6 +13,7 @@ import Idris.Core.TT import Idris.Docstrings import Idris.DSL+import Idris.Options import Idris.Parser.Expr import Idris.Parser.Helpers import Idris.Parser.Ops
src/Idris/Parser/Expr.hs view
@@ -12,6 +12,7 @@ import Idris.AbsSyntax import Idris.Core.TT import Idris.DSL+import Idris.Options import Idris.Parser.Helpers import Idris.Parser.Ops @@ -233,6 +234,7 @@                     = DoBindP fc (update ns i) (update ns t)                                  (map (\(l,r) -> (update ns l, update ns r)) ts)             upd ns (DoLetP fc i t) = DoLetP fc (update ns i) (update ns t)+            upd ns (DoRewrite fc h) = DoRewrite fc (update ns h)     update ns (PIdiom fc t) = PIdiom fc $ update ns t     update ns (PMetavar fc n) = uncurry (flip PMetavar) $ updateB ns (n, fc)     update ns (PProof tacs) = PProof $ map (updTactic ns) tacs@@ -1342,6 +1344,7 @@ Do ::=     'let' Name  TypeSig'?      '=' Expr   | 'let' Expr'                '=' Expr+  | 'rewrite Expr   | Name  '<-' Expr   | Expr' '<-' Expr   | Expr@@ -1366,6 +1369,11 @@                sc <- expr syn                highlightP kw AnnKeyword                return (DoLetP fc i sc))+   <|> try (do kw <- reservedFC "rewrite"+               fc <- getFC+               sc <- expr syn+               highlightP kw AnnKeyword+               return (DoRewrite fc sc))    <|> try (do (i, ifc) <- name                symbol "<-"                fc <- getFC
src/Idris/Parser/Helpers.hs view
@@ -5,11 +5,9 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE CPP, ConstraintKinds, GeneralizedNewtypeDeriving, PatternGuards,-             StandaloneDeriving #-}-#if !(MIN_VERSION_base(4,8,0))-{-# LANGUAGE OverlappingInstances #-}-#endif+{-# LANGUAGE CPP, ConstraintKinds, FlexibleInstances,+             GeneralizedNewtypeDeriving, PatternGuards, StandaloneDeriving,+             TypeSynonymInstances #-} module Idris.Parser.Helpers where  import Idris.AbsSyntax@@ -17,6 +15,7 @@ import Idris.Core.TT import Idris.Delaborate (pprintErr) import Idris.Docstrings+import Idris.Options import Idris.Output (iWarn)  import qualified Util.Pretty as Pretty (text)@@ -69,11 +68,7 @@  #endif -#if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} TokenParsing IdrisParser where-#else-instance TokenParsing IdrisParser where-#endif   someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()   token p = do s <- get                (FC fn (sl, sc) _) <- getFC --TODO: Update after fixing getFC
src/Idris/Parser/Ops.hs view
@@ -5,7 +5,8 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, PatternGuards #-}+{-# LANGUAGE ConstraintKinds, FlexibleContexts, GeneralizedNewtypeDeriving,+             PatternGuards #-} module Idris.Parser.Ops where  import Idris.AbsSyntax
src/Idris/PartialEval.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts, PatternGuards #-}  module Idris.PartialEval(     partial_eval, getSpecApps, specType
src/Idris/Prover.hs view
@@ -32,6 +32,7 @@ import Idris.ElabDecls import Idris.Error import qualified Idris.IdeMode as IdeMode+import Idris.Options import Idris.Output import Idris.Parser hiding (params) import Idris.TypeSearch (searchByType)@@ -349,6 +350,7 @@               Success (Right cmd') ->                 case cmd' of                   DoLetP  {} -> ifail "Pattern-matching let not supported here"+                  DoRewrite  {} -> ifail "Pattern-matching do-rewrite not supported here"                   DoBindP {} -> ifail "Pattern-matching <- not supported here"                   DoLet fc i ifc Placeholder expr ->                     do (tm, ty) <- elabVal (recinfo proverfc) ERHS (inLets ist env expr)
src/Idris/REPL.hs view
@@ -5,7 +5,7 @@ Maintainer  : The Idris Community. -} -{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts, PatternGuards #-}  module Idris.REPL   ( idemodeStart@@ -26,6 +26,10 @@ import Control.Monad.Trans (lift) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.State.Strict (evalStateT, get, put)+import qualified Data.Binary as Binary+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString.UTF8 as UTF8 import Data.Char import Data.Either (partitionEithers) import Data.List hiding (group)@@ -64,6 +68,7 @@ import Idris.Inliner import Idris.Interactive import Idris.ModeCommon+import Idris.Options import Idris.Output import Idris.Parser hiding (indent) import Idris.Prover@@ -582,6 +587,16 @@      runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id  splitName :: String -> Either String Name+splitName s | "{{{{{" `isPrefixOf` s =+              decode $ drop 5 $ reverse $ drop 5 $ reverse s+  where decode x =+          case Base64.decode (UTF8.fromString x) of+            Left err -> Left err+            Right ok ->+              case Binary.decodeOrFail (Lazy.fromStrict ok) of+                Left _ -> Left "Bad binary instance for Name"+                Right (_, _, n) -> Right n+ splitName s = case reverse $ splitOn "." s of                 [] -> Left ("Didn't understand name '" ++ s ++ "'")                 [n] -> Right . sUN $ unparen n
src/Idris/REPL/Commands.hs view
@@ -3,6 +3,7 @@ import Idris.AbsSyntaxTree import Idris.Colours import Idris.Core.TT+import Idris.Options  -- | REPL commands data Command = Quit
src/Idris/REPL/Parser.hs view
@@ -15,6 +15,7 @@ import Idris.Colours import Idris.Core.TT import Idris.Help+import Idris.Options import qualified Idris.Parser as P import Idris.REPL.Commands
src/Idris/Reflection.hs view
@@ -21,11 +21,6 @@                             initEState, pairCon, pairTy) import Idris.Delaborate (delab) -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (pure, (<$>), (<*>))-import Data.Traversable (mapM)-import Prelude hiding (mapM)-#endif import Control.Monad (liftM, liftM2, liftM4) import Control.Monad.State.Strict (lift) import Data.List (findIndex, (\\))
src/Idris/Termination.hs view
@@ -14,6 +14,7 @@ import Idris.Core.TT import Idris.Delaborate import Idris.Error+import Idris.Options import Idris.Output (iWarn, iputStrLn)  import Control.Monad.State.Strict@@ -284,8 +285,8 @@  delazy = delazy' False -- not lazy codata delazy' all t@(App _ f a)-     | (P _ (UN l) _, [_, _, arg]) <- unApply t,-       l == txt "Force" = delazy' all arg+     | (P _ (UN l) _, [P _ (UN lty) _, _, arg]) <- unApply t,+       l == txt "Force" && (all || lty /= txt "Infinite") = delazy' all arg      | (P _ (UN l) _, [P _ (UN lty) _, _, arg]) <- unApply t,        l == txt "Delay" && (all || lty /= txt "Infinite") = delazy arg      | (P _ (UN l) _, [P _ (UN lty) _, arg]) <- unApply t,
src/Util/Pretty.hs view
@@ -5,6 +5,9 @@ License     : BSD3 Maintainer  : The Idris Community. -}++{-# LANGUAGE MultiParamTypeClasses #-}+ module Util.Pretty (     module Text.PrettyPrint.Annotated.Leijen   , Sized(..)
src/Util/System.hs view
@@ -14,6 +14,7 @@                   , writeSource                   , writeSourceText                   , readSource+                  , readSourceStrict                   , setupBundledCC                   , isATTY                   ) where@@ -59,6 +60,15 @@ readSource f = do h <- openFile f ReadMode                   hSetEncoding h utf8                   hGetContents h++-- | Read a source file, make sure that the it all has been read before exiting the function.+-- | This is useful when we want to write the file again and need it to be closed.+readSourceStrict :: FilePath -> IO String+readSourceStrict f = withFile f ReadMode $+                      \h ->  do+                          hSetEncoding h utf8+                          src <- hGetContents h+                          length src `seq` return src  -- | Write a source file, same as writeFile except the encoding is set to utf-8 writeSource :: FilePath -> String -> IO ()
stack-shell.nix view
@@ -2,7 +2,7 @@  let   # MUST match resolver in stack.yaml-  resolver = haskell.packages.lts-8_06.ghc;+  resolver = haskell.packages.lts-9_0.ghc;    native_libs = [     libffi
stack.yaml view
@@ -1,4 +1,4 @@-resolver: lts-8.06+resolver: lts-9.0  packages:   - location: .
stylize.sh view
@@ -11,6 +11,7 @@     stack install --resolver "lts-$STACKVER" stylish-haskell --no-terminal fi +command -v stylish-haskell >/dev/null 2>&1 || { echo "Could not find stylish-haskell. Aborting." >&2; exit 1; }  find . -name \*.hs -and \( -not \( -name Setup.hs -or -path ./.cabal-sandbox/\* -or -path ./dist/\* \) \) | xargs stylish-haskell -i > stylish-out 2>&1
test/README.md view
@@ -124,12 +124,6 @@     stack test --test-arguments="--pattern foo042 --accept"     ``` 8. Check the content of `expected`. Maybe the test didn't do what you thought it would. Fix and go back to 7 until it's ok.-9. Add under `Extra-source-files` in `idris.cabal` the patterns that match the folder's content. If you forget this, your test will fail in Travis CI. With the previous example, it should be at least:-    ```-    test/foo042/run-    test/foo042/expected-    test/foo042/*.idr-    ```  ### Specifying compatible backends @@ -138,7 +132,7 @@  - `ANY`: choose this if your test will work with any code generator - `C_CG`: choose this to only test against the C code generator-- `JS_CG`: choose this to only test against the Node code generator+- `NODE_CG`: choose this to only test against the Node code generator - `NONE`: choose this if you don't want your test to be run with multiple code generators (mainly for tests that only perform type checking)
test/TestData.hs view
@@ -127,6 +127,7 @@     , (  7, C_CG )     , (  8, C_CG )     , (  9, C_CG )+    , ( 10, NODE_CG )     ]),   ("folding",         "Folding",     [ (  1, ANY  )]),@@ -153,7 +154,10 @@       ( 10, ANY  ),       ( 11, ANY  ),       ( 12, ANY  ),-      ( 13, ANY  )]),+      ( 13, ANY  ),+      ( 14, C_CG ),+      ( 15, ANY  ),+      ( 16, ANY  )]),   ("interfaces",      "Interfaces",     [ (  1, ANY  ),       (  2, ANY  ),@@ -162,6 +166,9 @@ --       (  5, ANY  ),       (  6, ANY  ),       (  7, ANY  )]),+  ("interpret",      "Interpret",+    [ (  1, ANY  ),+      (  2, ANY  )]),   ("io",              "IO monad",     [ (  1, C_CG ),       (  2, ANY  ),@@ -251,7 +258,8 @@       ( 77, ANY  )]),   ("regression",      "Regression",     [ (  1 , ANY  ),-      (  2 , ANY  )]),+      (  2 , ANY  ),+      (  3 , ANY  )]),   ("sourceLocation",  "Source location",     [ (  1 , ANY  )]),   ("sugar",           "Syntactic sugar",@@ -287,7 +295,8 @@       ( 19, ANY  ),       ( 20, ANY  ),       ( 21, ANY  ),-      ( 22, ANY  )]),+      ( 22, ANY  ),+      ( 23, ANY  )]),   ("tutorial",        "Tutorial examples",     [ (  1, ANY  ),       (  2, ANY  ),
test/TestRun.hs view
@@ -7,9 +7,7 @@ import Data.Char (isLetter) import qualified Data.IntMap as IMap import Data.List-#if MIN_VERSION_optparse_applicative(0,13,0) import Data.Monoid ((<>))-#endif import Data.Proxy import Data.Typeable import Options.Applicative
test/basic009/expected view
@@ -1,5 +1,5 @@ MAIN-PASS-Faulty.idr:6:9-12:WARNING: num is bound as an implicit+Faulty.idr:6:9-12:num is bound as an implicit 	Did you mean to refer to A.num? Faulty.idr:7:7:When checking right hand side of fault with expected type         num = 0
test/basic018/expected view
@@ -1,6 +1,8 @@-basic018.idr:7:12-17:WARNING: thing is bound as an implicit+basic018.idr:7:12-17:+thing is bound as an implicit 	Did you mean to refer to Main.thing?-basic018.idr:12:8-13:WARNING: thing is bound as an implicit+basic018.idr:12:8-13:+thing is bound as an implicit 	Did you mean to refer to Main.thing? basic018.idr:13:6:When checking right hand side of test with expected type         thing = S 41
test/buffer001/buffer001.idr view
@@ -26,3 +26,8 @@           closeFile h            printLn !(bufferData buf3)++          -- Small buffer, tests issue #3828+          Just small <- newBuffer 3+          setByte small 0 0+          setByte small 2 1
test/docs003/expected view
@@ -10,6 +10,7 @@                  The function is Total Implementations:+    Functor (Pair a)     Functor List     Functor (IO' ffi)     Functor Stream
+ test/ffi010/expected view
@@ -0,0 +1,3 @@+start+olare+end
+ test/ffi010/ffi010.idr view
@@ -0,0 +1,43 @@++%inline+public export+jscall : (fname : String) -> (ty : Type) ->+          {auto fty : FTy FFI_JS [] ty} -> ty+jscall fname ty = foreign FFI_JS fname ty++export+data ServiceM : Type -> Type where+  PureServ : a -> ServiceM a+++get_jsio : ServiceM a -> JS_IO (Either String a)+get_jsio (PureServ x) = do+  pure $ Right x++export+mytst : String -> ServiceM String+mytst x = PureServ $ "end"++call_fn : (String -> JS_IO String) -> String -> JS_IO String+call_fn f x = jscall+                  "%0(%1)"+                  ((JsFn (String -> JS_IO String)) -> String -> JS_IO String)+                  (MkJsFn f)+                  x++mytstJs : String -> JS_IO String+mytstJs x = do+  r <- get_jsio $ mytst "arst"+  case r of+      Right k => pure k++tst2 : JS_IO String+tst2 = call_fn mytstJs "inputmytst"++export+main : JS_IO ()+main = do+  putStrLn' "start"+  r <- tst2+  putStrLn' "olare"+  putStrLn' r
+ test/ffi010/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ ffi010.idr -o ffi010+./ffi010+rm -f ffi010 *.ibc
+ test/interactive014/expected view
@@ -0,0 +1,7 @@+aa+bb+123+cc+"dd"+456+"xyz"
+ test/interactive014/input view
@@ -0,0 +1,5 @@+:exec voidIO+:exec intIO+:exec stringIO+:exec 456+:exec "xyz"
+ test/interactive014/interactive014.idr view
@@ -0,0 +1,10 @@+voidIO : IO ()+voidIO = do putStrLn "aa"++intIO : IO Int+intIO = do putStrLn "bb"+           pure 123++stringIO : IO String+stringIO = do putStrLn "cc"+              pure "dd"
+ test/interactive014/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ --quiet --port none interactive014.idr < input+rm -f *.ibc
+ test/interactive015/expected view
@@ -0,0 +1,6 @@+test (Just x) = ?Nothing_rhs_1++test : Maybe a -> Bool+test Nothing = False+test (Just x) = ?Nothing_rhs_1+
+ test/interactive015/input view
@@ -0,0 +1,2 @@+:addmissing  3 Nothing+:addmissing! 3 Nothing
+ test/interactive015/run view
@@ -0,0 +1,8 @@+#!/usr/bin/env bash++cp src/interactive015.idr .+${IDRIS:-idris} "$@" --quiet --port none interactive015.idr < input++cat interactive015.idr++rm -f *.ibc interactive015.idr
+ test/interactive015/src/interactive015.idr view
@@ -0,0 +1,4 @@++test : Maybe a -> Bool+test Nothing = False+
+ test/interactive016/expected view
@@ -0,0 +1,7 @@++test : Maybe a -> Bool+test Nothing = False+test (Just x)  = True++other : Int+other = 3
+ test/interactive016/input view
@@ -0,0 +1,2 @@+:addmissing  3 Nothing+:addmissing! 3 Nothing
+ test/interactive016/run view
@@ -0,0 +1,8 @@+#!/usr/bin/env bash++cp src/interactive016.idr .+${IDRIS:-idris} "$@" --quiet --port none interactive016.idr < input++cat interactive016.idr++rm -f *.ibc interactive016.idr
+ test/interactive016/src/interactive016.idr view
@@ -0,0 +1,7 @@++test : Maybe a -> Bool+test Nothing = False+test (Just x)  = True++other : Int+other = 3
+ test/interactive017/TestMod.idr view
@@ -0,0 +1,5 @@+module TestMod++export+test : IO ()+test = putStrLn "Hello from a module"
+ test/interactive017/expected view
@@ -0,0 +1,7 @@+hello from C+hello from C+hello from node+hello from node+Hello ["aaa"]+Hello ["bbb", "aaa"]+Hello from a module
+ test/interactive017/run view
@@ -0,0 +1,9 @@+#!/bin/sh+PATH="../../scripts:$PATH"+./shebang.idr+./shebang.idr+./shebang-node.idr+./shebang-node.idr+./shebang-args.idr aaa+./shebang-args.idr bbb aaa+./shebang-import.idr
+ test/interactive017/shebang-args.idr view
@@ -0,0 +1,6 @@+#!/usr/bin/env runidris++main : IO () +main = do+    args <- getArgs+    putStrLn $ "Hello " ++ (show $ drop 1 args)
+ test/interactive017/shebang-import.idr view
@@ -0,0 +1,6 @@+#!/usr/bin/env runidris++import TestMod++main : IO ()+main = TestMod.test
+ test/interactive017/shebang-node.idr view
@@ -0,0 +1,4 @@+#!/usr/bin/env runidris-node++main : IO ()+main = putStrLn "hello from node"
+ test/interactive017/shebang.idr view
@@ -0,0 +1,4 @@+#!/usr/bin/env runidris++main : IO ()+main = putStrLn "hello from C"
+ test/interpret001/double-echo.idr view
@@ -0,0 +1,6 @@+module Main++main : IO ()+main = do l <- getLine+          let ll = l ++ l+          putStrLn ll
+ test/interpret001/expected view
@@ -0,0 +1,2 @@+testtest+MkIO (\w => prim_io_pure ()) : IO' (MkFFI C_Types String String) ()
+ test/interpret001/input view
@@ -0,0 +1,2 @@+:x main+test
+ test/interpret001/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ --quiet --port none --nocolour double-echo.idr < input+rm -f *.ibc
+ test/interpret002/expected view
@@ -0,0 +1,4 @@+File Not Found+MkIO (\w => prim_io_pure ()) : IO' (MkFFI C_Types String String) ()+"readable"+MkIO (\w => prim_io_pure ()) : IO' (MkFFI C_Types String String) ()
+ test/interpret002/file-error.idr view
@@ -0,0 +1,6 @@+module Main++echo : String -> IO ()+echo name = do Right contents <- readFile name+                   | Left error => printLn error+               printLn contents
+ test/interpret002/input view
@@ -0,0 +1,2 @@+:x echo "not a file"+:x echo "readable.txt"
+ test/interpret002/readable.txt view
@@ -0,0 +1,1 @@+readable
+ test/interpret002/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ --quiet --port none --nocolour file-error.idr < input+rm -f *.ibc
test/pkg001/expected view
@@ -18,3 +18,6 @@ Elaborating type decl Main.main[] Elaborating clause Main.main Rechecking for positivity []+The presented iPKG file does not have a '.ipkg' extension: "malformed-package-name"+The presented iPKG file does not exist: "non-existent-package.ipkg"+The presented iPKG file does not have a '.ipkg' extension: "non-existent-package-with-malformed-name"
test/pkg001/run view
@@ -3,3 +3,6 @@ rm -f  *.ibc ${IDRIS:-idris} $@ --build test-pkg.ipkg --quiet ${IDRIS:-idris} $@ --build test-pkg.ipkg --logging-categories "elab" --log 1+${IDRIS:-idris} $@ --build malformed-package-name+${IDRIS:-idris} $@ --build non-existent-package.ipkg+${IDRIS:-idris} $@ --build non-existent-package-with-malformed-name
test/proof002/Reflect.idr view
@@ -10,7 +10,7 @@    data Elem : a -> List a -> Type where        Stop : Elem x (x :: xs)-       Pop  : Elem x ys -> Elem x (y :: xs)+       Pop  : Elem x ys -> Elem x (y :: ys)  -- Expr is a reflection of a list, indexed over the concrete list, -- and over a set of list variables.
+ test/regression002/Canonicity.idr view
@@ -0,0 +1,13 @@+module Canonicity+%default total++data ZeroSumList : Integer -> Type where+  Cons : (m : Integer) -> ZeroSumList n -> ZeroSumList (m + n)+  Nil : ZeroSumList 0++f : ZeroSumList 0 -> Nat+f Nil = 0++NaN : Nat+NaN = f (Cons 0 Nil)+
test/regression002/expected view
@@ -110,7 +110,8 @@ This is likely to lead to problems! reg068.idr:2:6:Main.ze has a name which may be implicitly bound. This is likely to lead to problems!-reg068.idr:2:8-11:WARNING: nat is bound as an implicit+reg068.idr:2:8-11:+nat is bound as an implicit 	Did you mean to refer to Main.nat? reg068.idr:2:6:When checking constructor Main.ze: Type level variable nat is not Main.nat@@ -145,3 +146,5 @@                         -0.0                 and                         0.0+Canonicity.idr:9:1:Canonicity.f is not total as there are missing cases+Canonicity.idr:12:1:Canonicity.NaN is possibly not total due to: Canonicity.f
test/regression002/run view
@@ -32,6 +32,7 @@ :load reg076.idr :load reg077.idr :load DoubleEquality.idr+:load Canonicity.idr !  rm -f *.ibc
+ test/regression003/expected view
@@ -0,0 +1,1 @@+ola
+ test/regression003/regression003.idr view
@@ -0,0 +1,56 @@+module Main++data Free : (f : Type -> Type) -> (a : Type) -> Type where+  Pure : a -> Free f a+  Bind : f (Free f a) -> Free f a++Functor f => Functor (Free f) where+  map f m = assert_total $ case m of+    Pure x => Pure (f x)+    Bind x => Bind (map (map f) x)++Functor f => Applicative (Free f) where+  pure = Pure++  m <*> x = assert_total $ case m of+    Pure f => map f x+    Bind f => Bind (map (<*> x) f)++Functor f => Monad (Free f) where+  m >>= f = assert_total $ case m of+    Pure x => f x+    Bind x => Bind (map (>>= f) x)++liftFree : Functor f => f a -> Free f a+liftFree = assert_total $ Bind . map Pure++foldFree : (Monad m, Functor f) => ({ a : Type } -> f a -> m a) -> Free f b -> m b+foldFree f m = assert_total $ case m of+  Pure x => pure x+  Bind x => f x >>= foldFree f++data FileSystemF next+  = ReadFile (String -> next)++FileSystem : Type -> Type+FileSystem = Free FileSystemF++Functor FileSystemF where+  map f (ReadFile nextFn) = ReadFile (f . nextFn)++readFileF : FileSystem String+readFileF = liftFree $ ReadFile id++++interpret2 : FileSystemF a -> IO a+interpret2 (ReadFile nextFn) = do+  contents <- pure "ola"+  pure (nextFn contents)++main : IO ()+main =+  do+    c <- foldFree interpret2 readFileF+    putStrLn' c+
+ test/regression003/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ regression003.idr -o regression003+./regression003+rm -f regression003 *.ibc
+ test/totality023/expected view
@@ -0,0 +1,2 @@+totality023.idr:9:1:+Main.run is possibly not total due to recursive path Main.run --> Main.run
+ test/totality023/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ totality023.idr --check+rm -f *.ibc
+ test/totality023/totality023.idr view
@@ -0,0 +1,11 @@+data InfIO : Type where+     Do : IO a -> (a -> Inf InfIO) -> InfIO++foo : InfIO+foo = Do (putStr "Foo") (\x => foo)++total+run : InfIO -> IO ()+run (Do x f) = do r <- x+                  run (f r)+