packages feed

idris 1.2.0 → 1.3.0

raw patch · 198 files changed

+3127/−2566 lines, 198 filesdep ~ansi-terminaldep ~asyncdep ~fingertreesetup-changedbinary-addedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ansi-terminal, async, fingertree

API changes (from Hackage documentation)

- Idris.AbsSyntaxTree: CaseTac :: t -> PTactic' t
- Idris.AbsSyntaxTree: Induction :: t -> PTactic' t
- Idris.Core.Elaborate: casetac :: Raw -> Elab' aux ()
- Idris.Core.Elaborate: induction :: Raw -> Elab' aux ()
- Idris.Core.ProofState: CaseTac :: Raw -> Tactic
- Idris.Core.ProofState: Induction :: Raw -> Tactic
- Idris.Core.TT: DefaultCaseFun :: DataOpt
- Idris.Core.TT: DefaultEliminator :: DataOpt
- Idris.Core.TT: ElimN :: !Name -> SpecialName
- Idris.Core.TT: NoEliminator :: String -> t -> Err' t
- Idris.Elab.Term: case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()
- Idris.Options: NoElimDeprecationWarnings :: Opt
+ Idris.CmdOptions: execArgParserPure :: [String] -> ParserResult [Opt]
+ Idris.Imports: instance GHC.Classes.Ord Idris.Imports.IFileType
+ Idris.Options: AllowCapitalizedPatternVariables :: Opt
+ Idris.Package.Parser: pOptions :: PParser [Opt]
+ Idris.Parser: moduleName :: Parsing m => m Name
+ Idris.Parser.Expr: rigCount :: Parsing m => m RigCount
+ Util.System: isDarwin :: Bool
- Idris.AbsSyntax: aiFn :: Name -> Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -> FC -> [[Text]] -> [PArg] -> Either Err PTerm
+ Idris.AbsSyntax: aiFn :: Name -> Bool -> Bool -> Bool -> Bool -> [Name] -> IState -> FC -> Name -> FC -> [[Text]] -> [PArg] -> Either Err PTerm
- Idris.Parser.Expr: let_binding :: SyntaxInfo -> StateT IState WriterT FC Parsec Void String (FC, PTerm, PTerm, PTerm, [(PTerm, PTerm)])
+ Idris.Parser.Expr: let_binding :: SyntaxInfo -> StateT IState WriterT FC Parsec Void String (FC, RigCount, PTerm, PTerm, PTerm, [(PTerm, PTerm)])

Files

+ .hlint.yaml view
@@ -0,0 +1,61 @@+# HLint configuration file+# https://github.com/ndmitchell/hlint+##########################++# This file contains a template configuration file, which is typically+# placed as .hlint.yaml in the root of your project+++# Specify additional command line arguments+#+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]+++# Control which extensions/flags/modules/functions can be used+#+# - extensions:+#   - default: false # all extension are banned by default+#   - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used+#   - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module+#+# - flags:+#   - {name: -w, within: []} # -w is allowed nowhere+#+# - modules:+#   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'+#   - {name: Control.Arrow, within: []} # Certain modules are banned entirely+#+# - functions:+#   - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules+++# Add custom hints for this project+#+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}+++# Turn on hints that are off by default+#+# Ban "module X(module X) where", to require a real export list+# - warn: {name: Use explicit module export list}+#+# Replace a $ b $ c with a . b $ c+# - group: {name: dollar, enabled: true}+#+# Generalise map to fmap, ++ to <>+# - group: {name: generalise, enabled: true}+++# Ignore some builtin hints+# - ignore: {name: Use let}+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules+- ignore: {name: Use camelCase}+- ignore: {name: Reduce duplication}++# Define some custom infix operators+# - fixity: infixr 3 ~^#^~+++# To generate a suitable file for HLint do:+# $ hlint --default > .hlint.yaml
.travis.yml view
@@ -9,26 +9,33 @@  matrix:   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]}}-    - 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]}}-    - env: CABALVER="1.22" GHCVER="7.10.3" TESTS="test_js"-      compiler: ": #GHC 7.10.3"-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,cppcheck,hscolour], sources: [hvr-ghc]}}+    - env: CABALVER="2.2" GHCVER="8.4.1" STACKVER="7.14" STYLISH=YES+      addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.1,hscolour], sources: [hvr-ghc]}}     - env: CABALVER="1.22" GHCVER="7.10.3" TESTS="test_c"       compiler: ": #GHC 7.10.3"       addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,cppcheck,hscolour], sources: [hvr-ghc]}}-    - env: CABALVER="1.24" GHCVER="8.0.1" TESTS="lib_doc doc"-      compiler: ": #GHC 8.0.1"-      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,cppcheck,hscolour], sources: [hvr-ghc]}}-    - env: CABALVER="1.24" GHCVER="8.0.1" TESTS="test_js"-      compiler: ": #GHC 8.0.1"-      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,cppcheck,hscolour], sources: [hvr-ghc]}}     - 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]}}+    - env: CABALVER="2.0" GHCVER="8.2.2" TESTS="lib_doc doc"+      compiler: ": #GHC 8.2.2"+      addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,cppcheck,hscolour], sources: [hvr-ghc]}}+    - env: CABALVER="2.0" GHCVER="8.2.2" TESTS="test_js"+      compiler: ": #GHC 8.2.2"+      addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,cppcheck,hscolour], sources: [hvr-ghc]}}+    - env: CABALVER="2.0" GHCVER="8.2.2" TESTS="test_c"+      compiler: ": #GHC 8.2.2"+      addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,cppcheck,hscolour], sources: [hvr-ghc]}}+#TODO: Uncomment when tasty-rerun has been updated for base-4.11+#    - env: CABALVER="2.2" GHCVER="8.4.1" TESTS="lib_doc doc"+#      compiler: ": #GHC 8.4.1"+#      addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.1,cppcheck,hscolour], sources: [hvr-ghc]}}+#    - env: CABALVER="2.2" GHCVER="8.4.1" TESTS="test_js"+#      compiler: ": #GHC 8.4.1"+#      addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.1,cppcheck,hscolour], sources: [hvr-ghc]}}+#    - env: CABALVER="2.2" GHCVER="8.4.1" TESTS="test_c"+#      compiler: ": #GHC 8.4.1"+#      addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.1,cppcheck,hscolour], sources: [hvr-ghc]}}   fast-finish: true  cache:
CHANGELOG.md view
@@ -1,3 +1,26 @@+# New in 1.3.0++## Language updates++ Old 'induction' tactics and eliminator generation functionality ('%elim', '%case', 'elim_for') is no longer supported.+  Please, rely on the ones provided by Pruviloj and elaborator reflection instead.++## Library updates+++ Changed rndInt in Effect.Random so that it does not alternate between odd+  and even.++ Additions to `contrib`:+  * `Data.SortedBag`: Bag (or Multiset) implemention based on `Data.SortedMap`.+  * `Data.PosNat`: A `Nat` paired with a proof that it is positive.+  * `Data.Chain`: A function with an arbitrary number of arguments, plus+    combinators for working with them.++## Tool updates++ Added a switch `--allow-capitalized-pattern-variables` to optionally allow capitalized pattern variables after they were prohibited in 1.2.0.++ REPL now prints an error message if program compiled by `:exec` terminates+  abnormally.++ Idris now builds with GHC 8.4.++ In the C backend, the representation of Idris values at runtime has been reworked.+ # New in 1.2.0  ## Language updates@@ -32,7 +55,7 @@ + C FFI now supports pasting in any expression by prefixing it with '#', e.g.   ```idris   intMax : IO Int-  intMax = foreign FFI_C "#INT_MAX" (IO Int) +  intMax = foreign FFI_C "#INT_MAX" (IO Int)   ``` + The deprecated keywords `%assert_total`, `abstract`, and `[static]` have   been removed as well as the use of "public" instead of "public export" to@@ -83,7 +106,7 @@ + Removed several deprecated items from the libraries shipped with Idris. + Moved `abs` from the `Neg` interface into its own `Abs` interface.  `Nat`   implements `Abs` with `abs = id`.-+ Added `Control.ST.File`, an ST based implementation of the same behaviour ++ Added `Control.ST.File`, an ST based implementation of the same behaviour   implemented by `Effect.File` in the effects package.  ## Tool Updates
CONTRIBUTORS view
@@ -126,6 +126,7 @@ Jonas Westerlund Jonathan Sterling Joomy Korkut+Jorge Acereda Joseph Huang Josh Vera JP Smith
− HLint.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---  --------------------------------------------------------------- [ HLint.hs ]--- HLint suggestions we like.------ This is a work in progress and the list of--- suggestions/warnings/errors will vary.------  -------------------------------------------------------------------- [ EOH ]---- import "hint" HLint.HLint -- In case we want to use all of them.----  ------------------------------------------------------------ [ Suggestions ]--- Styling that are good Suggestions but are okay if found.--suggest "Use exitSuccess"-suggest "Use concatMap"-suggest "Use unwords"-suggest "Use null"-suggest "Redundant $"-suggest "Use list literal pattern"-suggest "Use list literal"----  ------------------------------------------------------------------- [ Warn ]--- Styling that we think a programmer should be warned about using.-----  ------------------------------------------------------------------ [ Error ]--- Styling that we think a programmer should not use at all.-----  ----------------------------------------------------------------- [ Ignore ]--- Suggestions we want to ignore.----  -------------------------------------------------------------------- [ EOF ]
Setup.hs view
@@ -14,10 +14,11 @@ import Distribution.Simple.LocalBuildInfo as L import qualified Distribution.Simple.Setup as S import qualified Distribution.Simple.Program as P-import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFile, notice, installOrdinaryFiles)+import Distribution.Simple.Utils import Distribution.Compiler import Distribution.PackageDescription import Distribution.Text+import Distribution.Verbosity  import System.Environment import System.Exit@@ -65,28 +66,28 @@  usesGMP :: S.ConfigFlags -> Bool usesGMP flags =-  case lookup (mkFlagName "gmp") (S.configConfigurationsFlags flags) of+  case lookupFlagAssignment (mkFlagName "gmp") (S.configConfigurationsFlags flags) of     Just True -> True     Just False -> False     Nothing -> False  execOnly :: S.ConfigFlags -> Bool execOnly flags =-  case lookup (mkFlagName "execonly") (S.configConfigurationsFlags flags) of+  case lookupFlagAssignment (mkFlagName "execonly") (S.configConfigurationsFlags flags) of     Just True -> True     Just False -> False     Nothing -> False  isRelease :: S.ConfigFlags -> Bool isRelease flags =-    case lookup (mkFlagName "release") (S.configConfigurationsFlags flags) of+    case lookupFlagAssignment (mkFlagName "release") (S.configConfigurationsFlags flags) of       Just True -> True       Just False -> False       Nothing -> False  isFreestanding :: S.ConfigFlags -> Bool isFreestanding flags =-  case lookup (mkFlagName "freestanding") (S.configConfigurationsFlags flags) of+  case lookupFlagAssignment (mkFlagName "freestanding") (S.configConfigurationsFlags flags) of     Just True -> True     Just False -> False     Nothing -> False@@ -96,6 +97,11 @@ mkFlagName = FlagName #endif +#if !(MIN_VERSION_Cabal(2,2,0))+lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool+lookupFlagAssignment = lookup+#endif+ -- ----------------------------------------------------------------------------- -- Clean @@ -115,6 +121,18 @@                   (\e -> let e' = (e :: SomeException) in return "PRE")              return $ takeWhile (/= '\n') h +-- Generate a module that contains extra library directories passed+-- via command-line to cabal+generateBuildFlagsModule :: Verbosity -> FilePath -> [String] -> IO ()+generateBuildFlagsModule verbosity dir libdirs = do+    let buildFlagsModulePath = dir </> "BuildFlags_idris" Px.<.> "hs"+    putStrLn $ "Generating " ++ buildFlagsModulePath+    createDirectoryIfMissingVerbose verbosity True dir+    rewriteFileEx verbosity buildFlagsModulePath contents+  where contents = "module BuildFlags_idris where \n\n" +++                   "extraLibDirs :: [String]\n" +++                   "extraLibDirs = " ++ show libdirs+ -- Put the Git hash into a module for use in the program -- For release builds, just put the empty string in the module generateVersionModule verbosity dir release = do@@ -123,7 +141,7 @@     putStrLn $ "Generating " ++ versionModulePath ++              if release then " for release" else " for prerelease " ++ hash     createDirectoryIfMissingVerbose verbosity True dir-    rewriteFile versionModulePath (versionModuleContents hash)+    rewriteFileEx verbosity versionModulePath (versionModuleContents hash)    where versionModuleContents h = "module Version_idris where\n\n" ++                                   "gitHash :: String\n" ++@@ -137,7 +155,7 @@     let targetModulePath = dir </> "Target_idris" Px.<.> "hs"     putStrLn $ "Generating " ++ targetModulePath     createDirectoryIfMissingVerbose verbosity True dir-    rewriteFile targetModulePath (versionModuleContents absPath targetDir)+    rewriteFileEx verbosity targetModulePath (versionModuleContents absPath targetDir)             where versionModuleContents absolute td = "module Target_idris where\n\n" ++                                     "import System.FilePath\n" ++                                     "import System.Environment\n" ++@@ -163,12 +181,14 @@                                    "getToolchainDir = \"\""     let toolPath = srcDir </> "Tools_idris" Px.<.> "hs"     createDirectoryIfMissingVerbose verbosity True srcDir-    rewriteFile toolPath (commonContent ++ toolContent)+    rewriteFileEx verbosity toolPath (commonContent ++ toolContent)  idrisConfigure _ flags pkgdesc local = do     configureRTS-    withLibLBI pkgdesc local $ \_ libcfg -> do+    withLibLBI pkgdesc local $ \lib libcfg -> do       let libAutogenDir = autogenComponentModulesDir local libcfg+      let libDirs = extraLibDirs $ libBuildInfo lib+      generateBuildFlagsModule verbosity libAutogenDir libDirs       generateVersionModule verbosity libAutogenDir (isRelease (configFlags local))       if isFreestanding $ configFlags local           then do@@ -199,6 +219,7 @@   let dir = S.fromFlag (S.sDistDirectory flags)   let verb = S.fromFlag (S.sDistVerbosity flags)   generateVersionModule verb "src" True+  generateBuildFlagsModule verb "src" []   generateTargetModule verb "src" "./libs"   generateToolchainModule verb "src" Nothing   preSDist simpleUserHooks args flags@@ -224,6 +245,11 @@              (\e -> let e' = (e :: SomeException) in return ())   postSDist simpleUserHooks args flags desc lbi +#if !(MIN_VERSION_Cabal(2,0,0))+rewriteFileEx :: Verbosity -> FilePath -> String -> IO ()+rewriteFileEx _ = rewriteFile+#endif+ -- ----------------------------------------------------------------------------- -- Build @@ -250,7 +276,7 @@         return (Nothing, []) #endif -idrisBuild _ flags _ local +idrisBuild _ flags _ local    = if (execOnly (configFlags local)) then buildRTS         else do buildStdLib                 buildRTS@@ -272,7 +298,7 @@ -- ----------------------------------------------------------------------------- -- Copy/Install -idrisInstall verbosity copy pkg local +idrisInstall verbosity copy pkg local    = if (execOnly (configFlags local)) then installRTS         else do installStdLib                 installRTS
benchmarks/build.pl view
@@ -2,13 +2,14 @@  $bmarks = `cat ALL`; @bm = split(/\n/, $bmarks);+$idris = $ENV{'IDRIS'} || "idris";  foreach $b (@bm) {     if ($b =~ /([a-zA-Z0-9]+)\/([a-zA-Z0-9]+)\s+(.*)/) {         print "Building $1 / $2\n";         chdir $1;-        system("idris --clean $2.ipkg");-        system("idris --build $2.ipkg");+        system("$idris --clean $2.ipkg");+        system("$idris --build $2.ipkg") == 0 or die "Unable to build $2: $?";         chdir "..";     } }
benchmarks/fasta/fasta.idr view
@@ -3,10 +3,19 @@ import System  alu : String+alu = "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG"+   ++ "TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG"+   ++ "CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC"+   ++ "GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"++{- The following string literal syntax doesn't work anymore. Until fixed we shall concat the strings. alu = "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG\     \TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG\     \CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC\     \GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"++-}+  iub : List (Char, Double) iub = [('a',0.27),('c',0.12),('g',0.12),('t',0.27),('B',0.02)
config.mk view
@@ -14,7 +14,7 @@ CABAL           :=cabal # IDRIS_ENABLE_STATS should not be set in final release # Any flags defined here which alter the RTS API must also be added to src/IRTS/CodegenC.hs-CFLAGS          :=-O2 -Wall -DHAS_PTHREAD -DIDRIS_ENABLE_STATS $(CFLAGS)+CFLAGS          :=-O2 -Wall -std=c99 -pipe -fdata-sections -ffunction-sections -D_POSIX_C_SOURCE=200809L -DHAS_PTHREAD -DIDRIS_ENABLE_STATS $(CFLAGS)  # CABALFLAGS	:= CABALFLAGS      += --enable-tests
docs/conf.py view
@@ -59,9 +59,9 @@ # built documents. # # The short X.Y version.-version = '1.2'+version = '1.3' # The full version, including alpha/beta/rc tags.-release = '1.2.0'+release = '1.3.0'  # The language for content autogenerated by Sphinx. Refer to documentation # for a list of supported languages.
docs/faq/faq.rst view
@@ -173,8 +173,10 @@ argument which converges to a base case.  - Mutually recursive functions are supported+ - However, all functions on the path must be fully applied. In particular,   higher order applications are not supported+ - Idris identifies arguments which converge to a base case by looking for   recursive calls to syntactically smaller arguments of inputs. e.g.   ``k`` is syntactically smaller than ``S (S k)`` because ``k`` is a@@ -233,14 +235,17 @@ flag, the IDRIS_LIB_DIR environment variable needs to be set to the path where the Idris libs reside relative to the idris executable. The IDRIS_TOOLCHAIN_DIR environment variable is optional, if that is set,-Idris will use that path to find the C compiler.+Idris will use that path to find the C compiler. For example: -Example::+:: -   IDRIS_LIB_DIR="./libs" IDRIS_TOOLCHAIN_DIR="./mingw/bin" CABALFLAGS="-fffi -ffreestanding -frelease" make+   IDRIS_LIB_DIR="./libs" \+   IDRIS_TOOLCHAIN_DIR="./mingw/bin" \+   CABALFLAGS="-fffi -ffreestanding -frelease" \+   make  -What does the name ‘Idris’ mean?+What does the name “Idris” mean? ================================  British people of a certain age may be familiar with this@@ -256,16 +261,20 @@ - It's hard to type (this is important if you're using someone else's code, for   example). Various editors have their own input methods, but you have to know   what they are.+ - Not every piece of software easily supports it. Rendering issues have been   noted on some mobile email clients, terminal-based IRC clients, web browsers,   etc. There are ways to resolve these rendering issues but they provide a   barrier to entry to using Idris.+ - Even if we leave it out of the standard library (which we will in any case!)   as soon as people start using it in their library code, others have to deal   with it.+ - Too many characters look too similar. We had enough trouble with confusion   between 0 and O without worrying about all the different kinds of colons and   brackets.+ - There seems to be a tendency to go over the top with use of Unicode. For   example, using sharp and flat for delay and force (or is it the other way   around?) in Agda seems gratuitous. We don't want to encourage this sort of@@ -280,7 +289,7 @@ Law <http://www.haskell.org/haskellwiki/Wadler%27s_Law>`__ in action.  This answer is based on Edwin Brady's response in the following-`pull request <https://github.com/idris-lang/Idris-dev/pull/694#issuecomment-29559291>`__.+`pull request <https://github.com/idris-lang/Idris-dev/pull/694#issuecomment-29559291>`_.  Where can I find the community standards for the Idris community? ==================================================================
docs/guides/type-providers-ffi.rst view
@@ -200,6 +200,7 @@     module Providers      %dynamic "./stattypes.so"+    %access export      sizeOfDevT : IO Int     sizeOfDevT = foreign FFI_C "sizeof_dev_t" (IO Int)@@ -207,9 +208,10 @@      -- Indicates how many bits are used to represent various system     -- stat types.+    public export     data BitWidth = B8 | B16 | B32 | B64 -    implementation Show BitWidth where+    Show BitWidth where       show B8 = "8 bits"       show B16 = "16 bits"       show B32 = "32 bits"
docs/listing/idris-prompt-helloworld.txt view
@@ -1,7 +1,7 @@ $ idris hello.idr      ____    __     _     /  _/___/ /____(_)____-    / // __  / ___/ / ___/     Version 1.2.0+    / // __  / ___/ / ___/     Version 1.3.0   _/ // /_/ / /  / (__  )      http://www.idris-lang.org/  /___/\__,_/_/  /_/____/       Type :? for help
docs/listing/idris-prompt-interp.txt view
@@ -1,7 +1,7 @@ $ idris interp.idr      ____    __     _     /  _/___/ /____(_)____-    / // __  / ___/ / ___/     Version 1.2.0+    / // __  / ___/ / ___/     Version 1.3.0   _/ // /_/ / /  / (__  )      http://www.idris-lang.org/  /___/\__,_/_/  /_/____/       Type :? for help
docs/listing/idris-prompt-start.txt view
@@ -1,7 +1,7 @@ $ idris     ____    __     _    /  _/___/ /____(_)____-   / // __  / ___/ / ___/     Version 1.2.0+   / // __  / ___/ / ___/     Version 1.3.0  _/ // /_/ / /  / (__  )      http://www.idris-lang.org/ /___/\__,_/_/  /_/____/       Type :? for help
docs/reference/compilation.rst view
@@ -63,17 +63,17 @@ of Idris is captured using a category based logger. Currently, the logging infrastructure has support for the following categories: -+ Parser-+ Elaborator-+ Code generation-+ Erasure-+ Coverage Checking-+ IBC generation++ Parser (``parser``)++ Elaborator (``elab``)++ Code generation (``codegen``)++ Erasure (``erasure``)++ Coverage Checking (``coverage``)++ IBC generation (``ibc``)   These categories are specified using the command-line option: ``--logging-categories CATS``, where ``CATS`` is a quoted colon-seperated string of the categories you want to see. By default if this+separated string of the categories you want to see. By default if this option is not specified all categories are allowed.  Sub-categories have yet to be defined but will be in the future, especially for the elaborator.
docs/reference/elaborator-reflection.rst view
@@ -6,7 +6,7 @@  The Idris elaborator is responsible for converting high-level Idris code into the core language. It is implemented as a kind of embedded tactic language in Haskell, where tactic scripts are written in an *elaboration monad* that provides error handling and a proof state.-For details, see Edwin Brady's 2013 paper in the Journal of Functional Programming.+For details, see [Edwin Brady's 2013 paper in the Journal of Functional Programming](https://eb.host.cs.st-andrews.ac.uk/drafts/impldtp.pdf).  Elaborator reflection makes the elaboration type as well as a selection of its tactics available to Idris code. This means that metaprograms written in Idris can have complete control over the elaboration process, generating arbitrary code, and they have access to all of the facilities available in the elaborator, such as higher-order unification, type checking, and emitting auxiliary definitions.
docs/reference/erasure.rst view
@@ -103,7 +103,7 @@  This ought not to be the case since the ``Nat`` are never used at runtime and they are only there for typechecking purposes. Hence we-should get rid of them and get runtime code similar to what a idris+should get rid of them and get runtime code similar to what an Idris programmer would write.  U-views of lists@@ -127,7 +127,7 @@        x0   y0    (two)       x1   y1    (two)-      x2   y1    (two)+      x2   y2    (two)          z       (one)  When recursing over this structure, the values of ``xs`` range over
docs/reference/misc.rst view
@@ -220,7 +220,7 @@    source <(idris --bash-completion-script `which idris`)  -To enable completion permenatly you must either:+To enable completion permanently you must either:  * Modify your bash init script with the above command.
docs/reference/packages.rst view
@@ -123,7 +123,7 @@ Using Package files =================== -Given an Idris package file ``text.ipkg`` it can be used with the Idris compiler as follows:+Given an Idris package file ``test.ipkg`` it can be used with the Idris compiler as follows:  + ``idris --build test.ipkg`` will build all modules in the package
docs/reference/tactics.rst view
@@ -173,19 +173,6 @@      Vect Z a     -lemma> -induction-------------  ``induction`` - (``Note that this is still experimental`` and you may-   get strange results and error messages. We are aware of these and-   will finish the implementation eventually!) Prove the goal by-   induction. Each constructor of the datatype becomes a goal.-   Constructors with recursive arguments become induction steps, while-   simple constructors become base cases. Note that this only works for-   datatypes that have eliminators: a datatype definition must have the-   ``%elim`` modifier.-- sourceLocation --------------
docs/st/composing.rst view
@@ -1,7 +1,7 @@ .. _composing:  ************************-Composing State Machines +Composing State Machines ************************  In the previous section, we defined a ``DataStore`` interface and used it@@ -28,7 +28,7 @@  Furthermore, we may have *hierarchies* of state machines, in that one state machine could be implemented by composing several others. For-example, we can have a state machine representing the state of a +example, we can have a state machine representing the state of a graphics system, and use this to implement a *higher level* graphics API such as turtle graphics, which uses the graphics system plus some additional state for the turtle.@@ -50,7 +50,7 @@     *LoginCount> :exec main     Enter password: Mornington Crescent     Secret is: "Secret Data"-    Enter password: Dollis Hill +    Enter password: Dollis Hill     Failure     Number of failures: 1     Enter password: Mornington Crescent@@ -63,7 +63,7 @@ We'll start by adding a state resource to ``getData`` to keep track of the number of failures: -.. code-block:: idrs+.. code-block:: idris    getData : (ConsoleIO m, DataStore m) =>             (failcount : Var) -> ST m () [failcount ::: State Integer]@@ -116,7 +116,7 @@                 Required result states here are: st2_fn  In other words, ``connect`` requires that there are *no* resources on-entry, but we have *one*, the failure count!  +entry, but we have *one*, the failure count! This shouldn't be a problem, though: the required resources are a *subset* of the resources we have, after all, and the additional resources (here, the failure count) are not relevant to ``connect``. What we need, therefore,@@ -214,7 +214,7 @@ appear in ``old`` can't appear in the ``sub`` list more than once (you will get a type error if you try this). -The function ``updateWith`` takes the *output* resources of the +The function ``updateWith`` takes the *output* resources of the called function, and updates them in the current resource list. It makes an effort to preserve ordering as far as possible, although this isn't always possible if the called function does some complicated resource@@ -338,7 +338,7 @@  .. code-block:: idris -    interface Draw (m : Type -> Type) where +    interface Draw (m : Type -> Type) where         Surface : Type  We'll need to be able to create a new ``Surface`` by opening a window:@@ -369,7 +369,7 @@   an operation returns ``Just ty``, there's also ``addIfRight``:    .. code-block:: idris-     +      addIfJust : Type -> Action (Maybe Var)      addIfRight : Type -> Action (Either a Var) @@ -378,10 +378,10 @@   of an operation:    .. code-block:: idris-  +      Add : (ty -> Resources) -> Action ty-  -  Using this, you can create your own actions to add resources ++  Using this, you can create your own actions to add resources   based on the result of an operation, if required. For example,   ``addIfJust`` is implemented as follows: @@ -479,7 +479,7 @@  The ``flip win`` at the end is necessary because the drawing primitives are double buffered, to prevent flicker. We draw onto one buffer, off-screen,-and display the other.  When we call ``flip``, it displays the off-screen +and display the other.  When we call ``flip``, it displays the off-screen buffer, and creates a new off-screen buffer for drawing the next frame.  To include this in a program, we'll write a main loop which renders our@@ -496,7 +496,7 @@  Finally, we can create a main program which initialises a window, if possible, then runs the main loop:-                + .. code-block:: idris    drawMain : (ConsoleIO m, Draw m) => ST m () []@@ -593,7 +593,7 @@  .. code-block:: idris -  data Composite : List Type -> Type +  data Composite : List Type -> Type  If we have a composite resource, we can split it into its constituent resources, and create new variables for each of those resources, using@@ -604,7 +604,7 @@   splitComp : (comp : Var) -> ST m () [comp ::: Composite [State Int, State String]]   splitComp comp = do [int, str] <- split comp                       ?whatNow- + The call ``split comp`` extracts the ``State Int`` and ``State String`` from the composite resource ``comp``, and stores them in the variables ``int`` and ``str`` respectively. If we check the type of ``whatNow``, we'll see@@ -713,7 +713,7 @@   Line : Type   Line = ((Int, Int), (Int, Int), Col) -To implement ``start``, which creates a new ``Turtle`` (or returns ``Nothing`` +To implement ``start``, which creates a new ``Turtle`` (or returns ``Nothing`` if this is impossible), we begin by initialising the drawing surface then all of the components of the state. Finally, we combine all of these into a composite resource for the turtle:
docs/st/introduction.rst view
@@ -70,7 +70,7 @@ =======  This tutorial starts (:ref:`introst`) by describing how to manipulate-individual states, introduce a data type ``STrans`` for describing stateful+individual states, introduces a data type ``STrans`` for describing stateful functions, and ``ST`` which describes top level state transitions. Next (:ref:`smstypes`) it describes how to represent state machines in types, and how to define *interfaces* for describing stateful systems.
docs/st/state.rst view
@@ -456,7 +456,7 @@  .. code-block:: idris -    prf : InState lbl (State ty) res}+    prf : InState lbl (State ty) res  This relies on a predicate ``InState``. A value of type ``InState x ty res`` means that the reference ``x`` must have type ``ty`` in the list of
docs/tutorial/interactive.rst view
@@ -23,13 +23,12 @@ for `Emacs <https://github.com/idris-hackers/idris-mode>`_ is also available. - Editing at the REPL ===================  The REPL provides a number of commands, which we will describe shortly, which generate new program fragments based on the currently-loaded module. These take the general form+loaded module. These take the general form:  :: @@ -64,9 +63,9 @@ :addclause ---------- -The ``:addclause n f`` command (abbreviated ``:ac n f``) creates a+The ``:addclause n f`` command, abbreviated ``:ac n f``, creates a template definition for the function named ``f`` declared on line-``n``.  For example, if the code beginning on line 94 contains:+``n``. For example, if the code beginning on line 94 contains:  .. code-block:: idris @@ -129,7 +128,7 @@  The ``:addmissing n f`` command, abbreviated ``:am n f``, adds the clauses which are required to make the function ``f`` on line ``n``-cover all inputs. For example, if the code beginning on line 94 is+cover all inputs. For example, if the code beginning on line 94 is:  .. code-block:: idris @@ -143,7 +142,7 @@      vzipWith f (x :: xs) (y :: ys) = ?vzipWith_rhs_2 -That is, it notices that there are no cases for non-empty vectors,+That is, it notices that there are no cases for empty vectors, generates the required clauses, and eliminates the clauses which would lead to unification errors.
docs/tutorial/interfaces.rst view
@@ -11,8 +11,8 @@ to display different types in a uniform way.  To achieve this, we use *interfaces*, which are similar to type classes in-Haskell or traits in Rust.  To define an interface, we provide a collection of-overloadable functions.  A simple example is the ``Show``+Haskell or traits in Rust. To define an interface, we provide a collection of+overloadable functions. A simple example is the ``Show`` interface, which is defined in the prelude and provides an interface for converting values to ``String``: @@ -31,8 +31,7 @@ We can read this as: “under the constraint that ``a`` has an implementation of ``Show``, take an input ``a`` and return a ``String``.” An implementation of an interface is defined by giving definitions of the methods of the interface.-For example, the-``Show`` implementation for ``Nat`` could be defined as:+For example, the ``Show`` implementation for ``Nat`` could be defined as:  .. code-block:: idris @@ -49,7 +48,7 @@ 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) or variables-(i.e. you cannot give an implementation for a function).  For+(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``:@@ -534,7 +533,7 @@  It can be desirable to have multiple implementations of an interface for the same type, for example to provide alternative methods for sorting or printing-values.  To achieve this, implementations can be *named* as follows:+values. To achieve this, implementations can be *named* as follows:  .. code-block:: idris @@ -574,7 +573,7 @@     interface Semigroup ty where       (<+>) : ty -> ty -> ty -Then it defines ``Monoid``, which extends ``Semigroup`` with a "neutral"+Then it defines ``Monoid``, which extends ``Semigroup`` with a “neutral” value:  .. code-block:: idris
docs/tutorial/interp.rst view
@@ -106,7 +106,7 @@      Var : HasType i G t -> Expr G t -So, in an expression ``\x,\y. x y``, the variable ``x`` would have a+So, in an expression ``\x. \y. x y``, the variable ``x`` would have a de Bruijn index of 1, represented as ``Pop Stop``, and ``y 0``, represented as ``Stop``. We find these by counting the number of lambdas between the definition and the use.@@ -194,7 +194,7 @@     interp env (If x t e)  = if interp env x then interp env t                                              else interp env e -Let us look at each case in turn.  To translate a variable, we simply look it+Let us look at each case in turn. To translate a variable, we simply look it up in the environment:  .. code-block:: idris
docs/tutorial/miscellany.rst view
@@ -8,7 +8,7 @@  + auto, implicit, and default arguments; + literate programming;-+ interfacing with external libraries through the foreign function++ interfacing with external libraries through the foreign function; + interface; + type providers; + code generation; and@@ -23,7 +23,7 @@ .. code-block:: idris      index : {a:Type} -> {n:Nat} -> Fin n -> Vect n a -> a-    + Auto implicit arguments ------------------------ @@ -69,17 +69,17 @@ .. code-block:: idris      head xs {p = ?headProof}-    + Default implicit arguments --------------------------- -Besides having Idris automatically find a value of a given type, sometimes we +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. +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 +If we want to compute the n'th fibonacci number (and defining the 0th fibonacci number as 0), we could write:  .. code-block:: idris@@ -89,8 +89,8 @@ 	fibonacci {lag} {lead} (S n) = 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 +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.  @@ -329,13 +329,13 @@ C Target ======== -The default target of Idris is C. Compiling via :+The default target of Idris is C. Compiling via:  ::      $ idris hello.idr -o hello -is equivalent to :+is equivalent to:  :: @@ -344,14 +344,14 @@ When the command above is used, a temporary C source is generated, which is then compiled into an executable named ``hello``. -In order to view the generated C code, compile via :+In order to view the generated C code, compile via:  ::      $ idris hello.idr -S -o hello.c  To turn optimisations on, use the ``%flag C`` pragma within the code, as-is shown below :+is shown below:  .. code-block:: idris @@ -368,7 +368,7 @@  To compile the generated C with debugging information e.g. to use ``gdb`` to debug segmentation faults in Idris programs, use the-``%flag C`` pragma to include debugging symbols, as is shown below :+``%flag C`` pragma to include debugging symbols, as is shown below:  .. code-block:: idris @@ -503,13 +503,13 @@  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+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+The *JavaScript* and *NodeJS* backends of Idris will also lookup for the file on that location.  Including *NodeJS* modules@@ -552,7 +552,7 @@     *universe> :t Vect     Vect : Nat -> Type -> Type -But what about the type of ``Type``? If we ask Idris it reports+But what about the type of ``Type``? If we ask Idris it reports:  :: @@ -560,8 +560,8 @@     Type : Type 1  If ``Type`` were its own type, it would lead to an inconsistency due to-`Girard’s paradox <http://www.cs.cmu.edu/afs/cs.cmu.edu/user/kw/www/scans/girard72thesis.pdf>`_ , so internally there is a-*hierarchy* of types (or *universes*):+`Girard’s paradox <http://www.cs.cmu.edu/afs/cs.cmu.edu/user/kw/www/scans/girard72thesis.pdf>`_,+so internally there is a *hierarchy* of types (or *universes*):  .. code-block:: idris
docs/tutorial/modules.rst view
@@ -53,8 +53,7 @@               print (Btree.toList t)  The same names can be defined in multiple modules: names are *qualified* with-the name of the module.  The names defined in the ``Btree`` module are, in-full:+the name of the module. The names defined in the ``Btree`` module are, in full:  + ``Btree.BTree`` + ``Btree.Leaf``@@ -74,7 +73,7 @@ ``foo/bar.idr``, which would conventionally have the module declaration ``module foo.bar``. The only requirement for module names is that the main module, with the ``main`` function, must be called-``Main``—although its filename need not be ``Main.idr``.+``Main`` — although its filename need not be ``Main.idr``.  Export Modifiers ================@@ -82,18 +81,16 @@ Idris allows for fine-grained control over the visibility of a module's contents. By default, all names defined in a module are kept private.  This aides in specification of a minimal interface and for-internal details to be left hidden.  Idris allows for functions,+internal details to be left hidden. Idris allows for functions, types, and interfaces to be marked as: ``private``, ``export``, or-``public export``.  Their general meaning is as follows:+``public export``. Their general meaning is as follows: -- ``private`` meaning that it's not exported at all. This is the-  default.+- ``private`` meaning that it's not exported at all. This is the default.  - ``export`` meaning that its top level type is exported.  - ``public export`` meaning that the entire definition is exported. - A further restriction in modifying the visibility is that definitions must not refer to anything within a lower level of visibility. For example, ``public export`` definitions cannot use private names, and@@ -129,10 +126,9 @@  For data types, the meanings are: -- ``export``  the type constructor is exported+- ``export`` the type constructor is exported -- ``public export`` the type constructor and data constructors are-  exported+- ``public export`` the type constructor and data constructors are exported   Meaning for Interfaces@@ -141,6 +137,7 @@ For interfaces, the meanings are:  - ``export`` the interface name is exported+ - ``public export`` the interface name, method names and default   definitions are exported
docs/tutorial/packages.rst view
@@ -1,27 +1,32 @@+.. _sect-packages:+ ******** Packages ******** --Idris includes a simple build system for building packages and executables from a named package description file.-These files can be used with the Idris compiler to manage the development process .+Idris includes a simple build system for building packages and executables+from a named package description file. These files can be used with the+Idris compiler to manage the development process .  Package Descriptions ====================  A package description includes the following: -+ A header, consisting of the keyword package followed by the package++ A header, consisting of the keyword ``package`` followed by a package   name. Package names can be any valid Idris identifier. The iPKG   format also takes a quoted version that accepts any valid filename.-+ Fields describing package contents, ``<field> = <value>`` ++ Fields describing package contents, ``<field> = <value>``.+ At least one field must be the modules field, where the value is a-comma separated list of modules.  For example, given an idris package+comma separated list of modules. For example, given an idris package ``maths`` that has modules ``Maths.idr``, ``Maths.NumOps.idr``, ``Maths.BinOps.idr``, and ``Maths.HexOps.idr``, the corresponding-package file would be::+package file would be: +::+     package maths      modules = Maths@@ -38,7 +43,6 @@ Using Package files =================== - Idris itself is aware about packages, and special commands are available to help with, for example, building packages, installing packages, and cleaning packages.  For instance, given the ``maths``@@ -54,8 +58,10 @@  Once the maths package has been installed, the command line option ``--package maths`` makes it accessible (abbreviated to ``-p maths``).-For example::+For example: +::+     idris -p maths Main.idr  @@ -66,20 +72,18 @@ This framework collects functions listed in the ``ipkg`` file under ``tests``. All test functions must return ``IO ()``. - When you enter ``idris --testpkg yourmodule.ipkg``, the build system creates a temporary file in a fresh environment on your machine by listing the ``tests`` functions under a single ``main`` function. It compiles this temporary file to an executable and then executes it. - The tests themselves are responsible for reporting their success or failure. Test functions commonly use ``putStrLn`` to report test results. The test framework does not impose any standards for reporting and consequently does not aggregate test results. --For example, lets take the following list of functions that are defined in a module called ``NumOps`` for a sample package ``maths``.+For example, lets take the following list of functions that are defined in a+module called ``NumOps`` for a sample package ``maths``:  .. name: Math/NumOps.idr .. code-block:: idris@@ -94,8 +98,9 @@     triple : Num a => a -> a     triple a = a + double a -A simple test module, with a qualified name of ``Test.NumOps`` can be declared as +A simple test module, with a qualified name of ``Test.NumOps`` can be declared as:+ .. name: Math/TestOps.idr .. code-block:: idris @@ -122,9 +127,12 @@     testTriple = assertNotEq (triple 2) 5  -The functions ``assertEq`` and ``assertNotEq`` are used to run expected passing, and failing, equality tests.-The actual tests are ``testDouble`` and ``testTriple``, and are declared in the ``maths.ipkg`` file as follows::+The functions ``assertEq`` and ``assertNotEq`` are used to run expected passing,+and failing, equality tests. The actual tests are ``testDouble`` and ``testTriple``,+and are declared in the ``maths.ipkg`` file as follows: +::+     package maths      modules = Maths.NumOps@@ -134,8 +142,10 @@           , Test.NumOps.testTriple  -The testing framework can then be invoked using ``idris --testpkg maths.ipkg``::+The testing framework can then be invoked using ``idris --testpkg maths.ipkg``: +::+     > idris --testpkg maths.ipkg     Type checking ./Maths/NumOps.idr     Type checking ./Test/NumOps.idr@@ -146,25 +156,27 @@ Note how both tests have reported success by printing ``Test Passed`` as we arranged for with the ``assertEq`` and ``assertNoEq`` functions. -Package Dependencies Using Atom +Package Dependencies Using Atom =============================== -If you are using the Atom editor and have a dependency on another package, -corresponding to for instance ``import Lightyear`` or ``import Pruviloj``, -you need to let Atom know that it should be loaded. The easiest way to -accomplish that is with a .ipkg file. The general contents of an ipkg file -will be described in the next section of the tutorial, but for now here is -a simple recipe for this trivial case. +If you are using the Atom editor and have a dependency on another package,+corresponding to for instance ``import Lightyear`` or ``import Pruviloj``,+you need to let Atom know that it should be loaded. The easiest way to+accomplish that is with a .ipkg file. The general contents of an ipkg file+will be described in the next section of the tutorial, but for now here is+a simple recipe for this trivial case: -- Create a folder myProject. +- Create a folder myProject. -- Add a file myProject.ipkg containing just a couple of lines: +- Add a file myProject.ipkg containing just a couple of lines: -``package myProject`` +.. code-block:: idris -``pkgs = pruviloj, lightyear`` +    package myProject -- In Atom, use the File menu to Open Folder myProject. +    pkgs = pruviloj, lightyear++- In Atom, use the File menu to Open Folder myProject.  More information ================
docs/tutorial/syntax.rst view
@@ -34,7 +34,7 @@ itself consists of:  -  **Keywords** — here, ``if``, ``then`` and ``else``, which must be-   valid identifiers+   valid identifiers.  -  **Non-terminals** — included in square brackets, ``[test]``, ``[t]``    and ``[e]`` here, which stand for arbitrary expressions. To avoid@@ -44,9 +44,9 @@ -  **Names** — included in braces, which stand for names which may be    bound on the right hand side. --  **Symbols** — included in quotations marks, e.g. ``:=``. This can+-  **Symbols** — included in quotations marks, e.g. ``":="``. This can    also be used to include reserved words in syntax rules, such as-   ``let`` or ``in``.+   ``"let"`` or ``"in"``.  The limitations on the form of a syntax rule are that it must include at least one symbol or keyword, and there must be no repeated@@ -63,7 +63,7 @@     syntax select [x] from [t] "where" [w] = SelectWhere x t w;     syntax select [x] from [t]             = Select x t; -Syntax macros can be further restricted to apply only in patterns (i.e.,+Syntax macros can be further restricted to apply only in patterns (i.e. only on the left hand side of a pattern match clause) or only in terms (i.e. everywhere but the left hand side of a pattern match clause) by being marked as ``pattern`` or ``term`` syntax rules. For example, we
docs/tutorial/theorems.rst view
@@ -115,8 +115,8 @@  Even for trivial theorems like these, the proofs are a little tricky to construct in one go. When things get even slightly more complicated, it-becomes too much to think about to construct proofs in this ‘batch-mode’.+becomes too much to think about to construct proofs in this “batch+mode”.  Idris provides interactive editing capabilities, which can help with building proofs. For more details on building proofs interactively in@@ -383,7 +383,7 @@        = qsort (filter (< x) xs) ++           (x :: qsort (filter (>= x) xs)) -The function ``assert_smaller``, defined in the Prelude, is intended to+The function ``assert_smaller``, defined in the prelude, is intended to address this problem:  .. code-block:: idris
docs/tutorial/typesfuns.rst view
@@ -13,8 +13,7 @@ also several data types declared in the library, including ``Bool``, with values ``True`` and ``False``. We can declare some constants with these types. Enter the following into a file ``Prims.idr`` and load it-into the Idris interactive environment by typing ``idris-Prims.idr``:+into the Idris interactive environment by typing ``idris Prims.idr``:  .. code-block:: idris @@ -38,7 +37,7 @@ have been specified. However Idris programs can consist of several modules and the definitions in each module each have their own namespace. This is discussed further in Section-:ref:`sect-namespaces`). When writing Idris programs both the order in which+:ref:`sect-namespaces`. When writing Idris programs both the order in which definitions are given and indentation are significant. Functions and data types must be defined before use, incidentally each definition must have a type declaration, for example see ``x : Int``, ``foo :@@ -343,7 +342,7 @@  A standard example of a dependent data type is the type of “lists with length”, conventionally called vectors in the dependent type-literature.  They are available as part of the Idris library, by+literature. They are available as part of the Idris library, by importing ``Data.Vect``, or we can declare them as follows:  .. code-block:: idris@@ -521,8 +520,8 @@ clear.  Furthermore, ``{}`` can be used to pattern match on the left hand side, i.e.-``{var = pat}`` gets an implicit variable and attempts to pattern match on "pat";-For example :+``{var = pat}`` gets an implicit variable and attempts to pattern match on “pat”;+For example:  .. code-block:: idris @@ -559,7 +558,6 @@     inVect : IsElem 5 Main.testVec     inVect = There (There Here) - .. important:: Implicit Arguments and Scope      Within the type signature the typechecker will treat all variables@@ -569,7 +567,6 @@     ``testVec``. In the example above, we have assumed that the code     lives within the ``Main`` module. - If the same implicit arguments are being used a lot, it can make a definition difficult to read. To avoid this problem, a ``using`` block gives the types and ordering of any implicit arguments which can@@ -582,15 +579,13 @@          Here  : IsElem x (x :: xs)          There : IsElem x xs -> IsElem x (y :: xs) -- Note: Declaration Order and ``mutual`` blocks ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  In general, functions and data types must be defined before use, since dependent types allow functions to appear as part of types, and type checking can rely on how particular functions are defined (though this-is only true of total functions; see Section :ref:`sect-totality`)).+is only true of total functions; see Section :ref:`sect-totality`). However, this restriction can be relaxed by using a ``mutual`` block, which allows data types and functions to be defined simultaneously: @@ -673,7 +668,7 @@ I/O programs will typically need to sequence actions, feeding the output of one computation into the input of the next. ``IO`` is an abstract type, however, so we can’t access the result of a computation-directly.  Instead, we sequence operations with ``do`` notation:+directly. Instead, we sequence operations with ``do`` notation:  .. code-block:: idris @@ -713,7 +708,7 @@  This function uses one of the ``t`` or ``e`` arguments, but not both (in fact, this is used to implement the ``if...then...else`` construct-as we will see later. We would prefer if *only* the argument which was+as we will see later). We would prefer if *only* the argument which was used was evaluated. To achieve this, Idris provides a ``Lazy`` data type, which allows evaluation to be suspended: @@ -797,7 +792,7 @@ To fix this we must add explicit ``Inf`` declarations to the constructor parameter types, since codata will not add it to constructor parameters of a **different** type from the one being defined. For example, the following-outputs "1".+outputs ``1``.  .. code-block:: idris @@ -902,7 +897,7 @@  -  ``libs/base/Data/VectType.idr`` -Functions include filtering, appending, reversing, and so on. +Functions include filtering, appending, reversing, and so on.  Aside: Anonymous functions and operator sections ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -999,7 +994,7 @@ ---------------  Dependent pairs allow the type of the second element of a pair to depend-on the value of the first element. +on the value of the first element:  .. code-block:: idris @@ -1009,7 +1004,7 @@ Again, there is syntactic sugar for this. ``(a : A ** P)`` is the type of a pair of A and P, where the name ``a`` can occur inside ``P``. ``( a ** p )`` constructs a value of this type. For example, we can-pair a number with a ``Vect`` of a particular length.+pair a number with a ``Vect`` of a particular length:  .. code-block:: idris @@ -1017,7 +1012,7 @@     vec = (2 ** [3, 4])  If you like, you can write it out the long way, the two are precisely-equivalent.+equivalent:  .. code-block:: idris @@ -1070,7 +1065,7 @@  We will see more on ``with`` notation later. -Dependent pairs are sometimes referred to as “sigma types”.+Dependent pairs are sometimes referred to as “Sigma types”.  Records -------@@ -1080,7 +1075,7 @@ automatically generating field access and update functions. Unlike the syntax used for data structures, records in Idris follow a different syntax to that seen with Haskell. For example, we can-represent a person's name and age in a record:+represent a person’s name and age in a record:  .. code-block:: idris @@ -1092,12 +1087,11 @@     fred : Person     fred = MkPerson "Fred" "Joe" "Bloggs" 30 - The constructor name is provided using the ``constructor`` keyword, and the *fields* are then given which are in an indented block following the `where` keyword (here, ``firstName``, ``middleName``, ``lastName``, and ``age``). You can declare multiple fields on a-single line, provided that they have the same type.  The field names+single line, provided that they have the same type. The field names can be used to access the field values:  ::@@ -1171,7 +1165,7 @@     record { a->b->c = val } x  This returns a new record, with the field accessed by the path-``a->b->c`` set to ``val``. The syntax is first class, i.e.  ``record {+``a->b->c`` set to ``val``. The syntax is first class, i.e. ``record { a->b->c = val }`` itself has a function type. Symmetrically, the field can also be accessed with the following syntax: @@ -1196,12 +1190,10 @@         fst : a         snd : b - Using the ``class`` record from earlier, the size of the class can be restricted using a ``Vect`` and the size included in the type by parameterising the record with the size.  For example: - .. code-block:: idris      record SizedClass (size : Nat) where@@ -1214,7 +1206,7 @@ function to add a student must now specify in the type that the size of the class has been increased by one. As the size is specified using natural numbers, the new value can be incremented using the-``S`` constructor.+``S`` constructor:  .. code-block:: idris @@ -1327,7 +1319,7 @@ - Each branch *matches* a value of the same type, and *returns* a   value of the same type. -- The type of the result is "known". i.e. the type of the expression+- The type of the result is “known”. i.e. the type of the expression   can be determined *without* type checking the ``case``-expression   itself. @@ -1337,7 +1329,7 @@ Idris distinguishes between *total* and *partial* functions. A total function is a function that either: -+ Terminates for all possible inputs, or ++ Terminates for all possible inputs, or + Produces a non-empty, finite, prefix of a possibly infinite result  If a function is total, we can consider its type a precise description of what@@ -1345,12 +1337,12 @@ type of ``String`` we know something different, depending on whether or not it's total: -+ If it's total, it will return a value of type ``String`` in finite time++ If it's total, it will return a value of type ``String`` in finite time; + If it's partial, then as long as it doesn't crash or enter an infinite loop,   it will return a ``String``.  Idris makes this distinction so that it knows which functions are safe to-evaluate while type checking (as we've seen with :ref:`sect-fctypes`).  After all,+evaluate while type checking (as we've seen with :ref:`sect-fctypes`). After all, if it tries to evaluate a function during type checking which doesn't terminate, then type checking won't terminate! Therefore, only total functions will be evaluated during type checking.
docs/tutorial/views.rst view
@@ -103,14 +103,14 @@   ``Parity (n + n)`` from the ``Even`` constructor definition. So   ``(j + j)`` replaces ``k`` on the left side of ``|``, and the   ``Even`` constructor appears on the right side. The natural number-  ``j`` in the refined pattern can be used on the ride side of the+  ``j`` in the refined pattern can be used on the right side of the   ``=`` sign.  - Otherwise, when ``parity k`` evaluates to ``Odd``, the original   argument ``k`` is refined to ``S (j + j)`` according to ``Parity (S   (n + n))`` from the ``Odd`` constructor definition, and ``Odd`` now-  appears on the ride side of ``|``, again with the natural number-  ``j`` used on the ride side of the ``=`` sign.+  appears on the right side of ``|``, again with the natural number+  ``j`` used on the right side of the ``=`` sign.  Note that there is a function in the patterns (``+``) and repeated occurrences of ``j`` - this is allowed because another argument has
idris.cabal view
@@ -1,10 +1,11 @@ Name:           idris-Version:        1.2.0+Version:        1.3.0 License:        BSD3 License-file:   LICENSE Author:         Edwin Brady Maintainer:     Edwin Brady <eb@cs.st-andrews.ac.uk> Homepage:       http://www.idris-lang.org/+Bug-reports:    https://github.com/idris-lang/Idris-dev/issues  Stability:      Beta Category:       Compilers/Interpreters, Dependent Types@@ -40,7 +41,7 @@                 .                 * Hugs style interactive environment -Cabal-Version:  >= 1.18+Cabal-Version:  >= 1.22  Build-type:     Custom @@ -99,7 +100,7 @@  custom-setup   setup-depends:-    Cabal >= 1.10 && <2.1,+    Cabal >= 1.10 && <2.3,     base  >= 4 && <5,     directory,     filepath,@@ -260,17 +261,18 @@                   Util.Pretty                 , Util.Net -                 +                 -- Auto Generated                 , Paths_idris                 , Version_idris                 , Tools_idris+                , BuildFlags_idris    Build-depends:  base >=4 && <5                 , aeson >= 0.6 && < 1.3                 , annotated-wl-pprint >= 0.7 && < 0.8-                , ansi-terminal < 0.8+                , ansi-terminal < 0.9                 , ansi-wl-pprint < 0.7                 , array >= 0.4.0.1 && < 0.6                 , base64-bytestring < 1.1@@ -284,7 +286,7 @@                 , deepseq < 1.5                 , directory >= 1.2.2.0 && < 1.2.3.0 || > 1.2.3.0                 , filepath < 1.5-                , fingertree >= 0.1 && < 0.2+                , fingertree >= 0.1.4.1 && < 0.2                 , haskeline >= 0.7 && < 0.8                 , ieee754 >= 0.7 && < 0.9                 , megaparsec >= 6.2@@ -307,7 +309,7 @@                 , vector-binary-instances < 0.3                 , zip-archive > 0.2.3.5 && < 0.4                 , fsnotify >= 0.2 && < 2.2-                , async < 2.2+                , async < 2.3    if !impl(ghc >= 8.0)     Build-Depends: semigroups == 0.18.*
libs/base/Control/Monad/Identity.idr view
@@ -6,13 +6,26 @@   constructor Id   runIdentity : a -implementation Functor Identity where+Functor Identity where     map fn (Id a) = Id (fn a) -implementation Applicative Identity where+Applicative Identity where     pure x = Id x-     (Id f) <*> (Id g) = Id (f g) -implementation Monad Identity where+Monad Identity where     (Id x) >>= k = k x++Show a => Show (Identity a) where+  showPrec d (Id x) = showCon d "Id" $ showArg x++Eq a => Eq (Identity a) where+  (Id x) == (Id y) = x == y++Ord a => Ord (Identity a) where+  compare (Id x) (Id y) = compare x y++Enum a => Enum (Identity a) where+  toNat (Id x) = toNat x+  fromNat n = Id $ fromNat n+  pred (Id n) = Id $ pred n
libs/base/Data/Bits.idr view
@@ -501,5 +501,13 @@       helper FZ _ = []       helper (FS x) b = assert_total $ (if getBit x b then '1' else '0') :: helper (weaken x) b +bitsToHexStr : %static {n : Nat} -> Bits n -> String+bitsToHexStr {n} (MkBits b) with (nextBytes n)+  | Z           = b8ToHexString b+  | S Z         = b16ToHexString b+  | S (S Z)     = b32ToHexString b+  | S (S (S Z)) = b64ToHexString b+  | _ = assert_unreachable+ implementation Show (Bits n) where     show = bitsToStr
libs/base/Data/Buffer.idr view
@@ -3,7 +3,7 @@ %include C "idris_buffer.h"  ||| A buffer is a pointer to a sized, unstructured, mutable chunk of memory.-||| There are primitive operations for gettng and setting bytes, ints (32 bit) +||| There are primitive operations for getting and setting bytes, ints (32 bit)  ||| and strings at a location in the buffer. These operations silently fail  ||| if the location is out of bounds, so bounds checking should be done in  ||| advance.@@ -60,6 +60,15 @@     = foreign FFI_C "idris_setBufferInt" (ManagedPtr -> Int -> Int -> IO ())               (rawdata b) loc val +||| Set the double at position 'loc' to 'val'.+||| Uses 8 bytes (assumes 64 bit double).+||| Does nothing if the location is outside the bounds of the buffer+export+setDouble : Buffer -> (loc : Int) -> (val : Double) -> IO ()+setDouble b loc val+    = foreign FFI_C "idris_setBufferDouble" (ManagedPtr -> Int -> Double -> IO ())+              (rawdata b) loc val+ ||| Set the byte at position 'loc' to 'val'. ||| Does nothing if the location is out of bounds of the buffer, or the string ||| is too long for the location@@ -96,6 +105,15 @@     = foreign FFI_C "idris_getBufferInt" (ManagedPtr -> Int -> IO Int)               (rawdata b) loc  +||| Return the value at the given location in the buffer, assuming 8+||| bytes to store the Double.+||| Returns 0 if out of bounds.+export+getDouble : Buffer -> (loc : Int) -> IO Double+getDouble b loc+    = foreign FFI_C "idris_getBufferDouble" (ManagedPtr -> Int -> IO Double)+              (rawdata b) loc + ||| Return the string at the given location in the buffer, with the given ||| length. Returns "" if out of bounds. export@@ -115,7 +133,7 @@          pure (record { location $= (+numread) } buf)  ||| Write 'maxbytes' from the buffer from a file, returning a new-||| buffer with the 'locaton' pointer moved along+||| buffer with the 'location' pointer moved along export writeBufferToFile : File -> Buffer -> (maxbytes : Int) -> IO Buffer writeBufferToFile (FHandle h) buf max
libs/base/Data/Fin.idr view
@@ -135,7 +135,7 @@                      -- reasoning about primitives, so we need the                      -- 'believe_me'. It's fine because val' must be                      -- in the right range-                     fromInteger val'+                     fromInteger {n = S n} val'                          {prf = believe_me {a=IsJust (Just val')} ItIsJust}  %language ErrorReflection
libs/base/Data/IORef.idr view
@@ -1,5 +1,6 @@ module Data.IORef +||| A mutable variable in the IO monad. export data IORef a = MkIORef a @@ -37,18 +38,22 @@   writeIORef' (MkIORef ref) val =     foreign FFI_JS "%0.val = %1" (Ptr -> Ptr -> JS_IO ()) (believe_me ref) (believe_me val) +||| Build a new IORef export newIORef : a -> IO (IORef a) newIORef = newIORef' +||| read the value of an IORef export readIORef : IORef a -> IO a readIORef = readIORef' +||| write the value of an IORef export writeIORef : IORef a -> a -> IO () writeIORef = writeIORef' +||| mutate the contents of an IORef export modifyIORef : IORef a -> (a -> a) -> IO () modifyIORef = modifyIORef'
libs/base/Data/Vect.idr view
@@ -11,7 +11,6 @@ ||| Vectors: Generic lists with explicit length in the type ||| @ len the length of the list ||| @ elem the type of elements-%elim data Vect : (len : Nat) -> (elem : Type) -> Type where   ||| Empty vector   Nil  : Vect Z elem
libs/base/Language/Reflection/Utils.idr view
@@ -91,7 +91,6 @@     showPrec d (ParentN n s) = showCon d "ParentN" $ showArg n ++ showArg s     showPrec d (MethodN n) = showCon d "MethodN" $ showArg n     showPrec d (CaseN fc n) = showCon d "CaseN" $ showArg fc ++ showArg n-    showPrec d (ElimN n) = showCon d "ElimN" $ showArg n     showPrec d (ImplementationCtorN n) = showCon d "ImplementationCtorN" $ showArg n     showPrec d (MetaN parent meta) = showCon d "MetaN" $ showArg parent ++ showArg meta @@ -116,7 +115,6 @@     (ParentN n s)           == (ParentN n' s')          = n == n' && s == s'     (MethodN n)             == (MethodN n')             = n == n'     (CaseN fc n)            == (CaseN fc' n')           = fc == fc' && n == n'-    (ElimN n)               == (ElimN n')               = n == n'     (ImplementationCtorN n) == (ImplementationCtorN n') = n == n'     (MetaN parent meta)     == (MetaN parent' meta')    = parent == parent' && meta == meta'     _                       == _                        = False@@ -336,7 +334,6 @@   showPrec d (CantResolveAlts xs) = showCon d "CantResolveAlts" $ showArg xs   showPrec d (NoValidAlts xs) = showCon d "NoValidAlts" $ showArg xs   showPrec d (IncompleteTerm tm) = showCon d "IncompleteTerm" $ showArg tm-  showPrec d (NoEliminator s tm) = showCon d "NoEliminator" $ showArg s ++ showArg tm   showPrec d UniverseError = "UniverseError"   showPrec d ProgramLineComment = "ProgramLineComment"   showPrec d (Inaccessible n) = showCon d "Inaccessible" $ showArg n
libs/base/Makefile view
@@ -1,4 +1,4 @@-IDRIS := idris+IDRIS ?= idris PKG := base  build:
libs/base/System.idr view
@@ -93,9 +93,9 @@ time = do MkRaw t <- foreign FFI_C "idris_time" (IO (Raw Integer))           pure t -||| Specify interval to sleep for, must be in range [0, 1000000]-usleep : (i : Int) -> { auto prf : So (i >= 0 && i <= 1000000) } -> IO ()-usleep i = foreign FFI_C "usleep" (Int -> IO ()) i+||| Specify interval to sleep for in microseconds, must be nonnegative+usleep : (i : Int) -> { auto prf : So (i >= 0) } -> IO ()+usleep i = foreign FFI_C "idris_usleep" (Int -> IO ()) i  ||| Execute a program and returns its exit status code. system : String -> IO Int
libs/base/System/Concurrency/Raw.idr view
@@ -8,7 +8,7 @@  ||| Send a message of any type to the thread with the given thread id ||| Returns channel ID if the message was sent successfully, 0 otherwise-||| +||| ||| @channel an ID of a specific channel to send the message on. If 0, |||          the receiver will create a new channel ID sendToThread : (thread_id : Ptr) -> (channel : Int) -> a -> IO Int@@ -29,7 +29,7 @@ checkMsgsTimeout : Int -> IO Bool checkMsgsTimeout timeout           = do me <- getMyVM-               msgs <- foreign FFI_C "idris_checkMessagesTimeout" +               msgs <- foreign FFI_C "idris_checkMessagesTimeout"                             (Ptr -> Int -> IO Ptr) me timeout                null <- nullPtr msgs                pure (not null)@@ -43,7 +43,7 @@ channel_id msg = foreign FFI_C "idris_getChannel" (Ptr -> IO Int) msg  ||| Check for messages initiating a conversation in the process inbox.-||| Returns either 'Nothing', if none, or 'Just (pid, channel)' as pid +||| Returns either 'Nothing', if none, or 'Just (pid, channel)' as pid ||| of sender and new channel id. listenMsgs : IO (Maybe (Ptr, Int)) listenMsgs = do me <- getMyVM@@ -58,7 +58,7 @@ ||| Check for messages from a specific sender/channel in the process inbox ||| If channel is '0', accept on any channel. checkMsgsFrom : Ptr -> (channel : Int) -> IO Bool-checkMsgsFrom sender channel +checkMsgsFrom sender channel   = do me <- getMyVM        msgs <- foreign FFI_C "idris_checkMessagesFrom" (Ptr -> Int -> Ptr -> IO Ptr)                              me channel sender@@ -73,6 +73,7 @@ getMsg {a} = do me <- getMyVM                 m <- foreign FFI_C "idris_recvMessage" (Ptr -> IO Ptr) me                 MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m+                foreign FFI_C "idris_freeMsg" (Ptr -> IO ()) m                 pure x  ||| Check inbox for messages. If there are none, blocks until a message@@ -80,9 +81,9 @@ ||| Note that this is not at all type safe! It is intended to be used in ||| a type safe wrapper. getMsgWithSender : IO (Ptr, Int, a)-getMsgWithSender {a} +getMsgWithSender {a}            = do me <- getMyVM-                m <- foreign FFI_C "idris_recvMessage" +                m <- foreign FFI_C "idris_recvMessage"                              (Ptr -> IO Ptr) me                 MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m                 vm <- sender m@@ -94,12 +95,12 @@ ||| blocks until a message arrives. Returns `Nothing` if the sender isn't ||| alive getMsgFrom : Ptr -> (channel : Int) -> IO (Maybe a)-getMsgFrom {a} sender channel +getMsgFrom {a} sender channel   = do me <- getMyVM        m <- foreign FFI_C "idris_recvMessageFrom"                     (Ptr -> Int -> Ptr -> IO Ptr) me channel sender        null <- nullPtr m-       if null +       if null           then pure Nothing           else do              MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m@@ -110,5 +111,3 @@ stopThread = do vm <- getMyVM                 MkRaw res <- foreign FFI_C "idris_stopThread" (Ptr -> IO (Raw a)) vm                 pure res--
libs/base/base.ipkg view
@@ -1,6 +1,6 @@ package base -opts = "--nobasepkgs --total --no-elim-deprecation-warnings --partial-eval -i ../prelude"+opts = "--nobasepkgs --total --partial-eval -i ../prelude"  modules = Control.Arrow         , Control.Catchable
libs/contrib/CFFI/Types.idr view
@@ -70,9 +70,9 @@     alignOfCT I8 = 1     alignOfCT I16 = 2     alignOfCT I32 = 4-    alignOfCT I64 = 8+    alignOfCT I64 = min prim__sizeofPtr 8     alignOfCT FLOAT = 4-    alignOfCT DOUBLE = 8+    alignOfCT DOUBLE = min prim__sizeofPtr 8     alignOfCT PTR = prim__sizeofPtr      ||| Alignment requirement of the type
libs/contrib/Control/ST.idr view
@@ -399,7 +399,7 @@ runSTLoop : Fuel -> Env invars -> STransLoop m a invars outfn ->             (k : (x : a) -> Env (outfn x) -> m b) ->             (onDry : m b) -> m b-runSTLoop Empty _ _ _ onDry = onDry+runSTLoop Dry _ _ _ onDry = onDry runSTLoop (More x) env (Bind prog next) k onDry     = runST env prog (\prog', env' => runSTLoop x env' (next prog') k onDry) runSTLoop (More x) env (Pure result) k onDry = k result env
libs/contrib/Data/BoundedList.idr view
@@ -1,6 +1,7 @@ module Data.BoundedList  import Data.Fin+import Data.Vect  %access public export %default total@@ -51,6 +52,20 @@ fromList (x :: xs) = x :: fromList xs  --------------------------------------------------------------------------------+-- Conversions to and from vector+--------------------------------------------------------------------------------++||| Convert bounded list to vector.+toVect : (xs : BoundedList n a) -> Vect (finToNat (length xs)) a+toVect [] = []+toVect (x :: xs) = x :: toVect xs++||| Convert vector to bounded list.+fromVect : (xs : Vect n a) -> BoundedList n a+fromVect [] = []+fromVect (x :: xs) = x :: fromVect xs++-------------------------------------------------------------------------------- -- Building (bigger) bounded lists -------------------------------------------------------------------------------- @@ -75,6 +90,20 @@ implementation Functor (BoundedList n) where   map f [] = []   map f (x :: xs) = f x :: map f xs++--------------------------------------------------------------------------------+-- Monoid+--------------------------------------------------------------------------------++implementation Semigroup a => Semigroup (BoundedList n a) where+  (x :: xs) <+> (y :: ys) = (x <+> y) :: (xs <+> ys)+  xs <+> [] = xs+  [] <+> ys = ys++-- The Semigroup constraint is only needed because that's how we make a+-- semigroup from BoundedList, not used in this implementation.+implementation Semigroup a => Monoid (BoundedList n a) where+  neutral = []  -------------------------------------------------------------------------------- -- Misc
+ libs/contrib/Data/Chain.idr view
@@ -0,0 +1,46 @@+module Data.Chain++import Data.Vect+import Control.Isomorphism++%default total+%access public export++||| Repeated function application+Chain : Nat -> (i, o : Type) -> Type+Chain Z     _ o = o+Chain (S k) i o = i -> Chain k i o++||| Repeated endofunction application+EndoChain : Nat -> Type -> Type+EndoChain n t = Chain n t t++||| (.) generalized to any number of arguments.+after : (o -> o') -> (Chain n i o) -> (Chain n i o')+after {n=Z} f x = f x+after {n=S k} f fs = after f . fs++||| `on` generalized to any number of arguments+before : (i -> i') -> (Chain n i' o) -> (Chain n i o)+before {n=Z}   _ x  = x+before {n=S k} f fs = (f `before`) . (fs . f)++||| Fill in the same argument for all items (available for a single argument as+||| Data.Combinators.reflex)+reflexes : (Chain n i o) -> (i -> o)+reflexes {n=Z} x _ = x+reflexes {n=S k} fs y = reflexes (fs y) y++||| Create a vect of a given length from the arguments given.+packVect : Chain n i (Vect n i)+packVect {n=Z}   = []+packVect {n=S k} = (`after` packVect) . Data.Vect.(::)+-- For some reason we get a can't disambiguate name: Prelude.List.::,+-- Prelude.Stream.::, Data.Vect.:: if we leave out the Data.Vect specification++||| Apply a function over a vector to our new type+fromVectFunc : (Vect n i -> o) -> (Chain n i o)+fromVectFunc f = (f `after` packVect)++withIso : Iso t t' -> EndoChain n t -> EndoChain n t'+withIso (MkIso to from _ _) = (from `before`) . (to `after`)
libs/contrib/Data/Combinators.idr view
@@ -5,8 +5,7 @@ ||| hasn't actually read). See ||| http://www.angelfire.com/tx4/cus/combinator/birds.html and ||| https://hackage.haskell.org/package/data-aviary-0.4.0/docs/Data-Aviary-Birds.html-||| an (incomplete?) list of birds introduced. Also includes some operations defined-||| over Arrows.+||| an (incomplete?) list of birds introduced.  module Data.Combinators
+ libs/contrib/Data/List/Extra.idr view
@@ -0,0 +1,44 @@+module Data.List.Extra++%default total+%access export++||| Serves as a specification for reverseOnto.+reverseOntoSpec : (xs, ys : List a) -> reverseOnto xs ys = reverse ys ++ xs+reverseOntoSpec _  [] = Refl+reverseOntoSpec xs (y::ys) =+  trans (reverseOntoSpec (y::xs) ys)+        (trans (appendAssociative (reverse ys) [y] xs)+               (cong {f = \l => l ++ xs} (sym (reverseOntoSpec [y] ys))))++||| The reverse of an empty list is an empty list.  Together with reverseCons,+||| serves as a specification for reverse.+reverseNil : reverse [] = []+reverseNil = Refl++||| The reverse of a cons is the reverse of the tail followed by the head.+||| Together with reverseNil serves as a specification for reverse.+reverseCons : (x : a) -> (xs : List a) -> reverse (x::xs) = reverse xs ++ [x]+reverseCons x xs = reverseOntoSpec [x] xs++||| Reversing an append is appending reversals backwards.+reverseAppend : (xs, ys : List a) ->+  reverse (xs ++ ys) = reverse ys ++ reverse xs+reverseAppend [] ys = sym (appendNilRightNeutral (reverse ys))+reverseAppend (x :: xs) ys =+  trans (trans (reverseCons x (xs ++ ys))+               (cong {f = \l => l ++ [x]} (reverseAppend xs ys)))+        (sym (trans (cong (reverseCons x xs))+                    (appendAssociative (reverse ys) (reverse xs) [x])))++||| Reversing a singleton list is a no-op.+reverseSingletonId : (x : a) -> reverse [x] = [x]+reverseSingletonId _ = Refl++||| Reversing a reverse gives the original.+reverseReverseId : (xs : List a) -> reverse (reverse xs) = xs+reverseReverseId [] = Refl+reverseReverseId (x :: xs) =+  trans (cong (reverseCons x xs))+        (trans (reverseAppend (reverse xs) [x])+               (cong (reverseReverseId xs)))
libs/contrib/Data/List/Group.idr view
@@ -1,5 +1,8 @@ module Data.List.Group +%default total+%access export+ ||| The groupBy function returns a list of lists such that the concatenation ||| of the list is equal to the argument, and each sublist contains only ||| elements that are equal according to the user-supplied predicate.
libs/contrib/Data/List/Permutations.idr view
@@ -1,5 +1,7 @@ module Permutations +%access export+ -- | All permutations of a list. permutations : List a -> List (List a) permutations [] = [[]]
+ libs/contrib/Data/PosNat.idr view
@@ -0,0 +1,57 @@+module Data.PosNat++import Data.So++%default total+%access public export++||| ℤ⁺: {1..}.+PosNat : Type+PosNat = DPair Nat IsSucc++||| A proof that the addition of a natural number to a natural number that is+||| already positive doesn't make a difference+plusPos : (n, k : Nat) -> IsSucc n -> IsSucc (n + k)+plusPos (S n) k pn = ItIsSucc++|||| Add two PosNats+plusPosNat : PosNat -> PosNat -> PosNat+plusPosNat (n ** pn) (k ** _) = (n + k ** plusPos n k pn)++||| Add a Nat to a positive Nat+plusNatPosNat : Nat -> PosNat -> PosNat+plusNatPosNat n (S k ** pk) = (S $ k + n ** ItIsSucc)++||| The proof that one positive Nat times another is still positive+timesPos : (n, k : Nat) -> IsSucc n -> IsSucc k -> IsSucc (n * k)+timesPos n@(S _) k@(S _) pn pk = ItIsSucc++||| Multiply two PosNats+multPosNat : PosNat -> PosNat -> PosNat+multPosNat (n ** pn) (k ** pk) = (n * k ** timesPos n k pn pk)++||| 1+one : PosNat+one = (1 ** ItIsSucc)++||| The successor of a PosNat+succ : PosNat -> PosNat+succ (n ** _) = (S n ** ItIsSucc)++||| Semigroup using addition (this seems to be the more generally useful case,+||| even though it doesn't form a Monoid)+Semigroup PosNat where+  (<+>) = plusPosNat++||| Semigroup using multiplication+[MultPosNatSemi] Semigroup PosNat where+  (<+>) = multPosNat++||| Monoid, neutral = 1+[MultPosNatMonoid] Monoid PosNat using MultPosNatSemi where+  neutral = one++||| Convert a Nat to a PosNat, using automatic proof search+p : (n : Nat) -> {auto ok : IsSucc n} -> PosNat+p Z {ok} impossible+p k {ok} = (k ** ok)
libs/contrib/Data/Sign.idr view
@@ -5,6 +5,35 @@ ||| A representation of signs for signed datatypes such as `ZZ` data Sign = Plus | Zero | Minus +opposite : Sign -> Sign+opposite Plus  = Minus+opposite Zero  = Zero+opposite Minus = Plus++multiply : Sign -> Sign -> Sign+multiply Zero  _    = Zero+multiply _     Zero = Zero+multiply Plus  x    = x+multiply Minus x    = opposite x+ ||| Discover the sign of some type interface Signed t where   total sign : t -> Sign++Signed Int where+  sign x with (compare x 0)+    | LT = Minus+    | EQ = Zero+    | GT = Plus++Signed Integer where+  sign x with (compare x 0)+    | LT = Minus+    | EQ = Zero+    | GT = Plus++Signed Double where+  sign x with (compare x 0.0)+    | LT = Minus+    | EQ = Zero+    | GT = Plus
+ libs/contrib/Data/SortedBag.idr view
@@ -0,0 +1,127 @@+module Data.SortedBag++import Control.Isomorphism+import Control.Pipeline+import Data.Chain+import Data.Combinators+import Data.PosNat+import Data.SortedMap++%default total+%access export++data SortedBag k = BagWrapper (SortedMap k PosNat)++||| Remove the `BagWrapper` from a bag (the required proof from `PosNat` makes+||| this safe)+unwrapBag : SortedBag k -> SortedMap k PosNat+unwrapBag (BagWrapper m) = m++||| An `Isomorphism` between a wrapped and unwrapped bag+wrappedBagIso : Iso (SortedMap k PosNat) (SortedBag k)+wrappedBagIso = MkIso BagWrapper unwrapBag (\(BagWrapper _) => Refl) (\_ => Refl)++||| A type for converting a function from an operation over SortedMaps to an+||| operation over SortedBags+OnMapsT : Nat -> Type -> Type+OnMapsT n k = (EndoChain n $ SortedMap k PosNat) -> (EndoChain n $ SortedBag k)++||| Apply an n-ary function over the wrapped `SortedMap`.+onMaps : OnMapsT n k+onMaps = withIso wrappedBagIso++||| Special case for n=1 for `onMaps`+onMap : OnMapsT 1 k+onMap = onMaps {n=1}++||| An empty bag.+empty : Ord k => SortedBag k+empty = BagWrapper empty++||| The type of `insert` and the common core of most functions that update+||| the contests of a Bag.+UpdateBag : Type -> Type+UpdateBag k = k -> SortedBag k -> SortedBag k++-- Keep in mind:+-- Idris> the Nat $ sum Nothing+-- 0 : Nat+-- Idris> the Nat $ sum $ Just 10+-- 10 : Nat++||| Perform a count on the underlying `SortedMap`+countMap : k -> SortedMap k PosNat -> Nat+countMap k m = sum $ fst <$> lookup k m++||| Apply a function `(Nat -> Nat)` to a given argument+alterCounts : (Nat -> Nat) -> UpdateBag k+alterCounts f k = onMap $ \m => let+    n = countMap k m+    n' = f n+  in m |> if n == n'+    then id -- No change before and after.+    else case n' of+      Z => delete k+      n'@(S _) => insert k (n' ** ItIsSucc)++||| Count the number of occurances+count : k -> SortedBag k -> Nat+count k (BagWrapper m) = countMap k m++||| Is a count non-zero?+contains : k -> SortedBag k -> Bool+contains = isSucc ... count++||| insert a given number of items+insertN : Nat -> UpdateBag k+insertN n = alterCounts (plus n)++||| insert a single item.+insert : UpdateBag k+insert = alterCounts S++||| delete a given number of items+deleteN : Nat -> UpdateBag k+deleteN n = alterCounts (`minus` n)++||| delete 1 item (equivalent to `deleteN 1`)+delete1 : UpdateBag k+delete1 = deleteN 1++||| Delete all ocurances+delete : UpdateBag k+delete = alterCounts $ const Z++||| A single item (more efficient than `insert x empty`)+singleton : Ord k => k -> SortedBag k+singleton k = BagWrapper $ Data.SortedMap.insert k one empty+-- So that we don't need to do a fetch first++-- The reason for rewriting this file, because now it is+||| O(1). Are there any items? The proof in PosNat ensures that there are no+||| zero-counted items.+null : SortedBag k -> Bool+null (BagWrapper m) = null m++||| Convert a list to a Sorted Bag+fromList : Ord k => List k -> SortedBag k+fromList = foldr insert empty++||| Convert a Sorted Bag to a List, keeping it sorted.+toList : SortedBag k -> List k+toList (BagWrapper m) = concat $ (\(x, (n ** _)) => replicate n x) <$> toList m++-- TODO: more efficient, implementation also for Map and Set+Foldable SortedBag where+  foldl f zero = foldl f zero . Data.SortedBag.toList+  foldr f zero = foldr f zero . Data.SortedBag.toList++||| Merge two bags+union : EndoChain 2 (SortedBag k)+union = onMaps {n=2} merge++Semigroup (SortedBag a) where+  (<+>) = union++Ord a => Monoid (SortedBag a) where+  neutral = empty
libs/contrib/Data/SortedMap.idr view
@@ -249,6 +249,11 @@ values : SortedMap k v -> List v values = map snd . toList +export+null : SortedMap k v -> Bool+null Empty = True+null (M _ _) = False+ 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)
libs/contrib/Makefile view
@@ -1,4 +1,4 @@-IDRIS := idris+IDRIS ?= idris PKG := contrib  build:
libs/contrib/Network/Socket.idr view
@@ -133,7 +133,7 @@ ||| + `ResultCode` :: The result of the underlying function. ||| ||| @sock The socket on which to receive the message.-||| @len  How much of the data to send.+||| @len  How much of the data to receive. recv : (sock : Socket)     -> (len : ByteLength)     -> IO (Either SocketError (String, ResultCode))@@ -163,6 +163,25 @@                              recv_struct_ptr            freeRecvStruct (RSPtr recv_struct_ptr)            pure $ Right (payload, recv_res)++||| Receive all the remaining data on the specified socket.+|||+||| Returns on failure a `SocketError`+||| Returns on success the payload `String`+|||+||| @sock The socket on which to receive the message.+partial+recvAll : (sock : Socket) -> IO (Either SocketError String)+recvAll sock = recvRec sock [] 64+  where+    partial+    recvRec : Socket -> List String -> ByteLength -> IO (Either SocketError String)+    recvRec sock acc n = do res <- recv sock n+                            case res of+                              Left 0 => pure (Right $ concat $ reverse acc)+                              Left c => pure (Left c)+                              Right (str, _) => let n' = min (n * 2) 65536 in+                                                recvRec sock (str :: acc) n'  ||| Send a message. |||
libs/contrib/contrib.ipkg view
@@ -25,6 +25,7 @@          , Data.Bool.Extra         , Data.BoundedList+        , Data.Chain         , Data.CoList         , Data.Combinators         , Data.Combinators.Applicative@@ -36,6 +37,7 @@         , Data.Heap         , Data.IOArray         , Data.List.Zipper+        , Data.List.Extra          , Data.Matrix         , Data.Matrix.Algebraic@@ -46,8 +48,10 @@         , Data.Nat.DivMod.IteratedSubtraction          , Data.Pairs.Implicit+        , Data.PosNat         , Data.Rel         , Data.Sign+        , Data.SortedBag         , Data.SortedMap         , Data.SortedSet         , Data.Storable
libs/effects/Effect/Random.idr view
@@ -5,6 +5,19 @@  %access public export +{-+ - This code implements a 'Linear Congruential Generator' as described here+ - https://en.wikipedia.org/wiki/Linear_congruential_generator+ -+ - Looking at the wiki page for 'linear congruential generator' it looks like the+ - parameters used by Idris come from the 'Numerical Recipes' books. The web page+ - does not give any known issues with these parameters, however another example is+ - known to have this bug: "If Xn is even then Xn+1 will be odd, and vice versa-the+ - lowest bit oscillates at each step." So although the 'Numerical Recipes' parameters+ - are not listed with this issue they do have it. Some of the implementations do not+ - use the lower significant bits so divBigInt v 2 has been added to do this.+ -}+ data Random : Effect where       GetRandom : sig Random Integer Integer      SetSeed   : Integer -> sig Random () Integer@@ -21,18 +34,22 @@ ||| Generates a random Integer in a given range rndInt : Integer -> Integer -> Eff Integer [RND] rndInt lower upper = do v <- call $ GetRandom-                        pure ((v `prim__sremBigInt` (upper - lower)) + lower)+                        pure (((divBigInt v 2) `prim__sremBigInt` (upper - lower)) + lower)+                        -- divBigInt v 2 is required to prevent low bit alternating between+                        -- 0 and 1 (odd and even)  ||| Generate a random number in Fin (S `k`)-||| +||| ||| Note that rndFin k takes values 0, 1, ..., k. rndFin : (k : Nat) -> Eff (Fin (S k)) [RND] rndFin k = do let v = assert_total $ !(call GetRandom) `prim__sremBigInt` (cast (S k))-              pure (toFin v)- where toFin : Integer -> Fin (S k) +              pure (toFin (divBigInt v 2))+ where toFin : Integer -> Fin (S k)        toFin x = case integerToFin x (S k) of                       Just v => v                       Nothing => toFin (assert_smaller x (x - cast (S k)))+       -- divBigInt v 2 is required to prevent low bit alternating between+       -- 0 and 1 (odd and even)  ||| Select a random element from a vector rndSelect' : Vect (S k) a -> Eff a [RND]
libs/effects/Effect/System.idr view
@@ -15,7 +15,7 @@      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 ()+     Usleep : (i : Int) -> (inbounds : So (i >= 0)) -> sig System ()  implementation Handler System IO where     handle () Args k = do x <- getArgs; k x ()@@ -48,5 +48,5 @@ system : String -> Eff Int [SYSTEM] system s = call $ CSystem s -usleep : (i : Int) -> { auto prf : So (i >= 0 && i <= 1000000) } -> Eff () [SYSTEM]+usleep : (i : Int) -> { auto prf : So (i >= 0) } -> Eff () [SYSTEM] usleep i {prf} = call $ Usleep i prf
libs/effects/Effects.idr view
@@ -434,10 +434,16 @@ runWith : (a -> m a) -> Env m xs -> EffM m a xs xs' -> m a runWith inj env prog = eff env prog (\r, env => inj r) +||| Similar to 'runInit', but take the result of `Env`. %no_implicit runEnv : Applicative m => Env m xs -> EffM m a xs xs' ->          m (x : a ** Env m (xs' x)) runEnv env prog = eff env prog (\r, env => pure (r ** env))++||| Similar to 'runEnv', but the context (m) is 'pure'+%no_implicit+runPureEnv : (env : Env Basics.id xs) -> (prog : EffM Basics.id a xs xs') -> (x : a ** Env Basics.id (xs' x))+runPureEnv env prog = eff env prog (\r, env => (r ** env))  -- ----------------------------------------------- [ some higher order things ]
libs/effects/Makefile view
@@ -1,4 +1,4 @@-IDRIS     := idris+IDRIS     ?= idris PKG       := effects  build:
libs/prelude/Builtins.idr view
@@ -7,7 +7,7 @@  ||| The canonical single-element type, also known as the trivially ||| true proposition.-%elim data Unit =+data Unit =   ||| The trivial constructor for `()`.   MkUnit @@ -15,7 +15,7 @@   ||| The non-dependent pair type, also known as conjunction.   ||| @A the type of the left elements in the pair   ||| @B the type of the right elements in the pair-  %elim data Pair : (A : Type) -> (B : Type) -> Type where+  data Pair : (A : Type) -> (B : Type) -> Type where      ||| A pair of elements      ||| @a the left element of the pair      ||| @b the right element of the pair@@ -54,7 +54,7 @@ ||| The empty type, also known as the trivially false proposition. ||| ||| Use `void` or `absurd` to prove anything if you have a variable of type `Void` in scope.-%elim data Void : Type where+data Void : Type where  ||| The eliminator for the `Void` type. void : Void -> a@@ -89,7 +89,7 @@ ||| in the other direction, which puts it in a form usable by the `rewrite` ||| tactic and term. rewrite__impl : (P : a -> Type) -> x = y -> P y -> P x-rewrite__impl P Refl prf = prf+rewrite__impl p Refl prf = prf  ||| Symmetry of propositional equality sym : {left:a} -> {right:b} -> left = right -> right = left
libs/prelude/Decidable/Equality.idr view
@@ -157,7 +157,8 @@   -- For the primitives, we have to cheat because we don't have access to their--- internal implementations.+-- internal implementations. We postulate the inequality proofs because we're+-- never going to have to compute anything from them.  -------------------------------------------------------------------------------- -- Int@@ -169,8 +170,7 @@                      False => No primitiveNotEq        where primitiveEq : x = y              primitiveEq = really_believe_me (Refl {x})-             primitiveNotEq : x = y -> Void-             primitiveNotEq = really_believe_me (id {a = x = y})+             postulate primitiveNotEq : x = y -> Void  -------------------------------------------------------------------------------- -- Char@@ -182,8 +182,7 @@                      False => No primitiveNotEq        where primitiveEq : x = y              primitiveEq = really_believe_me (Refl {x})-             primitiveNotEq : x = y -> Void-             primitiveNotEq = really_believe_me (id {a = x = y})+             postulate primitiveNotEq : x = y -> Void  -------------------------------------------------------------------------------- -- Integer@@ -195,8 +194,7 @@                      False => No primitiveNotEq        where primitiveEq : x = y              primitiveEq = really_believe_me (Refl {x})-             primitiveNotEq : x = y -> Void-             primitiveNotEq = really_believe_me (id {a = x = y})+             postulate primitiveNotEq : x = y -> Void  -------------------------------------------------------------------------------- -- String@@ -208,8 +206,7 @@                      False => No primitiveNotEq        where primitiveEq : x = y              primitiveEq = really_believe_me (Refl {x})-             primitiveNotEq : x = y -> Void-             primitiveNotEq = really_believe_me (id {a = x = y})+             postulate primitiveNotEq : x = y -> Void  -------------------------------------------------------------------------------- -- Ptr@@ -221,8 +218,7 @@                      False => No primitiveNotEq        where primitiveEq : x = y              primitiveEq = really_believe_me (Refl {x})-             primitiveNotEq : x = y -> Void-             primitiveNotEq = really_believe_me (id {a = x = y})+             postulate primitiveNotEq : x = y -> Void  -------------------------------------------------------------------------------- -- ManagedPtr@@ -234,5 +230,4 @@                      False => No primitiveNotEq        where primitiveEq : x = y              primitiveEq = really_believe_me (Refl {x})-             primitiveNotEq : x = y -> Void-             primitiveNotEq = really_believe_me (id {a = x = y})+             postulate primitiveNotEq : x = y -> Void
libs/prelude/Language/Reflection.idr view
@@ -3,9 +3,12 @@ import Builtins import Prelude.Applicative import Prelude.Basics+import Prelude.Bool+import Prelude.Either import Prelude.Foldable import Prelude.Functor import Prelude.List+import Prelude.Maybe import Prelude.Nat import Prelude.Traversable import Prelude.Uninhabited@@ -69,7 +72,6 @@                    | ParentN TTName String                    | MethodN TTName                    | CaseN SourceLocation TTName-                   | ElimN TTName                    | ImplementationCtorN TTName                    | MetaN TTName TTName   %name SpecialName sn, sn'@@ -129,9 +131,6 @@ implementation Uninhabited ((WhereN x n n') = (CaseN loc y)) where   uninhabited Refl impossible -implementation Uninhabited ((WhereN x n n') = (ElimN y)) where-  uninhabited Refl impossible- implementation Uninhabited ((WhereN x n n') = (ImplementationCtorN y)) where   uninhabited Refl impossible @@ -153,9 +152,6 @@ implementation Uninhabited ((WithN x n) = (CaseN loc n')) where   uninhabited Refl impossible -implementation Uninhabited ((WithN x n) = (ElimN n')) where-  uninhabited Refl impossible- implementation Uninhabited ((WithN x n) = (ImplementationCtorN n')) where   uninhabited Refl impossible @@ -177,9 +173,6 @@ implementation Uninhabited ((ImplementationN n xs) = (CaseN loc n')) where   uninhabited Refl impossible -implementation Uninhabited ((ImplementationN n xs) = (ElimN n')) where-  uninhabited Refl impossible- implementation Uninhabited ((ImplementationN n xs) = (ImplementationCtorN n')) where   uninhabited Refl impossible @@ -201,9 +194,6 @@ implementation Uninhabited ((ParentN n x) = (CaseN loc n')) where   uninhabited Refl impossible -implementation Uninhabited ((ParentN n x) = (ElimN n')) where-  uninhabited Refl impossible- implementation Uninhabited ((ParentN n x) = (ImplementationCtorN n')) where   uninhabited Refl impossible @@ -225,9 +215,6 @@ implementation Uninhabited ((MethodN n) = (CaseN loc n')) where   uninhabited Refl impossible -implementation Uninhabited ((MethodN n) = (ElimN n')) where-  uninhabited Refl impossible- implementation Uninhabited ((MethodN n) = (ImplementationCtorN n')) where   uninhabited Refl impossible @@ -249,39 +236,12 @@ implementation Uninhabited ((CaseN loc n) = (MethodN n')) where   uninhabited Refl impossible -implementation Uninhabited ((CaseN loc n) = (ElimN n')) where-  uninhabited Refl impossible- implementation Uninhabited ((CaseN loc n) = (ImplementationCtorN n')) where   uninhabited Refl impossible  implementation Uninhabited ((CaseN loc n) = (MetaN n' x)) where   uninhabited Refl impossible -implementation Uninhabited ((ElimN n) = (WhereN x n' y)) where-  uninhabited Refl impossible--implementation Uninhabited ((ElimN n) = (WithN x n')) where-  uninhabited Refl impossible--implementation Uninhabited ((ElimN n) = (ImplementationN n' xs)) where-  uninhabited Refl impossible--implementation Uninhabited ((ElimN n) = (ParentN n' x)) where-  uninhabited Refl impossible--implementation Uninhabited ((ElimN n) = (MethodN n')) where-  uninhabited Refl impossible--implementation Uninhabited ((ElimN n) = (CaseN loc n')) where-  uninhabited Refl impossible--implementation Uninhabited ((ElimN n) = (ImplementationCtorN n')) where-  uninhabited Refl impossible--implementation Uninhabited ((ElimN n) = (MetaN n' x)) where-  uninhabited Refl impossible- implementation Uninhabited ((ImplementationCtorN n) = (WhereN x n' y)) where   uninhabited Refl impossible @@ -300,9 +260,6 @@ implementation Uninhabited ((ImplementationCtorN n) = (CaseN loc n')) where   uninhabited Refl impossible -implementation Uninhabited ((ImplementationCtorN n) = (ElimN n')) where-  uninhabited Refl impossible- implementation Uninhabited ((ImplementationCtorN n) = (MetaN n' x)) where   uninhabited Refl impossible @@ -324,9 +281,6 @@ implementation Uninhabited ((MetaN n n') = (CaseN loc x)) where   uninhabited Refl impossible -implementation Uninhabited ((MetaN n n') = (ElimN x)) where-  uninhabited Refl impossible- implementation Uninhabited ((MetaN n n') = (ImplementationCtorN x)) where   uninhabited Refl impossible @@ -416,10 +370,6 @@   caseNInj Refl = (Refl, Refl)    private-  elimNInj : (ElimN n = ElimN n') -> n = n'-  elimNInj Refl = Refl--  private   implementationCtorNInj : (ImplementationCtorN n = ImplementationCtorN n') -> n = n'   implementationCtorNInj Refl = Refl @@ -445,7 +395,6 @@   decSNEq (WhereN x n n') (ParentN y z) = No absurd   decSNEq (WhereN x n n') (MethodN y) = No absurd   decSNEq (WhereN x n n') (CaseN loc y) = No absurd-  decSNEq (WhereN x n n') (ElimN y) = No absurd   decSNEq (WhereN x n n') (ImplementationCtorN y) = No absurd   decSNEq (WhereN x n n') (MetaN y z) = No absurd   decSNEq (WithN x n) (WhereN y n' z) = No absurd@@ -461,7 +410,6 @@   decSNEq (WithN x n) (ParentN n' y) = No absurd   decSNEq (WithN x n) (MethodN n') = No absurd   decSNEq (WithN x n) (CaseN loc n') = No absurd-  decSNEq (WithN x n) (ElimN n') = No absurd   decSNEq (WithN x n) (ImplementationCtorN n') = No absurd   decSNEq (WithN x n) (MetaN n' y) = No absurd   decSNEq (ImplementationN n xs) (WhereN x n' y) = No absurd@@ -477,7 +425,6 @@   decSNEq (ImplementationN n xs) (ParentN n' x) = No absurd   decSNEq (ImplementationN n xs) (MethodN n') = No absurd   decSNEq (ImplementationN n xs) (CaseN loc n') = No absurd-  decSNEq (ImplementationN n xs) (ElimN n') = No absurd   decSNEq (ImplementationN n xs) (ImplementationCtorN n') = No absurd   decSNEq (ImplementationN n xs) (MetaN n' x) = No absurd   decSNEq (ParentN n x) (WhereN y n' z) = No absurd@@ -493,7 +440,6 @@         No $ contra . fst . parentNInj   decSNEq (ParentN n x) (MethodN n') = No absurd   decSNEq (ParentN n x) (CaseN loc n') = No absurd-  decSNEq (ParentN n x) (ElimN n') = No absurd   decSNEq (ParentN n x) (ImplementationCtorN n') = No absurd   decSNEq (ParentN n x) (MetaN n' y) = No absurd   decSNEq (MethodN n) (WhereN x n' y) = No absurd@@ -506,7 +452,6 @@     decSNEq (MethodN n) (MethodN n') | No contra =         No $ contra . methodNInj   decSNEq (MethodN n) (CaseN loc n') = No absurd-  decSNEq (MethodN n) (ElimN n') = No absurd   decSNEq (MethodN n) (ImplementationCtorN n') = No absurd   decSNEq (MethodN n) (MetaN n' x) = No absurd   decSNEq (CaseN loc n) (WhereN x n' y) = No absurd@@ -522,29 +467,14 @@           No $ contra . snd . caseNInj     decSNEq (CaseN loc n) (CaseN loc' n') | No contra =         No $ contra . fst . caseNInj-  decSNEq (CaseN loc n) (ElimN n') = No absurd   decSNEq (CaseN loc n) (ImplementationCtorN n') = No absurd   decSNEq (CaseN loc n) (MetaN n' x) = No absurd-  decSNEq (ElimN n) (WhereN x n' y) = No absurd-  decSNEq (ElimN n) (WithN x n') = No absurd-  decSNEq (ElimN n) (ImplementationN n' xs) = No absurd-  decSNEq (ElimN n) (ParentN n' x) = No absurd-  decSNEq (ElimN n) (MethodN n') = No absurd-  decSNEq (ElimN n) (CaseN loc n') = No absurd-  decSNEq (ElimN n) (ElimN n') with (assert_total $ decTTNameEq n n')-    decSNEq (ElimN n) (ElimN n)  | Yes Refl =-        Yes Refl-    decSNEq (ElimN n) (ElimN n') | No contra =-        No $ contra . elimNInj-  decSNEq (ElimN n) (ImplementationCtorN n') = No absurd-  decSNEq (ElimN n) (MetaN n' x) = No absurd   decSNEq (ImplementationCtorN n) (WhereN x n' y) = No absurd   decSNEq (ImplementationCtorN n) (WithN x n') = No absurd   decSNEq (ImplementationCtorN n) (ImplementationN n' xs) = No absurd   decSNEq (ImplementationCtorN n) (ParentN n' x) = No absurd   decSNEq (ImplementationCtorN n) (MethodN n') = No absurd   decSNEq (ImplementationCtorN n) (CaseN loc n') = No absurd-  decSNEq (ImplementationCtorN n) (ElimN n') = No absurd   decSNEq (ImplementationCtorN n) (ImplementationCtorN n') with (assert_total $ decTTNameEq n n')     decSNEq (ImplementationCtorN n) (ImplementationCtorN n)  | Yes Refl =         Yes Refl@@ -557,7 +487,6 @@   decSNEq (MetaN n n') (ParentN x y) = No absurd   decSNEq (MetaN n n') (MethodN x) = No absurd   decSNEq (MetaN n n') (CaseN loc x) = No absurd-  decSNEq (MetaN n n') (ElimN x) = No absurd   decSNEq (MetaN n n') (ImplementationCtorN x) = No absurd   decSNEq (MetaN n n') (MetaN x y) with (assert_total $ decTTNameEq n x)     decSNEq (MetaN n n') (MetaN n y) | Yes Refl with (assert_total $ decTTNameEq n' y)@@ -877,6 +806,16 @@   quote Z     = `(Z)   quote (S k) = `(S ~(quote k)) +implementation Quotable Bool TT where+  quotedTy = `(Bool)+  quote True = `(True)+  quote False = `(False)++implementation Quotable Bool Raw where+  quotedTy = `(Bool)+  quote True = `(True)+  quote False = `(False)+ implementation Quotable Int TT where   quotedTy = `(Int)   quote x = TConst (I x)@@ -959,6 +898,26 @@   quote [] = `(List.Nil {elem=~(quotedTy {a})})   quote (x :: xs) = `(List.(::) {elem=~(quotedTy {a})} ~(quote x) ~(quote xs)) +implementation Quotable a TT => Quotable (Maybe a) TT where+  quotedTy = `(Maybe ~(quotedTy {a}))+  quote (Just x) = `(Just {a=~(quotedTy {a})} ~(quote x))+  quote Nothing = `(Nothing {a=~(quotedTy {a})})++implementation Quotable a Raw => Quotable (Maybe a) Raw where+  quotedTy = `(Maybe ~(quotedTy {a}))+  quote (Just x) = `(Just {a=~(quotedTy {a})} ~(quote x))+  quote Nothing = `(Nothing {a=~(quotedTy {a})})++implementation (Quotable a TT, Quotable b TT) => Quotable (Either a b) TT where+  quotedTy = `(Either ~(quotedTy {a}) ~(quotedTy {a=b}))+  quote (Left x) = `(Left {a=~(quotedTy {a})} {b=~(quotedTy {a=b})} ~(quote x))+  quote (Right x) = `(Right {a=~(quotedTy {a})} {b=~(quotedTy {a=b})} ~(quote x))++implementation (Quotable a Raw, Quotable b Raw) => Quotable (Either a b) Raw where+  quotedTy = `(Either ~(quotedTy {a}) ~(quotedTy {a=b}))+  quote (Left x) = `(Left {a=~(quotedTy {a})} {b=~(quotedTy {a=b})} ~(quote x))+  quote (Right x) = `(Right {a=~(quotedTy {a})} {b=~(quotedTy {a=b})} ~(quote x))+ implementation Quotable () TT where   quotedTy = `(Unit)   quote () = `(MkUnit)@@ -1006,7 +965,6 @@     quote (ParentN n s) = `(ParentN ~(quote n) ~(quote s))     quote (MethodN n) = `(MethodN ~(quote n))     quote (CaseN fc n) = `(CaseN ~(quote fc) ~(quote n))-    quote (ElimN n) = `(ElimN ~(quote n))     quote (ImplementationCtorN n) = `(ImplementationCtorN ~(quote n))     quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta)) @@ -1026,7 +984,6 @@     quote (ParentN n s) = `(ParentN ~(quote n) ~(quote s))     quote (MethodN n) = `(MethodN ~(quote n))     quote (CaseN fc n) = `(CaseN ~(quote fc) ~(quote n))-    quote (ElimN n) = `(ElimN ~(quote n))     quote (ImplementationCtorN n) = `(ImplementationCtorN ~(quote n))     quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta))
libs/prelude/Language/Reflection/Elab.idr view
@@ -16,6 +16,7 @@ import Prelude.Monad import Prelude.Nat import Language.Reflection+import Language.Reflection.Errors  %access public export @@ -138,6 +139,7 @@   Prim__BindElab : {a, b : Type} -> Elab a -> (a -> Elab b) -> Elab b    Prim__Try : {a : Type} -> Elab a -> Elab a -> Elab a+  Prim__TryCatch : {a : Type} -> Elab a -> (Err -> Elab a) -> Elab a   Prim__Fail : {a : Type} -> List ErrorReportPart -> Elab a    Prim__Env : Elab (List (TTName, Binder TT))@@ -217,6 +219,13 @@    implementation Monad Elab where     x >>= f = Prim__BindElab x f++  ||| `tryCatch t (\err => t')` will run `t`, and if it+  ||| fails, roll back the elaboration state and run `t'`,+  ||| but with access to the knowledge of why `t` failed.+  export+  tryCatch : Elab a -> (Err -> Elab a) -> Elab a+  tryCatch x f = Prim__TryCatch x f    ||| Halt elaboration with an error   export
libs/prelude/Language/Reflection/Errors.idr view
@@ -35,7 +35,6 @@          | CantResolveAlts (List TTName)          | NoValidAlts (List TTName)          | IncompleteTerm TT-         | NoEliminator String TT          | UniverseError          | ProgramLineComment          | Inaccessible TTName
libs/prelude/Makefile view
@@ -1,4 +1,4 @@-IDRIS := idris+IDRIS ?= idris PKG   := prelude  build:
libs/prelude/Prelude/Bool.idr view
@@ -7,7 +7,7 @@ %access public export  ||| Boolean Data Type-%case data Bool = False | True+data Bool = False | True  ||| The underlying implementation of the if ... then ... else ... syntax ||| @ b the condition on the if
libs/prelude/Prelude/Either.idr view
@@ -11,7 +11,7 @@ %access public export  ||| A sum type-%elim data Either : (a, b : Type) -> Type where+data Either : (a, b : Type) -> Type where   ||| One possibility of the sum, conventionally used to represent errors   Left : (l : a) -> Either a b   ||| The other possibility, conventionally used to represent success
libs/prelude/Prelude/File.idr view
@@ -141,18 +141,65 @@ do_getFileSize : Ptr -> IO Int do_getFileSize h = foreign FFI_C "fileSize" (Ptr -> IO Int) h +private+do_getFileAccessTime : Ptr -> IO Integer+do_getFileAccessTime h =+   do MkRaw i <- foreign FFI_C "fileAccessTime" (Ptr -> IO (Raw Integer)) h+      pure i++private+do_getFileModifiedTime : Ptr -> IO Integer+do_getFileModifiedTime h = +   do MkRaw i <- foreign FFI_C "fileModifiedTime" (Ptr -> IO (Raw Integer)) h+      pure i++private+do_getFileStatusTime : Ptr -> IO Integer+do_getFileStatusTime h = +   do MkRaw i <- foreign FFI_C "fileStatusTime" (Ptr -> IO (Raw Integer)) h+      pure i+ ||| Return the size of a File ||| Returns an error if the File is not an ordinary file (e.g. a directory) ||| Also note that this currently returns an Int, which may overflow if the ||| file is very big export fileSize : File -> IO (Either FileError Int)-fileSize (FHandle h) = do s <- do_getFileSize h-                          if (s < 0)-                             then do err <- getFileError-                                     pure (Left err)-                             else pure (Right s)+fileSize (FHandle h) +    = do s <- do_getFileSize h+         if (s < 0)+            then do err <- getFileError+                    pure (Left err)+            else pure (Right s) +export+fileModifiedTime : File -> IO (Either FileError Integer)+fileModifiedTime (FHandle h)+    = do s <- do_getFileModifiedTime h+         if (s < 0)+            then do err <- getFileError+                    pure (Left err)+            else pure (Right s)++export+fileAccessTime : File -> IO (Either FileError Integer)+fileAccessTime (FHandle h)+    = do s <- do_getFileAccessTime h+         if (s < 0)+            then do err <- getFileError+                    pure (Left err)+            else pure (Right s)++export+fileStatusTime : File -> IO (Either FileError Integer)+fileStatusTime (FHandle h)+    = do s <- do_getFileStatusTime h+         if (s < 0)+            then do err <- getFileError+                    pure (Left err)+            else pure (Right s)++ private do_fread : Ptr -> IO' l String do_fread h = prim_fread h@@ -326,5 +373,5 @@ export changeDir : String -> IO Bool changeDir dir -    = do ok <- foreign FFI_C "chdir" (String -> IO Int) dir+    = do ok <- foreign FFI_C "idris_chdir" (String -> IO Int) dir          pure (ok == 0)
libs/prelude/Prelude/Functor.idr view
@@ -23,5 +23,9 @@ (<$>) : Functor f => (func : a -> b) -> f a -> f b func <$> x = map func x +||| Run something for effects, throwing away the return value+ignore : Functor f => f a -> f ()+ignore x = map (const ()) x+ Functor (Pair a) where   map f (x, y) = (x, f y)
libs/prelude/Prelude/Interactive.idr view
@@ -81,7 +81,7 @@ putChar : Char -> IO () putChar c = foreign FFI_C "putchar" (Int -> IO ()) (cast c) -||| Write a singel character to stdout, with a trailing newline+||| Write a single character to stdout, with a trailing newline putCharLn : Char -> IO () putCharLn c = putStrLn (singleton c) @@ -160,12 +160,14 @@ replWith : (state : a) -> (prompt : String) ->            (onInput : a -> String -> Maybe (String, a)) -> IO () replWith acc prompt fn-   = do putStr prompt-        x <- getLine-        case fn acc x of-             Just (out, acc') => do putStr out-                                    replWith acc' prompt fn-             Nothing => pure ()+   = if !(fEOF stdin)+        then pure ()+        else do putStr prompt+                x <- getLine+                case fn acc x of+                     Just (out, acc') => do putStr out+                                            replWith acc' prompt fn+                     Nothing => pure ()  ||| A basic read-eval-print loop ||| @ prompt the prompt to show
libs/prelude/Prelude/Interfaces.idr view
@@ -66,7 +66,7 @@   -- ---------------------------------------------------------- [ Ordering Interface ]-%elim data Ordering = LT | EQ | GT+data Ordering = LT | EQ | GT  Eq Ordering where     LT == LT = True
libs/prelude/Prelude/List.idr view
@@ -19,7 +19,7 @@ infixr 7 ::,++  ||| Generic lists-%elim data List : (elem : Type) -> Type where+data List : (elem : Type) -> Type where   ||| Empty list   Nil : List elem   ||| A non-empty list, consisting of a head element and the rest of@@ -394,13 +394,14 @@ -- Transformations -------------------------------------------------------------------------------- +||| Reverse a list onto an existing tail.+reverseOnto : List a -> List a -> List a+reverseOnto acc [] = acc+reverseOnto acc (x::xs) = reverseOnto (x::acc) xs+ ||| Return the elements of a list in reverse order. reverse : List a -> List a-reverse = reverse' []-  where-    reverse' : List a -> List a -> List a-    reverse' acc []      = acc-    reverse' acc (x::xs) = reverse' (x::acc) xs+reverse = reverseOnto []  ||| Insert some separator between the elements of a list. |||
libs/prelude/Prelude/Maybe.idr view
@@ -100,6 +100,12 @@   (Just _) == Nothing  = False   (Just a) == (Just b) = a == b +(Ord a) => Ord (Maybe a) where+  compare Nothing  Nothing  = EQ+  compare Nothing  (Just _) = LT+  compare (Just _) Nothing  = GT+  compare (Just a) (Just b) = compare a b+ ||| Prioritised choice. Just like the `Alternative` implementation, the ||| `Semigroup` for `Maybe a` keeps the first succeeding computation. |||
libs/prelude/Prelude/Nat.idr view
@@ -14,7 +14,7 @@  ||| Natural numbers: unbounded, unsigned integers which can be pattern ||| matched.-%elim data Nat =+data Nat =   ||| Zero   Z |   ||| Successor
libs/prelude/Prelude/WellFounded.idr view
@@ -60,8 +60,8 @@ accInd : {rel : a -> a -> Type} -> {P : a -> Type} ->          (step : (x : a) -> ((y : a) -> rel y x -> P y) -> P x) ->          (z : a) -> Accessible rel z -> P z-accInd {P} step z (Access f) =-  step z $ \y, lt => accInd {P} step y (f y lt)+accInd {P=p} step z (Access f) =+  step z $ \y, lt => accInd {P=p} step y (f y lt)   ||| Use well-foundedness of a relation to write terminating operations.
libs/prelude/prelude.ipkg view
@@ -1,6 +1,6 @@ package prelude -opts = "--nobuiltins --total --no-elim-deprecation-warnings --partial-eval"+opts = "--nobuiltins --total --partial-eval"  modules = Builtins
libs/pruviloj/Makefile view
@@ -1,4 +1,4 @@-IDRIS     := idris+IDRIS     ?= idris PKG       := pruviloj  build:
libs/pruviloj/Pruviloj/Core.idr view
@@ -7,10 +7,6 @@  %access public export -||| Run something for effects, throwing away the return value-ignore : Functor f => f a -> f ()-ignore x = map (const ()) x- ||| Do nothing skip : Applicative f => f () skip = pure ()@@ -234,12 +230,12 @@ both : Raw -> TTName -> TTName -> Elab () both tm n1 n2 =     do -- We don't know that the term is canonical, so let-bind projections applied to it-       (A, B) <- isPairTy !(getTTType tm)-       remember n1 A; apply `(fst {a=~A} {b=~B} ~tm) []; solve-       remember n2 B; apply `(snd {a=~A} {b=~B} ~tm) []; solve+       (a, b) <- isPairTy !(getTTType tm)+       remember n1 a; apply `(fst {a=~a} {b=~b} ~tm) []; solve+       remember n2 b; apply `(snd {a=~a} {b=~b} ~tm) []; solve   where     isPairTy : TT -> Elab (Raw, Raw)-    isPairTy `((~A, ~B) : Type) = [| MkPair (forget A) (forget B) |]+    isPairTy `((~a, ~b) : Type) = [| MkPair (forget a) (forget b) |]     isPairTy tm = fail [TermPart tm, TextPart "is not a pair"]  ||| Let-bind all results of completely destructuring nested tuples.@@ -282,8 +278,8 @@ reflexivity : Elab () reflexivity =     case !goalType of-      `((=) {A=~A} {B=~_} ~x ~_) =>-        do fill `(Refl {A=~A} {x=~x})+      `((=) {A=~a} {B=~_} ~x ~_) =>+        do fill `(Refl {A=~a} {x=~x})            solve       _ => fail [ TextPart "The goal is not an equality, so"                 , NamePart `{reflexivity}@@ -307,9 +303,9 @@ symmetryAs : (t : Raw) -> (hint : String) -> Elab TTName symmetryAs t hint =     case !(getTTType t) of-      `((=) {A=~A} {B=~B} ~l ~r) =>-        do af <- forget A-           bf <- forget B+      `((=) {A=~a} {B=~b} ~l ~r) =>+        do af <- forget a+           bf <- forget b            lf <- forget l            rf <- forget r            let ts = the Raw $ `(sym {a=~af} {b=~bf} {left=~lf} {right=~rf} ~t)
libs/pruviloj/Pruviloj/Derive/DecEq.idr view
@@ -82,7 +82,7 @@ mkRhs : (fn, fam : TTName) -> Nat -> Elab () mkRhs fn fam k =     case snd !getGoal of-      `(Dec ((=) {A=~A} {B=~_} ~x ~y)) =>+      `(Dec ((=) {A=~_} {B=~_} ~x ~y)) =>         let (c1, args1) = unApply x             (c2, args2) = unApply y         in if c1 /= c2@@ -138,17 +138,17 @@ deriveDecEq fn =     do (_, Ref, sig') <- lookupTyExact fn        sig <- forget sig'-       (args, `(Dec ((=) {A=~A} {B=~_} ~(Var x) ~(Var y)))) <- stealBindings sig noRenames+       (args, `(Dec ((=) {A=~aTy} {B=~_} ~(Var x) ~(Var y)))) <- stealBindings sig noRenames          | other => fail [ TextPart "Return type"                          , RawPart (snd other)                          , TextPart "isn't decidable equality"                          ] -       datatype <- maybe (fail [ RawPart A+       datatype <- maybe (fail [ RawPart aTy                                , TextPart "is not an application of a TC"                                ])                          lookupDatatypeExact-                         (headName A)+                         (headName aTy)         -- the signature must be like this:        -- 1. a collection of variable bindings (will be implicit)
libs/pruviloj/Pruviloj/Disjoint.idr view
@@ -78,7 +78,7 @@   do compute      g <- snd <$> getGoal      case g of-       `(((=) {A=~A} {B=~B} ~a ~b) -> Void) =>+       `(((=) {A=~aTy} {B=~bTy} ~a ~b) -> Void) =>          do Just lHead <- headName <$> forget a               | Nothing => fail [TermPart a, TextPart "doesn't have a name at the head"]             Just rHead <- headName <$> forget b@@ -101,7 +101,7 @@       -- for each thing in the context, until we find one that succeeds       flip choiceMap !getEnv $ \(n, b) =>         do -- 1) check if it is an equality-           `(((=) {A=~A} {B=~B} ~a ~b)) <- forget (binderTy b)+           `(((=) {A=~aTy} {B=~bTy} ~a ~b)) <- forget (binderTy b)              | _ => fail [TextPart "Not equality type"]            -- 2) check if both sides of the equality have heads            case (headName a, headName b) of
libs/pruviloj/Pruviloj/Injective.idr view
@@ -97,7 +97,7 @@ injective tm n =   do (_, ty) <- check !getEnv tm      case !(forget ty) of-       `((=) {A=~A} {B=~B} ~x ~y) =>+       `((=) {A=~a} {B=~b} ~x ~y) =>          case (headName x, headName y) of            (Just xHd, Just yHd) =>              if xHd /= yHd
man/idris.1 view
@@ -1,6 +1,6 @@ .\" Manpage for Idris. .\" Contact <> to correct errors or typos.-.TH man 1 "7 January 2018" "1.2.0" "Idris man page"+.TH man 1 "26 May 2018" "1.3.0" "Idris man page" .SH NAME idris -\ a general purpose pure functional programming language with dependent types. .SH SYNOPSIS@@ -101,8 +101,6 @@   --nocolor,--nocolour     Disable coloured output   --consolewidth WIDTH     Select console width: auto, infinite, nat   --highlight              Emit source code highlighting-  --no-elim-deprecation-warnings-                           Disable deprecation warnings for %elim   --no-tactic-deprecation-warnings                            Disable deprecation warnings for the old tactic                            sublanguage
rts/Makefile view
@@ -40,6 +40,6 @@ clean : 	rm -f $(OBJS) $(LIBTARGET) $(DYLIBTARGET) -idris_rts.o: idris_rts.h+$(OBJS): $(HDRS)  .PHONY: build install clean
rts/idris_bitstring.c view
@@ -2,824 +2,558 @@  #include "idris_rts.h" -VAL idris_b8CopyForGC(VM *vm, VAL a) {-    uint8_t A = a->info.bits8;-    VAL cl = allocate(sizeof(Closure), 1);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = A;-    return cl;+VAL idris_b8const(VM *vm, uint8_t a) {+    return MKINT(a); } -VAL idris_b16CopyForGC(VM *vm, VAL a) {-    uint16_t A = a->info.bits16;-    VAL cl = allocate(sizeof(Closure), 1);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = A;-    return cl;+VAL idris_b16const(VM *vm, uint16_t a) {+    return MKINT(a); } -VAL idris_b32CopyForGC(VM *vm, VAL a) {-    uint32_t A = a->info.bits32;-    VAL cl = allocate(sizeof(Closure), 1);+VAL idris_b32const(VM *vm, uint32_t a) {+    Bits32 * cl = iallocate(vm, sizeof(*cl), 0);     SETTY(cl, CT_BITS32);-    cl->info.bits32 = A;-    return cl;+    cl->bits32 = a;+    return (VAL)cl; } -VAL idris_b64CopyForGC(VM *vm, VAL a) {-    uint64_t A = a->info.bits64;-    VAL cl = allocate(sizeof(Closure), 1);+VAL idris_b64const(VM *vm, uint64_t a) {+    Bits64 * cl = iallocate(vm, sizeof(*cl), 0);     SETTY(cl, CT_BITS64);-    cl->info.bits64 = A;-    return cl;+    cl->bits64 = a;+    return (VAL)cl; }  VAL idris_b8(VM *vm, VAL a) {-    uint8_t A = GETINT(a);-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = (uint8_t) A;-    return cl;+    return idris_b8const(vm, GETINT(a)); }  VAL idris_b16(VM *vm, VAL a) {-    uint16_t A = GETINT(a);-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = (uint16_t) A;-    return cl;+    return idris_b16const(vm, GETINT(a)); }  VAL idris_b32(VM *vm, VAL a) {-    uint32_t A = GETINT(a);-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = (uint32_t) A;-    return cl;+    return idris_b32const(vm, GETINT(a)); }  VAL idris_b64(VM *vm, VAL a) {-    uint64_t A = GETINT(a);-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = (uint64_t) A;-    return cl;+    return idris_b64const(vm, GETINT(a)); }  VAL idris_castB32Int(VM *vm, VAL a) {-    return MKINT((i_int)a->info.bits32);-}--VAL idris_b8const(VM *vm, uint8_t a) {-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = a;-    return cl;-}--VAL idris_b16const(VM *vm, uint16_t a) {-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = a;-    return cl;-}--VAL idris_b32const(VM *vm, uint32_t a) {-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = a;-    return cl;-}--VAL idris_b64const(VM *vm, uint64_t a) {-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = a;-    return cl;+    return MKINT(GETBITS32(a)); }  VAL idris_b8Plus(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = A + B;-    return cl;+    uint8_t A = GETBITS8(a);+    uint8_t B = GETBITS8(b);+    return idris_b8const(vm, A + B); }  VAL idris_b8Minus(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = A - B;-    return cl;+    uint8_t A = GETBITS8(a);+    uint8_t B = GETBITS8(b);+    return idris_b8const(vm, A - B); }  VAL idris_b8Times(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = A * B;-    return cl;+    uint8_t A = GETBITS8(a);+    uint8_t B = GETBITS8(b);+    return idris_b8const(vm, A * B); }  VAL idris_b8UDiv(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = A / B;-    return cl;+    uint8_t A = GETBITS8(a);+    uint8_t B = GETBITS8(b);+    return idris_b8const(vm, A / B); }  VAL idris_b8SDiv(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = (uint8_t) (((int8_t) A) / ((int8_t) B));-    return cl;+    int8_t A = GETBITS8(a);+    int8_t B = GETBITS8(b);+    return idris_b8const(vm, A / B); }  VAL idris_b8URem(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = A % B;-    return cl;+    uint8_t A = GETBITS8(a);+    uint8_t B = GETBITS8(b);+    return idris_b8const(vm, A % B); }  VAL idris_b8SRem(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = (uint8_t) (((int8_t) A) % ((int8_t) B));-    return cl;+    int8_t A = GETBITS8(a);+    int8_t B = GETBITS8(b);+    return idris_b8const(vm, A % B); }  VAL idris_b8Lt(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits8 < b->info.bits8));+    return MKINT((i_int) (GETBITS8(a) < GETBITS8(b))); }  VAL idris_b8Gt(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits8 > b->info.bits8));+    return MKINT((i_int) (GETBITS8(a) > GETBITS8(b))); }  VAL idris_b8Eq(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits8 == b->info.bits8));+    return MKINT((i_int) (GETBITS8(a) == GETBITS8(b))); }  VAL idris_b8Lte(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits8 <= b->info.bits8));+    return MKINT((i_int) (GETBITS8(a) <= GETBITS8(b))); }  VAL idris_b8Gte(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits8 >= b->info.bits8));+    return MKINT((i_int) (GETBITS8(a) >= GETBITS8(b))); }  VAL idris_b8Compl(VM *vm, VAL a) {-    uint8_t A = a->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = ~ A;-    return cl;+    uint8_t A = GETBITS8(a);+    return idris_b8const(vm, ~ A); }  VAL idris_b8And(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = A & B;-    return cl;+    uint8_t A = GETBITS8(a);+    uint8_t B = GETBITS8(b);+    return idris_b8const(vm, A & B); }  VAL idris_b8Or(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = A | B;-    return cl;+    uint8_t A = GETBITS8(a);+    uint8_t B = GETBITS8(b);+    return idris_b8const(vm, A | B); }  VAL idris_b8Xor(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = A ^ B;-    return cl;+    uint8_t A = GETBITS8(a);+    uint8_t B = GETBITS8(b);+    return idris_b8const(vm, A ^ B); }  VAL idris_b8Shl(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = A << B;-    return cl;+    uint8_t A = GETBITS8(a);+    uint8_t B = GETBITS8(b);+    return idris_b8const(vm, A << B); }  VAL idris_b8LShr(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = A >> B;-    return cl;+    uint8_t A = GETBITS8(a);+    uint8_t B = GETBITS8(b);+    return idris_b8const(vm, A >> B); }  VAL idris_b8AShr(VM *vm, VAL a, VAL b) {-    uint8_t A = a->info.bits8;-    uint8_t B = b->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = (uint8_t) (((int8_t) A) >> ((int8_t) B));-    return cl;+    int8_t A = GETBITS8(a);+    int8_t B = GETBITS8(b);+    return idris_b8const(vm, A >> B); }  VAL idris_b16Plus(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = A + B;-    return cl;+    uint16_t A = GETBITS16(a);+    uint16_t B = GETBITS16(b);+    return idris_b16const(vm, A + B); }  VAL idris_b16Minus(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = A - B;-    return cl;+    uint16_t A = GETBITS16(a);+    uint16_t B = GETBITS16(b);+    return idris_b16const(vm, A - B); }  VAL idris_b16Times(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = A * B;-    return cl;+    uint16_t A = GETBITS16(a);+    uint16_t B = GETBITS16(b);+    return idris_b16const(vm, A * B); }  VAL idris_b16UDiv(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = A / B;-    return cl;+    uint16_t A = GETBITS16(a);+    uint16_t B = GETBITS16(b);+    return idris_b16const(vm, A / B); }  VAL idris_b16SDiv(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = (uint16_t) (((int16_t) A) / ((int16_t) B));-    return cl;+    int16_t A = GETBITS16(a);+    int16_t B = GETBITS16(b);+    return idris_b16const(vm, A / B); }  VAL idris_b16URem(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = A % B;-    return cl;+    uint16_t A = GETBITS16(a);+    uint16_t B = GETBITS16(b);+    return idris_b16const(vm, A % B); }  VAL idris_b16SRem(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = (uint16_t) (((int16_t) A) % ((int16_t) B));-    return cl;+    int16_t A = GETBITS16(a);+    int16_t B = GETBITS16(b);+    return idris_b16const(vm, A % B); }  VAL idris_b16Lt(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits16 < b->info.bits16));+    return MKINT((i_int) (GETBITS16(a) < GETBITS16(b))); }  VAL idris_b16Gt(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits16 > b->info.bits16));+    return MKINT((i_int) (GETBITS16(a) > GETBITS16(b))); }  VAL idris_b16Eq(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits16 == b->info.bits16));+    return MKINT((i_int) (GETBITS16(a) == GETBITS16(b))); }  VAL idris_b16Lte(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits16 <= b->info.bits16));+    return MKINT((i_int) (GETBITS16(a) <= GETBITS16(b))); }  VAL idris_b16Gte(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits16 >= b->info.bits16));+    return MKINT((i_int) (GETBITS16(a) >= GETBITS16(b))); }  VAL idris_b16Compl(VM *vm, VAL a) {-    uint16_t A = a->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = ~ A;-    return cl;+    uint16_t A = GETBITS16(a);+    return idris_b16const(vm, ~ A); }  VAL idris_b16And(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = A & B;-    return cl;+    uint16_t A = GETBITS16(a);+    uint16_t B = GETBITS16(b);+    return idris_b16const(vm, A & B); }  VAL idris_b16Or(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = A | B;-    return cl;+    uint16_t A = GETBITS16(a);+    uint16_t B = GETBITS16(b);+    return idris_b16const(vm, A | B); }  VAL idris_b16Xor(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = A ^ B;-    return cl;+    uint16_t A = GETBITS16(a);+    uint16_t B = GETBITS16(b);+    return idris_b16const(vm, A ^ B); }  VAL idris_b16Shl(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = A << B;-    return cl;+    uint16_t A = GETBITS16(a);+    uint16_t B = GETBITS16(b);+    return idris_b16const(vm, A << B); }  VAL idris_b16LShr(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = A >> B;-    return cl;+    uint16_t A = GETBITS16(a);+    uint16_t B = GETBITS16(b);+    return idris_b16const(vm, A >> B); }  VAL idris_b16AShr(VM *vm, VAL a, VAL b) {-    uint16_t A = a->info.bits16;-    uint16_t B = b->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = (uint16_t) (((int16_t) A) >> ((int16_t) B));-    return cl;+    int16_t A = GETBITS16(a);+    int16_t B = GETBITS16(b);+    return idris_b16const(vm, A >> B); }  VAL idris_b32Plus(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = A + B;-    return cl;+    uint32_t A = GETBITS32(a);+    uint32_t B = GETBITS32(b);+    return idris_b32const(vm, A + B); }  VAL idris_b32Minus(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = A - B;-    return cl;+    uint32_t A = GETBITS32(a);+    uint32_t B = GETBITS32(b);+    return idris_b32const(vm, A - B); }  VAL idris_b32Times(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = A * B;-    return cl;+    uint32_t A = GETBITS32(a);+    uint32_t B = GETBITS32(b);+    return idris_b32const(vm, A * B); }  VAL idris_b32UDiv(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = A / B;-    return cl;+    uint32_t A = GETBITS32(a);+    uint32_t B = GETBITS32(b);+    return idris_b32const(vm, A / B); }  VAL idris_b32SDiv(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = (uint32_t) (((int32_t) A) / ((int32_t) B));-    return cl;+    int32_t A = GETBITS32(a);+    int32_t B = GETBITS32(b);+    return idris_b32const(vm, A / B); }  VAL idris_b32URem(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = A % B;-    return cl;+    uint32_t A = GETBITS32(a);+    uint32_t B = GETBITS32(b);+    return idris_b32const(vm, A % B); }  VAL idris_b32SRem(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = (uint32_t) (((int32_t) A) % ((int32_t) B));-    return cl;+    int32_t A = GETBITS32(a);+    int32_t B = GETBITS32(b);+    return idris_b32const(vm, A % B); }  VAL idris_b32Lt(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits32 < b->info.bits32));+    return MKINT((i_int) (GETBITS32(a) < GETBITS32(b))); }  VAL idris_b32Gt(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits32 > b->info.bits32));+    return MKINT((i_int) (GETBITS32(a) > GETBITS32(b))); }  VAL idris_b32Eq(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits32 == b->info.bits32));+    return MKINT((i_int) (GETBITS32(a) == GETBITS32(b))); }  VAL idris_b32Lte(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits32 <= b->info.bits32));+    return MKINT((i_int) (GETBITS32(a) <= GETBITS32(b))); }  VAL idris_b32Gte(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits32 >= b->info.bits32));+    return MKINT((i_int) (GETBITS32(a) >= GETBITS32(b))); }  VAL idris_b32Compl(VM *vm, VAL a) {-    uint32_t A = a->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = ~ A;-    return cl;+    uint32_t A = GETBITS32(a);+    return idris_b32const(vm, ~ A); }  VAL idris_b32And(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = A & B;-    return cl;+    uint32_t A = GETBITS32(a);+    uint32_t B = GETBITS32(b);+    return idris_b32const(vm, A & B); }  VAL idris_b32Or(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = A | B;-    return cl;+    uint32_t A = GETBITS32(a);+    uint32_t B = GETBITS32(b);+    return idris_b32const(vm, A | B); }  VAL idris_b32Xor(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = A ^ B;-    return cl;+    uint32_t A = GETBITS32(a);+    uint32_t B = GETBITS32(b);+    return idris_b32const(vm, A ^ B); }  VAL idris_b32Shl(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = A << B;-    return cl;+    uint32_t A = GETBITS32(a);+    uint32_t B = GETBITS32(b);+    return idris_b32const(vm, A << B); }  VAL idris_b32LShr(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = A >> B;-    return cl;+    uint32_t A = GETBITS32(a);+    uint32_t B = GETBITS32(b);+    return idris_b32const(vm, A >> B); }  VAL idris_b32AShr(VM *vm, VAL a, VAL b) {-    uint32_t A = a->info.bits32;-    uint32_t B = b->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = (uint32_t) (((int32_t)A) >> ((int32_t)B));-    return cl;+    int32_t A = GETBITS32(a);+    int32_t B = GETBITS32(b);+    return idris_b32const(vm, A >> B); }  VAL idris_b64Plus(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = A + B;-    return cl;+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return idris_b64const(vm, A + B); }  VAL idris_b64Minus(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = A - B;-    return cl;+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return idris_b64const(vm, A - B); }  VAL idris_b64Times(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = A * B;-    return cl;+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return idris_b64const(vm, A * B); }  VAL idris_b64UDiv(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = A / B;-    return cl;+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return idris_b64const(vm, A / B); }  VAL idris_b64SDiv(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = (uint64_t) (((int64_t) A) / ((int64_t) B));-    return cl;+    int64_t A = GETBITS64(a);+    int64_t B = GETBITS64(b);+    return idris_b64const(vm, A / B); }  VAL idris_b64URem(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = A % B;-    return cl;+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return idris_b64const(vm, A % B); }  VAL idris_b64SRem(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = (uint64_t) (((int64_t) A) % ((int64_t) B));-    return cl;+    int64_t A = GETBITS64(a);+    int64_t B = GETBITS64(b);+    return idris_b64const(vm, A % B); }  VAL idris_b64Lt(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits64 < b->info.bits64));+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return MKINT((i_int) (A < B)); }  VAL idris_b64Gt(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits64 > b->info.bits64));+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return MKINT((i_int) (A > B)); }  VAL idris_b64Eq(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits64 == b->info.bits64));+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return MKINT((i_int) (A == B)); }  VAL idris_b64Lte(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits64 <= b->info.bits64));+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return MKINT((i_int) (A <= B)); }  VAL idris_b64Gte(VM *vm, VAL a, VAL b) {-    return MKINT((i_int) (a->info.bits64 >= b->info.bits64));+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return MKINT((i_int) (A >= B)); }  VAL idris_b64Compl(VM *vm, VAL a) {-    uint64_t A = a->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = ~ A;-    return cl;+    uint64_t A = GETBITS64(a);+    return idris_b64const(vm, ~ A); }  VAL idris_b64And(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = A & B;-    return cl;+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return idris_b64const(vm, A & B); }  VAL idris_b64Or(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = A | B;-    return cl;+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return idris_b64const(vm, A | B); }  VAL idris_b64Xor(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = A ^ B;-    return cl;+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return idris_b64const(vm, A ^ B); }  VAL idris_b64Shl(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = A << B;-    return cl;+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return idris_b64const(vm, A << B); }  VAL idris_b64LShr(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = A >> B;-    return cl;+    uint64_t A = GETBITS64(a);+    uint64_t B = GETBITS64(b);+    return idris_b64const(vm, A >> B); }  VAL idris_b64AShr(VM *vm, VAL a, VAL b) {-    uint64_t A = a->info.bits64;-    uint64_t B = b->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = (uint64_t) (((int64_t) A) >> ((int64_t) B));-    return cl;+    int64_t A = GETBITS64(a);+    int64_t B = GETBITS64(b);+    return idris_b64const(vm, A >> B); }  VAL idris_b8Z16(VM *vm, VAL a) {-    uint8_t A = a->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = (uint16_t) A;-    return cl;+    uint8_t A = GETBITS8(a);+    return idris_b16const(vm, A); }  VAL idris_b8Z32(VM *vm, VAL a) {-    uint8_t A = a->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = (uint32_t) A;-    return cl;+    uint8_t A = GETBITS8(a);+    return idris_b32const(vm, A); }  VAL idris_b8Z64(VM *vm, VAL a) {-    uint8_t A = a->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = (uint64_t) A;-    return cl;+    uint8_t A = GETBITS8(a);+    return idris_b64const(vm, A); }  VAL idris_b8S16(VM *vm, VAL a) {-    uint8_t A = a->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = (uint16_t) (int16_t) (int8_t) A;-    return cl;+    int8_t A = GETBITS8(a);+    return idris_b16const(vm, (int16_t) A); }  VAL idris_b8S32(VM *vm, VAL a) {-    uint8_t A = a->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = (uint32_t) (int32_t) (int8_t) A;-    return cl;+    int8_t A = GETBITS8(a);+    return idris_b32const(vm, (int32_t) A); }  VAL idris_b8S64(VM *vm, VAL a) {-    uint8_t A = a->info.bits8;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = (uint64_t) (int64_t) (int8_t) A;-    return cl;+    int8_t A = GETBITS8(a);+    return idris_b64const(vm, (int64_t) A); }  VAL idris_b16Z32(VM *vm, VAL a) {-    uint16_t A = a->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = (uint32_t) A;-    return cl;+    uint16_t A = GETBITS16(a);+    return idris_b32const(vm, (uint32_t) A); }  VAL idris_b16Z64(VM *vm, VAL a) {-    uint16_t A = a->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = (uint64_t) A;-    return cl;+    uint16_t A = GETBITS16(a);+    return idris_b64const(vm, (uint64_t) A); }  VAL idris_b16S32(VM *vm, VAL a) {-    uint16_t A = a->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = (uint32_t) (int32_t) (int16_t) A;-    return cl;+    int16_t A = GETBITS16(a);+    return idris_b32const(vm, (int32_t) A); }  VAL idris_b16S64(VM *vm, VAL a) {-    uint16_t A = a->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = (uint64_t) (int64_t) (int16_t) A;-    return cl;+    int16_t A = GETBITS16(a);+    return idris_b64const(vm, (int64_t) A); }  VAL idris_b16T8(VM *vm, VAL a) {-    uint16_t A = a->info.bits16;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = (uint8_t) A;-    return cl;+    uint16_t A = GETBITS16(a);+    return idris_b8const(vm, (uint8_t) A); }  VAL idris_b32Z64(VM *vm, VAL a) {-    uint32_t A = a->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = (uint64_t) A;-    return cl;+    uint32_t A = GETBITS32(a);+    return idris_b64const(vm, (uint64_t) A); }  VAL idris_b32S64(VM *vm, VAL a) {-    uint32_t A = a->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS64);-    cl->info.bits64 = (uint64_t) (int64_t) (int32_t) A;-    return cl;+    int32_t A = GETBITS32(a);+    return idris_b64const(vm, (int64_t) A); }  VAL idris_b32T8(VM *vm, VAL a) {-    uint32_t A = a->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = (uint8_t) A;-    return cl;+    uint32_t A = GETBITS32(a);+    return idris_b8const(vm, (uint8_t) A); }  VAL idris_b32T16(VM *vm, VAL a) {-    uint32_t A = a->info.bits32;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = (uint16_t) A;-    return cl;+    uint32_t A = GETBITS32(a);+    return idris_b16const(vm, (uint16_t) A); }  VAL idris_b64T8(VM *vm, VAL a) {-    uint64_t A = a->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS8);-    cl->info.bits8 = (uint8_t) A;-    return cl;+    uint64_t A = GETBITS64(a);+    return idris_b8const(vm, (uint8_t) A); }  VAL idris_b64T16(VM *vm, VAL a) {-    uint64_t A = a->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS16);-    cl->info.bits16 = (uint16_t) A;-    return cl;+    uint64_t A = GETBITS64(a);+    return idris_b16const(vm, (uint16_t) A); }  VAL idris_b64T32(VM *vm, VAL a) {-    uint64_t A = a->info.bits64;-    VAL cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_BITS32);-    cl->info.bits32 = (uint32_t) A;-    return cl;+    uint64_t A = GETBITS64(a);+    return idris_b32const(vm, (uint32_t) A); }  VAL idris_peekB8(VM* vm, VAL ptr, VAL offset) {
rts/idris_bitstring.h view
@@ -1,11 +1,6 @@ #ifndef _IDRISBITSTRING_H #define _IDRISBITSTRING_H -VAL idris_b8CopyForGC(VM *vm, VAL a);-VAL idris_b16CopyForGC(VM *vm, VAL a);-VAL idris_b32CopyForGC(VM *vm, VAL a);-VAL idris_b64CopyForGC(VM *vm, VAL a);- VAL idris_b8(VM *vm, VAL a); VAL idris_b16(VM *vm, VAL a); VAL idris_b32(VM *vm, VAL a);
rts/idris_buffer.c view
@@ -49,6 +49,18 @@     } } +void idris_setBufferDouble(void* buffer, int loc, double val) {+    Buffer* b = buffer;+    // I am not proud of this+    if (loc >= 0 && loc + sizeof(double) <= b->size) {+        unsigned char* c = (unsigned char*)(& val);+        int i;+        for (i = 0; i < sizeof(double); ++i) {+            b->data[loc+i] = c[i];+        }+    }+}+ void idris_setBufferString(void* buffer, int loc, char* str) {     Buffer* b = buffer;     int len = strlen(str);@@ -70,33 +82,37 @@ int idris_getBufferInt(void* buffer, int loc) {     Buffer* b = buffer;     if (loc >= 0 && loc+3 < b->size) {-        return b->data[loc] + +        return b->data[loc] +                (b->data[loc+1] << 8) +-               (b->data[loc+2] << 16) + +               (b->data[loc+2] << 16) +                (b->data[loc+3] << 24);     } else {         return 0;     } } -VAL idris_getBufferString(void* buffer, int loc, int len) {+double idris_getBufferDouble(void* buffer, int loc) {     Buffer* b = buffer;--    Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) +-                           sizeof(char)*(len+1), 0);-    SETTY(cl, CT_STRING);-    cl->info.str.str = (char*)cl + sizeof(Closure);--    if (loc >= 0 && loc+len <= b->size) {-        memcpy(cl->info.str.str, (b->data)+loc, len);-        cl->info.str.str[len]='\0';-        cl->info.str.len = len;-    } else {-        cl->info.str.str[0] = '\0';-        cl->info.str.len = 0;+    double d;+    // I am even less proud of this+    unsigned char *c = (unsigned char*)(& d);+    if (loc >= 0 && loc + sizeof(double) <= b->size) {+        int i;+        for (i = 0; i < sizeof(double); ++i) {+            c[i] = b->data[loc+i];+        }+        return d;     }+    else {+        return 0;+    }+} -    return cl;+VAL idris_getBufferString(void* buffer, int loc, int len) {+    Buffer* b = buffer;+    char * s = (char*)(b->data + loc);+    size_t sz = loc >= 0 && loc+len <= b->size? len : 0;+    return MKSTRlen(get_vm(), s, sz); }  int idris_readBuffer(FILE* h, void* buffer, int loc, int max) {@@ -124,4 +140,3 @@         fwrite((b->data)+loc, sizeof(uint8_t), len, h);     } }-
rts/idris_buffer.h view
@@ -11,7 +11,8 @@ int idris_getBufferSize(void* buffer);  void idris_setBufferByte(void* buffer, int loc, uint8_t byte);-void idris_setBufferInt(void* buffer, int loc, int byte);+void idris_setBufferInt(void* buffer, int loc, int val);+void idris_setBufferDouble(void* buffer, int loc, double val); void idris_setBufferString(void* buffer, int loc, char* str);  void idris_copyBuffer(void* from, int start, int len,@@ -22,6 +23,7 @@  uint8_t idris_getBufferByte(void* buffer, int loc); int idris_getBufferInt(void* buffer, int loc);+double idris_getBufferDouble(void* buffer, int loc); VAL idris_getBufferString(void* buffer, int loc, int len);  #endif
rts/idris_gc.c view
@@ -4,116 +4,97 @@ #include "idris_bitstring.h" #include <assert.h> +static inline VAL copy_plain(VM* vm, VAL x, size_t sz) {+    VAL cl = iallocate(vm, sz, 1);+    memcpy(cl, x, sz);+    return cl;+}+ VAL copy(VM* vm, VAL x) {-    int ar, len;-    Closure* cl = NULL;-    if (x==NULL || ISINT(x)) {+    int ar;+    VAL cl;+    if (x==NULL) {         return x;     }     switch(GETTY(x)) {+    case CT_INT: return x;+    case CT_BITS32: return copy_plain(vm, x, sizeof(Bits32));+    case CT_BITS64: return copy_plain(vm, x, sizeof(Bits64));+    case CT_FLOAT: return copy_plain(vm, x, sizeof(Float));+    case CT_FWD:+        return GETPTR(x);+    case CT_CDATA:+        cl = copy_plain(vm, x, sizeof(CDataC));+        c_heap_mark_item(GETCDATA(x));+        break;+    case CT_BIGINT:+        cl = MKBIGMc(vm, GETMPZ(x));+        break;     case CT_CON:         ar = CARITY(x);         if (ar == 0 && CTAG(x) < 256) {             return x;-        } else {-            allocCon(cl, vm, CTAG(x), ar, 1);-            memcpy(&(cl->info.c.args), &(x->info.c.args), sizeof(VAL)*ar);         }-        break;+        // FALLTHROUGH     case CT_ARRAY:-        len = x->info.arr.length;-	allocArray(cl, vm, len, 1);-        memcpy(&(cl->info.arr.content), &(x->info.arr.content), sizeof(VAL)*len);-        break;-    case CT_FLOAT:-        cl = MKFLOATc(vm, x->info.f);-        break;     case CT_STRING:-        cl = MKSTRclen(vm, x->info.str.str, x->info.str.len);-        break;+    case CT_REF:     case CT_STROFFSET:-        cl = MKSTROFFc(vm, x->info.str_offset);-        break;-    case CT_BIGINT:-        cl = MKBIGMc(vm, x->info.ptr);-        break;     case CT_PTR:-        cl = MKPTRc(vm, x->info.ptr);-        break;     case CT_MANAGEDPTR:-        cl = MKMPTRc(vm, x->info.mptr->data, x->info.mptr->size);-        break;-    case CT_BITS8:-        cl = idris_b8CopyForGC(vm, x);-        break;-    case CT_BITS16:-        cl = idris_b16CopyForGC(vm, x);-        break;-    case CT_BITS32:-        cl = idris_b32CopyForGC(vm, x);-        break;-    case CT_BITS64:-        cl = idris_b64CopyForGC(vm, x);-        break;-    case CT_REF:-        cl = idris_newRefLock((VAL)(x->info.ptr), 1);-        break;-    case CT_FWD:-        return x->info.ptr;     case CT_RAWDATA:-        {-            size_t size = x->info.size + sizeof(Closure);-            cl = allocate(size, 1);-            memcpy(cl, x, size);-        }-        break;-    case CT_CDATA:-        cl = MKCDATAc(vm, x->info.c_heap_item);-        c_heap_mark_item(x->info.c_heap_item);+        cl = copy_plain(vm, x, x->hdr.sz);         break;     default:+        cl = NULL;+        assert(0);         break;     }+    assert(x->hdr.sz >= sizeof(Fwd));     SETTY(x, CT_FWD);-    x->info.ptr = cl;+    ((Fwd*)x)->fwd = cl;     return cl; }  void cheney(VM *vm) {-    int i;-    int ar, len;     char* scan = aligned_heap_pointer(vm->heap.heap);      while(scan < vm->heap.next) {-       size_t inc = *((size_t*)scan);-       VAL heap_item = (VAL)(scan+sizeof(size_t));+       VAL heap_item = (VAL)scan;        // If it's a CT_CON, CT_REF or CT_STROFFSET, copy its arguments        switch(GETTY(heap_item)) {        case CT_CON:-           ar = ARITY(heap_item);-           for(i = 0; i < ar; ++i) {-               VAL newptr = copy(vm, heap_item->info.c.args[i]);-               heap_item->info.c.args[i] = newptr;+           {+               Con * c = (Con*)heap_item;+               size_t len = CARITY(c);+               for(size_t i = 0; i < len; ++i)+                   c->args[i] = copy(vm, c->args[i]);            }            break;        case CT_ARRAY:-           len = heap_item->info.arr.length;-           for(i = 0; i < len; ++i) {-               VAL newptr = copy(vm, heap_item->info.arr.content[i]);-               heap_item->info.arr.content[i] = newptr;+           {+               Array * a = (Array*)heap_item;+               size_t len = CELEM(a);+               for(size_t i = 0; i < len; ++i)+                   a->array[i] = copy(vm, a->array[i]);            }            break;        case CT_REF:-           heap_item->info.ptr = copy(vm, (VAL)(heap_item->info.ptr));+           {+               Ref * r = (Ref*)heap_item;+               r->ref = copy(vm, r->ref);+           }            break;        case CT_STROFFSET:-           heap_item->info.str_offset->str-               = copy(vm, heap_item->info.str_offset->str);+           {+               StrOffset * s = (StrOffset*)heap_item;+               s->base = (String*)copy(vm, (VAL)s->base);+           }            break;        default: // Nothing to copy            break;        }-       scan += inc;+       scan += aligned(valSize(heap_item));     }     assert(scan == vm->heap.next); }
rts/idris_gmp.c view
@@ -22,249 +22,126 @@     return MKINT((i_int)val); } +static BigInt * allocBig(VM * vm) {+    idris_requireAlloc(vm, IDRIS_MAXGMP);+    BigInt * cl = iallocate(vm, sizeof(*cl) + sizeof(mpz_t), 0);+    idris_doneAlloc(vm);+    SETTY(cl, CT_BIGINT);+    mpz_init(*getmpz(cl));+    return cl;+}+ VAL MKBIGC(VM* vm, char* val) {     if (*val == '\0') {         return MKBIGI(0);     }     else {-        idris_requireAlloc(IDRIS_MAXGMP);-        mpz_t* bigint;-        -        VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-        idris_doneAlloc();-        bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));-        -        mpz_init(*bigint);-        mpz_set_str(*bigint, val, 10);--        SETTY(cl, CT_BIGINT);-        cl -> info.ptr = (void*)bigint;--        return cl;+        BigInt * cl = allocBig(vm);+        mpz_set_str(*getmpz(cl), val, 10);+        return (VAL)cl;     } } -VAL MKBIGM(VM* vm, void* big) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));--    mpz_init(*bigint);-    mpz_set(*bigint, *((mpz_t*)big));--    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;--    return cl;+VAL MKBIGM(VM* vm, void* ibig) {+    BigInt * cl = allocBig(vm);+    mpz_set(*getmpz(cl), *((mpz_t*)ibig));+    return (VAL)cl; } -VAL MKBIGMc(VM* vm, void* big) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));--    mpz_init_set(*bigint, *((mpz_t*)big));--    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;--    return cl;+VAL MKBIGMc(VM* vm, void* ibig) {+    BigInt * cl = allocBig(vm);+    mpz_init_set(*getmpz(cl), *((mpz_t*)ibig));+    return (VAL)cl; }  VAL MKBIGUI(VM* vm, unsigned long val) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));--    mpz_init_set_ui(*bigint, val);--    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;--    return cl;+    BigInt * cl = allocBig(vm);+    mpz_init_set_ui(*getmpz(cl), val);+    return (VAL)cl; }  VAL MKBIGSI(VM* vm, signed long val) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));--    mpz_init_set_si(*bigint, val);--    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;--    return cl;+    BigInt * cl = allocBig(vm);+    mpz_init_set_si(*getmpz(cl), val);+    return (VAL)cl; } -VAL GETBIG(VM * vm, VAL x) {-    idris_requireAlloc(IDRIS_MAXGMP);--    if (ISINT(x)) {-        mpz_t* bigint;-        VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-        idris_doneAlloc();-        bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));--        mpz_init(*bigint);-        mpz_set_si(*bigint, GETINT(x));--        SETTY(cl, CT_BIGINT);-        cl -> info.ptr = (void*)bigint;--        return cl;-    } else {-        idris_doneAlloc();-        switch(GETTY(x)) {-        case CT_FWD:-            return GETBIG(vm, x->info.ptr);-        default:-            return x;+static BigInt * getbig(VM * vm, VAL x) {+    switch(GETTY(x)) {+    case CT_INT:+        {+            BigInt * cl = allocBig(vm);+            mpz_set_si(*getmpz(cl), GETINT(x));+            return cl;         }+    case CT_FWD:+        return getbig(vm, ((Fwd*)x)->fwd);+    default:+        return (BigInt*)x;     } } -VAL bigAdd(VM* vm, VAL x, VAL y) {-    idris_requireAlloc(IDRIS_MAXGMP);+#define GETBIG (VAL)getbig -    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));-    mpz_add(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));-    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;-    return cl;+VAL bigAdd(VM* vm, VAL x, VAL y) {+    BigInt * cl = allocBig(vm);+    mpz_add(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));+    return (VAL)cl; }  VAL bigSub(VM* vm, VAL x, VAL y) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));-    mpz_sub(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));-    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;-    return cl;+    BigInt * cl = allocBig(vm);+    mpz_sub(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));+    return (VAL)cl; }  VAL bigMul(VM* vm, VAL x, VAL y) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));-    mpz_mul(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));-    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;-    return cl;+    BigInt * cl = allocBig(vm);+    mpz_mul(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));+    return (VAL)cl; }  VAL bigDiv(VM* vm, VAL x, VAL y) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));-    mpz_tdiv_q(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));-    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;-    return cl;+    BigInt * cl = allocBig(vm);+    mpz_tdiv_q(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));+    return (VAL)cl; }  VAL bigMod(VM* vm, VAL x, VAL y) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));-    mpz_tdiv_r(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));-    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;-    return cl;+    BigInt * cl = allocBig(vm);+    mpz_tdiv_r(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));+    return (VAL)cl; }  VAL bigAnd(VM* vm, VAL x, VAL y) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));-    mpz_and(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));-    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;-    return cl;+    BigInt * cl = allocBig(vm);+    mpz_and(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));+    return (VAL)cl; }  VAL bigOr(VM* vm, VAL x, VAL y) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));-    mpz_ior(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));-    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;-    return cl;+    BigInt * cl = allocBig(vm);+    mpz_ior(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));+    return (VAL)cl; }  VAL bigShiftLeft(VM* vm, VAL x, VAL y) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));-    mpz_mul_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));-    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;-    return cl;+    BigInt * cl = allocBig(vm);+    mpz_mul_2exp(*getmpz(cl), *getmpz(getbig(vm,x)), GETINT(y));+    return (VAL)cl; }   VAL bigLShiftRight(VM* vm, VAL x, VAL y) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));-    mpz_fdiv_q_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));-    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;-    return cl;+    BigInt * cl = allocBig(vm);+    mpz_fdiv_q_2exp(*getmpz(cl), *getmpz(getbig(vm,x)), GETINT(y));+    return (VAL)cl; }  VAL bigAShiftRight(VM* vm, VAL x, VAL y) {-    idris_requireAlloc(IDRIS_MAXGMP);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    idris_doneAlloc();-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));-    mpz_fdiv_q_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));-    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;-    return cl;+    BigInt * cl = allocBig(vm);+    mpz_fdiv_q_2exp(*getmpz(cl), *getmpz(getbig(vm,x)), GETINT(y));+    return (VAL)cl; }  VAL idris_bigAnd(VM* vm, VAL x, VAL y) {@@ -323,15 +200,15 @@     if (ISINT(x) && ISINT(y)) {         i_int vx = GETINT(x);         i_int vy = GETINT(y);-	// we could work out likelihood of overflow by checking the number-	// of necessary bits. Here's a quick conservative hack instead.-	if ((vx < (1<<15) && vy < (1<16)) ||-	    (vx < (1<<16) && vy < (1<15)) ||-	    (vx < (1<<20) && vy < (1<11)) ||-	    (vx < (1<<11) && vy < (1<20)) ||-	    (vx < (1<<23) && vy < (1<<8)) ||-	    (vx < (1<<8) && vy < (1<<23))) { // ultra-conservative!-	    return INTOP(*,x,y);+        // we could work out likelihood of overflow by checking the number+        // of necessary bits. Here's a quick conservative hack instead.+        if ((vx < (1<<15) && vy < (1<16)) ||+            (vx < (1<<16) && vy < (1<15)) ||+            (vx < (1<<20) && vy < (1<11)) ||+            (vx < (1<<11) && vy < (1<20)) ||+            (vx < (1<<23) && vy < (1<<8)) ||+            (vx < (1<<8) && vy < (1<<23))) { // ultra-conservative!+            return INTOP(*,x,y);         } else {             return bigMul(vm, GETBIG(vm, x), GETBIG(vm, y));         }@@ -382,8 +259,8 @@  int bigEqConst(VAL x, int c) {     if (ISINT(x)) { return (GETINT(x) == c); }-    else { -        int rv = mpz_cmp_si(GETMPZ(x), c); +    else {+        int rv = mpz_cmp_si(GETMPZ(x), c);         return (rv == 0);     } }@@ -471,17 +348,9 @@  VAL idris_castFloatBig(VM* vm, VAL f) {     double val = GETFLOAT(f);--    mpz_t* bigint;-    VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);-    bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));--    mpz_init_set_d(*bigint, val);--    SETTY(cl, CT_BIGINT);-    cl -> info.ptr = (void*)bigint;--    return cl;+    BigInt * cl = allocBig(vm);+    mpz_init_set_d(*getmpz(cl), val);+    return (VAL)cl; }  VAL idris_castStrBig(VM* vm, VAL i) {@@ -489,7 +358,7 @@ }  VAL idris_castBigStr(VM* vm, VAL i) {-    char* str = mpz_get_str(NULL, 10, GETMPZ(GETBIG(vm, i)));+    char* str = mpz_get_str(NULL, 10, *getmpz(getbig(vm, i)));     return MKSTR(vm, str); } @@ -502,7 +371,7 @@     }     int64_t out = mpz_get_ui(bi);     if (mpz_size(bi) > 1) {-        out |= mpz_getlimbn(bi, 1) << 32;+        out |= ((int64_t)mpz_getlimbn(bi, 1)) << 32;     }     return out; }
rts/idris_gmp.h view
@@ -48,6 +48,10 @@  uint64_t idris_truncBigB64(const mpz_t bi); -#define GETMPZ(x) *((mpz_t*)((x)->info.ptr))+static inline mpz_t * getmpz(BigInt * v) {+    return (mpz_t*)(v->big);+}++#define GETMPZ(x) *getmpz((BigInt*)x)  #endif
rts/idris_heap.c view
@@ -55,7 +55,7 @@     heap->first = item;      // at this point, links are done; let's calculate sizes-    +     heap->size += item->size;     if (heap->size >= heap->gc_trigger_size)     {@@ -186,16 +186,17 @@      size_t item_size = 0;     for(scan = heap->heap; scan < heap->next; scan += item_size) {-       item_size = *((size_t*)scan);-       VAL heap_item = (VAL)(scan + sizeof(size_t));+       VAL heap_item = (VAL)scan;+       item_size = aligned(valSize(heap_item));         switch(GETTY(heap_item)) {        case CT_CON:            {-             int ar = ARITY(heap_item);-             int i = 0;+	     Con * c = (Con*)heap_item;+             size_t ar = CARITY(c);+             size_t i;              for(i = 0; i < ar; ++i) {-                 VAL ptr = heap_item->info.c.args[i];+                 VAL ptr = c->args[i];                   if (is_valid_ref(ptr)) {                      // Check for closure.
rts/idris_main.c view
@@ -4,8 +4,11 @@ #include "idris_stats.h"  void _idris__123_runMain_95_0_125_(VM* vm, VAL* oldbase);-#if defined(WIN32) || defined(__WIN32) || defined(__WIN32__)++#ifdef _WIN32+ #include <Windows.h>+ int win32_get_argv_utf8(int *argc_ptr, char ***argv_ptr) {     int argc;@@ -26,16 +29,17 @@     *argv_ptr = argv;     return 0; }+ #endif  // The default options should give satisfactory results under many circumstances.-RTSOpts opts = { +RTSOpts opts = {     .init_heap_size = 16384000,     .max_stack_size = 4096000,     .show_summary   = 0 }; -#if defined(WIN32) || defined(__WIN32) || defined(__WIN32__)+#ifdef _WIN32 int main() {     int argc;     char **argv;@@ -70,6 +74,5 @@         print_stats(&stats);     } -    free_nullaries();     return EXIT_SUCCESS; }
rts/idris_net.c view
@@ -8,7 +8,7 @@ #include <stdio.h> #include <string.h> -#ifndef WIN32+#ifndef _WIN32 #include <netinet/in.h> #include <arpa/inet.h> #else@@ -58,7 +58,7 @@   int idrnet_socket(int domain, int type, int protocol) {-#ifdef WIN32+#ifdef _WIN32     if (!check_init()) {         return -1;     }
rts/idris_net.h view
@@ -2,7 +2,7 @@ #define IDRISNET_H  // Includes used by the idris-file.-#ifdef WIN32+#ifdef _WIN32 #include <winsock2.h> #include <Ws2tcpip.h> #else
rts/idris_rts.c view
@@ -7,13 +7,22 @@ #include "idris_bitstring.h" #include "getline.h" +#define STATIC_ASSERT(COND,MSG) typedef char static_assertion_##MSG[(COND)?1:-1]++STATIC_ASSERT(sizeof(Hdr) == 8, condSizeOfHdr);++#if defined(__linux__) || defined(__APPLE__) || defined(__FreeBSD__) || defined(__DragonFly__)+#include <signal.h>+#endif++ #ifdef HAS_PTHREAD static pthread_key_t vm_key; #else static VM* global_vm; #endif -void free_key(VM *vm) {+void free_key(void *vvm) {     // nothing to free, we just used the VM pointer which is freed elsewhere } @@ -40,8 +49,9 @@     vm->ret = NULL;     vm->reg1 = NULL; #ifdef HAS_PTHREAD-    vm->inbox = malloc(1024*sizeof(VAL));-    memset(vm->inbox, 0, 1024*sizeof(VAL));+    vm->inbox = malloc(1024*sizeof(vm->inbox[0]));+    assert(vm->inbox);+    memset(vm->inbox, 0, 1024*sizeof(vm->inbox[0]));     vm->inbox_end = vm->inbox + 1024;     vm->inbox_write = vm->inbox;     vm->inbox_nextid = 1;@@ -83,7 +93,6 @@  VM* get_vm(void) { #ifdef HAS_PTHREAD-    init_threadkeys();     return pthread_getspecific(vm_key); #else     return global_vm;@@ -96,7 +105,7 @@  #ifdef HAS_PTHREAD void create_key(void) {-    pthread_key_create(&vm_key, (void*)free_key);+    pthread_key_create(&vm_key, free_key); } #endif @@ -114,7 +123,7 @@ }  void init_signals(void) {-#if (__linux__ || __APPLE__ || __FreeBSD__ || __DragonFly__)+#if defined(__linux__) || defined(__APPLE__) || defined(__FreeBSD__) || defined(__DragonFly__)     signal(SIGPIPE, SIG_IGN); #endif }@@ -155,13 +164,7 @@     return c_heap_create_item(data, size, finalizer); } -void idris_requireAlloc(size_t size) {-#ifdef HAS_PTHREAD-    VM* vm = pthread_getspecific(vm_key);-#else-    VM* vm = global_vm;-#endif-+void idris_requireAlloc(VM * vm, size_t size) {     if (!(vm->heap.next + size < vm->heap.end)) {         idris_gc(vm);     }@@ -173,9 +176,8 @@ #endif } -void idris_doneAlloc(void) {+void idris_doneAlloc(VM * vm) { #ifdef HAS_PTHREAD-    VM* vm = pthread_getspecific(vm_key);     int lock = vm->processes > 0;     if (lock) { // We only need to lock if we're in concurrent mode        pthread_mutex_unlock(&vm->alloc_lock);@@ -184,14 +186,13 @@ }  int space(VM* vm, size_t size) {-    return (vm->heap.next + size + sizeof(size_t) < vm->heap.end);+    return (vm->heap.next + size) < vm->heap.end; }  void* idris_alloc(size_t size) {-    Closure* cl = (Closure*) allocate(sizeof(Closure)+size, 0);+    RawData * cl = (RawData*) allocate(sizeof(*cl)+size, 0);     SETTY(cl, CT_RAWDATA);-    cl->info.size = size;-    return (void*)((char *)cl+sizeof(Closure));+    return (void*)cl->raw; }  void* idris_realloc(void* old, size_t old_size, size_t size) {@@ -203,41 +204,36 @@ void idris_free(void* ptr, size_t size) { } -void* allocate(size_t size, int outerlock) {-//    return malloc(size);+void * allocate(size_t sz, int lock) {+    return iallocate(get_vm(), sz, lock);+} +void* iallocate(VM * vm, size_t isize, int outerlock) {+//    return malloc(isize);+    size_t size = aligned(isize);+ #ifdef HAS_PTHREAD-    VM* vm = pthread_getspecific(vm_key);     int lock = vm->processes > 0 && !outerlock;      if (lock) { // not message passing        pthread_mutex_lock(&vm->alloc_lock);     }-#else-    VM* vm = global_vm; #endif -    if ((size & 7)!=0) {-	size = 8 + ((size >> 3) << 3);-    }--    size_t chunk_size = size + sizeof(size_t);--    if (vm->heap.next + chunk_size < vm->heap.end) {-        STATS_ALLOC(vm->stats, chunk_size)-        void* ptr = (void*)(vm->heap.next + sizeof(size_t));-        *((size_t*)(vm->heap.next)) = chunk_size;-        vm->heap.next += chunk_size;-+    if (vm->heap.next + size < vm->heap.end) {+        STATS_ALLOC(vm->stats, size)+        char* ptr = vm->heap.next;+        vm->heap.next += size;         assert(vm->heap.next <= vm->heap.end);-         memset(ptr, 0, size);+        ((Hdr*)ptr)->sz = isize;+ #ifdef HAS_PTHREAD         if (lock) { // not message passing            pthread_mutex_unlock(&vm->alloc_lock);         } #endif-        return ptr;+        return (void*)ptr;     } else {         // If we're trying to allocate something bigger than the heap,         // grow the heap here so that the new heap is big enough.@@ -250,173 +246,143 @@            pthread_mutex_unlock(&vm->alloc_lock);         } #endif-        return allocate(size, 0);+        return iallocate(vm, size, outerlock);     }  } -/* Now a macro-void* allocCon(VM* vm, int arity, int outer) {-    Closure* cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*arity,-                               outer);-    SETTY(cl, CT_CON);+static String * allocStr(VM * vm, size_t len, int outer) {+    String * cl = iallocate(vm, sizeof(*cl) + len + 1, outer);+    SETTY(cl, CT_STRING);+    cl->slen = len;+    return cl;+} -    cl -> info.c.arity = arity;-//    cl -> info.c.tag = 42424242;-//    printf("%p\n", cl);-    return (void*)cl;+static VAL mkfloat(VM* vm, double val, int outer) {+    Float * cl = iallocate(vm, sizeof(*cl), outer);+    SETTY(cl, CT_FLOAT);+    cl->f = val;+    return (VAL)cl; }-*/  VAL MKFLOAT(VM* vm, double val) {-    Closure* cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_FLOAT);-    cl -> info.f = val;-    return cl;+    return mkfloat(vm, val, 0); } +VAL MKFLOATc(VM* vm, double val) {+    return mkfloat(vm, val, 1);+}++static VAL mkstrlen(VM* vm, const char * str, size_t len, int outer) {+    String * cl = allocStr(vm, len, outer);+    // hdr.u8 used to mark a null string+    cl->hdr.u8 = str == NULL;+    if (!cl->hdr.u8)+      memcpy(cl->str, str, len);+    return (VAL)cl;+}++VAL MKSTRlen(VM* vm, const char * str, size_t len) {+    return mkstrlen(vm, str, len, 0);+}++VAL MKSTRclen(VM* vm, char* str, size_t len) {+    return mkstrlen(vm, str, len, 1);+}+ VAL MKSTR(VM* vm, const char* str) {-    int len;-    if (str == NULL) {-        len = 0;-    } else {-        len = strlen(str)+1;-    }-    Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) +-                           sizeof(char)*len, 0);-    SETTY(cl, CT_STRING);-    cl->info.str.str = (char*)cl + sizeof(Closure);-    if (str == NULL) {-        cl->info.str.str = NULL;-    } else {-        strcpy(cl->info.str.str, str);-    }-    cl->info.str.len = len > 0 ? len : 0;-    return cl;+    return mkstrlen(vm, str, str? strlen(str) : 0, 0); } +VAL MKSTRc(VM* vm, char* str) {+    return mkstrlen(vm, str, strlen(str), 1);+}++static char * getstroff(StrOffset * stroff) {+    return stroff->base->str + stroff->offset;+}+ char* GETSTROFF(VAL stroff) {     // Assume STROFF-    StrOffset* root = stroff->info.str_offset;-    return (root->str->info.str.str + root->offset);+    return getstroff((StrOffset*)stroff); } +static size_t getstrofflen(StrOffset * stroff) {+    return stroff->base->slen - stroff->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);+    return getstrofflen((StrOffset*)stroff); } -VAL MKCDATA(VM* vm, CHeapItem * item) {+static VAL mkcdata(VM * vm, CHeapItem * item, int outer) {     c_heap_insert_if_needed(vm, &vm->c_heap, item);-    Closure* cl = allocate(sizeof(Closure), 0);+    CDataC * cl = iallocate(vm, sizeof(*cl), outer);     SETTY(cl, CT_CDATA);-    cl->info.c_heap_item = item;-    return cl;+    cl->item = item;+    return (VAL)cl; } -VAL MKCDATAc(VM* vm, CHeapItem * item) {-    c_heap_insert_if_needed(vm, &vm->c_heap, item);-    Closure* cl = allocate(sizeof(Closure), 1);-    SETTY(cl, CT_CDATA);-    cl->info.c_heap_item = item;-    return cl;+VAL MKCDATA(VM* vm, CHeapItem * item) {+    return mkcdata(vm, item, 0); } -VAL MKPTR(VM* vm, void* ptr) {-    Closure* cl = allocate(sizeof(Closure), 0);-    SETTY(cl, CT_PTR);-    cl -> info.ptr = ptr;-    return cl;+VAL MKCDATAc(VM* vm, CHeapItem * item) {+    return mkcdata(vm, item, 1); } -VAL MKMPTR(VM* vm, void* ptr, size_t size) {-    Closure* cl = allocate(sizeof(Closure) +-                           sizeof(ManagedPtr) + size, 0);-    SETTY(cl, CT_MANAGEDPTR);-    cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));-    cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);-    memcpy(cl->info.mptr->data, ptr, size);-    cl->info.mptr->size = size;-    return cl;+static VAL mkptr(VM* vm, void* ptr, int outer) {+    Ptr * cl = iallocate(vm, sizeof(*cl), outer);+    SETTY(cl, CT_PTR);+    cl->ptr = ptr;+    return (VAL)cl; } -VAL MKFLOATc(VM* vm, double val) {-    Closure* cl = allocate(sizeof(Closure), 1);-    SETTY(cl, CT_FLOAT);-    cl -> info.f = val;-    return cl;+VAL MKPTR(VM* vm, void* ptr) {+    return mkptr(vm, ptr, 0); } -VAL MKSTRc(VM* vm, char* str) {-    int len = strlen(str);--    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) {+    return mkptr(vm, ptr, 1); } -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 mkmptr(VM* vm, void* ptr, size_t size, int outer) {+    ManagedPtr * cl = iallocate(vm, sizeof(*cl) + size, outer);+    SETTY(cl, CT_MANAGEDPTR);+    memcpy(cl->mptr, ptr, size);+    return (VAL)cl; } -VAL MKPTRc(VM* vm, void* ptr) {-    Closure* cl = allocate(sizeof(Closure), 1);-    SETTY(cl, CT_PTR);-    cl -> info.ptr = ptr;-    return cl;+VAL MKMPTR(VM* vm, void* ptr, size_t size) {+    return mkmptr(vm, ptr, size, 0); }  VAL MKMPTRc(VM* vm, void* ptr, size_t size) {-    Closure* cl = allocate(sizeof(Closure) +-                           sizeof(ManagedPtr) + size, 1);-    SETTY(cl, CT_MANAGEDPTR);-    cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));-    cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);-    memcpy(cl->info.mptr->data, ptr, size);-    cl->info.mptr->size = size;-    return cl;+    return mkmptr(vm, ptr, size, 1); }  VAL MKB8(VM* vm, uint8_t bits8) {-    Closure* cl = allocate(sizeof(Closure), 1);-    SETTY(cl, CT_BITS8);-    cl -> info.bits8 = bits8;-    return cl;+    return MKINT(bits8); }  VAL MKB16(VM* vm, uint16_t bits16) {-    Closure* cl = allocate(sizeof(Closure), 1);-    SETTY(cl, CT_BITS16);-    cl -> info.bits16 = bits16;-    return cl;+    return MKINT(bits16); }  VAL MKB32(VM* vm, uint32_t bits32) {-    Closure* cl = allocate(sizeof(Closure), 1);+    Bits32 * cl = iallocate(vm, sizeof(*cl), 1);     SETTY(cl, CT_BITS32);-    cl -> info.bits32 = bits32;-    return cl;+    cl->bits32 = bits32;+    return (VAL)cl; }  VAL MKB64(VM* vm, uint64_t bits64) {-    Closure* cl = allocate(sizeof(Closure), 1);+    Bits64 * cl = iallocate(vm, sizeof(*cl), 1);     SETTY(cl, CT_BITS64);-    cl -> info.bits64 = bits64;-    return cl;+    cl->bits64 = bits64;+    return (VAL)cl; }  void idris_trace(VM* vm, const char* func, int line) {@@ -445,29 +411,40 @@ void dumpVal(VAL v) {     if (v==NULL) return;     int i;-    if (ISINT(v)) {-        printf("%d ", (int)(GETINT(v)));-        return;-    }     switch(GETTY(v)) {+    case CT_INT:+        printf("%" PRIdPTR " ", GETINT(v));+        break;     case CT_CON:-        printf("%d[", TAG(v));-        for(i = 0; i < ARITY(v); ++i) {-            dumpVal(v->info.c.args[i]);+        {+            Con * cl = (Con*)v;+            printf("%d[", (int)TAG(cl));+            for(i = 0; i < CARITY(cl); ++i) {+                dumpVal(cl->args[i]);+            }+            printf("] ");         }-        printf("] ");         break;     case CT_STRING:-        printf("STR[%s]", v->info.str.str);+        {+            String * cl = (String*)v;+            printf("STR[%s]", cl->str);+        }         break;     case CT_STROFFSET:-        printf("OFFSET[");-        dumpVal((VAL)(v->info.str_offset->str));-        printf("]");+        {+            StrOffset * cl = (StrOffset*)v;+            printf("OFFSET[");+            dumpVal((VAL)cl->base);+            printf("]");+        }         break;     case CT_FWD:-        printf("CT_FWD ");-        dumpVal((VAL)(v->info.ptr));+        {+            Fwd * cl = (Fwd*)v;+            printf("CT_FWD ");+            dumpVal((VAL)cl->fwd);+        }         break;     default:         printf("val");@@ -489,7 +466,7 @@   VAL idris_peekPtr(VM* vm, VAL ptr, VAL offset) {-    void** addr = (void **)((char *)GETPTR(ptr) + GETINT(offset));+    void** addr = (void **)(((char *)GETPTR(ptr)) + GETINT(offset));     return MKPTR(vm, *addr); } @@ -523,51 +500,36 @@  VAL idris_castIntStr(VM* vm, VAL i) {     int x = (int) GETINT(i);-    Closure* cl = allocate(sizeof(Closure) + sizeof(char)*16, 0);-    SETTY(cl, CT_STRING);-    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;+    String * cl = allocStr(vm, 16, 0);+    cl->slen = sprintf(cl->str, "%d", x);+    return (VAL)cl; }  VAL idris_castBitsStr(VM* vm, VAL i) {-    Closure* cl;-    ClosureType ty = i->ty;+    String * cl;+    ClosureType ty = GETTY(i);      switch (ty) {-    case CT_BITS8:-        // max length 8 bit unsigned int str 3 chars (256)-        cl = allocate(sizeof(Closure) + sizeof(char)*4, 0);-        cl->info.str.str = (char*)cl + sizeof(Closure);-        sprintf(cl->info.str.str, "%" PRIu8, (uint8_t)i->info.bits8);-        break;-    case CT_BITS16:+    case CT_INT: // 8/16 bits         // max length 16 bit unsigned int str 5 chars (65,535)-        cl = allocate(sizeof(Closure) + sizeof(char)*6, 0);-        cl->info.str.str = (char*)cl + sizeof(Closure);-        sprintf(cl->info.str.str, "%" PRIu16, (uint16_t)i->info.bits16);+        cl = allocStr(vm, 6, 0);+        cl->slen = sprintf(cl->str, "%" PRIu16, (uint16_t)GETBITS16(i));         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.str = (char*)cl + sizeof(Closure);-        sprintf(cl->info.str.str, "%" PRIu32, (uint32_t)i->info.bits32);+        cl = allocStr(vm, 11, 0);+        cl->slen = sprintf(cl->str, "%" PRIu32, GETBITS32(i));         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.str = (char*)cl + sizeof(Closure);-        sprintf(cl->info.str.str, "%" PRIu64, (uint64_t)i->info.bits64);+        cl = allocStr(vm, 21, 0);+        cl->slen = sprintf(cl->str, "%" PRIu64, GETBITS64(i));         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;+    return (VAL)cl; }  VAL idris_castStrInt(VM* vm, VAL i) {@@ -580,13 +542,9 @@ }  VAL idris_castFloatStr(VM* vm, VAL i) {-    Closure* cl = allocate(sizeof(Closure) + sizeof(char)*32, 0);-    SETTY(cl, CT_STRING);-    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;+    String * cl = allocStr(vm, 32, 0);+    cl->slen = snprintf(cl->str, 32, "%.16g", GETFLOAT(i));+    return (VAL)cl; }  VAL idris_castStrFloat(VM* vm, VAL i) {@@ -596,17 +554,13 @@ VAL idris_concat(VM* vm, VAL l, VAL r) {     char *rs = GETSTR(r);     char *ls = GETSTR(l);-    int llen = GETSTRLEN(l);-    int rlen = GETSTRLEN(r);--    Closure* cl = allocate(sizeof(Closure) + llen + rlen + 1, 0);-    SETTY(cl, CT_STRING);-    cl->info.str.str = (char*)cl + sizeof(Closure);-    strcpy(cl->info.str.str, ls);-    strcat(cl->info.str.str, rs);+    size_t llen = GETSTRLEN(l);+    size_t rlen = GETSTRLEN(r); -    cl->info.str.len = llen + rlen;-    return cl;+    String * cl = allocStr(vm, llen + rlen, 0);+    memcpy(cl->str, ls, llen);+    memcpy(cl->str + llen, rs, rlen);+    return (VAL)cl; }  VAL idris_strlt(VM* vm, VAL l, VAL r) {@@ -667,38 +621,32 @@     return idris_strIndex(vm, str, 0); } -VAL MKSTROFFc(VM* vm, StrOffset* off) {-    Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 1);+VAL MKSTROFFc(VM* vm, VAL basestr) {+    StrOffset * cl = iallocate(vm, sizeof(*cl), 1);     SETTY(cl, CT_STROFFSET);-    cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure));--    cl->info.str_offset->str = off->str;-    cl->info.str_offset->offset = off->offset;--    return cl;+    cl->base = (String*)basestr;+    return (VAL)cl; }  VAL idris_strShift(VM* vm, VAL str, int num) {+    size_t sz = sizeof(StrOffset);     // If there's no room, just copy the string, or we'll have a problem after     // gc moves str-    if (space(vm, sizeof(Closure) + sizeof(StrOffset))) {-        Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 0);-        SETTY(cl, CT_STROFFSET);-        cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure));-+    if (space(vm, sz)) {         int offset = 0;-        VAL root = str;+        StrOffset * root = (StrOffset*)str;+        StrOffset * cl = iallocate(vm, sz, 0);+        SETTY(cl, CT_STROFFSET);          while(root!=NULL && !ISSTR(root)) { // find the root, carry on.                               // In theory, at most one step here!-            offset += root->info.str_offset->offset;-            root = root->info.str_offset->str;+            offset += root->offset;+            root = (StrOffset*)root->base;         } -        cl->info.str_offset->str = root;-        cl->info.str_offset->offset = offset+idris_utf8_findOffset(GETSTR(str), num);--        return cl;+        cl->base = (String*)root;+        cl->offset = offset+idris_utf8_findOffset(GETSTR(str), num);+        return (VAL)cl;     } else {         char* nstr = GETSTR(str);         return MKSTR(vm, nstr+idris_utf8_charlen(nstr));@@ -712,29 +660,23 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs) {     char *xstr = GETSTR(xs);     int xval = GETINT(x);-    int xlen = GETSTRLEN(xs);+    size_t xlen = GETSTRLEN(xs);+    String * cl;      if (xval < 0x80) { // ASCII char-        Closure* cl = allocate(sizeof(Closure) +-                               xlen + 2, 0);-        SETTY(cl, CT_STRING);-        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;+      cl = allocStr(vm, xlen + 1, 0);+        cl->str[0] = (char)(GETINT(x));+        memcpy(cl->str+1, xstr, xlen);     } else {         char *init = idris_utf8_fromChar(xval);-        int newlen = strlen(init) + xlen;-        Closure* cl = allocate(sizeof(Closure) + newlen + 1, 0);-        SETTY(cl, CT_STRING);-        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;+        size_t ilen = strlen(init);+        int newlen = ilen + xlen;+        cl = allocStr(vm, newlen, 0);+        memcpy(cl->str, init, ilen);+        memcpy(cl->str + ilen, xstr, xlen);         free(init);-        return cl;     }+    return (VAL)cl; }  VAL idris_strIndex(VM* vm, VAL str, VAL i) {@@ -743,8 +685,8 @@ }  VAL idris_substr(VM* vm, VAL offset, VAL length, VAL str) {-    int offset_val = GETINT(offset);-    int length_val = GETINT(length);+    size_t offset_val = GETINT(offset);+    size_t length_val = GETINT(length);     char* str_val = GETSTR(str);      // If the substring is a suffix, use idris_strShift to avoid reallocating@@ -754,33 +696,28 @@     else {         char *start = idris_utf8_advance(str_val, offset_val);         char *end = idris_utf8_advance(start, length_val);-        Closure* newstr = allocate(sizeof(Closure) + (end - start) +1, 0);-        SETTY(newstr, CT_STRING);-        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;+        size_t sz = end - start;+        String * newstr = allocStr(vm, sz, 0);+        memcpy(newstr->str, start, sz);+        newstr->str[sz] = '\0';+        return (VAL)newstr;     } }  VAL idris_strRev(VM* vm, VAL str) {     char *xstr = GETSTR(str);-    int xlen = GETSTRLEN(str);+    size_t xlen = GETSTRLEN(str); -    Closure* cl = allocate(sizeof(Closure) + xlen + 1, 0);-    SETTY(cl, CT_STRING);-    cl->info.str.str = (char*)cl + sizeof(Closure);-    cl->info.str.len = xlen;-    idris_utf8_rev(xstr, cl->info.str.str);-    return cl;+    String * cl = allocStr(vm, xlen, 0);+    idris_utf8_rev(xstr, cl->str);+    return (VAL)cl; }  VAL idris_newRefLock(VAL x, int outerlock) {-    Closure* cl = allocate(sizeof(Closure), outerlock);+    Ref * cl = allocate(sizeof(*cl), outerlock);     SETTY(cl, CT_REF);-    cl->info.ptr = (void*)x;-    return cl;+    cl->ref = x;+    return (VAL)cl; }  VAL idris_newRef(VAL x) {@@ -788,30 +725,34 @@ }  void idris_writeRef(VAL ref, VAL x) {-    ref->info.ptr = (void*)x;+    Ref * r = (Ref*)ref;+    r->ref = x;     SETTY(ref, CT_REF); }  VAL idris_readRef(VAL ref) {-    return (VAL)(ref->info.ptr);+    Ref * r = (Ref*)ref;+    return r->ref; }  VAL idris_newArray(VM* vm, int size, VAL def) {-    Closure* cl;+    Array * cl;     int i;-    allocArray(cl, vm, size, 0);+    cl = allocArrayF(vm, size, 0);     for(i=0; i<size; ++i) {-	cl->info.arr.content[i] = def;+        cl->array[i] = def;     }-    return cl;+    return (VAL)cl; }  void idris_arraySet(VAL arr, int index, VAL newval) {-     arr->info.arr.content[index] = newval;+    Array * cl = (Array*)arr;+    cl->array[index] = newval; }  VAL idris_arrayGet(VAL arr, int index) {-     return arr->info.arr.content[index];+    Array * cl = (Array*)arr;+    return cl->array[index]; }  VAL idris_systemInfo(VM* vm, VAL index) {@@ -892,88 +833,69 @@     return NULL; } +static VAL doCopyTo(VM* vm, VAL x);++static void copyArray(VM* vm, VAL * dst, VAL * src, size_t len) {+    size_t i;+    for(i = 0; i < len; ++i)+      dst[i] = doCopyTo(vm, src[i]);+}++ // VM is assumed to be a different vm from the one x lives on -VAL doCopyTo(VM* vm, VAL x) {-    int i, ar, len;-    VAL* argptr;-    Closure* cl;-    if (x==NULL || ISINT(x)) {+static VAL doCopyTo(VM* vm, VAL x) {+    int ar;+    VAL cl;+    if (x==NULL) {         return x;     }     switch(GETTY(x)) {+    case CT_INT:+        return x;+    case CT_CDATA:+        cl = MKCDATAc(vm, GETCDATA(x));+        break;+    case CT_BIGINT:+        cl = MKBIGMc(vm, GETMPZ(x));+        break;     case CT_CON:         ar = CARITY(x);         if (ar == 0 && CTAG(x) < 256) { // globally allocated             cl = x;         } else {-            allocCon(cl, vm, CTAG(x), ar, 1);--            argptr = (VAL*)(cl->info.c.args);-            for(i = 0; i < ar; ++i) {-                *argptr = doCopyTo(vm, *((VAL*)(x->info.c.args)+i)); // recursive version-                argptr++;-            }+            Con * c = allocConF(vm, CTAG(x), ar, 1);+            copyArray(vm, c->args, ((Con*)x)->args, ar);+            cl = (VAL)c;         }         break;-    case CT_ARRAY:-        len = x->info.arr.length;-	allocArray(cl, vm, len, 1);--	argptr = (VAL*)(cl->info.arr.content);-	for(i = 0; i < len; ++i) {-	    *argptr = doCopyTo(vm, *((VAL*)(x->info.arr.content)+i)); // recursive version-	    argptr++;-	}-        break;-    case CT_FLOAT:-        cl = MKFLOATc(vm, x->info.f);-        break;+    case CT_ARRAY: {+        size_t len = CELEM(x);+        Array * a = allocArrayF(vm, len, 1);+        copyArray(vm, a->array, ((Array*)x)->array, len);+        cl = (VAL)a;+    } break;     case CT_STRING:-        cl = MKSTRc(vm, x->info.str.str);-        break;-    case CT_BIGINT:-        cl = MKBIGMc(vm, x->info.ptr);-        break;+    case CT_FLOAT:     case CT_PTR:-        cl = MKPTRc(vm, x->info.ptr);-        break;     case CT_MANAGEDPTR:-        cl = MKMPTRc(vm, x->info.mptr->data, x->info.mptr->size);-        break;-    case CT_CDATA:-        cl = MKCDATAc(vm, x->info.c_heap_item);-        break;-    case CT_BITS8:-        cl = idris_b8CopyForGC(vm, x);-        break;-    case CT_BITS16:-        cl = idris_b16CopyForGC(vm, x);-        break;     case CT_BITS32:-        cl = idris_b32CopyForGC(vm, x);-        break;     case CT_BITS64:-        cl = idris_b64CopyForGC(vm, x);-        break;     case CT_RAWDATA:         {-            size_t size = x->info.size + sizeof(Closure);-            cl = allocate(size, 0);-            memcpy(cl, x, size);+            cl = iallocate(vm, x->hdr.sz, 0);+            memcpy(cl, x, x->hdr.sz);         }         break;     default:         assert(0); // We're in trouble if this happens...+	cl = NULL;     }     return cl; }  VAL copyTo(VM* vm, VAL x) {-    VM* current = pthread_getspecific(vm_key);-    pthread_setspecific(vm_key, vm);     VAL ret = doCopyTo(vm, x);-    pthread_setspecific(vm_key, current);     return ret; } @@ -1045,7 +967,7 @@     Msg* msg;      for (msg = vm->inbox; msg < vm->inbox_end && msg->msg != NULL; ++msg) {-        if (msg->channel_id && 1 == 1) { // init bit set+	if ((msg->channel_id & 1) == 1) { // init bit set             return msg;         }     }@@ -1108,11 +1030,11 @@  Msg* idris_recvMessageFrom(VM* vm, int channel_id, VM* sender) {     Msg* msg;-    Msg* ret = malloc(sizeof(Msg));+    Msg* ret;      struct timespec timeout;     int status;-    +     if (sender && sender->active == 0) { return NULL; } // No VM to receive from      pthread_mutex_lock(&vm->inbox_block);@@ -1132,6 +1054,7 @@     pthread_mutex_unlock(&vm->inbox_block);      if (msg != NULL) {+        ret = malloc(sizeof(*ret));         ret->msg = msg->msg;         ret->sender = msg->sender; @@ -1158,7 +1081,6 @@         fprintf(stderr, "No messages waiting");         exit(-1);     }-     return ret; } #endif@@ -1187,28 +1109,18 @@     return strerror(err); } -VAL* nullary_cons;+Con nullary_cons[256];  void init_nullaries(void) {     int i;-    VAL cl;-    nullary_cons = malloc(256 * sizeof(VAL));     for(i = 0; i < 256; ++i) {-        cl = malloc(sizeof(Closure));+        Con * cl = nullary_cons + i;+        cl->hdr.sz = sizeof(*cl);         SETTY(cl, CT_CON);-        cl->info.c.tag_arity = i << 8;-        nullary_cons[i] = cl;+        cl->tag = i;     } } -void free_nullaries(void) {-    int i;-    for(i = 0; i < 256; ++i) {-        free(nullary_cons[i]);-    }-    free(nullary_cons);-}- int __idris_argc; char **__idris_argv; @@ -1224,6 +1136,16 @@   setvbuf(stdin, NULL, _IONBF, 0);   setvbuf(stdout, NULL, _IONBF, 0); }++#ifndef SEL4+int idris_usleep(int usec) {+    struct timespec t;+    t.tv_sec = usec / 1000000;+    t.tv_nsec = (usec % 1000000) * 1000;++    return nanosleep(&t, NULL);+}+#endif // SEL4  void stackOverflow(void) {   fprintf(stderr, "Stack overflow");
rts/idris_rts.h view
@@ -1,21 +1,19 @@ #ifndef _IDRISRTS_H #define _IDRISRTS_H +#include <assert.h> #include <stdlib.h> #include <stdio.h>+#ifdef HAS_PTHREAD #include <string.h> #include <stdarg.h>-#ifdef HAS_PTHREAD #include <pthread.h> #endif-#include <stdint.h>-#if (__linux__ || __APPLE__ || __FreeBSD__ || __DragonFly__)-#include <signal.h>-#endif  #include "idris_heap.h" #include "idris_stats.h" + #ifndef EXIT_SUCCESS #define EXIT_SUCCESS 0 #endif@@ -25,69 +23,98 @@  // Closures typedef enum {-    CT_CON, CT_ARRAY, CT_INT, CT_BIGINT, CT_FLOAT, CT_STRING, CT_STROFFSET,-    CT_BITS8, CT_BITS16, CT_BITS32, CT_BITS64, CT_UNIT, CT_PTR, CT_REF,-    CT_FWD, CT_MANAGEDPTR, CT_RAWDATA, CT_CDATA+    CT_CON, CT_ARRAY, CT_INT, CT_BIGINT,+    CT_FLOAT, CT_STRING, CT_STROFFSET, CT_BITS32,+    CT_BITS64, CT_PTR, CT_REF, CT_FWD,+    CT_MANAGEDPTR, CT_RAWDATA, CT_CDATA } ClosureType; -typedef struct Closure *VAL;+typedef struct Hdr {+    uint8_t ty;+    uint8_t u8;+    uint16_t u16;+    uint32_t sz;+} Hdr; -// A constructor, consisting of a tag, an arity (16 bits each of the-// tag_arity field) and arguments-typedef struct {-    uint32_t tag_arity;-    VAL args[];-} con;+typedef struct Val {+    Hdr hdr;+} Val; -// An array; similar to a constructor but with a length, and contents-// initialised to NULL (high level Idris programs are responsible for-// initialising them properly)-typedef struct {-    uint32_t length;-    VAL content[];-} array;+typedef struct Val * VAL; -typedef struct {-    VAL str;+typedef struct Con {+    Hdr hdr;+    uint32_t tag;+    VAL args[0];+} Con;++typedef struct Array {+    Hdr hdr;+    VAL array[0];+} Array;++typedef struct BigInt {+    Hdr hdr;+    char big[0];+} BigInt;++typedef struct Float {+    Hdr hdr;+    double f;+} Float;++typedef struct String {+    Hdr hdr;+    size_t slen;+    char str[0];+} String;++typedef struct StrOffset {+    Hdr hdr;+    String * base;     size_t offset; } StrOffset; -typedef struct {-    char* str;-    size_t len; // Cached strlen (we do 'strlen' a lot)-} String;+typedef struct Bits32 {+    Hdr hdr;+    uint32_t bits32;+} Bits32; -// A foreign pointer, managed by the idris GC-typedef struct {-    size_t size;-    void* data;+typedef struct Bits64 {+    Hdr hdr;+    uint64_t bits64;+} Bits64;++typedef struct Ptr {+    Hdr hdr;+    void * ptr;+} Ptr;++typedef struct Ref {+    Hdr hdr;+    VAL ref;+} Ref;++typedef struct Fwd {+    Hdr hdr;+    VAL fwd;+} Fwd;++typedef struct ManagedPtr {+    Hdr hdr;+    char mptr[0]; } ManagedPtr; -typedef struct Closure {-// Use top 16 bits of ty for saying which heap value is in-// Bottom 16 bits for closure type-//-// NOTE: ty can not have type ClosureType because ty must be a-// uint32_t but enum is platform dependent-    uint32_t ty;-    union {-        con c;-        array arr;-        int i;-        double f;-        String str;-        StrOffset* str_offset;-        void* ptr;-        uint8_t bits8;-        uint16_t bits16;-        uint32_t bits32;-        uint64_t bits64;-        ManagedPtr* mptr;-        CHeapItem* c_heap_item;-        size_t size;-    } info;-} Closure;+typedef struct RawData {+    Hdr hdr;+    char raw[0];+} RawData; +typedef struct CDataC {+    Hdr hdr;+    CHeapItem * item;+} CDataC;+ struct VM;  struct Msg_t {@@ -190,34 +217,44 @@ // Register access  #define RVAL (vm->ret)-#define LOC(x) (*(vm->valstack_base + (x)))-#define TOP(x) (*(vm->valstack_top + (x)))+#define LOC(x) (vm->valstack_base[x])+#define TOP(x) (vm->valstack_top[x]) #define REG1 (vm->reg1)  // Retrieving values-#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)-#define GETCDATA(x) (((VAL)(x))->info.c_heap_item)+static inline char * getstr(String * x) {+    // hdr.u8 used to mark a null string+    return x->hdr.u8? NULL : x->str;+} -#define GETBITS8(x) (((VAL)(x))->info.bits8)-#define GETBITS16(x) (((VAL)(x))->info.bits16)-#define GETBITS32(x) (((VAL)(x))->info.bits32)-#define GETBITS64(x) (((VAL)(x))->info.bits64)+static inline size_t getstrlen(String * x) {+    return x->slen;+} -#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CT_CON ? (x)->info.c.tag_arity >> 8 : (-1)) )-#define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CT_CON ? (x)->info.c.tag_arity & 0x000000ff : (-1)) )+#define GETSTR(x) (ISSTR(x) ? getstr((String*)(x)) : GETSTROFF(x))+#define GETSTRLEN(x) (ISSTR(x) ? getstrlen((String*)(x)) : GETSTROFFLEN(x))+#define GETPTR(x) (((Ptr*)(x))->ptr)+#define GETMPTR(x) (((ManagedPtr*)(x))->mptr)+#define GETFLOAT(x) (((Float*)(x))->f)+#define GETCDATA(x) (((CDataC*)(x))->item) +#define GETBITS8(x) (GETINT(x))+#define GETBITS16(x) (GETINT(x))+#define GETBITS32(x) (((Bits32*)(x))->bits32)+#define GETBITS64(x) (((Bits64*)(x))->bits64)+ // Already checked it's a CT_CON-#define CTAG(x) (((x)->info.c.tag_arity) >> 8)-#define CARITY(x) ((x)->info.c.tag_arity & 0x000000ff)+#define CTAG(x) (((Con*)(x))->tag)+#define CARITY(x) (((Con*)(x))->hdr.u16) // hdr.u16 used to store arity +#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CT_CON ? CTAG((Con*)x) : (-1)) )+#define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CT_CON ? CARITY((Con*)x) : (-1)) ) -#define GETTY(x) ((x)->ty)-#define SETTY(x,t) ((x)->ty = t)+#define CELEM(x) (((x)->hdr.sz - sizeof(Array)) / sizeof(VAL)) +#define GETTY(x) (ISINT(x)? CT_INT : (ClosureType)((x)->hdr.ty))+#define SETTY(x,t) ((x)->hdr.ty = t)+ // Integers, floats and operators  typedef intptr_t i_int;@@ -241,15 +278,17 @@ #ifdef IDRIS_TRACE #define TRACE idris_trace(vm, __FUNCTION__, __LINE__); #else-#define TRACE +#define TRACE #endif  #define INITFRAME TRACE\-                  VAL* myoldbase+                  __attribute__((unused)) 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)); }+#define RESERVE(x) do { \+    if (vm->valstack_top+(x) > vm->stack_max) { stackOverflow(); } \+    else { memset(vm->valstack_top, 0, (x)*sizeof(VAL)); } \+  } while(0) #define ADDTOP(x) vm->valstack_top += (x) #define TOPBASE(x) vm->valstack_top = vm->valstack_base + (x) #define BASETOP(x) vm->valstack_base = vm->valstack_top + (x)@@ -260,6 +299,7 @@ // Creating new values (each value placed at the top of the stack) VAL MKFLOAT(VM* vm, double val); VAL MKSTR(VM* vm, const char* str);+VAL MKSTRlen(VM* vm, const char* str, size_t size); VAL MKPTR(VM* vm, void* ptr); VAL MKMPTR(VM* vm, void* ptr, size_t size); VAL MKB8(VM* vm, uint8_t b);@@ -270,9 +310,9 @@  // following versions don't take a lock when allocating VAL MKFLOATc(VM* vm, double val);-VAL MKSTROFFc(VM* vm, StrOffset* off);+VAL MKSTROFFc(VM* vm, VAL basestr); VAL MKSTRc(VM* vm, char* str);-VAL MKSTRclen(VM* vm, char* str, int len);+VAL MKSTRclen(VM* vm, char* str, size_t len); VAL MKPTRc(VM* vm, void* ptr); VAL MKMPTRc(VM* vm, void* ptr, size_t size); VAL MKCDATAc(VM* vm, CHeapItem * item);@@ -280,15 +320,16 @@ 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))-#define GETARG(x, i) ((x)->info.c.args)[i]+#define SETARG(x, i, a) (((Con*)(x))->args)[i] = ((VAL)(a))+#define GETARG(x, i) (((Con*)(x))->args[i])  #define PROJECT(vm,r,loc,num) \-    memcpy(&(LOC(loc)), &((r)->info.c.args), sizeof(VAL)*num)+    memcpy(&(LOC(loc)), ((Con*)(r))->args, sizeof(VAL)*num) #define SLIDE(vm, args) \     memcpy(&(LOC(0)), &(TOP(0)), sizeof(VAL)*args) +void* iallocate(VM *, size_t, int);+ void* allocate(size_t size, int outerlock); // void* allocCon(VM* vm, int arity, int outerlock); @@ -298,8 +339,8 @@ // idris_doneAlloc *must* be called when allocation from C is done (as it // may take a lock if other threads are running). -void idris_requireAlloc(size_t size);-void idris_doneAlloc(void);+void idris_requireAlloc(VM *, size_t size);+void idris_doneAlloc(VM *);  // public interface to allocation (note that this may move other pointers // if allocating beyond the limits given by idris_requireAlloc!)@@ -308,29 +349,44 @@ void* idris_realloc(void* old, size_t old_size, size_t size); void idris_free(void* ptr, size_t size); -#define allocCon(cl, vm, t, a, o) \-  cl = allocate(sizeof(Closure) + sizeof(VAL)*a, o); \-  SETTY(cl, CT_CON); \-  cl->info.c.tag_arity = ((t) << 8) | (a);+static inline void updateConF(Con * cl, unsigned tag, unsigned arity) {+    SETTY(cl, CT_CON);+    cl->tag = tag;+    // hdr.u16 used to store arity+    cl->hdr.u16 = arity;+    assert(cl->hdr.sz == sizeof(*cl) + sizeof(VAL) * arity);+    // cl->hdr.sz = sizeof(*cl) + sizeof(VAL) * arity;+} -#define updateCon(cl, old, t, a) \-  cl = old; \-  SETTY(cl, CT_CON); \-  cl->info.c.tag_arity = ((t) << 8) | (a);+static inline Con * allocConF(VM * vm, unsigned tag, unsigned arity, int outer) {+    Con * cl = iallocate(vm, sizeof(*cl) + sizeof(VAL) * arity, outer);+    SETTY(cl, CT_CON);+    cl->tag = tag;+    // hdr.u16 used to store arity+    cl->hdr.u16 = arity;+    return cl;+} -#define NULL_CON(x) nullary_cons[x]+static inline Array * allocArrayF(VM * vm, size_t len, int outer) {+    Array * cl = iallocate(vm, sizeof(*cl) + sizeof(VAL) * len, outer);+    SETTY(cl, CT_ARRAY);+    return cl;+} -#define allocArray(cl, vm, len, o) \-  cl = allocate(sizeof(Closure) + sizeof(VAL)*len, o); \-  SETTY(cl, CT_ARRAY); \-  cl->info.arr.length = len; +#define allocCon(cl, vm, t, a, o) (cl) = (VAL)allocConF(vm, t, a, o)++#define updateCon(cl, old, tag, arity) (cl) = (old); updateConF(cl, tag, arity)++#define NULL_CON(x) ((VAL)(nullary_cons + x))++#define allocArray(cl, vm, len, o) (cl) = (VAL)allocArrayF(vm, len, o)+ int idris_errno(void); char* idris_showerror(int err); -extern VAL* nullary_cons;+extern Con nullary_cons[]; void init_nullaries(void);-void free_nullaries(void);  void init_signals(void); @@ -442,6 +498,10 @@ // disable stdin/stdout buffering void idris_disableBuffering(void); +#ifndef SEL4+int idris_usleep(int usec);+#endif // SEL4+ // Handle stack overflow. // Just reports an error and exits. @@ -456,4 +516,22 @@  #include "idris_gmp.h" +static inline size_t valSize(VAL v) {+    return v->hdr.sz;+}++static inline size_t aligned(size_t sz) {+    return (sz + sizeof(void*) - 1) & ~(sizeof(void*)-1);+}++VM* get_vm(void);+ #endif++/*+  Local variables: **+  c-file-style: "bsd" **+  c-basic-offset: 4 **+  indent-tabs-mode: nil **+  End: **+*/
rts/idris_stdfgn.c view
@@ -6,11 +6,11 @@ #include <fcntl.h> #include <errno.h> #include <sys/stat.h>-#include <stdio.h> #include <time.h> #include <dirent.h>+#include <unistd.h> -#if defined(WIN32) || defined(__WIN32) || defined(__WIN32__)+#ifdef _WIN32 int win_fpoll(void* h); FILE *win32_u8fopen(const char *path, const char *mode); FILE *win32_u8popen(const char *path, const char *mode);@@ -25,7 +25,7 @@ }  void *fileOpen(char *name, char *mode) {-#if defined(WIN32) || defined(__WIN32) || defined(__WIN32__)+#ifdef _WIN32     FILE *f = win32_u8fopen(name, mode); #else     FILE *f = fopen(name, mode);@@ -60,6 +60,42 @@     } } +VAL fileAccessTime(void* h) {+    FILE* f = (FILE*)h;+    int fd = fileno(f);++    struct stat buf;+    if (fstat(fd, &buf) == 0) {+        return MKBIGI(buf.st_atime);+    } else {+        return MKBIGI(-1);+    }+}++VAL fileModifiedTime(void* h) {+    FILE* f = (FILE*)h;+    int fd = fileno(f);++    struct stat buf;+    if (fstat(fd, &buf) == 0) {+        return MKBIGI(buf.st_mtime);+    } else {+        return MKBIGI(-1);+    }+}++VAL fileStatusTime(void* h) {+    FILE* f = (FILE*)h;+    int fd = fileno(f);++    struct stat buf;+    if (fstat(fd, &buf) == 0) {+        return MKBIGI(buf.st_ctime);+    } else {+        return MKBIGI(-1);+    }+}+ typedef struct {     DIR* dirptr;     int error;@@ -79,7 +115,7 @@  void idris_dirClose(void* h) {     DirInfo* di = (DirInfo*)h;-    +     closedir(di->dirptr);     free(di); }@@ -97,13 +133,17 @@ }  int idris_mkdir(char* dname) {-#if defined(WIN32) || defined(__WIN32) || defined(__WIN32__)+#ifdef _WIN32     return mkdir(dname); #else     return mkdir(dname, S_IRWXU | S_IRGRP | S_IROTH); #endif } +int idris_chdir(char* dname) {+    return chdir(dname);+}+ int idris_dirError(void *dptr) {     return ((DirInfo*)dptr)->error; }@@ -119,7 +159,7 @@  int fpoll(void* h) {-#if defined(WIN32) || defined(__WIN32) || defined(__WIN32__)+#ifdef _WIN32     return win_fpoll(h); #else     FILE* f = (FILE*)h;@@ -138,7 +178,7 @@ }  void *do_popen(const char *cmd, const char *mode) {-#if defined(WIN32) || defined(__WIN32) || defined(__WIN32__)+#ifdef _WIN32     FILE *f = win32_u8popen(cmd, mode); #else     FILE *f = popen(cmd, mode);@@ -219,4 +259,3 @@     free(sb);     return str; }-
rts/idris_stdfgn.h view
@@ -15,12 +15,18 @@ // Returns a negative number if not a file (e.g. directory or device) int fileSize(void* h); +// Return a negative number if not a file (e.g. directory or device)+VAL fileAccessTime(void* h);+VAL fileModifiedTime(void* h);+VAL fileStatusTime(void* h);+ void* idris_dirOpen(char* dname); void idris_dirClose(void* h); char* idris_nextDirEntry(void* h);  // Create a directory; return 0 on success or -1 on failure int idris_mkdir(char* dname);+int idris_chdir(char* dname);  // Return 0 if ok, or -1 if there was an error with the given directory // (like ferror)
rts/mini-gmp.c view
@@ -2,24 +2,33 @@     Contributed to the GNU project by Niels Möller -Copyright 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1999, 2000, 2001,-2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013-Free Software Foundation, Inc.+Copyright 1991-1997, 1999-2016 Free Software Foundation, Inc.  This file is part of the GNU MP Library.  The GNU MP Library is free software; you can redistribute it and/or modify-it under the terms of the GNU Lesser General Public License as published by-the Free Software Foundation; either version 3 of the License, or (at your-option) any later version.+it under the terms of either: +  * the GNU Lesser General Public License as published by the Free+    Software Foundation; either version 3 of the License, or (at your+    option) any later version.++or++  * the GNU General Public License as published by the Free Software+    Foundation; either version 2 of the License, or (at your option) any+    later version.++or both in parallel, as here.+ The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY-or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public-License for more details.+or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License+for more details. -You should have received a copy of the GNU Lesser General Public License-along with the GNU MP Library.  If not, see http://www.gnu.org/licenses/.  */+You should have received copies of the GNU General Public License and the+GNU Lesser General Public License along with the GNU MP Library.  If not,+see https://www.gnu.org/licenses/.  */  /* NOTE: All functions in this file which are not declared in    mini-gmp.h are internal, and are not intended to be compatible@@ -60,8 +69,10 @@ #define GMP_MIN(a, b) ((a) < (b) ? (a) : (b)) #define GMP_MAX(a, b) ((a) > (b) ? (a) : (b)) +#define GMP_CMP(a,b) (((a) > (b)) - ((a) < (b)))+ #define gmp_assert_nocarry(x) do { \-    mp_limb_t __cy = x;		   \+    mp_limb_t __cy = (x);	   \     assert (__cy == 0);		   \   } while (0) @@ -227,6 +238,8 @@     (y) = __mpz_srcptr_swap__tmp;					\   } while (0) +const int mp_bits_per_limb = GMP_LIMB_BITS;+  /* Memory allocation and other helper functions. */ static void@@ -253,12 +266,12 @@ static void * gmp_default_realloc (void *old, size_t old_size, size_t new_size) {-  mp_ptr p;+  void * p;    p = realloc (old, new_size);    if (!p)-    gmp_die("gmp_default_realoc: Virtual memory exhausted.");+    gmp_die("gmp_default_realloc: Virtual memory exhausted.");    return p; }@@ -311,14 +324,14 @@ static mp_ptr gmp_xalloc_limbs (mp_size_t size) {-  return gmp_xalloc (size * sizeof (mp_limb_t));+  return (mp_ptr) gmp_xalloc (size * sizeof (mp_limb_t)); }  static mp_ptr gmp_xrealloc_limbs (mp_ptr old, mp_size_t size) {   assert (size > 0);-  return (*gmp_reallocate_func) (old, 0, size * sizeof (mp_limb_t));+  return (mp_ptr) (*gmp_reallocate_func) (old, 0, size * sizeof (mp_limb_t)); }  @@ -335,7 +348,7 @@ void mpn_copyd (mp_ptr d, mp_srcptr s, mp_size_t n) {-  while (n-- > 0)+  while (--n >= 0)     d[n] = s[n]; } @@ -362,13 +375,24 @@ static mp_size_t mpn_normalized_size (mp_srcptr xp, mp_size_t n) {-  for (; n > 0 && xp[n-1] == 0; n--)-    ;+  while (n > 0 && xp[n-1] == 0)+    --n;   return n; } -#define mpn_zero_p(xp, n) (mpn_normalized_size ((xp), (n)) == 0)+int+mpn_zero_p(mp_srcptr rp, mp_size_t n)+{+  return mpn_normalized_size (rp, n) == 0;+} +void+mpn_zero (mp_ptr rp, mp_size_t n)+{+  while (--n >= 0)+    rp[n] = 0;+}+ mp_limb_t mpn_add_1 (mp_ptr rp, mp_srcptr ap, mp_size_t n, mp_limb_t b) {@@ -432,7 +456,7 @@     {       mp_limb_t a = ap[i];       /* Carry out */-      mp_limb_t cy = a < b;;+      mp_limb_t cy = a < b;       rp[i] = a - b;       b = cy;     }@@ -558,17 +582,16 @@      way. */    rp[un] = mpn_mul_1 (rp, up, un, vp[0]);-  rp += 1, vp += 1, vn -= 1;    /* Now accumulate the product of up[] and the next higher limb from      vp[]. */ -  while (vn >= 1)+  while (--vn >= 1)     {+      rp += 1, vp += 1;       rp[un] = mpn_addmul_1 (rp, up, un, vp[0]);-      rp += 1, vp += 1, vn -= 1;     }-  return rp[un - 1];+  return rp[un]; }  void@@ -588,7 +611,6 @@ {   mp_limb_t high_limb, low_limb;   unsigned int tnc;-  mp_size_t i;   mp_limb_t retval;    assert (n >= 1);@@ -603,7 +625,7 @@   retval = low_limb >> tnc;   high_limb = (low_limb << cnt); -  for (i = n; --i != 0;)+  while (--n != 0)     {       low_limb = *--up;       *--rp = high_limb | (low_limb >> tnc);@@ -619,7 +641,6 @@ {   mp_limb_t high_limb, low_limb;   unsigned int tnc;-  mp_size_t i;   mp_limb_t retval;    assert (n >= 1);@@ -631,7 +652,7 @@   retval = (high_limb << tnc);   low_limb = high_limb >> cnt; -  for (i = n; --i != 0;)+  while (--n != 0)     {       high_limb = *up++;       *rp++ = low_limb | (high_limb << tnc);@@ -682,24 +703,68 @@ 			  i, ptr, i, GMP_LIMB_MAX); } +void+mpn_com (mp_ptr rp, mp_srcptr up, mp_size_t n)+{+  while (--n >= 0)+    *rp++ = ~ *up++;+}++mp_limb_t+mpn_neg (mp_ptr rp, mp_srcptr up, mp_size_t n)+{+  while (*up == 0)+    {+      *rp = 0;+      if (!--n)+	return 0;+      ++up; ++rp;+    }+  *rp = - *up;+  mpn_com (++rp, ++up, --n);+  return 1;+}+  /* MPN division interface. */++/* The 3/2 inverse is defined as++     m = floor( (B^3-1) / (B u1 + u0)) - B+*/ mp_limb_t mpn_invert_3by2 (mp_limb_t u1, mp_limb_t u0) {-  mp_limb_t r, p, m;-  unsigned ul, uh;-  unsigned ql, qh;+  mp_limb_t r, p, m, ql;+  unsigned ul, uh, qh; -  /* First, do a 2/1 inverse. */-  /* The inverse m is defined as floor( (B^2 - 1 - u1)/u1 ), so that 0 <-   * B^2 - (B + m) u1 <= u1 */   assert (u1 >= GMP_LIMB_HIGHBIT); +  /* For notation, let b denote the half-limb base, so that B = b^2.+     Split u1 = b uh + ul. */   ul = u1 & GMP_LLIMB_MASK;   uh = u1 >> (GMP_LIMB_BITS / 2); +  /* Approximation of the high half of quotient. Differs from the 2/1+     inverse of the half limb uh, since we have already subtracted+     u0. */   qh = ~u1 / uh;++  /* Adjust to get a half-limb 3/2 inverse, i.e., we want++     qh' = floor( (b^3 - 1) / u) - b = floor ((b^3 - b u - 1) / u+         = floor( (b (~u) + b-1) / u),++     and the remainder++     r = b (~u) + b-1 - qh (b uh + ul)+       = b (~u - qh uh) + b-1 - qh ul++     Subtraction of qh ul may underflow, which implies adjustments.+     But by normalization, 2 u >= B > qh ul, so we need to adjust by+     at most 2.+  */+   r = ((~u1 - (mp_limb_t) qh * uh) << (GMP_LIMB_BITS / 2)) | GMP_LLIMB_MASK;    p = (mp_limb_t) qh * ul;@@ -717,11 +782,19 @@     }   r -= p; -  /* Do a 3/2 division (with half limb size) */+  /* Low half of the quotient is++       ql = floor ( (b r + b-1) / u1).++     This is a 3/2 division (on half-limbs), for which qh is a+     suitable inverse. */+   p = (r >> (GMP_LIMB_BITS / 2)) * qh + r;+  /* Unlike full-limb 3/2, we can add 1 without overflow. For this to+     work, it is essential that ql is a full mp_limb_t. */   ql = (p >> (GMP_LIMB_BITS / 2)) + 1; -  /* By the 3/2 method, we don't need the high half limb. */+  /* By the 3/2 trick, we don't need the high half limb. */   r = (r << (GMP_LIMB_BITS / 2)) + GMP_LLIMB_MASK - ql * u1;    if (r >= (p << (GMP_LIMB_BITS / 2)))@@ -736,6 +809,8 @@       r -= u1;     } +  /* Now m is the 2/1 invers of u1. If u0 > 0, adjust it to become a+     3/2 inverse. */   if (u0 > 0)     {       mp_limb_t th, tl;@@ -847,7 +922,7 @@    if (inv->shift > 0)     {-      tp = gmp_xalloc_limbs (nn);+      tp = qp ? qp : gmp_xalloc_limbs (nn);       r = mpn_lshift (tp, np, nn, inv->shift);       np = tp;     }@@ -856,7 +931,7 @@    d = inv->d1;   di = inv->di;-  while (nn-- > 0)+  while (--nn >= 0)     {       mp_limb_t q; @@ -864,7 +939,7 @@       if (qp) 	qp[nn] = q;     }-  if (inv->shift > 0)+  if (inv->shift > 0 && !qp)     gmp_free (tp);    return r >> inv->shift;@@ -1140,7 +1215,7 @@   unsigned char mask;   size_t sn, j;   mp_size_t i;-  int shift;+  unsigned shift;    sn = ((un - 1) * GMP_LIMB_BITS + mpn_limb_size_in_base_2 (up[un-1]) 	+ bits - 1) / bits;@@ -1281,6 +1356,8 @@   return rn; } +/* Result is usually normalized, except for all-zero input, in which+   case a single zero limb is written at *RP, and 1 is returned. */ static mp_size_t mpn_set_str_other (mp_ptr rp, const unsigned char *sp, size_t sn, 		   mp_limb_t b, const struct mpn_base_info *info)@@ -1290,16 +1367,18 @@   unsigned k;   size_t j; +  assert (sn > 0);+   k = 1 + (sn - 1) % info->exp;    j = 0;   w = sp[j++];-  for (; --k > 0; )+  while (--k != 0)     w = w * b + sp[j++];    rp[0] = w; -  for (rn = (w > 0); j < sn;)+  for (rn = 1; j < sn;)     {       mp_limb_t cy; @@ -1342,9 +1421,11 @@ void mpz_init (mpz_t r) {-  r->_mp_alloc = 1;+  static const mp_limb_t dummy_limb = 0xc1a0;++  r->_mp_alloc = 0;   r->_mp_size = 0;-  r->_mp_d = gmp_xalloc_limbs (1);+  r->_mp_d = (mp_ptr) &dummy_limb; }  /* The utility of this function is a bit limited, since many functions@@ -1365,15 +1446,19 @@ void mpz_clear (mpz_t r) {-  gmp_free (r->_mp_d);+  if (r->_mp_alloc)+    gmp_free (r->_mp_d); } -static void *+static mp_ptr mpz_realloc (mpz_t r, mp_size_t size) {   size = GMP_MAX (size, 1); -  r->_mp_d = gmp_xrealloc_limbs (r->_mp_d, size);+  if (r->_mp_alloc)+    r->_mp_d = gmp_xrealloc_limbs (r->_mp_d, size);+  else+    r->_mp_d = gmp_xalloc_limbs (size);   r->_mp_alloc = size;    if (GMP_ABS (r->_mp_size) > size)@@ -1396,7 +1481,7 @@   else /* (x < 0) */     {       r->_mp_size = -1;-      r->_mp_d[0] = GMP_NEG_CAST (unsigned long int, x);+      MPZ_REALLOC (r, 1)[0] = GMP_NEG_CAST (unsigned long int, x);     } } @@ -1406,7 +1491,7 @@   if (x > 0)     {       r->_mp_size = 1;-      r->_mp_d[0] = x;+      MPZ_REALLOC (r, 1)[0] = x;     }   else     r->_mp_size = 0;@@ -1455,14 +1540,12 @@ {   mp_size_t us = u->_mp_size; -  if (us == 0)-    return 1;-  else if (us == 1)+  if (us == 1)     return u->_mp_d[0] < GMP_LIMB_HIGHBIT;   else if (us == -1)     return u->_mp_d[0] <= GMP_LIMB_HIGHBIT;   else-    return 0;+    return (us == 0); }  int@@ -1476,14 +1559,11 @@ long int mpz_get_si (const mpz_t u) {-  mp_size_t us = u->_mp_size;--  if (us > 0)-    return (long) (u->_mp_d[0] & ~GMP_LIMB_HIGHBIT);-  else if (us < 0)-    return (long) (- u->_mp_d[0] | GMP_LIMB_HIGHBIT);+  if (u->_mp_size < 0)+    /* This expression is necessary to properly handle 0x80000000 */+    return -1 - (long) ((u->_mp_d[0] - 1) & ~GMP_LIMB_HIGHBIT);   else-    return 0;+    return (long) (mpz_get_ui (u) & ~GMP_LIMB_HIGHBIT); }  unsigned long int@@ -1507,6 +1587,48 @@     return 0; } +void+mpz_realloc2 (mpz_t x, mp_bitcnt_t n)+{+  mpz_realloc (x, 1 + (n - (n != 0)) / GMP_LIMB_BITS);+}++mp_srcptr+mpz_limbs_read (mpz_srcptr x)+{+  return x->_mp_d;+}++mp_ptr+mpz_limbs_modify (mpz_t x, mp_size_t n)+{+  assert (n > 0);+  return MPZ_REALLOC (x, n);+}++mp_ptr+mpz_limbs_write (mpz_t x, mp_size_t n)+{+  return mpz_limbs_modify (x, n);+}++void+mpz_limbs_finish (mpz_t x, mp_size_t xs)+{+  mp_size_t xn;+  xn = mpn_normalized_size (x->_mp_d, GMP_ABS (xs));+  x->_mp_size = xs < 0 ? -xn : xn;+}++mpz_srcptr+mpz_roinit_n (mpz_t x, mp_srcptr xp, mp_size_t xs)+{+  x->_mp_alloc = 0;+  x->_mp_d = (mp_ptr) xp;+  mpz_limbs_finish (x, xs);+  return x;+}+  /* Conversions and comparison to double. */ void@@ -1654,9 +1776,7 @@ int mpz_sgn (const mpz_t u) {-  mp_size_t usize = u->_mp_size;--  return (usize > 0) - (usize < 0);+  return GMP_CMP (u->_mp_size, 0); }  int@@ -1671,13 +1791,7 @@   else if (usize >= 0)     return 1;   else /* usize == -1 */-    {-      mp_limb_t ul = u->_mp_d[0];-      if ((mp_limb_t)GMP_NEG_CAST (unsigned long int, v) < ul)-	return -1;-      else-	return (mp_limb_t)GMP_NEG_CAST (unsigned long int, v) > ul;-    }+    return GMP_CMP (GMP_NEG_CAST (mp_limb_t, v), u->_mp_d[0]); }  int@@ -1690,10 +1804,7 @@   else if (usize < 0)     return -1;   else-    {-      mp_limb_t ul = (usize > 0) ? u->_mp_d[0] : 0;-      return (ul > v) - (ul < v);-    }+    return GMP_CMP (mpz_get_ui (u), v); }  int@@ -1713,15 +1824,10 @@ int mpz_cmpabs_ui (const mpz_t u, unsigned long v) {-  mp_size_t un = GMP_ABS (u->_mp_size);-  mp_limb_t ul;--  if (un > 1)+  if (GMP_ABS (u->_mp_size) > 1)     return 1;--  ul = (un == 1) ? u->_mp_d[0] : 0;--  return (ul > v) - (ul < v);+  else+    return GMP_CMP (mpz_get_ui (u), v); }  int@@ -1734,18 +1840,14 @@ void mpz_abs (mpz_t r, const mpz_t u) {-  if (r != u)-    mpz_set (r, u);-+  mpz_set (r, u);   r->_mp_size = GMP_ABS (r->_mp_size); }  void mpz_neg (mpz_t r, const mpz_t u) {-  if (r != u)-    mpz_set (r, u);-+  mpz_set (r, u);   r->_mp_size = -r->_mp_size; } @@ -1771,7 +1873,7 @@   an = GMP_ABS (a->_mp_size);   if (an == 0)     {-      r->_mp_d[0] = b;+      MPZ_REALLOC (r, 1)[0] = b;       return b > 0;     } @@ -1790,14 +1892,15 @@ mpz_abs_sub_ui (mpz_t r, const mpz_t a, unsigned long b) {   mp_size_t an = GMP_ABS (a->_mp_size);-  mp_ptr rp = MPZ_REALLOC (r, an);+  mp_ptr rp;    if (an == 0)     {-      rp[0] = b;+      MPZ_REALLOC (r, 1)[0] = b;       return -(b > 0);     }-  else if (an == 1 && a->_mp_d[0] < b)+  rp = MPZ_REALLOC (r, an);+  if (an == 1 && a->_mp_d[0] < b)     {       rp[0] = b - a->_mp_d[0];       return -1;@@ -2015,12 +2118,51 @@   else     mpn_copyd (rp + limbs, u->_mp_d, un); -  while (limbs > 0)-    rp[--limbs] = 0;+  mpn_zero (rp, limbs);    r->_mp_size = (u->_mp_size < 0) ? - rn : rn; } +void+mpz_addmul_ui (mpz_t r, const mpz_t u, unsigned long int v)+{+  mpz_t t;+  mpz_init (t);+  mpz_mul_ui (t, u, v);+  mpz_add (r, r, t);+  mpz_clear (t);+}++void+mpz_submul_ui (mpz_t r, const mpz_t u, unsigned long int v)+{+  mpz_t t;+  mpz_init (t);+  mpz_mul_ui (t, u, v);+  mpz_sub (r, r, t);+  mpz_clear (t);+}++void+mpz_addmul (mpz_t r, const mpz_t u, const mpz_t v)+{+  mpz_t t;+  mpz_init (t);+  mpz_mul (t, u, v);+  mpz_add (r, r, t);+  mpz_clear (t);+}++void+mpz_submul (mpz_t r, const mpz_t u, const mpz_t v)+{+  mpz_t t;+  mpz_init (t);+  mpz_mul (t, u, v);+  mpz_sub (r, r, t);+  mpz_clear (t);+}+  /* MPZ division */ enum mpz_div_round_mode { GMP_DIV_FLOOR, GMP_DIV_CEIL, GMP_DIV_TRUNC };@@ -2085,8 +2227,7 @@       mp_size_t qn, rn;       mpz_t tq, tr; -      mpz_init (tr);-      mpz_set (tr, n);+      mpz_init_set (tr, n);       np = tr->_mp_d;        qn = nn - dn + 1;@@ -2230,7 +2371,6 @@    if (qn <= 0)     qn = 0;-   else     {       qp = MPZ_REALLOC (q, qn);@@ -2284,16 +2424,9 @@ 	{ 	  /* Have to negate and sign extend. */ 	  mp_size_t i;-	  mp_limb_t cy; -	  for (cy = 1, i = 0; i < un; i++)-	    {-	      mp_limb_t s = ~u->_mp_d[i] + cy;-	      cy = s < cy;-	      rp[i] = s;-	    }-	  assert (cy == 0);-	  for (; i < rn - 1; i++)+	  gmp_assert_nocarry (! mpn_neg (rp, u->_mp_d, un));+	  for (i = un; i < rn - 1; i++) 	    rp[i] = GMP_LIMB_MAX;  	  rp[rn-1] = mask;@@ -2318,23 +2451,13 @@       if (mode == ((us > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* us != 0 here. */ 	{ 	  /* If r != 0, compute 2^{bit_count} - r. */-	  mp_size_t i;--	  for (i = 0; i < rn && rp[i] == 0; i++)-	    ;-	  if (i < rn)-	    {-	      /* r > 0, need to flip sign. */-	      rp[i] = ~rp[i] + 1;-	      while (++i < rn)-		rp[i] = ~rp[i];+	  mpn_neg (rp, rp, rn); -	      rp[rn-1] &= mask;+	  rp[rn-1] &= mask; -	      /* us is not used for anything else, so we can modify it-		 here to indicate flipped sign. */-	      us = -us;-	    }+	  /* us is not used for anything else, so we can modify it+	     here to indicate flipped sign. */+	  us = -us; 	}     }   rn = mpn_normalized_size (rp, rn);@@ -2389,6 +2512,24 @@   return mpz_div_qr (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0; } +int+mpz_congruent_p (const mpz_t a, const mpz_t b, const mpz_t m)+{+  mpz_t t;+  int res;++  /* a == b (mod 0) iff a == b */+  if (mpz_sgn (m) == 0)+    return (mpz_cmp (a, b) == 0);++  mpz_init (t);+  mpz_sub (t, a, b);+  res = mpz_divisible_p (t, m);+  mpz_clear (t);++  return res;+}+ static unsigned long mpz_div_qr_ui (mpz_t q, mpz_t r, 	       const mpz_t n, unsigned long d, enum mpz_div_round_mode mode)@@ -2431,7 +2572,7 @@    if (r)     {-      r->_mp_d[0] = rl;+      MPZ_REALLOC (r, 1)[0] = rl;       r->_mp_size = rs;     }   if (q)@@ -2955,9 +3096,7 @@ mpz_ui_pow_ui (mpz_t r, unsigned long blimb, unsigned long e) {   mpz_t b;-  mpz_init_set_ui (b, blimb);-  mpz_pow_ui (r, b, e);-  mpz_clear (b);+  mpz_pow_ui (r, mpz_roinit_n (b, &blimb, 1), e); }  void@@ -3029,7 +3168,7 @@     }   mpz_init_set_ui (tr, 1); -  while (en-- > 0)+  while (--en >= 0)     {       mp_limb_t w = e->_mp_d[en];       mp_limb_t bit;@@ -3069,9 +3208,7 @@ mpz_powm_ui (mpz_t r, const mpz_t b, unsigned long elimb, const mpz_t m) {   mpz_t e;-  mpz_init_set_ui (e, elimb);-  mpz_powm (r, b, e, m);-  mpz_clear (e);+  mpz_powm (r, b, mpz_roinit_n (e, &elimb, 1), m); }  /* x=trunc(y^(1/z)), r=y-x^z */@@ -3088,19 +3225,16 @@     gmp_die ("mpz_rootrem: Zeroth root.");    if (mpz_cmpabs_ui (y, 1) <= 0) {-    mpz_set (x, y);+    if (x)+      mpz_set (x, y);     if (r)       r->_mp_size = 0;     return;   }    mpz_init (u);-  {-    mp_bitcnt_t tb;-    tb = mpz_sizeinbase (y, 2) / z + 1;-    mpz_init2 (t, tb);-    mpz_setbit (t, tb);-  }+  mpz_init (t);+  mpz_setbit (t, mpz_sizeinbase (y, 2) / z + 1);    if (z == 2) /* simplify sqrt loop: z-1 == 1 */     do {@@ -3132,7 +3266,8 @@     mpz_pow_ui (t, u, z);     mpz_sub (r, y, t);   }-  mpz_swap (x, u);+  if (x)+    mpz_swap (x, u);   mpz_clear (u);   mpz_clear (t); }@@ -3164,6 +3299,47 @@   mpz_rootrem (s, NULL, u, 2); } +int+mpz_perfect_square_p (const mpz_t u)+{+  if (u->_mp_size <= 0)+    return (u->_mp_size == 0);+  else+    return mpz_root (NULL, u, 2);+}++int+mpn_perfect_square_p (mp_srcptr p, mp_size_t n)+{+  mpz_t t;++  assert (n > 0);+  assert (p [n-1] != 0);+  return mpz_root (NULL, mpz_roinit_n (t, p, n), 2);+}++mp_size_t+mpn_sqrtrem (mp_ptr sp, mp_ptr rp, mp_srcptr p, mp_size_t n)+{+  mpz_t s, r, u;+  mp_size_t res;++  assert (n > 0);+  assert (p [n-1] != 0);++  mpz_init (r);+  mpz_init (s);+  mpz_rootrem (s, r, mpz_roinit_n (u, p, n), 2);++  assert (s->_mp_size == (n+1)/2);+  mpn_copyd (sp, s->_mp_d, s->_mp_size);+  mpz_clear (s);+  res = r->_mp_size;+  if (rp)+    mpn_copyd (rp, r->_mp_d, res);+  mpz_clear (r);+  return res;+}  /* Combinatorics */ @@ -3171,7 +3347,7 @@ mpz_fac_ui (mpz_t x, unsigned long n) {   mpz_set_ui (x, n + (n == 0));-  for (;n > 2;)+  while (n > 2)     mpz_mul_ui (x, x, --n); } @@ -3196,6 +3372,102 @@ }  +/* Primality testing */+static int+gmp_millerrabin (const mpz_t n, const mpz_t nm1, mpz_t y,+		 const mpz_t q, mp_bitcnt_t k)+{+  assert (k > 0);++  /* Caller must initialize y to the base. */+  mpz_powm (y, y, q, n);++  if (mpz_cmp_ui (y, 1) == 0 || mpz_cmp (y, nm1) == 0)+    return 1;++  while (--k > 0)+    {+      mpz_powm_ui (y, y, 2, n);+      if (mpz_cmp (y, nm1) == 0)+	return 1;+      /* y == 1 means that the previous y was a non-trivial square root+	 of 1 (mod n). y == 0 means that n is a power of the base.+	 In either case, n is not prime. */+      if (mpz_cmp_ui (y, 1) <= 0)+	return 0;+    }+  return 0;+}++/* This product is 0xc0cfd797, and fits in 32 bits. */+#define GMP_PRIME_PRODUCT \+  (3UL*5UL*7UL*11UL*13UL*17UL*19UL*23UL*29UL)++/* Bit (p+1)/2 is set, for each odd prime <= 61 */+#define GMP_PRIME_MASK 0xc96996dcUL++int+mpz_probab_prime_p (const mpz_t n, int reps)+{+  mpz_t nm1;+  mpz_t q;+  mpz_t y;+  mp_bitcnt_t k;+  int is_prime;+  int j;++  /* Note that we use the absolute value of n only, for compatibility+     with the real GMP. */+  if (mpz_even_p (n))+    return (mpz_cmpabs_ui (n, 2) == 0) ? 2 : 0;++  /* Above test excludes n == 0 */+  assert (n->_mp_size != 0);++  if (mpz_cmpabs_ui (n, 64) < 0)+    return (GMP_PRIME_MASK >> (n->_mp_d[0] >> 1)) & 2;++  if (mpz_gcd_ui (NULL, n, GMP_PRIME_PRODUCT) != 1)+    return 0;++  /* All prime factors are >= 31. */+  if (mpz_cmpabs_ui (n, 31*31) < 0)+    return 2;++  /* Use Miller-Rabin, with a deterministic sequence of bases, a[j] =+     j^2 + j + 41 using Euler's polynomial. We potentially stop early,+     if a[j] >= n - 1. Since n >= 31*31, this can happen only if reps >+     30 (a[30] == 971 > 31*31 == 961). */++  mpz_init (nm1);+  mpz_init (q);+  mpz_init (y);++  /* Find q and k, where q is odd and n = 1 + 2**k * q.  */+  nm1->_mp_size = mpz_abs_sub_ui (nm1, n, 1);+  k = mpz_scan1 (nm1, 0);+  mpz_tdiv_q_2exp (q, nm1, k);++  for (j = 0, is_prime = 1; is_prime & (j < reps); j++)+    {+      mpz_set_ui (y, (unsigned long) j*j+j+41);+      if (mpz_cmp (y, nm1) >= 0)+	{+	  /* Don't try any further bases. This "early" break does not affect+	     the result for any reasonable reps value (<=5000 was tested) */+	  assert (j >= 30);+	  break;+	}+      is_prime = gmp_millerrabin (n, nm1, y, q, k);+    }+  mpz_clear (nm1);+  mpz_clear (q);+  mpz_clear (y);++  return is_prime;+}++ /* Logical operations and bit manipulation. */  /* Numbers are treated as if represented in two's complement (and@@ -3246,7 +3518,7 @@ 	 must be complemented. */       if (shift > 0 && (w << (GMP_LIMB_BITS - shift)) > 0) 	return bit ^ 1;-      while (limb_index-- > 0)+      while (--limb_index >= 0) 	if (d->_mp_d[limb_index] > 0) 	  return bit ^ 1;     }@@ -3311,7 +3583,7 @@    gmp_assert_nocarry (mpn_sub_1 (dp + limb_index, dp + limb_index, 				 dn - limb_index, bit));-  dn -= (dp[dn-1] == 0);+  dn = mpn_normalized_size (dp, dn);   d->_mp_size = (d->_mp_size < 0) ? - dn : dn; } @@ -3389,7 +3661,7 @@   /* If the smaller input is positive, higher limbs don't matter. */   rn = vx ? un : vn; -  rp = MPZ_REALLOC (r, rn + rc);+  rp = MPZ_REALLOC (r, rn + (mp_size_t) rc);    up = u->_mp_d;   vp = v->_mp_d;@@ -3462,7 +3734,7 @@      don't matter. */   rn = vx ? vn : un; -  rp = MPZ_REALLOC (r, rn + rc);+  rp = MPZ_REALLOC (r, rn + (mp_size_t) rc);    up = u->_mp_d;   vp = v->_mp_d;@@ -3531,7 +3803,7 @@   vx = -vc;   rx = -rc; -  rp = MPZ_REALLOC (r, un + rc);+  rp = MPZ_REALLOC (r, un + (mp_size_t) rc);    up = u->_mp_d;   vp = v->_mp_d;@@ -3587,20 +3859,28 @@ }  mp_bitcnt_t-mpz_popcount (const mpz_t u)+mpn_popcount (mp_srcptr p, mp_size_t n) {-  mp_size_t un, i;+  mp_size_t i;   mp_bitcnt_t c; +  for (c = 0, i = 0; i < n; i++)+    c += gmp_popcount_limb (p[i]);++  return c;+}++mp_bitcnt_t+mpz_popcount (const mpz_t u)+{+  mp_size_t un;+   un = u->_mp_size;    if (un < 0)     return ~(mp_bitcnt_t) 0; -  for (c = 0, i = 0; i < un; i++)-    c += gmp_popcount_limb (u->_mp_d[i]);--  return c;+  return mpn_popcount (u->_mp_d, un); }  mp_bitcnt_t@@ -3799,7 +4079,7 @@    sn = 1 + mpz_sizeinbase (u, base);   if (!sp)-    sp = gmp_xalloc (1 + sn);+    sp = (char *) gmp_xalloc (1 + sn);    un = GMP_ABS (u->_mp_size); @@ -3846,7 +4126,7 @@   unsigned bits;   mp_size_t rn, alloc;   mp_ptr rp;-  size_t sn;+  size_t dn;   int sign;   unsigned char *dp; @@ -3860,18 +4140,17 @@    if (base == 0)     {-      if (*sp == '0')+      if (sp[0] == '0') 	{-	  sp++;-	  if (*sp == 'x' || *sp == 'X')+	  if (sp[1] == 'x' || sp[1] == 'X') 	    { 	      base = 16;-	      sp++;+	      sp += 2; 	    }-	  else if (*sp == 'b' || *sp == 'B')+	  else if (sp[1] == 'b' || sp[1] == 'B') 	    { 	      base = 2;-	      sp++;+	      sp += 2; 	    } 	  else 	    base = 8;@@ -3880,16 +4159,20 @@ 	base = 10;     } -  sn = strlen (sp);-  dp = gmp_xalloc (sn + (sn == 0));+  if (!*sp)+    {+      r->_mp_size = 0;+      return -1;+    }+  dp = (unsigned char *) gmp_xalloc (strlen (sp)); -  for (sn = 0; *sp; sp++)+  for (dn = 0; *sp; sp++)     {       unsigned digit;        if (isspace ((unsigned char) *sp)) 	continue;-      if (*sp >= '0' && *sp <= '9')+      else if (*sp >= '0' && *sp <= '9') 	digit = *sp - '0';       else if (*sp >= 'a' && *sp <= 'z') 	digit = *sp - 'a' + 10;@@ -3898,31 +4181,40 @@       else 	digit = base; /* fail */ -      if (digit >= base)+      if (digit >= (unsigned) base) 	{ 	  gmp_free (dp); 	  r->_mp_size = 0; 	  return -1; 	} -      dp[sn++] = digit;+      dp[dn++] = digit;     } +  if (!dn)+    {+      gmp_free (dp);+      r->_mp_size = 0;+      return -1;+    }   bits = mpn_base_power_of_two_p (base);    if (bits > 0)     {-      alloc = (sn * bits + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS;+      alloc = (dn * bits + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS;       rp = MPZ_REALLOC (r, alloc);-      rn = mpn_set_str_bits (rp, dp, sn, bits);+      rn = mpn_set_str_bits (rp, dp, dn, bits);     }   else     {       struct mpn_base_info info;       mpn_get_base_info (&info, base);-      alloc = (sn + info.exp - 1) / info.exp;+      alloc = (dn + info.exp - 1) / info.exp;       rp = MPZ_REALLOC (r, alloc);-      rn = mpn_set_str_other (rp, dp, sn, base, &info);+      rn = mpn_set_str_other (rp, dp, dn, base, &info);+      /* Normalization, needed for all-zero input. */+      assert (rn > 0);+      rn -= rp[rn-1] == 0;     }   assert (rn <= alloc);   gmp_free (dp);
rts/mini-gmp.h view
@@ -1,21 +1,32 @@ /* mini-gmp, a minimalistic implementation of a GNU GMP subset. -Copyright 2011, 2012, 2013 Free Software Foundation, Inc.+Copyright 2011-2015 Free Software Foundation, Inc.  This file is part of the GNU MP Library.  The GNU MP Library is free software; you can redistribute it and/or modify-it under the terms of the GNU Lesser General Public License as published by-the Free Software Foundation; either version 3 of the License, or (at your-option) any later version.+it under the terms of either: +  * the GNU Lesser General Public License as published by the Free+    Software Foundation; either version 3 of the License, or (at your+    option) any later version.++or++  * the GNU General Public License as published by the Free Software+    Foundation; either version 2 of the License, or (at your option) any+    later version.++or both in parallel, as here.+ The GNU MP Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY-or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public-License for more details.+or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License+for more details. -You should have received a copy of the GNU Lesser General Public License-along with the GNU MP Library.  If not, see http://www.gnu.org/licenses/.  */+You should have received copies of the GNU General Public License and the+GNU Lesser General Public License along with the GNU MP Library.  If not,+see https://www.gnu.org/licenses/.  */  /* About mini-gmp: This is a minimal implementation of a subset of the    GMP interface. It is intended for inclusion into applications which@@ -64,10 +75,14 @@ typedef __mpz_struct *mpz_ptr; typedef const __mpz_struct *mpz_srcptr; +extern const int mp_bits_per_limb;+ void mpn_copyi (mp_ptr, mp_srcptr, mp_size_t); void mpn_copyd (mp_ptr, mp_srcptr, mp_size_t);+void mpn_zero (mp_ptr, mp_size_t);  int mpn_cmp (mp_srcptr, mp_srcptr, mp_size_t);+int mpn_zero_p (mp_srcptr, mp_size_t);  mp_limb_t mpn_add_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); mp_limb_t mpn_add_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t);@@ -84,6 +99,8 @@ mp_limb_t mpn_mul (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); void mpn_mul_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); void mpn_sqr (mp_ptr, mp_srcptr, mp_size_t);+int mpn_perfect_square_p (mp_srcptr, mp_size_t);+mp_size_t mpn_sqrtrem (mp_ptr, mp_ptr, mp_srcptr, mp_size_t);  mp_limb_t mpn_lshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int); mp_limb_t mpn_rshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int);@@ -91,6 +108,11 @@ mp_bitcnt_t mpn_scan0 (mp_srcptr, mp_bitcnt_t); mp_bitcnt_t mpn_scan1 (mp_srcptr, mp_bitcnt_t); +void mpn_com (mp_ptr, mp_srcptr, mp_size_t);+mp_limb_t mpn_neg (mp_ptr, mp_srcptr, mp_size_t);++mp_bitcnt_t mpn_popcount (mp_srcptr, mp_size_t);+ mp_limb_t mpn_invert_3by2 (mp_limb_t, mp_limb_t); #define mpn_invert_limb(x) mpn_invert_3by2 ((x), 0) @@ -127,6 +149,10 @@ void mpz_mul_ui (mpz_t, const mpz_t, unsigned long int); void mpz_mul (mpz_t, const mpz_t, const mpz_t); void mpz_mul_2exp (mpz_t, const mpz_t, mp_bitcnt_t);+void mpz_addmul_ui (mpz_t, const mpz_t, unsigned long int);+void mpz_addmul (mpz_t, const mpz_t, const mpz_t);+void mpz_submul_ui (mpz_t, const mpz_t, unsigned long int);+void mpz_submul (mpz_t, const mpz_t, const mpz_t);  void mpz_cdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); void mpz_fdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t);@@ -150,6 +176,7 @@ void mpz_divexact (mpz_t, const mpz_t, const mpz_t);  int mpz_divisible_p (const mpz_t, const mpz_t);+int mpz_congruent_p (const mpz_t, const mpz_t, const mpz_t);  unsigned long mpz_cdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); unsigned long mpz_fdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long);@@ -179,6 +206,7 @@  void mpz_sqrtrem (mpz_t, mpz_t, const mpz_t); void mpz_sqrt (mpz_t, const mpz_t);+int mpz_perfect_square_p (const mpz_t);  void mpz_pow_ui (mpz_t, const mpz_t, unsigned long); void mpz_ui_pow_ui (mpz_t, unsigned long, unsigned long);@@ -191,6 +219,8 @@ void mpz_fac_ui (mpz_t, unsigned long); void mpz_bin_uiui (mpz_t, unsigned long, unsigned long); +int mpz_probab_prime_p (const mpz_t, int);+ int mpz_tstbit (const mpz_t, mp_bitcnt_t); void mpz_setbit (mpz_t, mp_bitcnt_t); void mpz_clrbit (mpz_t, mp_bitcnt_t);@@ -213,6 +243,15 @@ double mpz_get_d (const mpz_t); size_t mpz_size (const mpz_t); mp_limb_t mpz_getlimbn (const mpz_t, mp_size_t);++void mpz_realloc2 (mpz_t, mp_bitcnt_t);+mp_srcptr mpz_limbs_read (mpz_srcptr);+mp_ptr mpz_limbs_modify (mpz_t, mp_size_t);+mp_ptr mpz_limbs_write (mpz_t, mp_size_t);+void mpz_limbs_finish (mpz_t, mp_size_t);+mpz_srcptr mpz_roinit_n (mpz_t, mp_srcptr, mp_size_t);++#define MPZ_ROINIT_N(xp, xs) {{0, (xs),(xp) }}  void mpz_set_si (mpz_t, signed long int); void mpz_set_ui (mpz_t, unsigned long int);
+ rts/seL4/Kbuild view
@@ -0,0 +1,2 @@+libsel4-idris-rts: $(libc) common+libs-$(CONFIG_LIBSEL4_IDRIS_RTS) += libsel4-idris-rts
+ rts/seL4/Kconfig view
@@ -0,0 +1,9 @@+config LIBSEL4_IDRIS_RTS+    bool "libsel4-idris-rts"+    default y+    select HAVE_LIBSEL4_IDRIS_RTS+    help+        Idris RTS compiled for seL4++config HAVE_LIBSEL4_IDRIS_RTS+    bool
+ rts/seL4/Makefile view
@@ -0,0 +1,33 @@+# Target+TARGETS := libsel4-idris-rts.a++# Source files required to build the target+FILES := \+    idris_rts.c \+    idris_heap.c \+    idris_gc.c \+    idris_gmp.c \+    idris_bitstring.c \+    idris_opts.c \+    idris_stats.c \+    idris_utf8.c \+    idris_stdfgn.c \+    mini-gmp.c \+    idris_buffer.c \+    getline.c \+    idris_net.c \+    seL4/idris_main.c+CFILES := $(addprefix rts/,$(FILES))++# Header file directory this library provides+HDRFILES := $(wildcard ${SOURCE_DIR}/rts/*)++CFLAGS += -W -Wall+# Don't use the host machines' environment when cross compiling+CFLAGS += -undef+CFLAGS += -DIDRIS_TARGET_OS=\"seL4\"+CFLAGS += -DSEL4+MACHINE := $(shell $(CC) -dumpmachine)+CFLAGS += -DIDRIS_TARGET_TRIPLE=\"$(MACHINE)\"++include $(SEL4_COMMON)/common.mk
+ rts/seL4/idris_main.c view
@@ -0,0 +1,32 @@+#include "idris_gmp.h"+#include "idris_opts.h"+#include "idris_rts.h"+#include "idris_stats.h"++void _idris__123_runMain_95_0_125_(VM* vm, VAL* oldbase);++RTSOpts opts = {+    .init_heap_size = 16384000,+    .max_stack_size = 4096000,+    .show_summary   = 0+};++int main() {+    VM* vm = init_vm(opts.max_stack_size, opts.init_heap_size, 1);+    init_gmpalloc();+    init_nullaries();++    _idris__123_runMain_95_0_125_(vm, NULL);++#ifdef IDRIS_DEBUG+    if (opts.show_summary) {+        idris_gcInfo(vm, 1);+    }+#endif++    free_nullaries();+    // Remove call to terminate since it crashes the application during a free+    //Stats stats = terminate(vm);++    return EXIT_SUCCESS;+}
+ src/BuildFlags_idris.hs view
@@ -0,0 +1,4 @@+module BuildFlags_idris where ++extraLibDirs :: [String]+extraLibDirs = []
src/IRTS/CodegenC.hs view
@@ -79,18 +79,22 @@              libFlags <- getLibFlags              incFlags <- getIncFlags              envFlags <- getEnvFlags-             let stackFlag = if isWindows then ["-Wl,--stack,16777216"] else []+             let stripFlag = if isDarwin then "-dead_strip" else "-Wl,-gc-sections"+             let stackFlags = if isWindows then ["-Wl,--stack,16777216"] else []+             let linkFlags = stripFlag : stackFlags              let args = gccDbg dbg ++                         gccFlags iface ++                         -- # Any flags defined here which alter the RTS API must also be added to config.mk-                        ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS",-                         "-I."] ++ objs ++ envFlags ++-                        (if (exec == Executable) then [] else ["-c"]) +++                        [ "-std=c99", "-pipe"+                        , "-fdata-sections", "-ffunction-sections"+                        , "-D_POSIX_C_SOURCE=200809L", "-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS"+                        , "-I."] ++ objs ++ envFlags +++                        (if (exec == Executable) then linkFlags else ["-c"]) ++                         [tmpn] ++                         (if not iface then libFlags else []) ++                         incFlags ++                         (if not iface then libs else []) ++-                        flags ++ stackFlag +++                        flags ++                         ["-o", out] --              putStrLn (show args)              exit <- rawSystem comp args@@ -396,7 +400,7 @@ irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")" irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x irts_c (FArith (ATInt (ITFixed ity))) x-    = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"+    = "GETBITS" ++ show (nativeTyWidth ity) ++ "(" ++ x ++ ")" irts_c FString x = "GETSTR(" ++ x ++ ")" irts_c FUnit x = x irts_c FPtr x = "GETPTR(" ++ x ++ ")"@@ -536,13 +540,13 @@ doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]  doOp v (LSExt (ITFixed from) ITBig) [x]-    = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"+    = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ") GETBITS" ++ show (nativeTyWidth from) ++ "(" ++ creg x ++ "))" doOp v (LSExt ITNative (ITFixed to)) [x]     = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))" doOp v (LSExt ITChar (ITFixed to)) [x]     = doOp v (LSExt ITNative (ITFixed to)) [x] doOp v (LSExt (ITFixed from) ITNative) [x]-    = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"+    = v ++ "MKINT((i_int)((" ++ signedTy from ++ ") GETBITS" ++ show (nativeTyWidth from) ++ "(" ++ creg x ++ ")))" doOp v (LSExt (ITFixed from) ITChar) [x]     = doOp v (LSExt (ITFixed from) ITNative) [x] doOp v (LSExt (ITFixed from) (ITFixed to)) [x]@@ -552,11 +556,11 @@ doOp v (LZExt ITChar (ITFixed to)) [x]     = doOp v (LZExt ITNative (ITFixed to)) [x] doOp v (LZExt (ITFixed from) ITNative) [x]-    = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"+    = v ++ "MKINT((i_int)GETBITS" ++ show (nativeTyWidth from) ++ "(" ++ creg x ++ "))" doOp v (LZExt (ITFixed from) ITChar) [x]     = doOp v (LZExt (ITFixed from) ITNative) [x] doOp v (LZExt (ITFixed from) ITBig) [x]-    = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"+    = v ++ "MKBIGUI(vm, GETBITS" ++ show (nativeTyWidth from) ++ "(" ++ creg x ++ "))" doOp v (LZExt ITNative ITBig) [x]     = v ++ "MKBIGUI(vm, (uintptr_t)GETINT(" ++ creg x ++ "))" doOp v (LZExt (ITFixed from) (ITFixed to)) [x]@@ -566,7 +570,7 @@ doOp v (LTrunc ITChar (ITFixed to)) [x]     = doOp v (LTrunc ITNative (ITFixed to)) [x] doOp v (LTrunc (ITFixed from) ITNative) [x]-    = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"+    = v ++ "MKINT((i_int)GETBITS" ++ show (nativeTyWidth from) ++ "(" ++ creg x ++ "))" doOp v (LTrunc (ITFixed from) ITChar) [x]     = doOp v (LTrunc (ITFixed from) ITNative) [x] doOp v (LTrunc ITBig (ITFixed IT64)) [x]
src/IRTS/Compiler.hs view
@@ -197,7 +197,6 @@     snRank (ParentN n s) = "3" ++ nameRank n ++ show s     snRank (MethodN n) = "4" ++ nameRank n     snRank (CaseN _ n) = "5" ++ nameRank n-    snRank (ElimN n) = "6" ++ nameRank n     snRank (ImplementationCtorN n) = "7" ++ nameRank n     snRank (WithN i n) = "8" ++ nameRank n ++ show i
src/IRTS/JavaScript/Codegen.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-}  module IRTS.JavaScript.Codegen( codegenJs                               , CGConf(..)@@ -47,6 +47,11 @@                        , partialApplications :: Set Partial                        , hiddenClasses :: Set HiddenClass                        }++#if (MIN_VERSION_base(4,11,0))+instance Semigroup CGStats where+    (<>) = mappend+#endif  -- If we generate code for two declarations we want to merge their code -- generation stats.
src/IRTS/System.hs view
@@ -25,6 +25,7 @@ #else import Paths_idris #endif+import BuildFlags_idris  import Control.Applicative ((<$>)) import Data.List.Split@@ -60,7 +61,13 @@     Just ddir -> return ddir  getCC :: IO String-getCC = fromMaybe "gcc" <$> lookupEnv "IDRIS_CC"+getCC = fromMaybe cc <$> lookupEnv "IDRIS_CC"+  where+#ifdef mingw32_HOST_OS+    cc = "gcc"+#else+    cc = "cc"+#endif  getEnvFlags :: IO [String] getEnvFlags = maybe [] (splitOn " ") <$> lookupEnv "IDRIS_CFLAGS"@@ -81,9 +88,14 @@ gmpLib = [] #endif +extraLibFlags = map ("-L" ++) extraLibDirs+ getLibFlags = do dir <- getIdrisCRTSDir-                 return $ ["-L" ++ dropTrailingPathSeparator dir,-                           "-lidris_rts"] ++ extraLib ++ gmpLib ++ ["-lpthread"]+                 return $ extraLibFlags+                   ++ extraLib+                   ++ ["-L" ++ dropTrailingPathSeparator dir, "-lidris_rts"]+                   ++ gmpLib+                   ++ ["-lpthread"]  getIdrisLibDir = addTrailingPathSeparator <$> overrideIdrisSubDirWith "libs" "IDRIS_LIBRARY_PATH"
src/Idris/AbsSyntax.hs view
@@ -30,6 +30,7 @@ import Control.Monad.State import Prelude hiding (Applicative, Foldable, Traversable, (<$>)) +import Data.Char import Data.Either import Data.List hiding (insert, union) import qualified Data.Map as M@@ -1846,6 +1847,8 @@ addImpl' inpat env infns imp_meths ist ptm    = ai inpat False (zip env (repeat Nothing)) [] (mkUniqueNames env [] ptm)   where+    allowcap = AllowCapitalizedPatternVariables `elem` opt_cmdline (idris_options ist)+     topname = case ptm of                    PRef _ _ n -> n                    PApp _ (PRef _ _ n) _ -> n@@ -1854,9 +1857,9 @@     ai :: Bool -> Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm     ai inpat qq env ds (PRef fc fcs f)         | f `elem` infns = PInferRef fc fcs f-        | not (f `elem` map fst env) = handleErr $ aiFn topname inpat inpat qq imp_meths ist fc f fc ds []+        | not (f `elem` map fst env) = handleErr $ aiFn topname allowcap inpat inpat qq imp_meths ist fc f fc ds []     ai inpat qq env ds (PHidden (PRef fc hl f))-        | not (f `elem` map fst env) = PHidden (handleErr $ aiFn topname inpat False qq imp_meths ist fc f fc ds [])+        | not (f `elem` map fst env) = PHidden (handleErr $ aiFn topname allowcap inpat False qq imp_meths ist fc f fc ds [])     ai inpat qq env ds (PRewrite fc by l r g)        = let l' = ai inpat qq env ds l              r' = ai inpat qq env ds r@@ -1886,7 +1889,7 @@         | f `elem` infns = ai inpat qq env ds (PApp fc (PInferRef ffc hl f) as)         | not (f `elem` map fst env)               = let as' = map (fmap (ai inpat qq env ds)) as in-                    handleErr $ aiFn topname inpat False qq imp_meths ist fc f ffc ds as'+                    handleErr $ aiFn topname allowcap inpat False qq imp_meths ist fc f ffc ds as'         | Just (Just ty) <- lookup f env =              let as' = map (fmap (ai inpat qq env ds)) as                  arity = getPArity ty in@@ -1971,24 +1974,31 @@ -- if in a pattern, and there are no arguments, and there's no possible -- names with zero explicit arguments, don't add implicits. -aiFn :: Name -> Bool -> Bool -> Bool+aiFn :: Name -> Bool -- ^ Allow capitalization of pattern variables+     -> Bool -> Bool -> Bool      -> [Name]      -> IState -> FC      -> Name -- ^ function being applied      -> FC -> [[T.Text]]      -> [PArg] -- ^ initial arguments (if in a pattern)      -> Either Err PTerm-aiFn topname inpat True qq imp_meths ist fc f ffc ds []+aiFn topname allowcap inpat True qq imp_meths ist fc f ffc ds []   | inpat && implicitable f && unqualified f = Right $ PPatvar ffc f   | otherwise      = case lookupDef f (tt_ctxt ist) of-        [] -> Right $ PPatvar ffc f+        [] -> if allowcap+                then Right $ PPatvar ffc f+                else case f of+                       MN _ _ -> Right $ PPatvar ffc f+                       UN xs | isDigit (T.head xs) -- for partial evaluation vars+                                 -> Right $ PPatvar ffc f+                       _ -> Left $ Msg $ show f ++ " is not a valid name for a pattern variable"         alts -> let ialts = lookupCtxtName f (idris_implicits ist) in                     -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $                     if (not (vname f) || tcname f                            || any (conCaf (tt_ctxt ist)) ialts) --                            any constructor alts || any allImp ialts))-                        then aiFn topname inpat False qq imp_meths ist fc f ffc ds [] -- use it as a constructor+                        then aiFn topname allowcap inpat False qq imp_meths ist fc f ffc ds [] -- use it as a constructor                         else Right $ PPatvar ffc f     where imp (PExp _ _ _ _) = False           imp _ = True@@ -2003,9 +2013,9 @@           vname (UN n) = True -- non qualified           vname _ = False -aiFn topname inpat expat qq imp_meths ist fc f ffc ds as+aiFn topname allowcap inpat expat qq imp_meths ist fc f ffc ds as     | f `elem` primNames = Right $ PApp fc (PRef ffc [ffc] f) as-aiFn topname inpat expat qq imp_meths ist fc f ffc ds as+aiFn topname allowcap inpat expat qq imp_meths ist fc f ffc ds as           -- This is where namespaces get resolved by adding PAlternative      = do let ns = lookupCtxtName f (idris_implicits ist)           let nh = filter (\(n, _) -> notHidden n) ns
src/Idris/AbsSyntaxTree.hs view
@@ -6,9 +6,10 @@ Maintainer  : The Idris Community. -} -{-# LANGUAGE DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric,-             DeriveTraversable, FlexibleContexts, FlexibleInstances,-             MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFoldable, DeriveFunctor,+             DeriveGeneric, DeriveTraversable, FlexibleContexts,+             FlexibleInstances, MultiParamTypeClasses, PatternGuards,+             TypeSynonymInstances #-}  module Idris.AbsSyntaxTree where @@ -25,8 +26,11 @@ import Idris.Colours  import System.IO-+#if (MIN_VERSION_base(4,11,0))+import Prelude hiding (Foldable, Traversable, (<$>), (<>))+#else import Prelude hiding (Foldable, Traversable, (<$>))+#endif  import Control.Applicative ((<|>)) import qualified Control.Monad.Trans.Class as Trans (lift)@@ -47,7 +51,6 @@ import Data.Typeable import GHC.Generics (Generic) - data ElabWhat = ETypes | EDefns | EAll   deriving (Show, Eq) @@ -1092,8 +1095,6 @@  data PTactic' t = Intro [Name] | Intros | Focus Name                 | Refine Name [Bool] | Rewrite t | DoUnify-                | Induction t-                | CaseTac t                 | Equiv t                 | Claim Name t                 | Unfocus@@ -1132,7 +1133,6 @@   size (Focus nm)       = 1 + size nm   size (Refine nm bs)   = 1 + size nm + length bs   size (Rewrite t)      = 1 + size t-  size (Induction t)    = 1 + size t   size (LetTac nm t)    = 1 + size nm + size t   size (Exact t)        = 1 + size t   size Compute          = 1@@ -1153,7 +1153,6 @@   size (TFail ts)       = 1 + size ts   size SourceFC         = 1   size DoUnify          = 1-  size (CaseTac x)      = 1 + size x   size (Equiv t)        = 1 + size t   size (Claim x y)      = 1 + size x + size y   size Unfocus          = 1@@ -1992,7 +1991,7 @@     prettyArgS d bnd (PConstraint _ _ _ tm)     = prettyArgSc d bnd tm     prettyArgS d bnd (PTacImplicit _ _ n _ tm)  = prettyArgSti d bnd (n, tm) -    prettyArgSe d bnd arg       = prettySe d (funcAppPrec + 1) bnd arg+    prettyArgSe d bnd arg       = prettySe (decD d) (funcAppPrec + 1) bnd arg     prettyArgSi d bnd (n, val)  = lbrace <> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace     prettyArgSc d bnd val       = lbrace <> lbrace <> prettySe (decD d) startPrec bnd val <> rbrace <> rbrace     prettyArgSti d bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace@@ -2279,25 +2278,41 @@     ni 0 env (PPatvar _ n)            = [n]     ni 0 env (PApp _ f as)            = ni 0 env f ++ concatMap (ni 0 env . getTm) as     ni 0 env (PAppBind _ f as)        = ni 0 env f ++ concatMap (ni 0 env . getTm) as+    ni 0 env (PWithApp _ f a)         = ni 0 env f ++ ni 0 env a+    ni 0 env (PAppImpl t _)           = ni 0 env t     ni 0 env (PCase _ c os)           = ni 0 env c ++ concatMap (ni 0 env . snd) os     ni 0 env (PIfThenElse _ c t f)    = ni 0 env c ++ ni 0 env t ++ ni 0 env f     ni 0 env (PLam fc n _ ty sc)      = ni 0 env ty ++ ni 0 (n:env) sc     ni 0 env (PPi p n _ ty sc)        = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc     ni 0 env (PLet _ _ n _ ty val sc) = ni 0 env ty ++ ni 0 env val ++ ni 0 (n:env) sc     ni 0 env (PHidden tm)             = ni 0 env tm+    ni 0 env (PGoal _ t _ sc)         = ni 0 env t ++ ni 0 env sc+    ni 0 env (PIdiom _ tm)            = ni 0 env tm     ni 0 env (PRewrite _ _ l r _)     = ni 0 env l ++ ni 0 env r     ni 0 env (PTyped l r)             = ni 0 env l ++ ni 0 env r     ni 0 env (PPair _ _ _ l r)        = ni 0 env l ++ ni 0 env r     ni 0 env (PDPair _ _ _ (PRef _ _ n) Placeholder r) = n : ni 0 env r     ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r     ni 0 env (PDPair _ _ _ l t r)     = ni 0 env l ++ ni 0 env t ++ ni 0 env r+    ni 0 env (PAs _ _ tm)             = ni 0 env tm+    -- Just take the first, when disambiguating, since the shape will be+    -- the same and we'll get the name root+    ni 0 env (PAlternative ns (ExactlyOne _) (a : as))+            = map snd ns ++ ni 0 env a     ni 0 env (PAlternative ns a ls)   = map snd ns ++ concatMap (ni 0 env) ls     ni 0 env (PUnifyLog tm)           = ni 0 env tm     ni 0 env (PDisamb _ tm)           = ni 0 env tm     ni 0 env (PNoImplicits tm)        = ni 0 env tm+    ni 0 env (PCoerced tm)            = ni 0 env tm+    ni 0 env (PRunElab _ tm _)        = ni 0 env tm+    ni 0 env (PConstSugar _ tm)       = ni 0 env tm+    ni 0 env tm@(PDoBlock _)      = concatMap (ni 0 env) (children tm)+    ni 0 env tm@(PProof _)        = concatMap (ni 0 env) (children tm)+    ni 0 env tm@(PTactics _)      = concatMap (ni 0 env) (children tm)      ni i env (PQuasiquote tm ty)  = ni (i+1) env tm ++ maybe [] (ni i env) ty     ni i env (PUnquote tm)        = ni (i - 1) env tm+    ni 0 env tm                   = []     ni i env tm                   = concatMap (ni i env) (children tm)      niTacImp i env (TacImp _ _ scr _) = ni i env scr
src/Idris/Chaser.hs view
@@ -22,6 +22,8 @@  import Control.Monad.State import Data.List+import qualified Data.Map as M+import qualified Data.Set as S import Data.Time.Clock import System.Directory import Util.System (readSource)@@ -36,8 +38,7 @@ latest tm done [] = tm latest tm done (m : ms)     | mod_path m `elem` done = latest tm done ms-    | otherwise = latest (max tm (mod_time m)) (mod_path m : done)-                         (ms ++ mod_deps m)+    | otherwise = latest (max tm (mod_time m)) (mod_path m : done) ms  modName :: IFileType -> String modName (IDR fp) = fp@@ -48,24 +49,53 @@ -- any module has a descendent which needs reloading, return its -- source, otherwise return the IBC getModuleFiles :: [ModuleTree] -> [IFileType]-getModuleFiles ts = nub $ execState (modList ts) [] where-   modList :: [ModuleTree] -> State [IFileType] ()-   modList [] = return ()-   modList (m : ms) = do modTree [] m; modList ms+getModuleFiles ts+    = let (files, (rebuild, _)) = runState (modList ts) (S.empty, M.empty) in+          updateToSrc rebuild (reverse files)+ where+   -- Get the order of building modules. As we go we'll find things that+   -- need rebuilding, which we keep track of in the Set.+   -- The order of the list matters - things which get built first appear+   -- in the list first. We'll remove any repetition later.+   modList :: [ModuleTree] ->+              State (S.Set IFileType,+                     M.Map IFileType (Bool, [IFileType])) [IFileType]+   modList [] = return []+   modList (m : ms) = do (_, fs) <- modTree S.empty m+                         fs' <- modList ms+                         pure (fs ++ fs') -   modTree path (MTree p rechk tm deps)+   modTree path m@(MTree p rechk tm deps)        = do let file = chkReload rechk p-            -- Needs rechecking if 'rechk' is true, or if any of the-            -- modification times in 'deps' are later than tm-            let depMod = latest tm [] deps-            let needsRechk = rechk || depMod > tm+            (rebuild, res) <- get+            case M.lookup file res of+                 Just ms -> pure ms+                 Nothing -> do+                    toBuildsAll <- mapM (modTree (S.insert (getSrc p) path)) deps+                    let (rechkDep_in, toBuilds) = unzip toBuildsAll+                    let rechkDep = or rechkDep_in -            st <- get-            if needsRechk then put $ nub (getSrc file : updateToSrc path st)-                          else put $ nub (file : st)-            st <- get-            mapM_ (modTree (getSrc p : path)) deps+                    (rebuild, res) <- get +                    -- Needs rechecking if 'rechk' is true, or if any of the+                    -- modification times in 'deps' are later than tm, or+                    -- if any dependency needed rechecking+                    let depMod = latest tm [] deps+                    let needsRechk = rechkDep || rechk || depMod > tm++                    -- Remove duplicates, but keep the last...+                    let rnub = reverse . nub . reverse++                    let ret = if needsRechk+                                 then (needsRechk, rnub (getSrc file : concat toBuilds))+                                 else (needsRechk, rnub (file : concat toBuilds))++                    -- Cache the result+                    put (if needsRechk+                            then S.union path rebuild+                            else rebuild, M.insert file ret res)+                    pure ret+    chkReload False p = p    chkReload True (IBC fn src) = chkReload True src    chkReload True p = p@@ -73,10 +103,11 @@    getSrc (IBC fn src) = getSrc src    getSrc f = f -   updateToSrc path [] = []-   updateToSrc path (x : xs) = if getSrc x `elem` path-                                  then getSrc x : updateToSrc path xs-                                  else x : updateToSrc path xs+   updateToSrc rebuilds [] = []+   updateToSrc rebuilds (x : xs)+       = if getSrc x `S.member` rebuilds+            then getSrc x : updateToSrc rebuilds xs+            else x : updateToSrc rebuilds xs  -- | Strip quotes and the backslash escapes that Haskeline adds extractFileName :: String -> String@@ -173,8 +204,12 @@                                do [MTree _ _ _ ms'] <- mkChildren file src                                   return ms'                              else return []-                   mt <- lift $ idrisCatch (runIO $ getModificationTime fn)-                                    (\c -> runIO $ getIModTime src)+                   -- Modification time is the later of the source/ibc modification time+                   smt <- lift $ idrisCatch (runIO $ getIModTime src)+                                    (\c -> runIO $ getModificationTime fn)+                   mt <- lift $ idrisCatch (do t <- runIO $ getModificationTime fn+                                               return (max smt t))+                                    (\c -> return smt)                    -- FIXME: It's also not up to date if anything it imports has                    -- been modified since its own ibc has.                    --
src/Idris/CmdOptions.hs view
@@ -10,7 +10,8 @@  module Idris.CmdOptions   ( opt, getClient, getPkg, getPkgCheck, getPkgClean, getPkgMkDoc,-    getPkgREPL, getPkgTest, getPort, getIBCSubDir, pureArgParser, runArgParser+    getPkgREPL, getPkgTest, getPort, getIBCSubDir,+    pureArgParser, execArgParserPure, runArgParser   ) where  import Idris.Info (getIdrisVersion)@@ -72,10 +73,13 @@                                         PP.empty,                                         PP.indent 4 (PP.text "http://www.idris-lang.org/")] +execArgParserPure :: [String] -> ParserResult [Opt]+execArgParserPure args = preProcOpts <$> execParserPure (prefs idm) (info parser idm) args+ pureArgParser :: [String] -> [Opt]-pureArgParser args = case getParseResult $ execParserPure (prefs idm) (info parser idm) args of+pureArgParser args = case getParseResult (execArgParserPure args) of   Just opts -> preProcOpts opts-  Nothing -> []+  Nothing   -> []  parser :: Parser [Opt] parser = runA $ proc () -> do@@ -218,8 +222,8 @@    <|> flag' DumpHighlights (long "highlight" <> help "Emit source code highlighting") -  <|> flag' NoElimDeprecationWarnings      (long "no-elim-deprecation-warnings"   <> help "Disable deprecation warnings for %elim")   <|> flag' NoOldTacticDeprecationWarnings (long "no-tactic-deprecation-warnings" <> help "Disable deprecation warnings for the old tactic sublanguage")+  <|> flag' AllowCapitalizedPatternVariables (long "allow-capitalized-pattern-variables" <> help "Allow pattern variables to be capitalized")      where       getExt :: String -> LanguageExt
src/Idris/Core/Binary.hs view
@@ -133,9 +133,6 @@                                       put x1                                       put x2                                       put x3-  put (NoEliminator s t) = do putWord8 37-                              put s-                              put t   put (InvalidTCArg n t) = do putWord8 38                               put n                               put t@@ -211,9 +208,6 @@                       x2 <- get                       x3 <- get                       return (ElabScriptDebug x1 x2 x3)-             37 -> do x1 <- get-                      x2 <- get-                      return (NoEliminator x1 x2)              38 -> do x1 <- get                       x2 <- get                       return (InvalidTCArg x1 x2)
src/Idris/Core/Elaborate.hs view
@@ -446,12 +446,6 @@ rewrite :: Raw -> Elab' aux () rewrite tm = processTactic' (Rewrite tm) -induction :: Raw -> Elab' aux ()-induction tm = processTactic' (Induction tm)--casetac :: Raw -> Elab' aux ()-casetac tm = processTactic' (CaseTac tm)- equiv :: Raw -> Elab' aux () equiv tm = processTactic' (Equiv tm)
src/Idris/Core/ProofState.hs view
@@ -10,7 +10,7 @@ evaluation/checking inside the proof system, etc. -} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,+{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,              PatternGuards #-} module Idris.Core.ProofState(     ProofState(..), newProof, envAtFocus, goalAtFocus@@ -32,6 +32,10 @@ import Control.Monad.State.Strict import Data.List +#if (MIN_VERSION_base(4,11,0))+import Prelude hiding ((<>))+#endif+ data ProofState = PS { thname            :: Name,                        holes             :: [Name], -- ^ holes still to be solved                        usedns            :: [Name], -- ^ used names, don't use again@@ -91,8 +95,6 @@             | LetBind Name RigCount Raw Raw             | ExpandLet Name Term             | Rewrite Raw-            | Induction Raw-            | CaseTac Raw             | Equiv Raw             | PatVar Name             | PatBind Name RigCount@@ -566,6 +568,8 @@    = do ps <- get         dropdots <-              case lookup x (notunified ps) of+                Just (P _ h _)+                     | h == x -> return [] -- Can't solve itself!                 Just tm -> -- trace ("NEED MATCH: " ++ show (x, tm, val) ++ "\nIN " ++ show (pterm ps)) $                             do match_unify' ctxt env (tm, Just InferredVal)                                                      (val, Just GivenVal)@@ -726,62 +730,6 @@                              b { binderTy = ty' } mkP lt l r x = x -casetac :: Raw -> Bool -> RunTactic-casetac tm induction ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do-  (tmv, tmt) <- lift $ check ctxt env tm-  let tmt' = normalise ctxt env tmt-  let (tacn, tacstr, _) = if induction-              then (ElimN, "eliminator", "Induction")-              else (CaseN (FC' emptyFC), "case analysis", "Case analysis")-  case unApply tmt' of-    (P _ tnm _, tyargs) -> do-        case lookupTy (SN (tacn tnm)) ctxt of-          [elimTy] -> do-             param_pos <- case lookupMetaInformation tnm ctxt of-                               [DataMI param_pos]    -> return param_pos-                               m | not (null tyargs) -> fail $ "Invalid meta information for " ++ show tnm ++ " where the metainformation is " ++ show m ++ " and definition is" ++ show (lookupDef tnm ctxt)-                               _ -> return []-             let (params, indicies) = splitTyArgs param_pos tyargs-             let args     = getArgTys elimTy-             let args'    = drop (length params) args-             let restargs = init $ tail args'-             let consargs = take (length restargs - length indicies) restargs-             let indxnames = makeIndexNames indicies-             currentNames <- query $ allTTNames . getProofTerm . pterm-             let tmnm = case tm of-                         Var nm -> uniqueNameCtxt ctxt nm currentNames-                         _ -> uniqueNameCtxt ctxt (sMN 0 "iv") currentNames-             let tmvar = P Bound tmnm tmt'-             prop <- replaceIndicies indxnames indicies $ Bind tmnm (Lam RigW tmt') (mkP tmvar tmv tmvar t)-             consargs' <- query (\ps -> map (flip (uniqueNameCtxt (context ps)) (holes ps ++ allTTNames (getProofTerm (pterm ps))) *** uniqueBindersCtxt (context ps) (holes ps ++ allTTNames (getProofTerm (pterm ps)))) consargs)-             let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (tacn tnm)) (TType (UVal 0)))-                                                        (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv])))-             action (\ps -> ps {holes = holes ps \\ [x],-                                recents = x : recents ps })-             mapM_ addConsHole (reverse consargs')-             let res' = forget res-             (scv, sct) <- lift $ check ctxt env res'-             let (scv', _) = specialise ctxt env [] scv-             return scv'-          [] -> lift $ tfail $ NoEliminator tacstr tmt'-          xs -> lift $ tfail $ Msg $ "Multiple definitions found when searching for " ++ tacstr ++ "of " ++ show tnm-    _ -> lift $ tfail $ NoEliminator (if induction then "induction" else "case analysis")-                                     tmt'-    where makeConsArg (nm, ty) = P Bound nm ty-          bindConsArgs ((nm, ty):args) v = Bind nm (Hole ty) $ bindConsArgs args v-          bindConsArgs [] v = v-          addConsHole (nm, ty) =-            action (\ps -> ps { holes = nm : holes ps })-          splitTyArgs param_pos tyargs =-            let (params, indicies) = partition (flip elem param_pos . fst) . zip [0..] $ tyargs-            in (map snd params, map snd indicies)-          makeIndexNames = foldr (\_ nms -> (uniqueNameCtxt ctxt (sMN 0 "idx") nms):nms) []-          replaceIndicies idnms idxs prop = foldM (\t (idnm, idx) -> do (idxv, idxt) <- lift $ check ctxt env (forget idx)-                                                                        let var = P Bound idnm idxt-                                                                        return $ Bind idnm (Lam RigW idxt) (mkP var idxv var t)) prop $ zip idnms idxs-casetac tm induction ctxt env _ = fail $ "Can't do " ++ (if induction then "induction" else "case analysis") ++ " here"-- equiv :: Raw -> RunTactic equiv tm ctxt env (Bind x (Hole t) sc) =     do (tmv, tmt) <- lift $ check ctxt env tm@@ -1109,8 +1057,6 @@          mktac (LetBind n r t v) = letbind n r t v          mktac (ExpandLet n b)   = expandLet n b          mktac (Rewrite t)       = rewrite t-         mktac (Induction t)     = casetac t True-         mktac (CaseTac t)       = casetac t False          mktac (Equiv t)         = equiv t          mktac (PatVar n)        = patvar n          mktac (PatBind n rig)   = patbind n rig
src/Idris/Core/TT.hs view
@@ -22,10 +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, DeriveFoldable, DeriveFunctor, DeriveGeneric,-             DeriveTraversable, FlexibleContexts, FlexibleInstances,-             FunctionalDependencies, MultiParamTypeClasses, PatternGuards,-             TypeSynonymInstances #-}+{-# LANGUAGE CPP, 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(..)@@ -63,6 +63,10 @@                 Ordering(..), Show(..), String, div, error, fst, max, min, mod,                 not, otherwise, read, snd, ($), (&&), (.), (||)) +#if (MIN_VERSION_base(4,11,0))+import qualified Prelude as S (Semigroup(..))+#endif+ import Control.Applicative (Alternative, Applicative(..)) import qualified Control.Applicative as A (Alternative(..)) import Control.DeepSeq (($!!))@@ -117,6 +121,11 @@ fc_end NoFC = (0, 0) fc_end (FileFC f) = (0, 0) +#if (MIN_VERSION_base(4,11,0))+instance S.Semigroup FC where+    (<>) = mappend+#endif+ instance Monoid FC where   mempty = NoFC @@ -273,7 +282,6 @@           | CantResolveAlts [Name]           | NoValidAlts [Name]           | IncompleteTerm t-          | NoEliminator String t           | UniverseError FC UExp (Int, Int) (Int, Int) [ConstraintFC]             -- ^ Location, bad universe, old domain, new domain, suspects           | UniqueError Universe Name@@ -485,7 +493,6 @@                  | ParentN !Name !T.Text                  | MethodN !Name                  | CaseN !FC' !Name-                 | ElimN !Name                  | ImplementationCtorN !Name                  | MetaN !Name !Name   deriving (Eq, Ord, Data, Generic, Typeable)@@ -530,7 +537,6 @@     show (ParentN p c) = show p ++ "#" ++ T.unpack c     show (CaseN fc n) = "case block in " ++ show n ++                         if fc == FC' emptyFC then "" else " at " ++ show fc-    show (ElimN n) = "<<" ++ show n ++ " eliminator>>"     show (ImplementationCtorN n) = "constructor of " ++ show n     show (MetaN parent meta) = "<<" ++ show parent ++ " " ++ show meta ++ ">>" @@ -547,7 +553,6 @@         showCG' (MethodN m) = '!':showCG m         showCG' (ParentN p c) = showCG p ++ "#" ++ show c         showCG' (CaseN fc c) = showCG c ++ showFC' fc ++ "_case"-        showCG' (ElimN sn) = showCG sn ++ "_elim"         showCG' (ImplementationCtorN n) = showCG n ++ "_ictor"         showCG' (MetaN parent meta) = showCG parent ++ "_meta_" ++ showCG meta         showFC' (FC' NoFC) = ""@@ -581,7 +586,8 @@  implicitable (NS n _) = False implicitable (UN xs) | T.null xs = False-                     | otherwise = isLower (T.head xs) || T.head xs == '_'+                     | otherwise = isLower (T.head xs) ||+                                   T.head xs == '_' implicitable (MN _ x) = not (tnull x) && thead x /= '_' implicitable _ = False @@ -1089,8 +1095,6 @@  -- | Data declaration options data DataOpt = Codata -- ^ Set if the the data-type is coinductive-             | DefaultEliminator -- ^ Set if an eliminator should be generated for data type-             | DefaultCaseFun -- ^ Set if a case function should be generated for data type              | DataErrRev     deriving (Show, Eq, Generic) @@ -1511,7 +1515,6 @@     nextName' (ImplementationN n ns) = ImplementationN (nextName n) ns     nextName' (ParentN n ns) = ParentN (nextName n) ns     nextName' (CaseN fc n) = CaseN fc (nextName n)-    nextName' (ElimN n) = ElimN (nextName n)     nextName' (MethodN n) = MethodN (nextName n)     nextName' (ImplementationCtorN n) = ImplementationCtorN (nextName n)     nextName' (MetaN parent meta) = MetaN parent (nextName meta)
src/Idris/Coverage.hs view
@@ -476,4 +476,5 @@ -- reduce the function checkRec (P Ref _ _) (Constant _) = return True checkRec (Constant _) (P Ref _ _) = return True+checkRec (TType _) (TType _) = return True checkRec _ _ = return False
src/Idris/Delaborate.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE CPP, PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Delaborate (     annName, bugaddr, delab, delabWithEnv, delabDirect, delab', delabMV, delabSugared@@ -21,7 +21,11 @@  import Util.Pretty +#if (MIN_VERSION_base(4,11,0))+import Prelude hiding ((<$>), (<>))+#else import Prelude hiding ((<$>))+#endif  import Control.Applicative (Alternative((<|>))) import Control.Monad.State@@ -460,12 +464,6 @@    getMissing hs env (App _ f a)        = getMissing hs env f ++ getMissing hs env a    getMissing hs env _ = []-pprintErr' i (NoEliminator s t)-  = text "No " <> text s <> text " for type " <+>-       annTm t (pprintTerm i (delabSugared i t)) <$>-    text "Please note that 'induction' is experimental." <$>-    text "Only types declared with '%elim' can be used." <$>-    text "Consider writing a pattern matching definition instead." pprintErr' i (UniverseError fc uexp old new suspects) =   text "Universe inconsistency." <>   (indented . vsep) [ text "Working on:" <+> text (show uexp)
src/Idris/Docs.hs view
@@ -6,7 +6,7 @@ Maintainer  : The Idris Community. -} -{-# LANGUAGE DeriveFunctor, MultiWayIf, PatternGuards #-}+{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}  module Idris.Docs (@@ -30,7 +30,11 @@  import Util.Pretty +#if (MIN_VERSION_base(4,11,0))+import Prelude hiding ((<$>), (<>))+#else import Prelude hiding ((<$>))+#endif  import Data.List import Data.Maybe
src/Idris/Docstrings.hs view
@@ -6,8 +6,8 @@ Maintainer  : The Idris Community. -} -{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable,-             ScopedTypeVariables #-}+{-# LANGUAGE CPP, DeriveFoldable, DeriveFunctor, DeriveGeneric,+             DeriveTraversable, ScopedTypeVariables #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Docstrings (     Docstring(..), Block(..), Inline(..), parseDocstring, renderDocstring@@ -19,8 +19,11 @@  import Util.Pretty +#if (MIN_VERSION_base(4,11,0))+import Prelude hiding ((<$>), (<>))+#else import Prelude hiding ((<$>))-+#endif import qualified Cheapskate as C import Cheapskate.Html (renderDoc) import qualified Cheapskate.Types as CT
src/Idris/Elab/Data.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE CPP, PatternGuards #-} module Idris.Elab.Data(elabData) where  import Idris.AbsSyntax@@ -24,7 +24,11 @@  import Util.Pretty +#if (MIN_VERSION_base(4,11,0))+import Prelude hiding (id, (.), (<>))+#else import Prelude hiding (id, (.))+#endif  import Control.Category import Control.Monad@@ -110,12 +114,6 @@                 >> addIBC (IBCOpt cn) >> addIBC (IBCOpt n)             _ -> return () -         -- create an eliminator-         when (DefaultEliminator `elem` opts) $-            evalStateT (elabCaseFun True params n t dcons info) Map.empty-         -- create a case function-         when (DefaultCaseFun `elem` opts) $-            evalStateT (elabCaseFun False params n t dcons info) Map.empty          -- create a rewriting lemma          when (n /= sUN "=") $             elabRewriteLemma info n cty@@ -312,244 +310,3 @@                                        addIBC (IBCConstraint fc con)                   _ -> return ()         constraintTy t = return ()--type EliminatorState = StateT (Map.Map String Int) Idris---- -- Issue #1616 in the issue tracker.---     https://github.com/idris-lang/Idris-dev/issues/1616------ TODO: Rewrite everything to use idris_implicits instead of manual splitting (or in TT)--- FIXME: Many things have name starting with elim internally since this was the only purpose in the first edition of the function--- rename to caseFun to match updated intend-elabCaseFun :: Bool -> [Int] -> Name -> PTerm ->-                  [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name])] ->-                  ElabInfo -> EliminatorState ()-elabCaseFun ind paramPos n ty cons info = do-  elimLog "Elaborating case function"-  put (Map.fromList $ zip (concatMap (\(_, p, _, _, ty, _, _) -> (map show $ boundNamesIn ty) ++ map (show . fst) p) cons ++ (map show $ boundNamesIn ty)) (repeat 0))-  let (cnstrs, _) = splitPi ty-  let (pms, idxs) = splitPms cnstrs-  generalParams <- namePis False pms-  motiveIdxs    <- namePis False idxs-  let motive = mkMotive n paramPos generalParams motiveIdxs-  consTerms <- mapM (\(c@(_, _, cnm, _, _, _, _)) -> do-                               let casefunt = if ind then "elim_" else "case_"-                               name <- freshName $ casefunt ++ simpleName cnm-                               consTerm <- extractConsTerm c generalParams-                               return (name, expl, consTerm)) cons-  scrutineeIdxs <- namePis False idxs-  let motiveConstr = [(motiveName, expl, motive)]-  let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))-  let eliminatorTy = piConstr (generalParams ++ motiveConstr ++ consTerms ++ scrutineeIdxs ++ [scrutinee]) (applyMotive (map (\(n,_,_) -> PRef elimFC [] n) scrutineeIdxs) (PRef elimFC [] scrutineeName))-  let eliminatorTyDecl = PTy (fmap (const (Left $ Msg "")) . parseDocstring . T.pack $ show n) [] defaultSyntax elimFC [TotalFn] elimDeclName elimFC eliminatorTy-  let clauseConsElimArgs = map getPiName consTerms-  let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs-  let clauseGeneralArgs  = map (\arg -> pexp (PRef elimFC [] arg)) clauseGeneralArgs'-  let elimSig = "-- case function signature: " ++ showTmImpls eliminatorTy-  elimLog elimSig-  eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)-  let eliminatorDef = PClauses elimFC [TotalFn] elimDeclName eliminatorClauses-  elimLog $ "-- case function definition: " ++ (show . showDeclImp verbosePPOption) eliminatorDef-  State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorTyDecl)-                    (ierror . Elaborating "type declaration of " elimDeclName Nothing)-  -- Do not elaborate clauses if there aren't any-  case eliminatorClauses of-    [] -> State.lift $ solveDeferred elimFC elimDeclName -- Remove meta-variable for type-    _  -> State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorDef)-                    (ierror . Elaborating "clauses of " elimDeclName Nothing)-  where elimLog :: String -> EliminatorState ()-        elimLog s = State.lift (logElab 2 s)--        elimFC :: FC-        elimFC = fileFC $ "(casefun " ++ show n ++ ")"--        elimDeclName :: Name-        elimDeclName = if ind then SN . ElimN $ n else SN . CaseN (FC' elimFC) $ n--        splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm)-        splitPi = splitPi' []-          where splitPi' :: [(Name, Plicity, PTerm)] -> PTerm -> ([(Name, Plicity, PTerm)], PTerm)-                splitPi' acc (PPi pl n _ tyl tyr) = splitPi' ((n, pl, tyl):acc) tyr-                splitPi' acc t                    = (reverse acc, t)--        splitPms :: [(Name, Plicity, PTerm)] -> ([(Name, Plicity, PTerm)], [(Name, Plicity, PTerm)])-        splitPms cnstrs = (map fst pms, map fst idxs)-           where (pms, idxs) = partition (\c -> snd c `elem` paramPos) (zip cnstrs [0..])--        isMachineGenerated :: Name -> Bool-        isMachineGenerated (MN _ _) = True-        isMachineGenerated _        = False--        namePis :: Bool -> [(Name, Plicity, PTerm)] -> EliminatorState [(Name, Plicity, PTerm)]-        namePis keepOld pms = do names <- mapM (mkPiName keepOld) pms-                                 let oldNames = map fst names-                                 let params   = map snd names-                                 return $ map (\(n, pl, ty) -> (n, pl, removeParamPis oldNames params ty)) params--        mkPiName :: Bool -> (Name, Plicity, PTerm) -> EliminatorState (Name, (Name, Plicity, PTerm))-        mkPiName keepOld (n, pl, piarg) | not (isMachineGenerated n) && keepOld = do return (n, (n, pl, piarg))-        mkPiName _ (oldName, pl, piarg) =  do name <- freshName $ keyOf piarg-                                              return (oldName, (name, pl, piarg))-          where keyOf :: PTerm -> String-                keyOf (PRef _ _ name) | isLetter (nameStart name) = (toLower $ nameStart name):"__"-                keyOf (PApp _ tyf _) = keyOf tyf-                keyOf (PType _) = "ty__"-                keyOf _     = "carg__"-                nameStart :: Name -> Char-                nameStart n = nameStart' (simpleName n)-                  where nameStart' :: String -> Char-                        nameStart' "" = ' '-                        nameStart' ns = head ns--        simpleName :: Name -> String-        simpleName (NS n _) = simpleName n-        simpleName (MN i n) = str n ++ show i-        simpleName n        = show n--        freshName :: String -> EliminatorState Name-        freshName key = do-          nameMap <- get-          let i = fromMaybe 0 (Map.lookup key nameMap)-          let name = uniqueName (sUN (key ++ show i)) (map (\(nm, nb) -> sUN (nm ++ show nb)) $ Map.toList nameMap)-          put $ Map.insert key (i+1) nameMap-          return name--        scrutineeName :: Name-        scrutineeName = sUN "scrutinee"--        scrutineeArgName :: Name-        scrutineeArgName = sUN "scrutineeArg"--        motiveName :: Name-        motiveName = sUN "prop"--        mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm-        mkMotive n paramPos params indicies =-          let scrutineeTy = (scrutineeArgName, expl, applyCons n (interlievePos paramPos params indicies 0))-          in piConstr (indicies ++ [scrutineeTy]) (PType elimFC)--        piConstr :: [(Name, Plicity, PTerm)] -> PTerm -> PTerm-        piConstr [] ty = ty-        piConstr ((n, pl, tyb):tyr) ty = PPi pl n elimFC tyb (piConstr tyr ty)--        interlievePos :: [Int] -> [a] -> [a] -> Int -> [a]-        interlievePos idxs []     l2     i = l2-        interlievePos idxs l1     []     i = l1-        interlievePos idxs (x:xs) l2     i | i `elem` idxs = x:(interlievePos idxs xs l2 (i+1))-        interlievePos idxs l1     (y:ys) i = y:(interlievePos idxs l1 ys (i+1))--        replaceParams :: [Int] -> [(Name, Plicity, PTerm)] -> PTerm -> PTerm-        replaceParams paramPos params cns =-          let (_, cnsResTy) = splitPi cns-          in case cnsResTy of-               PApp _ _ args ->-                let oldParams = paramNamesOf 0 paramPos args-                in removeParamPis oldParams params cns-               _ -> cns--        removeParamPis :: [Name] -> [(Name, Plicity, PTerm)] -> PTerm -> PTerm-        removeParamPis oldParams params (PPi pl n fc tyb tyr) =-          case findIndex (== n) oldParams of-            Nothing -> (PPi pl n fc (removeParamPis oldParams params tyb) (removeParamPis oldParams params tyr))-            Just i  -> (removeParamPis oldParams params tyr)-        removeParamPis oldParams params (PRef _ _ n) =-          case findIndex (== n) oldParams of-               Nothing -> (PRef elimFC [] n)-               Just i  -> let (newname,_,_) = params !! i in (PRef elimFC [] (newname))-        removeParamPis oldParams params (PApp _ cns args) =-          PApp elimFC (removeParamPis oldParams params cns) $ replaceParamArgs args-            where replaceParamArgs :: [PArg] -> [PArg]-                  replaceParamArgs []          = []-                  replaceParamArgs (arg:args)  =-                    case extractName (getTm arg) of-                      []   -> arg:replaceParamArgs args-                      [n]  ->-                        case findIndex (== n) oldParams of-                          Nothing -> arg:replaceParamArgs args-                          Just i  -> let (newname,_,_) = params !! i in arg {getTm = PRef elimFC [] newname}:replaceParamArgs args-        removeParamPis oldParams params t = t--        paramNamesOf :: Int -> [Int] -> [PArg] -> [Name]-        paramNamesOf i paramPos []          = []-        paramNamesOf i paramPos (arg:args)  = (if i `elem` paramPos then extractName (getTm arg) else []) ++ paramNamesOf (i+1) paramPos args--        extractName :: PTerm -> [Name]-        extractName (PRef _ _ n) = [n]-        extractName _            = []--        splitArgPms :: PTerm -> ([PTerm], [PTerm])-        splitArgPms (PApp _ f args) = splitArgPms' args-          where splitArgPms' :: [PArg] -> ([PTerm], [PTerm])-                splitArgPms' cnstrs = (map (getTm . fst) pms, map (getTm . fst) idxs)-                    where (pms, idxs) = partition (\c -> snd c `elem` paramPos) (zip cnstrs [0..])-        splitArgPms _                 = ([],[])---        implicitIndexes :: (Docstring (Either Err PTerm), Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]-        implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do-          i <-  State.lift getIState-          implargs' <- case lookupCtxt cnm (idris_implicits i) of-            [] -> do fail $ "Error while showing implicits for " ++ show cnm-            [args] -> do return args-            _ -> do fail $ "Ambigous name for " ++ show cnm-          let implargs = mapMaybe convertImplPi implargs'-          let (_, cnsResTy) = splitPi ty-          case cnsResTy of-             PApp _ _ args ->-              let oldParams = paramNamesOf 0 paramPos args-              in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs-             _ -> return implargs--        extractConsTerm :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm-        extractConsTerm (doc, argDocs, cnm, _, ty, fc, fs) generalParameters = do-          let cons' = replaceParams paramPos generalParameters ty-          let (args, resTy) = splitPi cons'-          implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)-          consArgs <- namePis False args-          let recArgs = findRecArgs consArgs-          let recMotives = if ind then map applyRecMotive recArgs else []-          let (_, consIdxs) = splitArgPms resTy-          return $ piConstr (implidxs ++ consArgs ++ recMotives) (applyMotive consIdxs (applyCons cnm consArgs))-            where applyRecMotive :: (Name, Plicity, PTerm) -> (Name, Plicity, PTerm)-                  applyRecMotive (n,_,ty)  = (sUN $ "ih" ++ simpleName n, expl, applyMotive idxs (PRef elimFC [] n))-                      where (_, idxs) = splitArgPms ty--        findRecArgs :: [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)]-        findRecArgs []                            = []-        findRecArgs (ty@(_,_,PRef _ _ tn):rs)            | simpleName tn == simpleName n = ty:findRecArgs rs-        findRecArgs (ty@(_,_,PApp _ (PRef _ _ tn) _):rs) | simpleName tn == simpleName n = ty:findRecArgs rs-        findRecArgs (ty:rs)                                                              = findRecArgs rs--        applyCons :: Name -> [(Name, Plicity, PTerm)] -> PTerm-        applyCons tn targs = PApp elimFC (PRef elimFC [] tn) (map convertArg targs)--        convertArg :: (Name, Plicity, PTerm) -> PArg-        convertArg (n, _, _)      = pexp (PRef elimFC [] n)--        applyMotive :: [PTerm] -> PTerm -> PTerm-        applyMotive idxs t = PApp elimFC (PRef elimFC [] motiveName) (map pexp idxs ++ [pexp t])--        getPiName :: (Name, Plicity, PTerm) -> Name-        getPiName (name,_,_) = name--        convertImplPi :: PArg -> Maybe (Name, Plicity, PTerm)-        convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)-        convertImplPi _                             = Nothing--        generateEliminatorClauses :: (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause-        generateEliminatorClauses (doc, _, cnm, _, ty, fc, fs) cnsElim generalArgs generalParameters = do-          let cons' = replaceParams paramPos generalParameters ty-          let (args, resTy) = splitPi cons'-          i <- State.lift getIState-          implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)-          let (_, generalIdxs') = splitArgPms resTy-          let generalIdxs = map pexp generalIdxs'-          consArgs <- namePis False args-          let lhsPattern = PApp elimFC (PRef elimFC [] elimDeclName) (generalArgs ++ generalIdxs ++ [pexp $ applyCons cnm consArgs])-          let recArgs = findRecArgs consArgs-          let recElims = if ind then map applyRecElim recArgs else []-          let rhsExpr    = PApp elimFC (PRef elimFC [] cnsElim) (map convertArg implidxs ++ map convertArg consArgs ++ recElims)-          return $ PClause elimFC elimDeclName lhsPattern [] rhsExpr []-            where applyRecElim :: (Name, Plicity, PTerm) -> PArg-                  applyRecElim (constr@(recCnm,_,recTy)) = pexp $ PApp elimFC (PRef elimFC [] elimDeclName) (generalArgs ++ map pexp idxs ++ [pexp $ PRef elimFC [] recCnm])-                    where (_, idxs) = splitArgPms recTy
src/Idris/Elab/Quasiquote.hs view
@@ -23,7 +23,6 @@  extractTUnquotes :: Int -> PTactic -> Elab' aux (PTactic, [(Name, PTerm)]) extractTUnquotes n (Rewrite t) = extract1 n Rewrite t-extractTUnquotes n (Induction t) = extract1 n Induction t extractTUnquotes n (LetTac name t) = extract1 n (LetTac name) t extractTUnquotes n (LetTacTy name t1 t2) = extract2 n (LetTacTy name) t1 t2 extractTUnquotes n (Exact tm) = extract1 n Exact tm
src/Idris/Elab/Term.hs view
@@ -1749,24 +1749,6 @@                                         (cd env a)     cd env t = return t -case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()-case_ ind autoSolve ist fn tm = do-  attack-  tyn <- getNameFrom (sMN 0 "ity")-  claim tyn RType-  valn <- getNameFrom (sMN 0 "ival")-  claim valn (Var tyn)-  letn <- getNameFrom (sMN 0 "irule")-  letbind letn RigW (Var tyn) (Var valn)-  focus valn-  elab ist toplevel ERHS [] (sMN 0 "tac") tm-  env <- get_env-  let (Just binding) = lookupBinder letn env-  let val = binderVal binding-  if ind then induction (forget val)-         else casetac (forget val)-  when autoSolve solveAll- -- | Compute the appropriate name for a top-level metavariable metavarName :: [String] -> Name -> Name metavarName _          n@(NS _ _) = n@@ -2044,6 +2026,14 @@            first' <- eval first            alt' <- eval alt            try' (runTacTm first') (runTacTm alt') True+      | n == tacN "Prim__TryCatch"+      = do ~[_a, first, f] <- tacTmArgs 3 tac args+           first' <- eval first+           f' <- eval f+           tryCatch (runTacTm first') $ \err ->+             do (err', _) <- checkClosed (reflectErr err)+                f' <- eval (App Complete f err')+                runTacTm f'       | n == tacN "Prim__Fill"       = do ~[raw] <- tacTmArgs 1 tac args            raw' <- reifyRaw =<< eval raw@@ -2416,10 +2406,6 @@                    elab ist toplevel ERHS [] (sMN 0 "tac") tm                    rewrite (Var letn)                    when autoSolve solveAll-    runT (Induction tm) -- let bind tm, similar to the others-              = case_ True autoSolve ist fn tm-    runT (CaseTac tm)-              = case_ False autoSolve ist fn tm     runT (LetTac n tm)               = do attack                    tyn <- getNameFrom (sMN 0 "letty")
src/Idris/Elab/Utils.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE FlexibleContexts, PatternGuards #-}+{-# LANGUAGE CPP, FlexibleContexts, PatternGuards #-} module Idris.Elab.Utils where  import Idris.AbsSyntax@@ -20,6 +20,10 @@ import Idris.Output  import Util.Pretty++#if (MIN_VERSION_base(4,11,0))+import Prelude hiding ((<>))+#endif  import Control.Monad import Control.Monad.State
src/Idris/IBC.hs view
@@ -40,7 +40,7 @@ import System.FilePath  ibcVersion :: Word16-ibcVersion = 164+ibcVersion = 165  -- | When IBC is being loaded - we'll load different things (and omit -- different structures/definitions) depending on which phase we're in.
src/Idris/IdrisDoc.hs view
@@ -342,8 +342,6 @@ extractPTactic (Focus n)          = [n] extractPTactic (Refine n _)       = [n] extractPTactic (Rewrite p)        = extract p-extractPTactic (Induction p)      = extract p-extractPTactic (CaseTac p)        = extract p extractPTactic (Equiv p)          = extract p extractPTactic (MatchRefine n)    = [n] extractPTactic (LetTac n p)       = n : extract p
src/Idris/Imports.hs view
@@ -24,7 +24,13 @@ import System.FilePath  data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType-    deriving (Show, Eq)+    deriving (Show, Ord)++instance Eq IFileType where+    IDR x == IDR y = x == y+    LIDR x == LIDR y = x == y+    IBC x _ == IBC y _ = x == y+    _ == _ = False  newtype PkgName = PkgName String
src/Idris/Options.hs view
@@ -93,8 +93,8 @@          | UseConsoleWidth ConsoleWidth          | DumpHighlights          | DesugarNats-         | NoElimDeprecationWarnings      -- ^ Don't show deprecation warnings for %elim          | NoOldTacticDeprecationWarnings -- ^ Don't show deprecation warnings for old-style tactics+         | AllowCapitalizedPatternVariables -- ^ Allow pattern variables to be capitalized     deriving (Show, Eq, Generic)
src/Idris/Output.hs view
@@ -6,7 +6,7 @@ Maintainer  : The Idris Community. -} -{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP, FlexibleInstances #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}  module Idris.Output (clearHighlights, emitWarning, formatMessage, idemodePutSExp,@@ -30,7 +30,11 @@ import Util.ScreenSize (getScreenWidth) import Util.System (isATTY) +#if (MIN_VERSION_base(4,11,0))+import Prelude hiding ((<$>), (<>))+#else import Prelude hiding ((<$>))+#endif  import Control.Arrow (first) import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT)
src/Idris/Package/Parser.hs view
@@ -10,7 +10,9 @@  import Idris.CmdOptions import Idris.Imports+import Idris.Options (Opt) import Idris.Package.Common+import Idris.Parser (moduleName) import Idris.Parser.Helpers (Parser, Parsing, eol, iName, identifier, isEol,                              lchar, packageName, parseErrorDoc, reserved,                              runparser, someSpace, stringLiteral)@@ -18,6 +20,7 @@ import Control.Applicative import Control.Monad.State.Strict import Data.List (union)+import qualified Options.Applicative as Opts import System.Directory (doesFileExist) import System.Exit import System.FilePath (isValid, takeExtension, takeFileName)@@ -108,16 +111,24 @@ commaSep   :: Parsing m => m a -> m [a] commaSep p = P.sepBy1 p (lchar ',') +pOptions :: PParser [Opt]+pOptions = do+  str <- stringLiteral+  case execArgParserPure (words str) of+    Opts.Success a -> return a+    Opts.Failure e -> fail $ fst $ Opts.renderFailure e ""+    _              -> fail "Unexpected error"+ pClause :: PParser () pClause = clause "executable" filename (\st v -> st { execout = Just v })       <|> clause "main" (iName []) (\st v -> st { idris_main = Just v })       <|> clause "sourcedir" identifier (\st v -> st { sourcedir = v })-      <|> clause "opts" (pureArgParser . words <$> stringLiteral) (\st v -> st { idris_opts = v ++ idris_opts st })+      <|> clause "opts" pOptions (\st v -> st { idris_opts = v ++ idris_opts st })       <|> clause "pkgs" (commaSep (pPkgName <* someSpace)) (\st ps ->              let pkgs = pureArgParser $ concatMap (\x -> ["-p", show x]) ps              in st { pkgdeps    = ps `union` pkgdeps st                    , idris_opts = pkgs ++ idris_opts st })-      <|> clause "modules" (commaSep (iName [])) (\st v -> st { modules = modules st ++ v })+      <|> clause "modules" (commaSep moduleName) (\st v -> st { modules = modules st ++ v })       <|> clause "libs" (commaSep identifier) (\st v -> st { libdeps = libdeps st ++ v })       <|> clause "objs" (commaSep identifier) (\st v -> st { objs = objs st ++ v })       <|> clause "makefile" (iName []) (\st v -> st { makefile = Just (show v) })
src/Idris/Parser.hs view
@@ -12,7 +12,7 @@ -- FIXME: {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-# OPTIONS_GHC -fwarn-unused-imports #-} -module Idris.Parser(IdrisParser(..), ImportInfo(..), addReplSyntax, clearParserWarnings,+module Idris.Parser(IdrisParser(..), ImportInfo(..), moduleName, addReplSyntax, clearParserWarnings,                     decl, fixColour, loadFromIFile, loadModule, name, opChars, parseElabShellStep, parseConst, parseExpr, parseImports, parseTactic,                     runparser, ParseError, parseErrorDoc) where @@ -81,23 +81,31 @@       ModuleHeader ::= DocComment_t? 'module' Identifier_t ';'?; @ -}+++moduleName :: Parsing m => m Name+moduleName = mkName [] . map T.pack <$> moduleNamePieces where++  mkName :: [T.Text] -> [T.Text] -> Name+  mkName ts [x]    = if null ts then UN x else NS (UN x) ts+  mkName ts (x:xs) = mkName (x : ts) xs++moduleNamePieces :: Parsing m => m [String]+moduleNamePieces = Spl.splitOn "." <$> identifier+ moduleHeader :: IdrisParser (Maybe (Docstring ()), [String], [(FC, OutputAnnotation)]) moduleHeader =     P.try (do docs <- optional docComment                              noArgs docs                              keyword "module"-                             (i, ifc) <- withExtent identifier+                             (modName, ifc) <- withExtent moduleNamePieces                              P.option ';' (lchar ';')-                             let modName = moduleName i                              return (fmap fst docs,                                      modName,                                      [(ifc, AnnNamespace (map T.pack modName) Nothing)]))                <|> P.try (do lchar '%'; reserved "unqualified"                              return (Nothing, [], []))-               <|> return (Nothing, moduleName "Main", [])-  where moduleName x = case span (/='.') x of-                           (x, "")    -> [x]-                           (x, '.':y) -> x : moduleName y-        noArgs (Just (_, args)) | not (null args) = fail "Modules do not take arguments"+               <|> return (Nothing, ["Main"], [])+  where noArgs (Just (_, args)) | not (null args) = fail "Modules do not take arguments"         noArgs _ = return ()  data ImportInfo = ImportInfo { import_reexport :: Bool@@ -117,16 +125,15 @@ import_ :: IdrisParser ImportInfo import_ = do fc <- extent $ keyword "import"              reexport <- P.option False (True <$ keyword "public")-             (id, idfc) <- withExtent identifier+             (ns, idfc) <- withExtent moduleNamePieces              newName <- optional (do keyword "as"                                      withExtent identifier)              P.option ';' (lchar ';')-             return $ ImportInfo reexport (toPath id)-                        (fmap (\(n, fc) -> (toPath n, fc)) newName)-                        (map T.pack $ ns id) fc idfc+             return $ ImportInfo reexport (toPath ns)+                        (fmap (\(n, fc) -> (toPath (Spl.splitOn "." n), fc)) newName)+                        (map T.pack ns) fc idfc           <?> "import statement"-  where ns = Spl.splitOn "."-        toPath = foldl1' (</>) . ns+  where toPath = foldl1' (</>)  {-| Parses program source
src/Idris/Parser/Data.hs view
@@ -134,29 +134,15 @@ recordI = do keyword "record"; return []           <|> do keyword "corecord"; return [Codata] -{- | Parses if a data should not have a default eliminator-DefaultEliminator ::= 'noelim'?- -} dataOpts :: DataOpts -> IdrisParser DataOpts-dataOpts opts-    = do let kw = "%elim"-         fc <- extent $ reserved kw-         warnElim fc kw-         dataOpts (DefaultEliminator : DefaultCaseFun : opts)-  <|> do let kw = "%case"-         fc <- extent $ reserved kw-         warnElim fc kw-         dataOpts (DefaultCaseFun : opts)-  <|> do reserved "%error_reverse"; dataOpts (DataErrRev : opts)+dataOpts opts =+      do reserved "%error_reverse"; dataOpts (DataErrRev : opts)   <|> return opts   <?> "data options"-  where warnElim fc kw =-          parserWarning fc (Just NoElimDeprecationWarnings)-                           (Msg ("The '" ++ kw ++ "' directive is deprecated."))  {- | Parses a data type declaration-Data ::= DocComment? Accessibility? DataI DefaultEliminator FnName TypeSig ExplicitTypeDataRest?-       | DocComment? Accessibility? DataI DefaultEliminator FnName Name*   DataRest?+Data ::= DocComment? Accessibility? DataI FnName TypeSig ExplicitTypeDataRest?+       | DocComment? Accessibility? DataI FnName Name*   DataRest?        ; Constructor' ::= Constructor KeepTerminator; ExplicitTypeDataRest ::= 'where' OpenBlock Constructor'* CloseBlock;@@ -175,10 +161,10 @@                     (doc, argDocs) <- P.option noDocs docComment                     pushIndent                     acc <- accessibility-                    elim <- dataOpts []+                    errRev <- dataOpts []                     co <- dataI                     ist <- get-                    let dataOpts = combineDataOpts (elim ++ co)+                    let dataOpts = errRev ++ co                         doc' = annotCode (tryFullExpr syn ist) doc                         argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)                                    | (n, d) <- argDocs ]@@ -201,7 +187,7 @@                     let tyn = expandNS syn tyn_in                     d <- P.option (PData doc argDocs syn nfc dataOpts (PLaterdecl tyn nfc ty)) (do                       P.try (lchar '=') <|> do keyword "where"-                                               let kw = (if DefaultEliminator `elem` dataOpts then "%elim" else "") ++ (if Codata `elem` dataOpts then "co" else "") ++ "data "+                                               let kw = (if Codata `elem` dataOpts then "co" else "") ++ "data "                                                let n  = show tyn_in ++ " "                                                let s  = kw ++ n                                                let as = unwords (map show args) ++ " "@@ -227,10 +213,6 @@     mkPApp fc t xs = PApp fc t (map pexp xs)     bindArgs :: [PTerm] -> PTerm -> PTerm     bindArgs xs t = foldr (PPi expl (sMN 0 "_t") NoFC) t xs-    combineDataOpts :: DataOpts -> DataOpts-    combineDataOpts opts = if Codata `elem` opts-                              then delete DefaultEliminator opts-                              else opts   {- | Parses a type constructor declaration
src/Idris/Parser/Expr.hs view
@@ -391,7 +391,6 @@         <|> do lchar '%'; fc <- extent $ reserved "instance"                parserWarning fc Nothing $ Msg "The use of %instance is deprecated, use %implementation instead."                return (PResolveTC fc)-        <|> do reserved "elim_for"; (t, fc) <- withExtent $ fnName; return (PRef fc [] (SN $ ElimN t))         <|> proofExpr syn         <|> tacticsExpr syn         <|> P.try (do fc <- extent (reserved "Type*"); return $ PUniverse fc AllTypes)@@ -939,6 +938,11 @@                      return (PRewrite fc using prf sc giving)                   <?> "term rewrite expression" +-- | Parse rig count for linear types+rigCount :: Parsing m => m RigCount+rigCount = P.option RigW $ do lchar '1'; return Rig1+                       <|> do lchar '0'; return Rig0+ {- |Parses a let binding @ Let ::=@@ -957,18 +961,19 @@                      return (buildLets ls sc))            <?> "let binding"   where buildLets [] sc = sc-        buildLets ((fc, PRef nfc _ n, ty, v, []) : ls) sc-          = PLet fc RigW n nfc ty v (buildLets ls sc)-        buildLets ((fc, pat, ty, v, alts) : ls) sc+        buildLets ((fc, rc, PRef nfc _ n, ty, v, []) : ls) sc+          = PLet fc rc n nfc ty v (buildLets ls sc)+        buildLets ((fc, _, pat, ty, v, alts) : ls) sc           = PCase fc v ((pat, buildLets ls sc) : alts) -let_binding syn = do (pat, fc) <- withExtent $ expr' (syn { inPattern = True })+let_binding syn = do rc <- rigCount+                     (pat, fc) <- withExtent $ expr' (syn { inPattern = True })                      ty <- P.option Placeholder (do lchar ':'; expr' syn)                      lchar '='                      v <- expr (syn { withAppAllowed = isVar pat })                      ts <- P.option [] (do lchar '|'                                            P.sepBy1 (do_alt syn) (lchar '|'))-                     return (fc,pat,ty,v,ts)+                     return (fc,rc,pat,ty,v,ts)    where isVar (PRef _ _ _) = True          isVar _ = False @@ -1169,7 +1174,7 @@ @ -} typeDeclList :: SyntaxInfo -> IdrisParser [(RigCount, Name, FC, PTerm)]-typeDeclList syn = P.try (P.sepBy1 (do rig <- P.option RigW rigCount+typeDeclList syn = P.try (P.sepBy1 (do rig <- rigCount                                        (x, xfc) <- withExtent fnName                                        lchar ':'                                        t <- typeExpr (disallowImp syn)@@ -1180,9 +1185,6 @@                           t <- typeExpr (disallowImp syn)                           return (map (\(x, xfc) -> (RigW, x, xfc, t)) ns)                    <?> "type declaration list"-  where-    rigCount = do lchar '1'; return Rig1-           <|> do lchar '0'; return Rig0  {- | Parses a type declaration list with optional parameters @@@ -1488,8 +1490,6 @@        do n <- spaced fnName           return $ MatchRefine n)   , expressionTactic ["rewrite"] Rewrite-  , expressionTactic ["case"] CaseTac-  , expressionTactic ["induction"] Induction   , expressionTactic ["equiv"] Equiv   , (["let"], Nothing, \syn -> -- FIXME syntax for let        do n <- (indentGt *> name)
src/Idris/REPL.hs view
@@ -5,7 +5,7 @@ Maintainer  : The Idris Community. -} -{-# LANGUAGE FlexibleContexts, PatternGuards #-}+{-# LANGUAGE CPP, FlexibleContexts, PatternGuards #-} -- FIXME: {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-# OPTIONS_GHC -fwarn-unused-imports #-} @@ -82,7 +82,11 @@ import IRTS.CodegenCommon import IRTS.Compiler import Network+#if (MIN_VERSION_base(4,11,0))+import Prelude hiding (id, (.), (<$>), (<>))+#else import Prelude hiding (id, (.), (<$>))+#endif import System.Console.Haskeline as H import System.Directory import System.Environment@@ -1264,8 +1268,17 @@                            ir <- compile t tmpn (Just m)                            runIO $ generate t (fst (head (idris_imported ist))) ir                            case idris_outputmode ist of-                             RawOutput h -> do runIO $ rawSystem progName []-                                               return ()+                             RawOutput h ->+                               do res <- runIO $ rawSystem progName []+                                  case res of+                                    ExitSuccess -> return ()+                                    ExitFailure err ->+                                      ifail $ "Compiled program " +++                                              if err < 0+                                              then "was killed by signal " +++                                                   show (0 - err)+                                              else "terminated with exit code " +++                                                   show err                              IdeMode n h -> runIO . hPutStrLn h $                                              IdeMode.convSExp "run-program" tmpn n)                        (\e -> getIState >>= iRenderError . flip pprintErr e)
src/Idris/Reflection.hs view
@@ -115,8 +115,6 @@ reifyApp ist t [Constant (Str n), x]              | t == reflm "GoalType" = liftM (GoalType n) (reify ist x) reifyApp _ t [n] | t == reflm "Intro" = liftM (Intro . (:[])) (reifyTTName n)-reifyApp ist t [t'] | t == reflm "Induction" = liftM (Induction . delab ist) (reifyTT t')-reifyApp ist t [t'] | t == reflm "Case" = liftM (CaseTac . delab ist) (reifyTT t') reifyApp ist t [t']              | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t') reifyApp ist t [t']@@ -279,9 +277,6 @@                 | t == reflm "CaseN" =                   CaseN <$> (FC' <$> reifyFC fc) <*> reifyTTName n         reifySN t [n]-                | t == reflm "ElimN" =-                  ElimN <$> reifyTTName n-        reifySN t [n]                 | t == reflm "ImplementationCtorN" =                   ImplementationCtorN <$> reifyTTName n         reifySN t [n1, n2]@@ -722,8 +717,6 @@   reflCall "MethodN" [reflectName n] reflectSpecialName (CaseN fc n) =   reflCall "CaseN" [reflectFC (unwrapFC fc), reflectName n]-reflectSpecialName (ElimN n) =-  reflCall "ElimN" [reflectName n] reflectSpecialName (ImplementationCtorN n) =   reflCall "ImplementationCtorN" [reflectName n] reflectSpecialName (MetaN parent meta) =@@ -928,9 +921,6 @@   raw_apply (Var $ reflErrName "CantResolveAlts")             [rawList (Var $ reflm "TTName") (map reflectName ss)] reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]-reflectErr (NoEliminator str t)-  = raw_apply (Var $ reflErrName "NoEliminator") [RConstant (Str str),-                                                  reflect t] reflectErr (UniverseError fc ue old new tys) =   -- NB: loses information, but OK because this is not likely to be rewritten   Var $ reflErrName "UniverseError"
src/Idris/TypeSearch.hs view
@@ -5,7 +5,7 @@ License     : BSD3 Maintainer  : The Idris Community. -}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-}  module Idris.TypeSearch (     searchByType@@ -32,8 +32,12 @@  import Util.Pretty (Doc, annotate, char, text, vsep, (<>)) +#if (MIN_VERSION_base(4,11,0))+import Prelude hiding (Semigroup(..), pred)+import qualified Prelude as S (Semigroup(..))+#else import Prelude hiding (pred)-+#endif import Control.Applicative (Applicative(..), (<$>), (<*>), (<|>)) import Control.Arrow (first, second, (&&&), (***)) import Control.Monad (guard, when)@@ -237,6 +241,17 @@ instance Ord Score where   compare = comparing defaultScoreFunction ++#if (MIN_VERSION_base(4,11,0))+instance S.Semigroup a => S.Semigroup (Sided a) where+    (Sided l1 r1) <> (Sided l2 r2) = Sided (l1 S.<> l2) (r1 S.<> r2)++instance S.Semigroup AsymMods where+    (<>) = mappend++instance S.Semigroup Score where+    (<>) = mappend+#endif  instance Monoid a => Monoid (Sided a) where   mempty = Sided mempty mempty
src/Util/System.hs view
@@ -10,6 +10,7 @@                   , withTempdir                   , rmFile                   , catchIO+                  , isDarwin                   , isWindows                   , writeSource                   , writeSourceText@@ -49,6 +50,9 @@  isWindows :: Bool isWindows = os `elem` ["win32", "mingw32", "cygwin32"]++isDarwin :: Bool+isDarwin = os == "darwin"  -- | Create a temp file with the extensiom ext (in the format ".xxx") tempfile :: String -> IO (FilePath, Handle)
stack-shell.nix view
@@ -2,20 +2,21 @@ with (import <nixpkgs> {});  let-  native_libs = [+  libs = [     libffi     zlib     ncurses     gmp-    pkgconfig-  ] ++ lib.optionals stdenv.isDarwin (with darwin.apple_sdk.frameworks; [+  ];+  native_libs = lib.optionals stdenv.isDarwin (with darwin.apple_sdk.frameworks; [     Cocoa     CoreServices   ]);  in haskell.lib.buildStackProject {   inherit ghc;-  buildInputs = native_libs;+  nativeBuildInputs = native_libs;+  buildInputs = libs;   name = "idrisBuildEnv";-  src = ./.;+  src = if lib.inNixShell then null else ./.; }
stack.yaml view
@@ -1,5 +1,5 @@ #recheck extra-deps next on resolver or cabal file change-resolver: lts-10.0+resolver: lts-11.3  packages:   - location: .
test/TestData.hs view
@@ -76,10 +76,12 @@       ( 22, NODE_CG ),       ( 23, ANY     ),       ( 24, ANY     ),-      ( 25, ANY     )]),+      ( 25, ANY     ),+      ( 26, ANY     )]),   ("bignum",          "Bignum",     [ (  1, ANY  ),-      (  2, ANY  )]),+      (  2, ANY  ),+      (  3, C_CG )]),   ("bounded",         "Bounded",     [ (  1, ANY  )]),   ("buffer",          "Buffer",@@ -183,7 +185,8 @@       (  8, ANY  )]),   ("interpret",      "Interpret",     [ (  1, ANY  ),-      (  2, ANY  )]),+      (  2, ANY  ),+      (  3, C_CG )]),   ("io",              "IO monad",     [ (  1, C_CG ),       (  2, ANY  ),@@ -205,7 +208,8 @@       (  5, ANY  ),       (  6, ANY  ),       (  7, ANY  ),-      (  8, ANY  )]),+      (  8, ANY  ),+      ( 10, ANY  )]),   ("prelude",         "Prelude",     [ (  1, ANY  )]),   ("primitives",      "Primitive types",@@ -319,7 +323,9 @@       ( 20, ANY  ),       ( 21, ANY  ),       ( 22, ANY  ),-      ( 23, ANY  )]),+      ( 23, ANY  ),+      ( 25, ANY  ),+      ( 26, ANY  )]),   ("tutorial",        "Tutorial examples",     [ (  1, ANY  ),       (  2, ANY  ),
test/base001/Makefile view
@@ -2,10 +2,10 @@ all: exit1 sys.o  exit1:-	@gcc -Wall -o exit1 exit1.c+	@$(CC) -Wall -o exit1 exit1.c  sys.o:-	@gcc -Wall -c sys.c+	@$(CC) -Wall -c sys.c  clean: 	-@rm exit1 sys.o
+ test/basic026/basic026.idr view
@@ -0,0 +1,12 @@+module Main++import Data.Vect++||| Verifies that `Fin.restrict` generates a valid `Fin`+||| by using it to index a `Vect`.+main : IO ()+main = do+    let xs = the (Vect 2 Char) ['a','b']+    printLn $ Vect.index (restrict 1 0) xs == 'a'+    printLn $ Vect.index (restrict 1 1) xs == 'b'+
+ test/basic026/expected view
@@ -0,0 +1,2 @@+True+True
+ test/basic026/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ basic026.idr -o basic026+./basic026+rm -f basic026 *.ibc
+ test/bignum003/bignum003.idr view
@@ -0,0 +1,23 @@+allZeroesFromTo : Int -> Int -> String -> Bool+allZeroesFromTo n m str+  = if n < m+    then if strIndex str n == '0'+         then allZeroesFromTo (n+1) m str+         else False+    else True++isNthPowerOfTen : Int -> String -> Bool+isNthPowerOfTen n str+  = let m = cast (length str) in+    if m == n+1+    then strHead str == '1' && allZeroesFromTo 1 m str+    else False++main : IO ()+main = do+  let x = power 10 12468+  let sx = show x+  printLn (isNthPowerOfTen 12468 sx)+  let y = power 10 12470+  let sy = show y+  printLn (isNthPowerOfTen 12470 sy)
+ test/bignum003/expected view
@@ -0,0 +1,2 @@+True+True
+ test/bignum003/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ bignum003.idr -o bignum003+./bignum003+rm -f bignum003 *.ibc
test/buffer002/buffer002.idr view
@@ -3,15 +3,22 @@ main : IO () main = do Just buf <- newBuffer 40           printLn (size buf)-          setInt buf 5 1234567890-          setInt buf 36 1234567890+          setInt buf 5 (-1024567890)+          setInt buf 36 1034567890           setString buf 20 "Hello world!"+           printLn !(bufferData buf)+          +          setDouble buf 10 123.456            val <- getInt buf 5           printLn val           val <- getInt buf 6           printLn val++          val <- getDouble buf 10+          printLn val+           val <- getInt buf 36           printLn val           val <- getInt buf 37 -- out of bounds, expect 0
test/buffer002/expected view
@@ -1,8 +1,9 @@ 40-[00, 00, 00, 00, 00, D2, 02, 96, 49, 00, 00, 00, 00, 00, 00, 00, 00, 00, 00, 00, 48, 65, 6C, 6C, 6F, 20, 77, 6F, 72, 6C, 64, 21, 00, 00, 00, 00, D2, 02, 96, 49]-1234567890-4822530-1234567890+[00, 00, 00, 00, 00, AE, 55, EE, C2, 00, 00, 00, 00, 00, 00, 00, 00, 00, 00, 00, 48, 65, 6C, 6C, 6F, 20, 77, 6F, 72, 6C, 64, 21, 00, 00, 00, 00, D2, 40, AA, 3D]+-1024567890+12774997+123.456+1034567890 0 Hello worl Hello world!
test/disambig002/disambig002.idr view
@@ -8,7 +8,7 @@ Dec0 = Dec  Dec1 : {A : Type} -> (P : A -> Type) -> Type-Dec1 {A} P = (a : A) -> Dec0 (P a)+Dec1 {A=aTy} p = (a : aTy) -> Dec0 (p a)  Unique : Type -> Type Unique t = (p : t) -> (q : t) -> p = q@@ -41,7 +41,7 @@    ||| Notion of finiteness for types   Finite : Type -> Type-  Finite A = Exists (\ n => Iso A (Fin n))+  Finite a = Exists (\ n => Iso a (Fin n))    ||| Cardinality of finite types   card : {A : Type} -> (fA : Finite A) -> Nat
test/dsl002/Resimp.idr view
@@ -91,7 +91,7 @@                Args gam as -> Args gam (interpTy a :: as)    funTy : List Type -> Ty -> Ty-  funTy list.Nil t = t+  funTy List.Nil t = t   funTy (a :: as) t = a :-> funTy as t    data Res : Vect n Ty -> Vect n Ty -> Ty -> Type where
test/effects001/expected view
@@ -1,4 +1,4 @@ ["HELLO!!!\n", "WORLD!!!\n", ""] 3-15-Answer: 99+7+Answer: 91
test/effects003/expected view
@@ -4,44 +4,28 @@     |        ~~~~~ This style of tactic proof is deprecated. See %runElab for the replacement. -------------+----  6 guesses left-Enter guess: No, sorry---------------5 guesses left Enter guess: Good guess!-----ee--------5 guesses left-Enter guess: Good guess!-----ee---i----5 guesses left-Enter guess: Good guess!--o--ee---i----5 guesses left-Enter guess: Good guess!--offee---i--+-a-a -5 guesses left-Enter guess: Good guess!-coffee-c-i--+6 guesses left+Enter guess: No, sorry+-a-a  5 guesses left-Enter guess: Good guess!-coffeesc-i--+Enter guess: No, sorry+-a-a -5 guesses left-Enter guess: Good guess!-coffeesc-ip-+4 guesses left+Enter guess: No, sorry+-a-a -5 guesses left+3 guesses left Enter guess: Good guess!-coffeescrip-+ja-a -5 guesses left+3 guesses left Enter guess: Good guess!-You won! Successfully guessed coffeescript+You won! Successfully guessed java
test/effects003/input view
@@ -2,9 +2,5 @@ e i o-f-c-s-p-r-t+j+v
+ test/interpret003/expected view
@@ -0,0 +1,1 @@+Compiled program terminated with exit code 1
+ test/interpret003/input view
@@ -0,0 +1,1 @@+:exec
+ test/interpret003/interpret003.idr view
@@ -0,0 +1,4 @@+import System++main : IO ()+main = exitFailure
+ test/interpret003/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ --quiet --port none --nocolour interpret003.idr < input+rm -f *.ibc
+ test/interpret003/test view

binary file changed (absent → 128344 bytes)

+ test/meta003/Catch.idr view
@@ -0,0 +1,17 @@+import Language.Reflection.Elab++%language ElabReflection++f : Err -> Elab ()+f (Msg _) = fill `("message error")+f (CantUnify _ _ _ _ _ _) = fill `("unification error")+f _ = fill `("other")++s1 : String+s1 = %runElab (do tryCatch (fail []) f ; solve)++s2 : String+s2 = %runElab (do tryCatch (fill `(True)) f ; solve)++main : IO ()+main = do putStrLn s1 ; putStrLn s2
test/meta003/expected view
@@ -8,3 +8,5 @@ and         String +message error+unification error
test/meta003/run view
@@ -1,3 +1,5 @@ #!/usr/bin/env bash ${IDRIS:-idris} $@ --nocolour --check --consolewidth 70 BadDef.idr-rm -f *.ibc+${IDRIS:-idris} $@ --nocolour --consolewidth 70 -o meta003 Catch.idr+./meta003+rm -f meta003 *.ibc
+ test/pkg009/datatype.ipkg view
@@ -0,0 +1,6 @@+package datatypes++sourcedir = src++modules = Data.Type+
+ test/pkg009/expected view
@@ -0,0 +1,9 @@+Entering directory `./src'+Type checking ./Data/Type.idr+Leaving directory `./src'+Entering directory `./src'+Removed: Data/Type.ibc+Removed: 00datatypes-idx.ibc+Leaving directory `./src'+The following packages were specified but cannot be found:+- datatype.ipkg
+ test/pkg009/run view
@@ -0,0 +1,7 @@+#!/usr/bin/env bash++${IDRIS:-idris} $@ --build datatype.ipkg++${IDRIS:-idris} $@ --clean datatype.ipkg++${IDRIS:-idris} $@ -p datatype.ipkg
+ test/pkg009/src/Data/Type.idr view
@@ -0,0 +1,3 @@+module Data.Type++data D : Type where
+ test/pkg010/expected view
@@ -0,0 +1,28 @@+Uncaught error: user error (wrongopts.ipkg:4:1:+  |+4 | <empty line>+  | ^+Invalid option `-total'++Usage:  ([--nobanner] | [-q|--quiet] | [--ide-mode] | [--ide-mode-socket] |+        [--client ARG] | [--log LEVEL] | [--logging-categories CATS] |+        [--nobasepkgs] | [--noprelude] | [--nobuiltins] | [--check] |+        [-o|--output FILE] | [--interface] | [--typeintype] | [--total] |+        [--partial] | [--warnpartial] | [--warnreach] | [--warnipkg] |+        [--nocoverage] | [--errorcontext] | [--info] | [--listlogcats] |+        [--link] | [--listlibs] | [--libdir] | [--docdir] | [--include] | [--V2]+        | [--V1] | [-V|--V0|--verbose] | [--ibcsubdir FILE] |+        [-i|--idrispath ARG] | [--sourcepath ARG] | [--warn] |+        [-p|--package ARG] | [--port PORT] | [--build IPKG] | [--install IPKG] |+        [--repl IPKG] | [--clean IPKG] | [--mkdoc IPKG] | [--installdoc IPKG] |+        [--checkpkg IPKG] | [--testpkg IPKG] | [--indent-with INDENT] |+        [--indent-clause INDENT] | [--bytecode ARG] | [-S|--codegenonly] |+        [-c|--compileonly] | [--dumpdefuns ARG] | [--dumpcases ARG] |+        [--codegen TARGET] | [--portable-codegen TARGET] | [--cg-opt ARG] |+        [-e|--eval EXPR] | [--execute] | [--exec EXPR] | [-X|--extension EXT] |+        [--O3] | [--O2] | [--O1] | [--O0] | [--partial-eval] |+        [--no-partial-eval] | [-O|--level ARG] | [--target TRIPLE] | [--cpu CPU]+        | [--color|--colour] | [--nocolor|--nocolour] | [--consolewidth WIDTH] |+        [--highlight] | [--no-tactic-deprecation-warnings] |+        [--allow-capitalized-pattern-variables]) [FILES] [-v|--version]+)
+ test/pkg010/run view
@@ -0,0 +1,2 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ --build wrongopts.ipkg
+ test/pkg010/wrongopts.ipkg view
@@ -0,0 +1,3 @@+package wrongopts++opts = "-total"
test/proof002/Reflect.idr view
@@ -6,7 +6,7 @@ %default total %language FirstClassReflection -using (xs : List a, ys : List a, G : List (List a))+using (xs : List a, ys : List a, gam : List (List a))    data Elem : a -> List a -> Type where        Stop : Elem x (x :: xs)@@ -16,20 +16,20 @@ -- and over a set of list variables.    data Expr : List (List a) -> List a -> Type where-       App  : Expr G xs -> Expr G ys -> Expr G (xs ++ ys)-       Var  : Elem xs G -> Expr G xs-       ENil : Expr G []+       App  : Expr gam xs -> Expr gam ys -> Expr gam (xs ++ ys)+       Var  : Elem xs gam -> Expr gam xs+       ENil : Expr gam []  -- Reflection of list equalities, indexed over the concrete equality.    data ListEq : List (List a) -> Type -> Type where-       EqP : Expr G xs -> Expr G ys -> ListEq G (xs = ys)+       EqP : Expr gam xs -> Expr gam ys -> ListEq gam (xs = ys)  -- Fully right associative list expressions    data RExpr : List (List a) -> List a -> Type where-       RApp : RExpr G xs -> Elem ys G -> RExpr G (xs ++ ys)-       RNil : RExpr G []+       RApp : RExpr gam xs -> Elem ys gam -> RExpr gam (xs ++ ys)+       RNil : RExpr gam []  -- Convert an expression to a right associative expression, and return -- a proof that the rewriting has an equal interpretation to the original@@ -38,7 +38,7 @@ -- The idea is that we use this proof to build a proof of equality of -- list appends -  expr_r : Expr G xs -> (xs' ** (RExpr G xs', xs = xs'))+  expr_r : Expr gam xs -> (xs' ** (RExpr gam xs', xs = xs'))   expr_r ENil = (_ ** (RNil, Refl))   expr_r (Var i) = (_ ** (RApp RNil i, Refl))   expr_r (App ex ey) = let (xl ** (xr, xprf)) = expr_r ex in@@ -46,29 +46,29 @@                                appRExpr _ _ xr yr xprf yprf     where       appRExpr : (xs', ys' : List a) ->-                 {G : List (List a)} -> {xs, ys : List a} ->-                 RExpr G xs -> RExpr G ys -> (xs' = xs) -> (ys' = ys) ->-                 (ws' ** (RExpr G ws', xs' ++ ys' = ws'))+                 {gam : List (List a)} -> {xs, ys : List a} ->+                 RExpr gam xs -> RExpr gam ys -> (xs' = xs) -> (ys' = ys) ->+                 (ws' ** (RExpr gam ws', xs' ++ ys' = ws'))       appRExpr x' y' rxs (RApp e i) xprf yprf          = let (xs ** (rec, prf)) = appRExpr _ _ rxs e Refl Refl in                (_ ** (RApp rec i, ?appRExpr1))       appRExpr x' y' rxs RNil xprf yprf = (_ ** (rxs, ?appRExpr2)) -  r_expr : RExpr G xs -> Expr G xs+  r_expr : RExpr gam xs -> Expr gam xs   r_expr RNil = ENil   r_expr (RApp xs i) = App (r_expr xs) (Var i)  -- Convert an expression to some other equivalent expression (which -- just happens to be normalised to right associative form) -  reduce : Expr G xs -> (xs' ** (Expr G xs', xs = xs'))+  reduce : Expr gam xs -> (xs' ** (Expr gam xs', xs = xs'))   reduce e = let (x' ** (e', prf)) = expr_r e in                  (x' ** (r_expr e', prf))  -- Build a proof that two expressions are equal. If they are, we'll know -- that the indices are equal. -  eqExpr : (e : Expr G xs) -> (e' : Expr G ys) ->+  eqExpr : (e : Expr gam xs) -> (e' : Expr gam ys) ->            Maybe (e = e')   eqExpr (App x y) (App x' y') with (eqExpr x x', eqExpr y y')     eqExpr (App x y) (App x y)   | (Just Refl, Just Refl) = Just Refl@@ -83,20 +83,20 @@ -- they are equal    buildProof : {xs : List a} -> {ys : List a} ->-               Expr G ln -> Expr G rn ->+               Expr gam ln -> Expr gam rn ->                (xs = ln) -> (ys = rn) -> Maybe (xs = ys)   buildProof e e' lp rp with (eqExpr e e')     buildProof e e lp rp  | Just Refl = ?bp1     buildProof e e' lp rp | Nothing = Nothing -  testEq : Expr G xs -> Expr G ys -> Maybe (xs = ys)+  testEq : Expr gam xs -> Expr gam ys -> Maybe (xs = ys)   testEq l r = let (ln ** (l', lPrf)) = reduce l in                let (rn ** (r', rPrf)) = reduce r in                    buildProof l' r' lPrf rPrf  -- Given a reflected equality, try to produce a proof that holds -  prove : ListEq G t -> Maybe t+  prove : ListEq gam t -> Maybe t   prove (EqP xs ys) = testEq xs ys    getJust : (x : Maybe a) -> IsJust x -> a@@ -114,15 +114,15 @@     isElem x (x :: ys) | Just Refl = [| Stop |]     isElem x (y :: ys) | Nothing = [| Pop (isElem x ys) |] -  weakenElem : (G' : List a) -> Elem x xs -> Elem x (G' ++ xs)+  weakenElem : (gam' : List a) -> Elem x xs -> Elem x (gam' ++ xs)   weakenElem [] p = p-  weakenElem (g :: G) p = Pop (weakenElem G p)+  weakenElem (g :: gam) p = Pop (weakenElem gam p) -  weaken : (G' : List (List a)) ->-           Expr G xs -> Expr (G' ++ G) xs-  weaken G' (App l r) = App (weaken G' l) (weaken G' r)-  weaken G' (Var x) = Var (weakenElem G' x)-  weaken G' ENil = ENil+  weaken : (gam' : List (List a)) ->+           Expr gam xs -> Expr (gam' ++ gam) xs+  weaken gam' (App l r) = App (weaken gam' l) (weaken gam' r)+  weaken gam' (Var x) = Var (weakenElem gam' x)+  weaken gam' ENil = ENil   -- Now, some reflection magic.@@ -133,21 +133,21 @@ -- reduction will work the right way.  %reflection-reflectList : (G : List (List a)) ->-          (xs : List a) -> (G' ** Expr (G' ++ G) xs)-reflectList G [] = ([] ** ENil)+reflectList : (gam : List (List a)) ->+          (xs : List a) -> (gam' ** Expr (gam' ++ gam) xs)+reflectList gam [] = ([] ** ENil) -reflectList G (x :: xs) with (reflectList G xs)-     | (G' ** xs') with (isElem (List.(::) x []) (G' ++ G))-        | Just p = (G' ** App (Var p) xs')-        | Nothing = ([x] :: G' ** App (Var Stop) (weaken [[x]] xs'))+reflectList gam (x :: xs) with (reflectList gam xs)+     | (gam' ** xs') with (isElem (List.(::) x []) (gam' ++ gam))+        | Just p = (gam' ** App (Var p) xs')+        | Nothing = ([x] :: gam' ** App (Var Stop) (weaken [[x]] xs')) -reflectList G (xs ++ ys) with (reflectList G xs)-     | (G' ** xs') with (reflectList (G' ++ G) ys)-         | (G'' ** ys') = ((G'' ++ G') **-                              rewrite (sym (appendAssociative G'' G' G)) in-                                 App (weaken G'' xs') ys')-reflectList G t with (isElem t G)+reflectList gam (xs ++ ys) with (reflectList gam xs)+     | (gam' ** xs') with (reflectList (gam' ++ gam) ys)+         | (gam'' ** ys') = ((gam'' ++ gam') **+                              rewrite (sym (appendAssociative gam'' gam' gam)) in+                                 App (weaken gam'' xs') ys')+reflectList gam t with (isElem t gam)             | Just p = ([] ** Var p)             | Nothing = ([t] ** Var Stop) @@ -160,12 +160,12 @@ -- forms of equality proofs anyway.  %reflection-reflectEq : (a : Type) -> (G : List (List a)) -> (P : Type) -> (G' ** ListEq (G' ++ G) P)-reflectEq a G (the (List a) xs = the (List a) ys) with (reflectList G xs)-     | (G' ** xs')  with (reflectList (G' ++ G) ys)-        | (G'' ** ys') = ((G'' ++ G') **-                           rewrite (sym (appendAssociative G'' G' G)) in-                               EqP (weaken G'' xs') ys')+reflectEq : (a : Type) -> (gam : List (List a)) -> (P : Type) -> (gam' ** ListEq (gam' ++ gam) P)+reflectEq a gam (the (List a) xs = the (List a) ys) with (reflectList gam xs)+     | (gam' ** xs')  with (reflectList (gam' ++ gam) ys)+        | (gam'' ** ys') = ((gam'' ++ gam') **+                           rewrite (sym (appendAssociative gam'' gam' gam)) in+                               EqP (weaken gam'' xs') ys')   -- Need these before we can test it or the reductions won't normalise fully...
test/quasiquote001/expected view
@@ -1,5 +1,5 @@ App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar "./Prelude/List.idr" 28)) (TType (UVar "./Prelude/List.idr" 30))) (Bind (UN "x") (Pi (V 0) (TType (UVar "./Prelude/List.idr" 31))) (Bind (UN "xs") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar "./Prelude/List.idr" 32))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 8 0) (UN "Unit") (TType (UVar "./Builtins.idr" 20)))) (P (DCon 0 0) (UN "MkUnit") (P (TCon 0 0) (UN "Unit") Erased))) (App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar "./Prelude/List.idr" 28)) (TType (UVar "./Prelude/List.idr" 30))) (Bind (UN "x") (Pi (V 0) (TType (UVar "./Prelude/List.idr" 31))) (Bind (UN "xs") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar "./Prelude/List.idr" 32))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 8 0) (UN "Unit") (TType (UVar "./Builtins.idr" 20)))) (P (DCon 0 0) (UN "MkUnit") (P (TCon 0 0) (UN "Unit") Erased))) (App (P (DCon 0 1) (NS (UN "Nil") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar "./Prelude/List.idr" 25)) (TType (UVar "./Prelude/List.idr" 27))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 0)))) (P (TCon 8 0) (UN "Unit") (TType (UVar "./Builtins.idr" 20))))) ---------------App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar "./Prelude/List.idr" 28)) (TType (UVar "./Prelude/List.idr" 30))) (Bind (UN "x") (Pi (V 0) (TType (UVar "./Prelude/List.idr" 31))) (Bind (UN "xs") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar "./Prelude/List.idr" 32))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar "./QuasiquoteBasics.idr" 27))) (TType (UVar "./QuasiquoteBasics.idr" 28))) (App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar "./Prelude/List.idr" 28)) (TType (UVar "./Prelude/List.idr" 30))) (Bind (UN "x") (Pi (V 0) (TType (UVar "./Prelude/List.idr" 31))) (Bind (UN "xs") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar "./Prelude/List.idr" 32))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar "./QuasiquoteBasics.idr" 29))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar "./Builtins.idr" 74)) (TType (UVar "./Builtins.idr" 76))) (Bind (UN "B") (Pi (TType (UVar "./Builtins.idr" 77)) (TType (UVar "./Builtins.idr" 79))) (Bind (UN "a") (Pi (V 1) (TType (UVar "./Builtins.idr" 80))) (Bind (UN "b") (Pi (V 1) (TType (UVar "./Builtins.idr" 81))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar "./QuasiquoteBasics.idr" 23))) (TType (UVar "./QuasiquoteBasics.idr" 24))) (P (TCon 8 0) (NS (UN "Nat") ["Nat", "Prelude"]) (TType (UVar "./Prelude/Nat.idr" 20)))) (P (TCon 8 0) (NS (UN "Nat") ["Nat", "Prelude"]) (TType (UVar "./Prelude/Nat.idr" 20))))) (App (P (DCon 0 1) (NS (UN "Nil") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar "./Prelude/List.idr" 25)) (TType (UVar "./Prelude/List.idr" 27))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 0)))) (TType (UVar "./QuasiquoteBasics.idr" 30))))+App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar "./Prelude/List.idr" 28)) (TType (UVar "./Prelude/List.idr" 30))) (Bind (UN "x") (Pi (V 0) (TType (UVar "./Prelude/List.idr" 31))) (Bind (UN "xs") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar "./Prelude/List.idr" 32))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar "./QuasiquoteBasics.idr" 27))) (TType (UVar "./QuasiquoteBasics.idr" 28))) (App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar "./Prelude/List.idr" 28)) (TType (UVar "./Prelude/List.idr" 30))) (Bind (UN "x") (Pi (V 0) (TType (UVar "./Prelude/List.idr" 31))) (Bind (UN "xs") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar "./Prelude/List.idr" 32))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar "./QuasiquoteBasics.idr" 29))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar "./Builtins.idr" 30)) (TType (UVar "./Builtins.idr" 32))) (Bind (UN "B") (Pi (TType (UVar "./Builtins.idr" 33)) (TType (UVar "./Builtins.idr" 35))) (Bind (UN "a") (Pi (V 1) (TType (UVar "./Builtins.idr" 36))) (Bind (UN "b") (Pi (V 1) (TType (UVar "./Builtins.idr" 37))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar "./QuasiquoteBasics.idr" 23))) (TType (UVar "./QuasiquoteBasics.idr" 24))) (P (TCon 8 0) (NS (UN "Nat") ["Nat", "Prelude"]) (TType (UVar "./Prelude/Nat.idr" 20)))) (P (TCon 8 0) (NS (UN "Nat") ["Nat", "Prelude"]) (TType (UVar "./Prelude/Nat.idr" 20))))) (App (P (DCon 0 1) (NS (UN "Nil") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar "./Prelude/List.idr" 25)) (TType (UVar "./Prelude/List.idr" 27))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 0)))) (TType (UVar "./QuasiquoteBasics.idr" 30)))) ---------------App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar "./Builtins.idr" 74)) (TType (UVar "./Builtins.idr" 76))) (Bind (UN "B") (Pi (TType (UVar "./Builtins.idr" 77)) (TType (UVar "./Builtins.idr" 79))) (Bind (UN "a") (Pi (V 1) (TType (UVar "./Builtins.idr" 80))) (Bind (UN "b") (Pi (V 1) (TType (UVar "./Builtins.idr" 81))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar "./QuasiquoteBasics.idr" 23))) (TType (UVar "./QuasiquoteBasics.idr" 24))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar "./Builtins.idr" 74)) (TType (UVar "./Builtins.idr" 76))) (Bind (UN "B") (Pi (TType (UVar "./Builtins.idr" 77)) (TType (UVar "./Builtins.idr" 79))) (Bind (UN "a") (Pi (V 1) (TType (UVar "./Builtins.idr" 80))) (Bind (UN "b") (Pi (V 1) (TType (UVar "./Builtins.idr" 81))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar "./QuasiquoteBasics.idr" 23))) (TType (UVar "./QuasiquoteBasics.idr" 24))) (TType (UVar "./QuasiquoteBasics.idr" 28))) (TType (UVar "./QuasiquoteBasics.idr" 28)))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar "./Builtins.idr" 74)) (TType (UVar "./Builtins.idr" 76))) (Bind (UN "B") (Pi (TType (UVar "./Builtins.idr" 77)) (TType (UVar "./Builtins.idr" 79))) (Bind (UN "a") (Pi (V 1) (TType (UVar "./Builtins.idr" 80))) (Bind (UN "b") (Pi (V 1) (TType (UVar "./Builtins.idr" 81))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar "./QuasiquoteBasics.idr" 23))) (TType (UVar "./QuasiquoteBasics.idr" 24))) (TType (UVar "./QuasiquoteBasics.idr" 28))) (TType (UVar "./QuasiquoteBasics.idr" 28)))+App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar "./Builtins.idr" 30)) (TType (UVar "./Builtins.idr" 32))) (Bind (UN "B") (Pi (TType (UVar "./Builtins.idr" 33)) (TType (UVar "./Builtins.idr" 35))) (Bind (UN "a") (Pi (V 1) (TType (UVar "./Builtins.idr" 36))) (Bind (UN "b") (Pi (V 1) (TType (UVar "./Builtins.idr" 37))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar "./QuasiquoteBasics.idr" 23))) (TType (UVar "./QuasiquoteBasics.idr" 24))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar "./Builtins.idr" 30)) (TType (UVar "./Builtins.idr" 32))) (Bind (UN "B") (Pi (TType (UVar "./Builtins.idr" 33)) (TType (UVar "./Builtins.idr" 35))) (Bind (UN "a") (Pi (V 1) (TType (UVar "./Builtins.idr" 36))) (Bind (UN "b") (Pi (V 1) (TType (UVar "./Builtins.idr" 37))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar "./QuasiquoteBasics.idr" 23))) (TType (UVar "./QuasiquoteBasics.idr" 24))) (TType (UVar "./QuasiquoteBasics.idr" 28))) (TType (UVar "./QuasiquoteBasics.idr" 28)))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar "./Builtins.idr" 30)) (TType (UVar "./Builtins.idr" 32))) (Bind (UN "B") (Pi (TType (UVar "./Builtins.idr" 33)) (TType (UVar "./Builtins.idr" 35))) (Bind (UN "a") (Pi (V 1) (TType (UVar "./Builtins.idr" 36))) (Bind (UN "b") (Pi (V 1) (TType (UVar "./Builtins.idr" 37))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar "./QuasiquoteBasics.idr" 23))) (TType (UVar "./QuasiquoteBasics.idr" 24))) (TType (UVar "./QuasiquoteBasics.idr" 28))) (TType (UVar "./QuasiquoteBasics.idr" 28)))
test/regression001/reg001.idr view
@@ -53,7 +53,7 @@ total soElim            :  (C : (b : Bool) -> So b -> Type) ->                            C True Oh                       ->                            (b : Bool) -> (s : So b) -> (C b s)-soElim C coh True Oh  =  coh+soElim c coh True Oh  =  coh  soFalseElim             :  So False -> a soFalseElim x           =  void (soElim C () False x)
test/regression001/reg004.lidr view
@@ -6,9 +6,9 @@ >           (Functor F) => (Functor G) => >           (t : {A : Type} -> F A -> G A) ->  >           Type            -> Natural {F} {G} t = {A, B : Type} -> +> Natural {F=fF} {G=gG} t = {A, B : Type} ->  >                     (f : A -> B) ->->                     (x : F A) -> +>                     (x : fF A) ->  >                     t (map f x) = map f  (t x)   > Monotone : {B, C : Type} -> {F : Type -> Type} -> (Functor F) => @@ -16,13 +16,13 @@ >            (LTE_C : C -> C -> Type) ->  >            (measure : F B -> C) ->  >            Type-> Monotone {B} {C} {F} LTE_B LTE_C measure =+> Monotone {B=bB} {C=cC} {F=fF} lte_B lte_C measure = >   {A : Type} ->->   (f : A -> B) -> ->   (g : A -> B) -> ->   (p : (a : A) -> f a `LTE_B` g a) -> ->   (x : F A) -> ->   measure (map f x) `LTE_C` measure (map g x)  +>   (f : A -> bB) -> +>   (g : A -> bB) -> +>   (p : (a : A) -> f a `lte_B` g a) -> +>   (x : fF A) -> +>   measure (map f x) `lte_C` measure (map g x)    > monotoneNaturalLemma: {B, C : Type} -> {F : Type -> Type} -> (Functor F) =>  >                       (LTE_B : B -> B -> Type) -> @@ -32,12 +32,12 @@ >                       (t : {A : Type} -> F A -> F A) ->  >                       Natural t ->  >                       Monotone LTE_B LTE_C (measure . t)-> monotoneNaturalLemma {B} {C} {F} LTE_B LTE_C m mm t nt = mmt where+> monotoneNaturalLemma {B=bB} {C=cC} {F=fF} lte_B lte_C m mm t nt = mmt where >   mmt : {A : Type} -> ->         (f : A -> B) -> ->         (g : A -> B) -> ->         (p : (a : A) -> f a `LTE_B` g a) ->->         (x : F A) -> ->         m (t {A = B} (map f x)) `LTE_C` m (t {A = B} (map g x))   +>         (f : A -> bB) -> +>         (g : A -> bB) -> +>         (p : (a : A) -> f a `lte_B` g a) ->+>         (x : fF A) -> +>         m (t {A = bB} (map f x)) `lte_C` m (t {A = bB} (map g x))    >   mmt = ?kika
test/regression001/reg046.idr view
@@ -10,10 +10,10 @@            (f2 : (a : A) -> (as : MyList A) -> m as -> m (MyCons A a as)) ->            (e : MyList A) ->            m e-elimList A m f1 f2 (MyNil A) = f1-elimList A m f1 f2 (MyCons A a as) = f2 a as (elimList A m f1 f2 as)+elimList aA m f1 f2 (MyNil aA) = f1+elimList aA m f1 f2 (MyCons aA a as) = f2 a as (elimList aA m f1 f2 as)  append : (A : Type) ->  (b : MyList A) ->  (c : MyList A) ->  MyList A-append A b c = (elimList A (\ d =>  MyList A) c-                (\ d =>  \ e =>  \ f =>  MyCons A d f)+append aA b c = (elimList aA (\ d =>  MyList aA) c+                (\ d =>  \ e =>  \ f =>  MyCons aA d f)                 b)
test/regression001/reg047.idr view
@@ -6,10 +6,10 @@ data Nat = Zero | Succ Nat  Id : (A : Type) -> A -> A -> Type-Id A = (=) {A = A} {B = A}+Id aTy = (=) {A = aTy} {B = aTy}  IdRefl : (A : Type) -> (a : A) -> Id A a a-IdRefl A a = Refl {x = a}+IdRefl aTy a = Refl {x = a}  zzz : Id Nat Zero Zero zzz = IdRefl Nat Zero
test/regression001/reg047a.idr view
@@ -9,7 +9,7 @@ Id = \A,x,y => x = y --  {a = A} {b = A}  IdRefl : (A : Type) -> (a : A) -> Id A a a-IdRefl A a = Refl {x = a}+IdRefl aTy a = Refl {x = a}  zzzz : Id MNat Zero Zero zzzz = IdRefl MNat Zero
− test/regression001/reg062.lidr 
@@ -1,41 +0,0 @@--This is a test to make sure that #2130 doesn't re-break.--> import Data.Vect-> import Data.Fin--> %default total --> idSuccPreservesLTE : (m : Nat) -> (n : Nat) -> m `LTE` n -> m `LTE` (S n)-> idSuccPreservesLTE  Z     n    prf = LTEZero-> idSuccPreservesLTE (S m)  Z    prf = absurd prf-> idSuccPreservesLTE (S m) (S n) prf = LTESucc (idSuccPreservesLTE m n (fromLteSucc prf))--> ltZS : (m : Nat) -> LT Z (S m)-> ltZS  Z    = LTESucc LTEZero -> ltZS (S m) = idSuccPreservesLTE (S Z) (S m) (ltZS m)--> record Preorder : {T : Type} -> (T -> T -> Type) -> Type where->   MkPreorder : {T : Type} -> ->                (R : T -> T -> Type) ->->                (reflexive : (x : T) -> R x x) ->->                (transitive : (x : T) -> (y : T) -> (z : T) -> R x y -> R y z -> R x z) ->->                Preorder R--> record TotalPreorder : {T : Type} -> (T -> T -> Type) -> Type where->   MkTotalPreorder : {T : Type} -> ->                     (R : T -> T -> Type) ->->                     (reflexive : (x : T) -> R x x) ->->                     (transitive : (x : T) -> (y : T) -> (z : T) -> R x y -> R y z -> R x z) ->->                     (either : (x : T) -> (y : T) -> Either (R x y) (R y x)) ->->                     TotalPreorder R--> argmaxMax : {A : Type} -> {R : A -> A -> Type} -> TotalPreorder {T = A} R -> ->             Vect n A -> LT Z n -> (Fin n, A)-> argmaxMax         {n = Z}       tp  Nil                p = absurd p-> argmaxMax         {n = S Z}     tp (a :: Nil)          _ = (FZ, a)-> argmaxMax {A} {R} {n = S (S m)} (MkTotalPreorder R r t e) (a' :: (a'' :: as)) _ ->   with (argmaxMax (MkTotalPreorder {T = A} R r t e) (a'' :: as) (ltZS m))->     | (k, max) with (e a' max)->       | (Left  _) = (FS k, max)->       | (Right _) = (FZ, a')
test/regression001/reg064.idr view
@@ -5,4 +5,4 @@            fst s1 = fst s2 ->            snd s1 = snd s2 ->            s1 = s2-sigmaEq2 {A} {P} {s1 = (x ** prf)} {s2 = (x ** prf)} Refl Refl = Refl+sigmaEq2 {A=a} {P=p} {s1 = (x ** prf)} {s2 = (x ** prf)} Refl Refl = Refl
test/regression001/run view
@@ -13,6 +13,6 @@ ${IDRIS:-idris} $@ --check --nobuiltins reg047.idr  ${IDRIS:-idris} $@ --check --nocolour \-     reg062.lidr reg073.lidr+     reg073.lidr  rm -f *.ibc
test/regression002/expected view
@@ -1,3 +1,18 @@+reg001.idr:2:1-9:+  |+2 | foo a a x = x+  | ~~~~~~~~~+When checking left hand side of foo:+Can't match on foo a a x++reg002.idr:3:1-19:+  |+3 | append (X :: XS) ys = X :: append XS ys+  | ~~~~~~~~~~~~~~~~~~~+When checking left hand side of append:+When checking argument x to constructor Prelude.List.:::+        X is not a valid name for a pattern variable+ reg003a.idr:4:13-38:   | 4 |     ECons : Nat -> OddList -> EvenList
+ test/regression002/reg001.idr view
@@ -0,0 +1,2 @@+foo : (a : Type) -> (b : Type) -> a -> b+foo a a x = x
+ test/regression002/reg002.idr view
@@ -0,0 +1,3 @@+append : List a -> List a -> List a+append [] ys = ys+append (X :: XS) ys = X :: append XS ys
test/regression002/run view
@@ -1,6 +1,8 @@ #!/usr/bin/env bash  ${IDRIS:-idris} $@ --nobanner --nocolour --quiet --port none <<!+:load reg001.idr+:load reg002.idr :load reg003.idr :load reg003a.idr :load reg006.idr
test/sugar005/As.idr view
@@ -8,7 +8,7 @@ -- Test @ under a constructor hasS : List Nat -> Maybe Nat hasS (Z::xs) = hasS xs-hasS (n@(S_)::xs) = Just n+hasS (n@(S _)::xs) = Just n hasS _ = Nothing  -- Test nested @s
test/totality011/totality011.lidr view
@@ -20,10 +20,10 @@ >                     t'' `GTE` t  > weCanOnlyGetOlder {t'' = Z} {t = Z}   _ _ _  =  LTEZero-> weCanOnlyGetOlder {t'' = Z} {t = S m} _ _ (Zeqt , _)  = +> weCanOnlyGetOlder {t'' = Z} {t = S m} _ _ (zeqt , _)  =  >   void (uninhabited u) where >     u : Z = S m ->     u = trans Zeqt Refl+>     u = trans zeqt Refl  > weCanOnlyGetOlder {t'' = S _} {t = S _} _ _ _ = ?foo
+ test/totality025/expected view
@@ -0,0 +1,18 @@+totality025.idr:3:17-26:+  |+3 | bad1 _ _ _ Refl impossible+  |                 ~~~~~~~~~~+bad1 _ _ _ Refl is a valid case++totality025.idr:12:17-26:+   |+12 | bad2 _ _ _ Refl impossible+   |                 ~~~~~~~~~~+bad2 _ _ _ Refl is a valid case++totality025.idr:16:19-28:+   |+16 | bad3 _ _ _ _ Refl impossible+   |                   ~~~~~~~~~~+bad3 _ _ _ _ Refl is a valid case+
+ test/totality025/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ totality025.idr --check+rm -f *.ibc
+ test/totality025/totality025.idr view
@@ -0,0 +1,17 @@+total+bad1 : (f : Type -> Type) -> (x, y : Type) -> f x = f y -> Void+bad1 _ _ _ Refl impossible++total+ohoh : Void+ohoh = bad1 id Unit Unit Refl++-- of course, these shouldn't be provable as well:+total+bad2 : (f, g : Type -> Type) -> (x : Type) -> f x = g x -> Void+bad2 _ _ _ Refl impossible++total+bad3 : (f, g : Type -> Type) -> (x, y : Type) -> f x = g y -> Void+bad3 _ _ _ _ Refl impossible+
+ test/totality026/expected view
@@ -0,0 +1,6 @@+totality026.idr:5:8-17:+  |+5 | p Here impossible+  |        ~~~~~~~~~~+p Here is a valid case+
+ test/totality026/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ totality026.idr --check+rm -f *.ibc
+ test/totality026/totality026.idr view
@@ -0,0 +1,7 @@+import Data.Vect++total+p : Elem (Maybe x) (map Maybe xs) -> Elem x xs+p Here impossible+p (There l) impossible+