diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/RELEASE-CHECKS.md b/RELEASE-CHECKS.md --- a/RELEASE-CHECKS.md +++ b/RELEASE-CHECKS.md @@ -26,6 +26,7 @@ + [ ] Push to GITHUB. + [ ] Upload to Hackage. ++ [ ] Upload package documentation to web site ## Binaries diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 } diff --git a/appveyor.yml b/appveyor.yml --- a/appveyor.yml +++ b/appveyor.yml @@ -1,7 +1,7 @@ version: 1.0.{build} init: - ps: >- - choco install cabal + choco install cabal --no-progress mkdir C:\ghc diff --git a/codegen/idris-codegen-c/Main.hs b/codegen/idris-codegen-c/Main.hs --- a/codegen/idris-codegen-c/Main.hs +++ b/codegen/idris-codegen-c/Main.hs @@ -4,6 +4,7 @@ import Idris.Core.TT import Idris.ElabDecls import Idris.Main +import Idris.Options import IRTS.CodegenC import IRTS.Compiler diff --git a/codegen/idris-codegen-javascript/Main.hs b/codegen/idris-codegen-javascript/Main.hs --- a/codegen/idris-codegen-javascript/Main.hs +++ b/codegen/idris-codegen-javascript/Main.hs @@ -4,6 +4,7 @@ import Idris.Core.TT import Idris.ElabDecls import Idris.Main +import Idris.Options import IRTS.CodegenJavaScript import IRTS.Compiler diff --git a/codegen/idris-codegen-node/Main.hs b/codegen/idris-codegen-node/Main.hs --- a/codegen/idris-codegen-node/Main.hs +++ b/codegen/idris-codegen-node/Main.hs @@ -4,6 +4,7 @@ import Idris.Core.TT import Idris.ElabDecls import Idris.Main +import Idris.Options import IRTS.CodegenJavaScript import IRTS.Compiler diff --git a/docs/effects/introduction.rst b/docs/effects/introduction.rst --- a/docs/effects/introduction.rst +++ b/docs/effects/introduction.rst @@ -65,7 +65,7 @@ import Effect.StdIO hello : Eff () [STDIO] - hello = putStrLn “Hello world!” + hello = putStrLn "Hello world!" main : IO () main = run hello diff --git a/docs/reference/codegen.rst b/docs/reference/codegen.rst --- a/docs/reference/codegen.rst +++ b/docs/reference/codegen.rst @@ -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 diff --git a/docs/reference/elaborator-reflection.rst b/docs/reference/elaborator-reflection.rst --- a/docs/reference/elaborator-reflection.rst +++ b/docs/reference/elaborator-reflection.rst @@ -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: diff --git a/docs/reference/ide-protocol.rst b/docs/reference/ide-protocol.rst --- a/docs/reference/ide-protocol.rst +++ b/docs/reference/ide-protocol.rst @@ -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. diff --git a/docs/reference/misc.rst b/docs/reference/misc.rst --- a/docs/reference/misc.rst +++ b/docs/reference/misc.rst @@ -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 ========== diff --git a/docs/reference/syntax-guide.rst b/docs/reference/syntax-guide.rst --- a/docs/reference/syntax-guide.rst +++ b/docs/reference/syntax-guide.rst @@ -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 ^^^^^^^ diff --git a/docs/st/composing.rst b/docs/st/composing.rst --- a/docs/st/composing.rst +++ b/docs/st/composing.rst @@ -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: diff --git a/docs/st/examples.rst b/docs/st/examples.rst --- a/docs/st/examples.rst +++ b/docs/st/examples.rst @@ -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 `_ by Edwin Brady. diff --git a/docs/st/machines.rst b/docs/st/machines.rst --- a/docs/st/machines.rst +++ b/docs/st/machines.rst @@ -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 diff --git a/docs/tutorial/interfaces.rst b/docs/tutorial/interfaces.rst --- a/docs/tutorial/interfaces.rst +++ b/docs/tutorial/interfaces.rst @@ -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``: diff --git a/docs/tutorial/miscellany.rst b/docs/tutorial/miscellany.rst --- a/docs/tutorial/miscellany.rst +++ b/docs/tutorial/miscellany.rst @@ -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 -------------------------- diff --git a/docs/tutorial/syntax.rst b/docs/tutorial/syntax.rst --- a/docs/tutorial/syntax.rst +++ b/docs/tutorial/syntax.rst @@ -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 diff --git a/idris.cabal b/idris.cabal --- a/idris.cabal +++ b/idris.cabal @@ -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 diff --git a/jsrts/Runtime-browser.js b/jsrts/Runtime-browser.js deleted file mode 100644 --- a/jsrts/Runtime-browser.js +++ /dev/null @@ -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 ""; -} diff --git a/jsrts/Runtime-common.js b/jsrts/Runtime-common.js --- a/jsrts/Runtime-common.js +++ b/jsrts/Runtime-common.js @@ -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); -} +}; diff --git a/jsrts/Runtime-javascript.js b/jsrts/Runtime-javascript.js new file mode 100644 --- /dev/null +++ b/jsrts/Runtime-javascript.js @@ -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') }; diff --git a/jsrts/Runtime-node.js b/jsrts/Runtime-node.js --- a/jsrts/Runtime-node.js +++ b/jsrts/Runtime-node.js @@ -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 ""; -} +}; diff --git a/jsrts/jsbn/jsbn-browser.js b/jsrts/jsbn/jsbn-browser.js new file mode 100644 --- /dev/null +++ b/jsrts/jsbn/jsbn-browser.js @@ -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<>= 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 + // + // 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); diff --git a/jsrts/jsbn/jsbn-node.js b/jsrts/jsbn/jsbn-node.js new file mode 100644 --- /dev/null +++ b/jsrts/jsbn/jsbn-node.js @@ -0,0 +1,1 @@ +$JSRTS.jsbn = require('jsbn'); diff --git a/jsrts/jsbn/jsbn.js b/jsrts/jsbn/jsbn.js deleted file mode 100644 --- a/jsrts/jsbn/jsbn.js +++ /dev/null @@ -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<= 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))<>(this.DB-sh)); - } - else - this[this.t-1] |= x<= 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)< 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< 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+=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<= 0; --i) { - r[i+ds+1] = (this[i]>>cbs)|c; - c = (this[i]&bm)<= 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; - for(var i = ds+1; i < this.t; ++i) { - r[i-ds-1] |= (this[i]&bm)<>bs; - } - if(bs > 0) r[this.t-ds-1] |= (this.s&bm)<>= 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<1)?y[ys-2]>>this.F2:0); - var d1 = this.FV/yt, d2 = (1<= 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< 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))<>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< 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+=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<>= 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< 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< 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"); diff --git a/libs/base/Control/Catchable.idr b/libs/base/Control/Catchable.idr --- a/libs/base/Control/Catchable.idr +++ b/libs/base/Control/Catchable.idr @@ -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 diff --git a/libs/base/Control/Monad/RWS.idr b/libs/base/Control/Monad/RWS.idr --- a/libs/base/Control/Monad/RWS.idr +++ b/libs/base/Control/Monad/RWS.idr @@ -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 diff --git a/libs/base/Data/Bits.idr b/libs/base/Data/Bits.idr --- a/libs/base/Data/Bits.idr +++ b/libs/base/Data/Bits.idr @@ -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 diff --git a/libs/base/Data/List/Views.idr b/libs/base/Data/List/Views.idr --- a/libs/base/Data/List/Views.idr +++ b/libs/base/Data/List/Views.idr @@ -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 diff --git a/libs/base/Data/Nat/Views.idr b/libs/base/Data/Nat/Views.idr --- a/libs/base/Data/Nat/Views.idr +++ b/libs/base/Data/Nat/Views.idr @@ -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 _))) diff --git a/libs/base/Data/SortedSet.idr b/libs/base/Data/SortedSet.idr deleted file mode 100644 --- a/libs/base/Data/SortedSet.idr +++ /dev/null @@ -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) diff --git a/libs/base/Data/String.idr b/libs/base/Data/String.idr --- a/libs/base/Data/String.idr +++ b/libs/base/Data/String.idr @@ -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. diff --git a/libs/base/Data/Vect/Views.idr b/libs/base/Data/Vect/Views.idr --- a/libs/base/Data/Vect/Views.idr +++ b/libs/base/Data/Vect/Views.idr @@ -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) diff --git a/libs/base/base.ipkg b/libs/base/base.ipkg --- a/libs/base/base.ipkg +++ b/libs/base/base.ipkg @@ -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 diff --git a/libs/contrib/Control/Algebra/NumericImplementations.idr b/libs/contrib/Control/Algebra/NumericImplementations.idr --- a/libs/contrib/Control/Algebra/NumericImplementations.idr +++ b/libs/contrib/Control/Algebra/NumericImplementations.idr @@ -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) diff --git a/libs/contrib/Control/Pipeline.idr b/libs/contrib/Control/Pipeline.idr new file mode 100644 --- /dev/null +++ b/libs/contrib/Control/Pipeline.idr @@ -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 diff --git a/libs/contrib/Control/ST.idr b/libs/contrib/Control/ST.idr --- a/libs/contrib/Control/ST.idr +++ b/libs/contrib/Control/ST.idr @@ -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) diff --git a/libs/contrib/Data/CoList.idr b/libs/contrib/Data/CoList.idr --- a/libs/contrib/Data/CoList.idr +++ b/libs/contrib/Data/CoList.idr @@ -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) diff --git a/libs/contrib/Data/Heap.idr b/libs/contrib/Data/Heap.idr --- a/libs/contrib/Data/Heap.idr +++ b/libs/contrib/Data/Heap.idr @@ -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 diff --git a/libs/contrib/Data/SortedMap.idr b/libs/contrib/Data/SortedMap.idr --- a/libs/contrib/Data/SortedMap.idr +++ b/libs/contrib/Data/SortedMap.idr @@ -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 diff --git a/libs/contrib/Data/SortedSet.idr b/libs/contrib/Data/SortedSet.idr --- a/libs/contrib/Data/SortedSet.idr +++ b/libs/contrib/Data/SortedSet.idr @@ -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 ()) diff --git a/libs/contrib/Interfaces/Verified.idr b/libs/contrib/Interfaces/Verified.idr --- a/libs/contrib/Interfaces/Verified.idr +++ b/libs/contrib/Interfaces/Verified.idr @@ -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 {} - --} diff --git a/libs/contrib/Network/Socket.idr b/libs/contrib/Network/Socket.idr --- a/libs/contrib/Network/Socket.idr +++ b/libs/contrib/Network/Socket.idr @@ -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 diff --git a/libs/contrib/Text/Lexer.idr b/libs/contrib/Text/Lexer.idr new file mode 100644 --- /dev/null +++ b/libs/contrib/Text/Lexer.idr @@ -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')) + diff --git a/libs/contrib/Text/Parser.idr b/libs/contrib/Text/Parser.idr new file mode 100644 --- /dev/null +++ b/libs/contrib/Text/Parser.idr @@ -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 + + diff --git a/libs/contrib/Text/PrettyPrint/WL.idr b/libs/contrib/Text/PrettyPrint/WL.idr new file mode 100644 --- /dev/null +++ b/libs/contrib/Text/PrettyPrint/WL.idr @@ -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 diff --git a/libs/contrib/Text/PrettyPrint/WL/Characters.idr b/libs/contrib/Text/PrettyPrint/WL/Characters.idr new file mode 100644 --- /dev/null +++ b/libs/contrib/Text/PrettyPrint/WL/Characters.idr @@ -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 '%' diff --git a/libs/contrib/Text/PrettyPrint/WL/Combinators.idr b/libs/contrib/Text/PrettyPrint/WL/Combinators.idr new file mode 100644 --- /dev/null +++ b/libs/contrib/Text/PrettyPrint/WL/Combinators.idr @@ -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) diff --git a/libs/contrib/Text/PrettyPrint/WL/Core.idr b/libs/contrib/Text/PrettyPrint/WL/Core.idr new file mode 100644 --- /dev/null +++ b/libs/contrib/Text/PrettyPrint/WL/Core.idr @@ -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 diff --git a/libs/contrib/contrib.ipkg b/libs/contrib/contrib.ipkg --- a/libs/contrib/contrib.ipkg +++ b/libs/contrib/contrib.ipkg @@ -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 diff --git a/libs/effects/Effect/System.idr b/libs/effects/Effect/System.idr --- a/libs/effects/Effect/System.idr +++ b/libs/effects/Effect/System.idr @@ -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 diff --git a/libs/prelude/Decidable/Equality.idr b/libs/prelude/Decidable/Equality.idr --- a/libs/prelude/Decidable/Equality.idr +++ b/libs/prelude/Decidable/Equality.idr @@ -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 diff --git a/libs/prelude/Prelude/Bool.idr b/libs/prelude/Prelude/Bool.idr --- a/libs/prelude/Prelude/Bool.idr +++ b/libs/prelude/Prelude/Bool.idr @@ -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 diff --git a/libs/prelude/Prelude/Cast.idr b/libs/prelude/Prelude/Cast.idr --- a/libs/prelude/Prelude/Cast.idr +++ b/libs/prelude/Prelude/Cast.idr @@ -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 diff --git a/libs/prelude/Prelude/Doubles.idr b/libs/prelude/Prelude/Doubles.idr --- a/libs/prelude/Prelude/Doubles.idr +++ b/libs/prelude/Prelude/Doubles.idr @@ -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 diff --git a/libs/prelude/Prelude/Functor.idr b/libs/prelude/Prelude/Functor.idr --- a/libs/prelude/Prelude/Functor.idr +++ b/libs/prelude/Prelude/Functor.idr @@ -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) diff --git a/libs/prelude/Prelude/Monad.idr b/libs/prelude/Prelude/Monad.idr --- a/libs/prelude/Prelude/Monad.idr +++ b/libs/prelude/Prelude/Monad.idr @@ -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 - diff --git a/libs/prelude/Prelude/Nat.idr b/libs/prelude/Prelude/Nat.idr --- a/libs/prelude/Prelude/Nat.idr +++ b/libs/prelude/Prelude/Nat.idr @@ -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 diff --git a/libs/prelude/Prelude/Strings.idr b/libs/prelude/Prelude/Strings.idr --- a/libs/prelude/Prelude/Strings.idr +++ b/libs/prelude/Prelude/Strings.idr @@ -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) diff --git a/libs/prelude/Prelude/WellFounded.idr b/libs/prelude/Prelude/WellFounded.idr --- a/libs/prelude/Prelude/WellFounded.idr +++ b/libs/prelude/Prelude/WellFounded.idr @@ -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 diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -11,6 +11,7 @@ import Idris.Error import Idris.Info.Show import Idris.Main +import Idris.Options import Idris.Package import Util.System (setupBundledCC) diff --git a/rts/idris_buffer.c b/rts/idris_buffer.c --- a/rts/idris_buffer.c +++ b/rts/idris_buffer.c @@ -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); } } diff --git a/rts/idris_gc.c b/rts/idris_gc.c --- a/rts/idris_gc.c +++ b/rts/idris_gc.c @@ -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); diff --git a/rts/idris_gmp.h b/rts/idris_gmp.h --- a/rts/idris_gmp.h +++ b/rts/idris_gmp.h @@ -7,6 +7,8 @@ #include "mini-gmp.h" #endif +#include "idris_rts.h" + // Set memory allocation functions void init_gmpalloc(void); diff --git a/rts/idris_main.c b/rts/idris_main.c --- a/rts/idris_main.c +++ b/rts/idris_main.c @@ -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 int win32_get_argv_utf8(int *argc_ptr, char ***argv_ptr) diff --git a/rts/idris_rts.c b/rts/idris_rts.c --- a/rts/idris_rts.c +++ b/rts/idris_rts.c @@ -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); diff --git a/rts/idris_rts.h b/rts/idris_rts.h --- a/rts/idris_rts.h +++ b/rts/idris_rts.h @@ -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); diff --git a/rts/idris_stdfgn.c b/rts/idris_stdfgn.c --- a/rts/idris_stdfgn.c +++ b/rts/idris_stdfgn.c @@ -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; diff --git a/scripts/runidris b/scripts/runidris new file mode 100644 --- /dev/null +++ b/scripts/runidris @@ -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" "$@" diff --git a/scripts/runidris-node b/scripts/runidris-node new file mode 100644 --- /dev/null +++ b/scripts/runidris-node @@ -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" "$@" diff --git a/src/IRTS/CodegenC.hs b/src/IRTS/CodegenC.hs --- a/src/IRTS/CodegenC.hs +++ b/src/IRTS/CodegenC.hs @@ -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 diff --git a/src/IRTS/CodegenJavaScript.hs b/src/IRTS/CodegenJavaScript.hs --- a/src/IRTS/CodegenJavaScript.hs +++ b/src/IRTS/CodegenJavaScript.hs @@ -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 "" - 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 [ "\n" + , " \n" + , " \n" + , " \n" + , " \n" + , " \n" + , " \n" + , "" + ] + +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 + }) diff --git a/src/IRTS/Compiler.hs b/src/IRTS/Compiler.hs --- a/src/IRTS/Compiler.hs +++ b/src/IRTS/Compiler.hs @@ -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 diff --git a/src/IRTS/Defunctionalise.hs b/src/IRTS/Defunctionalise.hs --- a/src/IRTS/Defunctionalise.hs +++ b/src/IRTS/Defunctionalise.hs @@ -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 diff --git a/src/IRTS/JavaScript/AST.hs b/src/IRTS/JavaScript/AST.hs --- a/src/IRTS/JavaScript/AST.hs +++ b/src/IRTS/JavaScript/AST.hs @@ -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) [] diff --git a/src/IRTS/JavaScript/Codegen.hs b/src/IRTS/JavaScript/Codegen.hs new file mode 100644 --- /dev/null +++ b/src/IRTS/JavaScript/Codegen.hs @@ -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") diff --git a/src/IRTS/JavaScript/LangTransforms.hs b/src/IRTS/JavaScript/LangTransforms.hs new file mode 100644 --- /dev/null +++ b/src/IRTS/JavaScript/LangTransforms.hs @@ -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 diff --git a/src/IRTS/JavaScript/Name.hs b/src/IRTS/JavaScript/Name.hs new file mode 100644 --- /dev/null +++ b/src/IRTS/JavaScript/Name.hs @@ -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 diff --git a/src/IRTS/JavaScript/PrimOp.hs b/src/IRTS/JavaScript/PrimOp.hs new file mode 100644 --- /dev/null +++ b/src/IRTS/JavaScript/PrimOp.hs @@ -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 diff --git a/src/IRTS/JavaScript/Specialize.hs b/src/IRTS/JavaScript/Specialize.hs new file mode 100644 --- /dev/null +++ b/src/IRTS/JavaScript/Specialize.hs @@ -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 diff --git a/src/IRTS/Lang.hs b/src/IRTS/Lang.hs --- a/src/IRTS/Lang.hs +++ b/src/IRTS/Lang.hs @@ -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 diff --git a/src/IRTS/Portable.hs b/src/IRTS/Portable.hs --- a/src/IRTS/Portable.hs +++ b/src/IRTS/Portable.hs @@ -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)] diff --git a/src/IRTS/Simplified.hs b/src/IRTS/Simplified.hs --- a/src/IRTS/Simplified.hs +++ b/src/IRTS/Simplified.hs @@ -5,6 +5,7 @@ License : BSD3 Maintainer : The Idris Community. -} +{-# LANGUAGE FlexibleContexts #-} module IRTS.Simplified(simplifyDefs, SDecl(..), SExp(..), SAlt(..)) where import Idris.Core.CaseTree diff --git a/src/IRTS/System.hs b/src/IRTS/System.hs --- a/src/IRTS/System.hs +++ b/src/IRTS/System.hs @@ -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 diff --git a/src/Idris/ASTUtils.hs b/src/Idris/ASTUtils.hs --- a/src/Idris/ASTUtils.hs +++ b/src/Idris/ASTUtils.hs @@ -48,6 +48,7 @@ import Idris.AbsSyntaxTree import Idris.Core.Evaluate import Idris.Core.TT +import Idris.Options import Prelude hiding (id, (.)) diff --git a/src/Idris/AbsSyntax.hs b/src/Idris/AbsSyntax.hs --- a/src/Idris/AbsSyntax.hs +++ b/src/Idris/AbsSyntax.hs @@ -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 diff --git a/src/Idris/AbsSyntaxTree.hs b/src/Idris/AbsSyntaxTree.hs --- a/src/Idris/AbsSyntaxTree.hs +++ b/src/Idris/AbsSyntaxTree.hs @@ -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 _ [] = [] diff --git a/src/Idris/Apropos.hs b/src/Idris/Apropos.hs --- a/src/Idris/Apropos.hs +++ b/src/Idris/Apropos.hs @@ -5,6 +5,7 @@ License : BSD3 Maintainer : The Idris Community. -} +{-# LANGUAGE FlexibleInstances #-} module Idris.Apropos (apropos, aproposModules) where import Idris.AbsSyntax diff --git a/src/Idris/CaseSplit.hs b/src/Idris/CaseSplit.hs --- a/src/Idris/CaseSplit.hs +++ b/src/Idris/CaseSplit.hs @@ -17,7 +17,7 @@ names over '_', patterns over names, etc. -} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts, PatternGuards #-} module Idris.CaseSplit( splitOnLine, replaceSplits diff --git a/src/Idris/Chaser.hs b/src/Idris/Chaser.hs --- a/src/Idris/Chaser.hs +++ b/src/Idris/Chaser.hs @@ -5,6 +5,8 @@ License : BSD3 Maintainer : The Idris Community. -} +{-# LANGUAGE FlexibleContexts #-} + module Idris.Chaser( buildTree, getImports , getModuleFiles diff --git a/src/Idris/CmdOptions.hs b/src/Idris/CmdOptions.hs --- a/src/Idris/CmdOptions.hs +++ b/src/Idris/CmdOptions.hs @@ -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(..)) diff --git a/src/Idris/Core/Binary.hs b/src/Idris/Core/Binary.hs --- a/src/Idris/Core/Binary.hs +++ b/src/Idris/Core/Binary.hs @@ -5,6 +5,8 @@ License : BSD3 Maintainer : The Idris Community. -} +{-# LANGUAGE FlexibleInstances #-} + {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Core.Binary where diff --git a/src/Idris/Core/CaseTree.hs b/src/Idris/Core/CaseTree.hs --- a/src/Idris/Core/CaseTree.hs +++ b/src/Idris/Core/CaseTree.hs @@ -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 diff --git a/src/Idris/Core/DeepSeq.hs b/src/Idris/Core/DeepSeq.hs --- a/src/Idris/Core/DeepSeq.hs +++ b/src/Idris/Core/DeepSeq.hs @@ -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 diff --git a/src/Idris/Core/Evaluate.hs b/src/Idris/Core/Evaluate.hs --- a/src/Idris/Core/Evaluate.hs +++ b/src/Idris/Core/Evaluate.hs @@ -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 diff --git a/src/Idris/Core/Execute.hs b/src/Idris/Core/Execute.hs --- a/src/Idris/Core/Execute.hs +++ b/src/Idris/Core/Execute.hs @@ -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 = diff --git a/src/Idris/Core/ProofState.hs b/src/Idris/Core/ProofState.hs --- a/src/Idris/Core/ProofState.hs +++ b/src/Idris/Core/ProofState.hs @@ -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 diff --git a/src/Idris/Core/TT.hs b/src/Idris/Core/TT.hs --- a/src/Idris/Core/TT.hs +++ b/src/Idris/Core/TT.hs @@ -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(..) diff --git a/src/Idris/Core/Typecheck.hs b/src/Idris/Core/Typecheck.hs --- a/src/Idris/Core/Typecheck.hs +++ b/src/Idris/Core/Typecheck.hs @@ -6,8 +6,8 @@ Maintainer : The Idris Community. -} -{-# LANGUAGE DeriveFunctor, FlexibleInstances, MultiParamTypeClasses, - PatternGuards #-} +{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses, PatternGuards #-} module Idris.Core.Typecheck where diff --git a/src/Idris/Core/Unify.hs b/src/Idris/Core/Unify.hs --- a/src/Idris/Core/Unify.hs +++ b/src/Idris/Core/Unify.hs @@ -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 diff --git a/src/Idris/Core/WHNF.hs b/src/Idris/Core/WHNF.hs --- a/src/Idris/Core/WHNF.hs +++ b/src/Idris/Core/WHNF.hs @@ -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 diff --git a/src/Idris/Coverage.hs b/src/Idris/Coverage.hs --- a/src/Idris/Coverage.hs +++ b/src/Idris/Coverage.hs @@ -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 diff --git a/src/Idris/DSL.hs b/src/Idris/DSL.hs --- a/src/Idris/DSL.hs +++ b/src/Idris/DSL.hs @@ -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, diff --git a/src/Idris/DataOpts.hs b/src/Idris/DataOpts.hs --- a/src/Idris/DataOpts.hs +++ b/src/Idris/DataOpts.hs @@ -5,7 +5,7 @@ License : BSD3 Maintainer : The Idris Community. -} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleInstances, PatternGuards #-} module Idris.DataOpts(applyOpts) where diff --git a/src/Idris/DeepSeq.hs b/src/Idris/DeepSeq.hs --- a/src/Idris/DeepSeq.hs +++ b/src/Idris/DeepSeq.hs @@ -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(..)) diff --git a/src/Idris/Docs.hs b/src/Idris/Docs.hs --- a/src/Idris/Docs.hs +++ b/src/Idris/Docs.hs @@ -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 diff --git a/src/Idris/Docstrings.hs b/src/Idris/Docstrings.hs --- a/src/Idris/Docstrings.hs +++ b/src/Idris/Docstrings.hs @@ -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 diff --git a/src/Idris/Elab/Clause.hs b/src/Idris/Elab/Clause.hs --- a/src/Idris/Elab/Clause.hs +++ b/src/Idris/Elab/Clause.hs @@ -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 diff --git a/src/Idris/Elab/Provider.hs b/src/Idris/Elab/Provider.hs --- a/src/Idris/Elab/Provider.hs +++ b/src/Idris/Elab/Provider.hs @@ -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 diff --git a/src/Idris/Elab/Quasiquote.hs b/src/Idris/Elab/Quasiquote.hs --- a/src/Idris/Elab/Quasiquote.hs +++ b/src/Idris/Elab/Quasiquote.hs @@ -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)]) diff --git a/src/Idris/Elab/Term.hs b/src/Idris/Elab/Term.hs --- a/src/Idris/Elab/Term.hs +++ b/src/Idris/Elab/Term.hs @@ -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 diff --git a/src/Idris/Elab/Type.hs b/src/Idris/Elab/Type.hs --- a/src/Idris/Elab/Type.hs +++ b/src/Idris/Elab/Type.hs @@ -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 diff --git a/src/Idris/Elab/Utils.hs b/src/Idris/Elab/Utils.hs --- a/src/Idris/Elab/Utils.hs +++ b/src/Idris/Elab/Utils.hs @@ -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) - - diff --git a/src/Idris/Elab/Value.hs b/src/Idris/Elab/Value.hs --- a/src/Idris/Elab/Value.hs +++ b/src/Idris/Elab/Value.hs @@ -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 diff --git a/src/Idris/ElabDecls.hs b/src/Idris/ElabDecls.hs --- a/src/Idris/ElabDecls.hs +++ b/src/Idris/ElabDecls.hs @@ -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 diff --git a/src/Idris/Erasure.hs b/src/Idris/Erasure.hs --- a/src/Idris/Erasure.hs +++ b/src/Idris/Erasure.hs @@ -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, (.)) diff --git a/src/Idris/Error.hs b/src/Idris/Error.hs --- a/src/Idris/Error.hs +++ b/src/Idris/Error.hs @@ -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 diff --git a/src/Idris/IBC.hs b/src/Idris/IBC.hs --- a/src/Idris/IBC.hs +++ b/src/Idris/IBC.hs @@ -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'" diff --git a/src/Idris/IdeMode.hs b/src/Idris/IdeMode.hs --- a/src/Idris/IdeMode.hs +++ b/src/Idris/IdeMode.hs @@ -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 $ diff --git a/src/Idris/IdrisDoc.hs b/src/Idris/IdrisDoc.hs --- a/src/Idris/IdrisDoc.hs +++ b/src/Idris/IdrisDoc.hs @@ -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] diff --git a/src/Idris/Info.hs b/src/Idris/Info.hs --- a/src/Idris/Info.hs +++ b/src/Idris/Info.hs @@ -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 diff --git a/src/Idris/Interactive.hs b/src/Idris/Interactive.hs --- a/src/Idris/Interactive.hs +++ b/src/Idris/Interactive.hs @@ -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 diff --git a/src/Idris/Main.hs b/src/Idris/Main.hs --- a/src/Idris/Main.hs +++ b/src/Idris/Main.hs @@ -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 diff --git a/src/Idris/ModeCommon.hs b/src/Idris/ModeCommon.hs --- a/src/Idris/ModeCommon.hs +++ b/src/Idris/ModeCommon.hs @@ -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 diff --git a/src/Idris/Options.hs b/src/Idris/Options.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Options.hs @@ -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 diff --git a/src/Idris/Output.hs b/src/Idris/Output.hs --- a/src/Idris/Output.hs +++ b/src/Idris/Output.hs @@ -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) diff --git a/src/Idris/Package.hs b/src/Idris/Package.hs --- a/src/Idris/Package.hs +++ b/src/Idris/Package.hs @@ -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 diff --git a/src/Idris/Package/Common.hs b/src/Idris/Package/Common.hs --- a/src/Idris/Package/Common.hs +++ b/src/Idris/Package/Common.hs @@ -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 { diff --git a/src/Idris/Package/Parser.hs b/src/Idris/Package/Parser.hs --- a/src/Idris/Package/Parser.hs +++ b/src/Idris/Package/Parser.hs @@ -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 diff --git a/src/Idris/Parser.hs b/src/Idris/Parser.hs --- a/src/Idris/Parser.hs +++ b/src/Idris/Parser.hs @@ -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) diff --git a/src/Idris/Parser/Data.hs b/src/Idris/Parser/Data.hs --- a/src/Idris/Parser/Data.hs +++ b/src/Idris/Parser/Data.hs @@ -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 diff --git a/src/Idris/Parser/Expr.hs b/src/Idris/Parser/Expr.hs --- a/src/Idris/Parser/Expr.hs +++ b/src/Idris/Parser/Expr.hs @@ -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 diff --git a/src/Idris/Parser/Helpers.hs b/src/Idris/Parser/Helpers.hs --- a/src/Idris/Parser/Helpers.hs +++ b/src/Idris/Parser/Helpers.hs @@ -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 diff --git a/src/Idris/Parser/Ops.hs b/src/Idris/Parser/Ops.hs --- a/src/Idris/Parser/Ops.hs +++ b/src/Idris/Parser/Ops.hs @@ -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 diff --git a/src/Idris/PartialEval.hs b/src/Idris/PartialEval.hs --- a/src/Idris/PartialEval.hs +++ b/src/Idris/PartialEval.hs @@ -5,7 +5,7 @@ License : BSD3 Maintainer : The Idris Community. -} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts, PatternGuards #-} module Idris.PartialEval( partial_eval, getSpecApps, specType diff --git a/src/Idris/Prover.hs b/src/Idris/Prover.hs --- a/src/Idris/Prover.hs +++ b/src/Idris/Prover.hs @@ -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) diff --git a/src/Idris/REPL.hs b/src/Idris/REPL.hs --- a/src/Idris/REPL.hs +++ b/src/Idris/REPL.hs @@ -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 diff --git a/src/Idris/REPL/Commands.hs b/src/Idris/REPL/Commands.hs --- a/src/Idris/REPL/Commands.hs +++ b/src/Idris/REPL/Commands.hs @@ -3,6 +3,7 @@ import Idris.AbsSyntaxTree import Idris.Colours import Idris.Core.TT +import Idris.Options -- | REPL commands data Command = Quit diff --git a/src/Idris/REPL/Parser.hs b/src/Idris/REPL/Parser.hs --- a/src/Idris/REPL/Parser.hs +++ b/src/Idris/REPL/Parser.hs @@ -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 diff --git a/src/Idris/Reflection.hs b/src/Idris/Reflection.hs --- a/src/Idris/Reflection.hs +++ b/src/Idris/Reflection.hs @@ -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, (\\)) diff --git a/src/Idris/Termination.hs b/src/Idris/Termination.hs --- a/src/Idris/Termination.hs +++ b/src/Idris/Termination.hs @@ -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, diff --git a/src/Util/Pretty.hs b/src/Util/Pretty.hs --- a/src/Util/Pretty.hs +++ b/src/Util/Pretty.hs @@ -5,6 +5,9 @@ License : BSD3 Maintainer : The Idris Community. -} + +{-# LANGUAGE MultiParamTypeClasses #-} + module Util.Pretty ( module Text.PrettyPrint.Annotated.Leijen , Sized(..) diff --git a/src/Util/System.hs b/src/Util/System.hs --- a/src/Util/System.hs +++ b/src/Util/System.hs @@ -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 () diff --git a/stack-shell.nix b/stack-shell.nix --- a/stack-shell.nix +++ b/stack-shell.nix @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-8.06 +resolver: lts-9.0 packages: - location: . diff --git a/stylize.sh b/stylize.sh --- a/stylize.sh +++ b/stylize.sh @@ -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 diff --git a/test/README.md b/test/README.md --- a/test/README.md +++ b/test/README.md @@ -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) diff --git a/test/TestData.hs b/test/TestData.hs --- a/test/TestData.hs +++ b/test/TestData.hs @@ -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 ), diff --git a/test/TestRun.hs b/test/TestRun.hs --- a/test/TestRun.hs +++ b/test/TestRun.hs @@ -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 diff --git a/test/basic009/expected b/test/basic009/expected --- a/test/basic009/expected +++ b/test/basic009/expected @@ -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 diff --git a/test/basic018/expected b/test/basic018/expected --- a/test/basic018/expected +++ b/test/basic018/expected @@ -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 diff --git a/test/buffer001/buffer001.idr b/test/buffer001/buffer001.idr --- a/test/buffer001/buffer001.idr +++ b/test/buffer001/buffer001.idr @@ -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 diff --git a/test/docs003/expected b/test/docs003/expected --- a/test/docs003/expected +++ b/test/docs003/expected @@ -10,6 +10,7 @@ The function is Total Implementations: + Functor (Pair a) Functor List Functor (IO' ffi) Functor Stream diff --git a/test/ffi010/expected b/test/ffi010/expected new file mode 100644 --- /dev/null +++ b/test/ffi010/expected @@ -0,0 +1,3 @@ +start +olare +end diff --git a/test/ffi010/ffi010.idr b/test/ffi010/ffi010.idr new file mode 100644 --- /dev/null +++ b/test/ffi010/ffi010.idr @@ -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 diff --git a/test/ffi010/run b/test/ffi010/run new file mode 100644 --- /dev/null +++ b/test/ffi010/run @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +${IDRIS:-idris} $@ ffi010.idr -o ffi010 +./ffi010 +rm -f ffi010 *.ibc diff --git a/test/interactive014/expected b/test/interactive014/expected new file mode 100644 --- /dev/null +++ b/test/interactive014/expected @@ -0,0 +1,7 @@ +aa +bb +123 +cc +"dd" +456 +"xyz" diff --git a/test/interactive014/input b/test/interactive014/input new file mode 100644 --- /dev/null +++ b/test/interactive014/input @@ -0,0 +1,5 @@ +:exec voidIO +:exec intIO +:exec stringIO +:exec 456 +:exec "xyz" diff --git a/test/interactive014/interactive014.idr b/test/interactive014/interactive014.idr new file mode 100644 --- /dev/null +++ b/test/interactive014/interactive014.idr @@ -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" diff --git a/test/interactive014/run b/test/interactive014/run new file mode 100644 --- /dev/null +++ b/test/interactive014/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +${IDRIS:-idris} $@ --quiet --port none interactive014.idr < input +rm -f *.ibc diff --git a/test/interactive015/expected b/test/interactive015/expected new file mode 100644 --- /dev/null +++ b/test/interactive015/expected @@ -0,0 +1,6 @@ +test (Just x) = ?Nothing_rhs_1 + +test : Maybe a -> Bool +test Nothing = False +test (Just x) = ?Nothing_rhs_1 + diff --git a/test/interactive015/input b/test/interactive015/input new file mode 100644 --- /dev/null +++ b/test/interactive015/input @@ -0,0 +1,2 @@ +:addmissing 3 Nothing +:addmissing! 3 Nothing diff --git a/test/interactive015/run b/test/interactive015/run new file mode 100644 --- /dev/null +++ b/test/interactive015/run @@ -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 diff --git a/test/interactive015/src/interactive015.idr b/test/interactive015/src/interactive015.idr new file mode 100644 --- /dev/null +++ b/test/interactive015/src/interactive015.idr @@ -0,0 +1,4 @@ + +test : Maybe a -> Bool +test Nothing = False + diff --git a/test/interactive016/expected b/test/interactive016/expected new file mode 100644 --- /dev/null +++ b/test/interactive016/expected @@ -0,0 +1,7 @@ + +test : Maybe a -> Bool +test Nothing = False +test (Just x) = True + +other : Int +other = 3 diff --git a/test/interactive016/input b/test/interactive016/input new file mode 100644 --- /dev/null +++ b/test/interactive016/input @@ -0,0 +1,2 @@ +:addmissing 3 Nothing +:addmissing! 3 Nothing diff --git a/test/interactive016/run b/test/interactive016/run new file mode 100644 --- /dev/null +++ b/test/interactive016/run @@ -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 diff --git a/test/interactive016/src/interactive016.idr b/test/interactive016/src/interactive016.idr new file mode 100644 --- /dev/null +++ b/test/interactive016/src/interactive016.idr @@ -0,0 +1,7 @@ + +test : Maybe a -> Bool +test Nothing = False +test (Just x) = True + +other : Int +other = 3 diff --git a/test/interactive017/TestMod.idr b/test/interactive017/TestMod.idr new file mode 100644 --- /dev/null +++ b/test/interactive017/TestMod.idr @@ -0,0 +1,5 @@ +module TestMod + +export +test : IO () +test = putStrLn "Hello from a module" diff --git a/test/interactive017/expected b/test/interactive017/expected new file mode 100644 --- /dev/null +++ b/test/interactive017/expected @@ -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 diff --git a/test/interactive017/run b/test/interactive017/run new file mode 100644 --- /dev/null +++ b/test/interactive017/run @@ -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 diff --git a/test/interactive017/shebang-args.idr b/test/interactive017/shebang-args.idr new file mode 100644 --- /dev/null +++ b/test/interactive017/shebang-args.idr @@ -0,0 +1,6 @@ +#!/usr/bin/env runidris + +main : IO () +main = do + args <- getArgs + putStrLn $ "Hello " ++ (show $ drop 1 args) diff --git a/test/interactive017/shebang-import.idr b/test/interactive017/shebang-import.idr new file mode 100644 --- /dev/null +++ b/test/interactive017/shebang-import.idr @@ -0,0 +1,6 @@ +#!/usr/bin/env runidris + +import TestMod + +main : IO () +main = TestMod.test diff --git a/test/interactive017/shebang-node.idr b/test/interactive017/shebang-node.idr new file mode 100644 --- /dev/null +++ b/test/interactive017/shebang-node.idr @@ -0,0 +1,4 @@ +#!/usr/bin/env runidris-node + +main : IO () +main = putStrLn "hello from node" diff --git a/test/interactive017/shebang.idr b/test/interactive017/shebang.idr new file mode 100644 --- /dev/null +++ b/test/interactive017/shebang.idr @@ -0,0 +1,4 @@ +#!/usr/bin/env runidris + +main : IO () +main = putStrLn "hello from C" diff --git a/test/interpret001/double-echo.idr b/test/interpret001/double-echo.idr new file mode 100644 --- /dev/null +++ b/test/interpret001/double-echo.idr @@ -0,0 +1,6 @@ +module Main + +main : IO () +main = do l <- getLine + let ll = l ++ l + putStrLn ll diff --git a/test/interpret001/expected b/test/interpret001/expected new file mode 100644 --- /dev/null +++ b/test/interpret001/expected @@ -0,0 +1,2 @@ +testtest +MkIO (\w => prim_io_pure ()) : IO' (MkFFI C_Types String String) () diff --git a/test/interpret001/input b/test/interpret001/input new file mode 100644 --- /dev/null +++ b/test/interpret001/input @@ -0,0 +1,2 @@ +:x main +test diff --git a/test/interpret001/run b/test/interpret001/run new file mode 100644 --- /dev/null +++ b/test/interpret001/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +${IDRIS:-idris} $@ --quiet --port none --nocolour double-echo.idr < input +rm -f *.ibc diff --git a/test/interpret002/expected b/test/interpret002/expected new file mode 100644 --- /dev/null +++ b/test/interpret002/expected @@ -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) () diff --git a/test/interpret002/file-error.idr b/test/interpret002/file-error.idr new file mode 100644 --- /dev/null +++ b/test/interpret002/file-error.idr @@ -0,0 +1,6 @@ +module Main + +echo : String -> IO () +echo name = do Right contents <- readFile name + | Left error => printLn error + printLn contents diff --git a/test/interpret002/input b/test/interpret002/input new file mode 100644 --- /dev/null +++ b/test/interpret002/input @@ -0,0 +1,2 @@ +:x echo "not a file" +:x echo "readable.txt" diff --git a/test/interpret002/readable.txt b/test/interpret002/readable.txt new file mode 100644 --- /dev/null +++ b/test/interpret002/readable.txt @@ -0,0 +1,1 @@ +readable diff --git a/test/interpret002/run b/test/interpret002/run new file mode 100644 --- /dev/null +++ b/test/interpret002/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +${IDRIS:-idris} $@ --quiet --port none --nocolour file-error.idr < input +rm -f *.ibc diff --git a/test/pkg001/expected b/test/pkg001/expected --- a/test/pkg001/expected +++ b/test/pkg001/expected @@ -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" diff --git a/test/pkg001/run b/test/pkg001/run --- a/test/pkg001/run +++ b/test/pkg001/run @@ -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 diff --git a/test/proof002/Reflect.idr b/test/proof002/Reflect.idr --- a/test/proof002/Reflect.idr +++ b/test/proof002/Reflect.idr @@ -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. diff --git a/test/regression002/Canonicity.idr b/test/regression002/Canonicity.idr new file mode 100644 --- /dev/null +++ b/test/regression002/Canonicity.idr @@ -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) + diff --git a/test/regression002/expected b/test/regression002/expected --- a/test/regression002/expected +++ b/test/regression002/expected @@ -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 diff --git a/test/regression002/run b/test/regression002/run --- a/test/regression002/run +++ b/test/regression002/run @@ -32,6 +32,7 @@ :load reg076.idr :load reg077.idr :load DoubleEquality.idr +:load Canonicity.idr ! rm -f *.ibc diff --git a/test/regression003/expected b/test/regression003/expected new file mode 100644 --- /dev/null +++ b/test/regression003/expected @@ -0,0 +1,1 @@ +ola diff --git a/test/regression003/regression003.idr b/test/regression003/regression003.idr new file mode 100644 --- /dev/null +++ b/test/regression003/regression003.idr @@ -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 + diff --git a/test/regression003/run b/test/regression003/run new file mode 100644 --- /dev/null +++ b/test/regression003/run @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +${IDRIS:-idris} $@ regression003.idr -o regression003 +./regression003 +rm -f regression003 *.ibc diff --git a/test/totality023/expected b/test/totality023/expected new file mode 100644 --- /dev/null +++ b/test/totality023/expected @@ -0,0 +1,2 @@ +totality023.idr:9:1: +Main.run is possibly not total due to recursive path Main.run --> Main.run diff --git a/test/totality023/run b/test/totality023/run new file mode 100644 --- /dev/null +++ b/test/totality023/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +${IDRIS:-idris} $@ totality023.idr --check +rm -f *.ibc diff --git a/test/totality023/totality023.idr b/test/totality023/totality023.idr new file mode 100644 --- /dev/null +++ b/test/totality023/totality023.idr @@ -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) +