idris 0.11.2 → 0.12
raw patch · 249 files changed
+5277/−3209 lines, 249 filessetup-changed
Files
- CHANGELOG.md +36/−4
- CONTRIBUTING.md +1/−1
- HLint.hs +33/−0
- Setup.hs +10/−12
- idris.cabal +26/−57
- libs/base/Data/Bits.idr +30/−9
- libs/base/Data/Mod2.idr +3/−4
- libs/base/Data/Primitives/Views.idr +12/−10
- libs/base/Data/String.idr +1/−2
- libs/base/Language/Reflection/Utils.idr +31/−28
- libs/base/System/Concurrency/Raw.idr +50/−28
- libs/base/System/Concurrency/Sessions.idr +63/−0
- libs/base/base.ipkg +1/−1
- libs/contrib/Data/Heap.idr +3/−4
- libs/contrib/Network/Socket.idr +400/−173
- libs/contrib/System/Concurrency/Process.idr +10/−8
- libs/effects/Effects.idr +4/−4
- libs/effects/effects.ipkg +1/−1
- libs/prelude/Builtins.idr +11/−4
- libs/prelude/Language/Reflection.idr +3/−3
- libs/prelude/Language/Reflection/Errors.idr +1/−1
- libs/prelude/Prelude.idr +7/−0
- libs/prelude/Prelude/File.idr +35/−11
- libs/prelude/Prelude/Foldable.idr +23/−2
- libs/prelude/Prelude/List.idr +1/−2
- libs/prelude/Prelude/Stream.idr +2/−3
- man/idris.1 +1/−1
- rts/idris_rts.c +43/−13
- rts/idris_rts.h +11/−3
- rts/idris_stdfgn.c +16/−3
- rts/idris_stdfgn.h +4/−0
- src/IRTS/BCImp.hs +7/−3
- src/IRTS/Bytecode.hs +37/−35
- src/IRTS/CodegenC.hs +19/−12
- src/IRTS/CodegenCommon.hs +29/−19
- src/IRTS/CodegenJavaScript.hs +11/−1
- src/IRTS/Compiler.hs +95/−82
- src/IRTS/Defunctionalise.hs +31/−26
- src/IRTS/DumpBC.hs +7/−0
- src/IRTS/Exports.hs +7/−0
- src/IRTS/Inliner.hs +7/−1
- src/IRTS/JavaScript/AST.hs +8/−1
- src/IRTS/Lang.hs +18/−11
- src/IRTS/LangOpts.hs +17/−9
- src/IRTS/Portable.hs +7/−1
- src/IRTS/Simplified.hs +8/−5
- src/IRTS/System.hs +17/−2
- src/Idris/ASTUtils.hs +57/−52
- src/Idris/AbsSyntax.hs +85/−64
- src/Idris/AbsSyntaxTree.hs +528/−423
- src/Idris/Apropos.hs +7/−0
- src/Idris/CaseSplit.hs +45/−36
- src/Idris/Chaser.hs +30/−18
- src/Idris/CmdOptions.hs +8/−1
- src/Idris/Colours.hs +14/−6
- src/Idris/Completion.hs +9/−5
- src/Idris/Core/Binary.hs +23/−14
- src/Idris/Core/CaseTree.hs +35/−19
- src/Idris/Core/Constraints.hs +58/−23
- src/Idris/Core/DeepSeq.hs +13/−6
- src/Idris/Core/Elaborate.hs +44/−37
- src/Idris/Core/Evaluate.hs +39/−27
- src/Idris/Core/Execute.hs +31/−14
- src/Idris/Core/ProofState.hs +54/−42
- src/Idris/Core/ProofTerm.hs +31/−28
- src/Idris/Core/TT.hs +66/−103
- src/Idris/Core/Typecheck.hs +89/−72
- src/Idris/Core/Unify.hs +46/−36
- src/Idris/Core/WHNF.hs +28/−23
- src/Idris/Coverage.hs +100/−51
- src/Idris/DSL.hs +9/−3
- src/Idris/DataOpts.hs +8/−3
- src/Idris/DeepSeq.hs +12/−1
- src/Idris/Delaborate.hs +32/−25
- src/Idris/Directives.hs +21/−2
- src/Idris/Docs.hs +15/−4
- src/Idris/Docstrings.hs +11/−4
- src/Idris/Elab/AsPat.hs +8/−1
- src/Idris/Elab/Class.hs +35/−23
- src/Idris/Elab/Clause.hs +58/−42
- src/Idris/Elab/Data.hs +55/−18
- src/Idris/Elab/Instance.hs +57/−48
- src/Idris/Elab/Provider.hs +7/−0
- src/Idris/Elab/Quasiquote.hs +7/−0
- src/Idris/Elab/Record.hs +76/−53
- src/Idris/Elab/Rewrite.hs +35/−28
- src/Idris/Elab/RunElab.hs +9/−2
- src/Idris/Elab/Term.hs +85/−62
- src/Idris/Elab/Transform.hs +11/−4
- src/Idris/Elab/Type.hs +50/−24
- src/Idris/Elab/Utils.hs +122/−26
- src/Idris/Elab/Value.hs +14/−5
- src/Idris/ElabDecls.hs +41/−22
- src/Idris/Erasure.hs +23/−15
- src/Idris/ErrReverse.hs +13/−8
- src/Idris/Error.hs +9/−1
- src/Idris/Help.hs +24/−16
- src/Idris/IBC.hs +81/−61
- src/Idris/IdeMode.hs +19/−12
- src/Idris/IdrisDoc.hs +9/−5
- src/Idris/Imports.hs +13/−4
- src/Idris/Inliner.hs +9/−4
- src/Idris/Interactive.hs +26/−15
- src/Idris/Output.hs +9/−1
- src/Idris/Parser.hs +62/−46
- src/Idris/Parser/Data.hs +18/−9
- src/Idris/Parser/Expr.hs +31/−12
- src/Idris/Parser/Helpers.hs +9/−1
- src/Idris/Parser/Ops.hs +7/−0
- src/Idris/PartialEval.hs +63/−49
- src/Idris/Primitives.hs +8/−1
- src/Idris/ProofSearch.hs +37/−30
- src/Idris/Prover.hs +30/−22
- src/Idris/Providers.hs +12/−2
- src/Idris/REPL.hs +51/−37
- src/Idris/REPL/Browse.hs +8/−0
- src/Idris/REPL/Parser.hs +13/−2
- src/Idris/Reflection.hs +55/−39
- src/Idris/Transforms.hs +30/−22
- src/Idris/TypeSearch.hs +68/−59
- src/Idris/Unlit.hs +7/−0
- src/Idris/WhoCalls.hs +8/−1
- src/Pkg/PParser.hs +111/−13
- src/Pkg/Package.hs +8/−1
- src/Util/DynamicLinker.hs +12/−5
- src/Util/Net.hs +7/−0
- src/Util/Pretty.hs +12/−6
- src/Util/ScreenSize.hs +7/−0
- src/Util/System.hs +18/−4
- test/basic010/expected +3/−3
- test/error001/expected +4/−4
- test/error004/idx.idr +0/−4
- test/interactive010/expected +2/−2
- test/interactive012/expected +2/−2
- test/io003/test018.idr +2/−2
- test/pkg001/run +3/−3
- test/pkg001/test-pkg.ipkg +17/−0
- test/pkg001/test.ipkg +0/−7
- test/primitives006/Data/Bytes.idr +3/−4
- test/proof002/Reflect.idr +1/−1
- test/proof003/expected +2/−2
- test/proof003/test015.idr +8/−2
- test/proof011/expected +6/−4
- test/proofsearch002/Process.idr +11/−12
- test/pruviloj001/pruviloj001.idr +0/−1
- test/quasiquote001/expected +3/−3
- test/reg001/expected +0/−0
- test/reg001/reg001.idr +0/−209
- test/reg001/run +0/−4
- test/reg035/reg035a.lidr +1/−2
- test/reg036/expected +0/−0
- test/reg036/reg036.idr +0/−12
- test/reg036/run +0/−3
- test/reg037/expected +0/−0
- test/reg037/reg037.idr +0/−9
- test/reg037/run +0/−3
- test/reg038/expected +0/−0
- test/reg038/reg038.idr +0/−17
- test/reg038/run +0/−3
- test/reg041/ott.idr +2/−3
- test/reg046/expected +0/−0
- test/reg046/reg046.idr +0/−19
- test/reg046/run +0/−3
- test/reg047/expected +0/−0
- test/reg047/reg047.idr +0/−18
- test/reg047/reg047a.idr +0/−24
- test/reg047/run +0/−4
- test/reg053/expected +0/−0
- test/reg053/four.idr +0/−9
- test/reg053/run +0/−3
- test/reg056/reg056.idr +0/−1
- test/reg057/expected +0/−0
- test/reg057/reg057.idr +0/−8
- test/reg057/run +0/−3
- test/reg058/expected +0/−0
- test/reg058/implicits.idr +0/−14
- test/reg058/implicits2.idr +0/−19
- test/reg058/run +0/−5
- test/reg059/expected +0/−0
- test/reg059/reg059.idr +0/−8
- test/reg059/run +0/−3
- test/reg060/expected +0/−0
- test/reg060/reg060.idr +0/−12
- test/reg060/run +0/−3
- test/reg061/Capture.idr +0/−9
- test/reg061/expected +0/−0
- test/reg061/run +0/−3
- test/reg062/expected +0/−0
- test/reg062/reg062.idr +0/−13
- test/reg062/run +0/−4
- test/reg063/Cmp.idr +0/−19
- test/reg063/expected +0/−0
- test/reg063/run +0/−3
- test/reg064/expected +0/−0
- test/reg064/reg064.idr +0/−8
- test/reg064/run +0/−3
- test/reg065/expected +0/−0
- test/reg065/reg065.idr +0/−26
- test/reg065/run +0/−3
- test/reg066/expected +0/−0
- test/reg066/reg066.idr +0/−7
- test/reg066/run +0/−3
- test/reg071/expected +0/−0
- test/reg071/reg071.idr +0/−19
- test/reg071/run +0/−3
- test/reg075/expected +6/−0
- test/reg075/input +1/−0
- test/reg075/reg075.idr +33/−0
- test/reg075/run +3/−0
- test/regression001/expected +0/−0
- test/regression001/reg001.idr +209/−0
- test/regression001/reg036.idr +12/−0
- test/regression001/reg037.idr +9/−0
- test/regression001/reg038.idr +17/−0
- test/regression001/reg046.idr +19/−0
- test/regression001/reg047.idr +18/−0
- test/regression001/reg047a.idr +24/−0
- test/regression001/reg053.idr +9/−0
- test/regression001/reg057.idr +8/−0
- test/regression001/reg058.idr +14/−0
- test/regression001/reg058a.idr +19/−0
- test/regression001/reg059.idr +8/−0
- test/regression001/reg060.idr +12/−0
- test/regression001/reg061.idr +9/−0
- test/regression001/reg062.idr +13/−0
- test/regression001/reg062.lidr +41/−0
- test/regression001/reg063.idr +19/−0
- test/regression001/reg064.idr +8/−0
- test/regression001/reg065.idr +26/−0
- test/regression001/reg066.idr +7/−0
- test/regression001/reg071.idr +19/−0
- test/regression001/reg073.lidr +24/−0
- test/regression001/reg074.idr +21/−0
- test/regression001/run +13/−0
- test/totality012/totality012.idr +3/−3
- test/totality012/totality012a.idr +2/−3
- test/totality014/expected +8/−0
- test/totality014/run +3/−0
- test/totality014/totality014.idr +7/−0
- test/totality015/expected +6/−0
- test/totality015/run +4/−0
- test/totality015/totality015.idr +70/−0
- test/totality015/totality015a.idr +63/−0
- test/universes001/expected +9/−0
- test/universes001/run +3/−0
- test/universes001/universes001.idr +8/−0
- test/universes002/expected +9/−0
- test/universes002/run +3/−0
- test/universes002/universes002.idr +45/−0
CHANGELOG.md view
@@ -16,14 +16,14 @@ ``` [PlusNatSemi] Semigroup Nat where (<+>) x y = x + y- + [MultNatSemi] Semigroup Nat where (<+>) x y = x * y- + -- use PlusNatSemi as the parent implementation [PlusNatMonoid] Monoid Nat using PlusNatSemi where neutral = 0- + -- use MultNatSemi as the parent implementation [MultNatMonoid] Monoid Nat using MultNatSemi where neutral = 1@@ -73,6 +73,14 @@ them as mutually defined functions with their top level function, meaning that it can spot more total functions. +* The totality checker now looks under `if...then...else` blocks when checking+ for productivity.++* The `%assert_total` directive is now deprecated. Instead, you can+ use one of the functions `assert_total`, `assert_smaller` or+ `assert_unreachable` to describe more precisely where a totality assertion+ is needed.+ ## Library updates * `Control.WellFounded` module removed, and added to the Prelude as@@ -80,7 +88,25 @@ * Added `Data.List.Views` with views on `List` and their covering functions. * Added `Data.Nat.Views` with views on `Nat` and their covering functions. * Added `Data.Primitives.Views` with views on various primitive types and their covering functions.+* Added `System.Concurrency.Sessions` for simple management of conversations+ between processes +## iPKG Updates++* Taking cues from cabal, the `iPKG` format has been extended to+ include more package metadata information. The following fields+ have been added:++ + `brief`: Brief description of the package.+ + `version`: Version string to associate with the package.+ + `readme`: Location of the README file.+ + `license`: Description of the licensing information.+ + `author`: Author information.+ + `maintainer`: Maintainer information.+ + `homepage`: Website associated with the package.+ + `sourcepage`: Location of the DVCS where the source can be found.++ ## Miscellaneous updates * The Idris man page is now installed as part of the cabal/stack build process.@@ -107,6 +133,12 @@ not, leading to a contradiction. The new fine-grained equality prevents this. +* Naming conventions for Idris packages in an iPKG file now follow the+ same rules for executables. Unquoted names must be valid namespaced+ Idris identifiers e.g. ``package my.first.package``. Quoted package+ names allow for packages to be given valid file names, for example,+ ``package "my-first-package"``.+ ## Reflection changes * The implicit coercion from String to TTName was removed.@@ -278,7 +310,7 @@ package names that the idris project depends on. This reduces bloat in the `opts` option with multiple package declarations. * iPKG files now allow `executable = "your filename here"` in addition to the- existing `executable = yourFilenameHere` style. While the unquoted version is+ Existing `Executable = yourFilenameHere` style. While the unquoted version is limited to filenames that look like namespaced Idris identifiers (`your.filename.here`), the quoted version accepts any valid filename. * Add definition command (`\d` in Vim, `Ctrl-Alt-A` in Atom, `C-c C-s` in Emacs)
CONTRIBUTING.md view
@@ -49,7 +49,7 @@ 1. The mailing List. 1. On our IRC Channel `#idris` on freenode, or-1. As a [Dragon Egg](https://github.com/idris-lang/Idris-dev/wiki/Feature-proposals).+1. As an RFC in the issue tracker Developers then seeking to add content to Idris's prelude and default library, should do so through a PR where more discussions and refinements can be made.
+ HLint.hs view
@@ -0,0 +1,33 @@+-- --------------------------------------------------------------- [ 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
@@ -83,13 +83,11 @@ -- ----------------------------------------------------------------------------- -- Clean -idrisClean _ flags _ _ = do- cleanStdLib+idrisClean _ flags _ _ = cleanStdLib where verbosity = S.fromFlag $ S.cleanVerbosity flags - cleanStdLib = do- makeClean "libs"+ cleanStdLib = makeClean "libs" makeClean dir = make verbosity [ "-C", dir, "clean", "IDRIS=idris" ] @@ -108,7 +106,7 @@ hash <- gitHash let versionModulePath = dir </> "Version_idris" Px.<.> "hs" putStrLn $ "Generating " ++ versionModulePath ++- if release then " for release" else (" for prerelease " ++ hash)+ if release then " for release" else " for prerelease " ++ hash createDirectoryIfMissingVerbose verbosity True dir rewriteFile versionModulePath (versionModuleContents hash) @@ -120,7 +118,7 @@ -- Generate a module that contains the lib path for a freestanding Idris generateTargetModule verbosity dir targetDir = do- absPath <- return $ isAbsolute targetDir+ let absPath = isAbsolute targetDir let targetModulePath = dir </> "Target_idris" Px.<.> "hs" putStrLn $ "Generating " ++ targetModulePath createDirectoryIfMissingVerbose verbosity True dir@@ -155,15 +153,15 @@ idrisConfigure _ flags _ local = do configureRTS generateVersionModule verbosity (autogenModulesDir local) (isRelease (configFlags local))- if (isFreestanding $ configFlags local)- then (do+ if isFreestanding $ configFlags local+ then do toolDir <- lookupEnv "IDRIS_TOOLCHAIN_DIR" generateToolchainModule verbosity (autogenModulesDir local) toolDir targetDir <- lookupEnv "IDRIS_LIB_DIR" case targetDir of Just d -> generateTargetModule verbosity (autogenModulesDir local) d Nothing -> error $ "Trying to build freestanding without a target directory."- ++ " Set it by defining IDRIS_LIB_DIR.")+ ++ " Set it by defining IDRIS_LIB_DIR." else generateToolchainModule verbosity (autogenModulesDir local) Nothing where@@ -179,7 +177,7 @@ idrisPreSDist args flags = do let dir = S.fromFlag (S.sDistDirectory flags) let verb = S.fromFlag (S.sDistVerbosity flags)- generateVersionModule verb ("src") True+ generateVersionModule verb "src" True generateTargetModule verb "src" "./libs" generateToolchainModule verb "src" Nothing preSDist simpleUserHooks args flags@@ -257,7 +255,7 @@ makeInstall "rts" target' installManPage = do- let mandest = (mandir $ L.absoluteInstallDirs pkg local copy) ++ "/man1"+ let mandest = mandir (L.absoluteInstallDirs pkg local copy) ++ "/man1" notice verbosity $ unwords ["Copying man page to", mandest] installOrdinaryFiles verbosity mandest [("man", "idris.1")] @@ -281,6 +279,6 @@ , postInst = \_ flags pkg local -> idrisInstall (S.fromFlag $ S.installVerbosity flags) NoCopyDest pkg local- , preSDist = idrisPreSDist --do { putStrLn (show args) ; putStrLn (show flags) ; return emptyHookedBuildInfo }+ , preSDist = idrisPreSDist , postSDist = idrisPostSDist }
idris.cabal view
@@ -1,5 +1,5 @@ Name: idris-Version: 0.11.2+Version: 0.12 License: BSD3 License-file: LICENSE Author: Edwin Brady@@ -91,6 +91,7 @@ Makefile config.mk stack.yaml+ HLint.hs man/idris.1 rts/*.c@@ -157,9 +158,12 @@ test/Makefile test/runtest.hs- test/reg001/run- test/reg001/*.idr- test/reg001/expected++ test/regression001/run+ test/regression001/expected+ test/regression001/*.idr+ test/regression001/*.lidr+ test/reg002/run test/reg002/*.idr test/reg002/expected@@ -227,15 +231,6 @@ test/reg035/*.idr test/reg035/*.lidr test/reg035/expected- test/reg036/run- test/reg036/*.idr- test/reg036/expected- test/reg037/run- test/reg037/*.idr- test/reg037/expected- test/reg038/run- test/reg038/*.idr- test/reg038/expected test/reg039/run test/reg039/*.idr test/reg039/expected@@ -254,12 +249,6 @@ test/reg045/run test/reg045/*.idr test/reg045/expected- test/reg046/run- test/reg046/*.idr- test/reg046/expected- test/reg047/run- test/reg047/*.idr- test/reg047/expected test/reg048/run test/reg048/*.idr test/reg048/expected@@ -275,9 +264,6 @@ test/reg052/run test/reg052/*.idr test/reg052/expected- test/reg053/run- test/reg053/*.idr- test/reg053/expected test/reg054/run test/reg054/*.idr test/reg054/expected@@ -287,36 +273,6 @@ test/reg056/run test/reg056/*.idr test/reg056/expected- test/reg057/run- test/reg057/*.idr- test/reg057/expected- test/reg058/run- test/reg058/*.idr- test/reg058/expected- test/reg059/run- test/reg059/*.idr- test/reg059/expected- test/reg060/run- test/reg060/*.idr- test/reg060/expected- test/reg061/run- test/reg061/*.idr- test/reg061/expected- test/reg062/run- test/reg062/*.idr- test/reg062/expected- test/reg063/run- test/reg063/*.idr- test/reg063/expected- test/reg064/run- test/reg064/*.idr- test/reg064/expected- test/reg065/run- test/reg065/*.idr- test/reg065/expected- test/reg066/run- test/reg066/*.idr- test/reg066/expected test/reg067/run test/reg067/*.idr test/reg067/expected@@ -329,13 +285,13 @@ test/reg070/run test/reg070/*.idr test/reg070/expected- test/reg071/run- test/reg071/*.idr- test/reg071/expected test/reg072/run test/reg072/*.idr test/reg072/expected-+ test/reg075/run+ test/reg075/input+ test/reg075/*.idr+ test/reg075/expected test/basic001/run test/basic001/*.idr@@ -671,7 +627,7 @@ test/primitives006/expected test/pkg001/run- test/pkg001/test.ipkg+ test/pkg001/test-pkg.ipkg test/pkg001/*.idr test/pkg001/expected @@ -824,6 +780,12 @@ test/totality013/run test/totality013/*.idr test/totality013/expected+ test/totality014/run+ test/totality014/*.idr+ test/totality014/expected+ test/totality015/run+ test/totality015/*.idr+ test/totality015/expected test/tutorial001/run test/tutorial001/*.idr@@ -867,6 +829,13 @@ test/views003/run test/views003/*.idr test/views003/expected++ test/universes001/run+ test/universes001/*.idr+ test/universes001/expected+ test/universes002/run+ test/universes002/*.idr+ test/universes002/expected test/docs001/run test/docs001/input
libs/base/Data/Bits.idr view
@@ -2,7 +2,8 @@ import Data.Fin -%default total+%default total -- This file is full of totality assertions though. Let's try+ -- to improve it! (EB) %access export public export@@ -28,7 +29,6 @@ bitsUsed : Nat -> Nat bitsUsed n = 8 * (2 `power` n) -%assert_total natToBits' : %static {n : Nat} -> machineTy n -> Nat -> machineTy n natToBits' a Z = a natToBits' {n=n} a x with (n)@@ -37,6 +37,7 @@ natToBits' a (S x') | S Z = natToBits' {n=1} (prim__addB16 a (prim__truncInt_B16 1)) x' natToBits' a (S x') | S (S Z) = natToBits' {n=2} (prim__addB32 a (prim__truncInt_B32 1)) x' natToBits' a (S x') | S (S (S _)) = natToBits' {n=3} (prim__addB64 a (prim__truncInt_B64 1)) x'+ natToBits' a _ | _ = assert_unreachable natToBits : %static {n : Nat} -> Nat -> machineTy n natToBits {n=n} x with (n)@@ -44,9 +45,10 @@ | S Z = natToBits' {n=1} (prim__truncInt_B16 0) x | S (S Z) = natToBits' {n=2} (prim__truncInt_B32 0) x | S (S (S _)) = natToBits' {n=3} (prim__truncInt_B64 0) x+ | _ = assert_unreachable getPad : %static {n : Nat} -> Nat -> machineTy n-getPad n = natToBits (minus (bitsUsed (nextBytes n)) n)+getPad n = assert_total $ natToBits (minus (bitsUsed (nextBytes n)) n) public export data Bits : Nat -> Type where@@ -101,6 +103,7 @@ | S Z = pad16' n prim__shlB16 x c | S (S Z) = pad32' n prim__shlB32 x c | S (S (S _)) = pad64' n prim__shlB64 x c+ | _ = assert_unreachable shiftLeft : %static {n : Nat} -> Bits n -> Bits n -> Bits n shiftLeft (MkBits x) (MkBits y) = MkBits (shiftLeft' x y)@@ -111,6 +114,7 @@ | S Z = prim__lshrB16 x c | S (S Z) = prim__lshrB32 x c | S (S (S _)) = prim__lshrB64 x c+ | _ = assert_unreachable shiftRightLogical : %static {n : Nat} -> Bits n -> Bits n -> Bits n shiftRightLogical {n} (MkBits x) (MkBits y)@@ -122,6 +126,7 @@ | S Z = pad16' n prim__ashrB16 x c | S (S Z) = pad32' n prim__ashrB32 x c | S (S (S _)) = pad64' n prim__ashrB64 x c+ | _ = assert_unreachable shiftRightArithmetic : %static {n : Nat} -> Bits n -> Bits n -> Bits n shiftRightArithmetic (MkBits x) (MkBits y) = MkBits (shiftRightArithmetic' x y)@@ -132,6 +137,7 @@ | S Z = prim__andB16 x y | S (S Z) = prim__andB32 x y | S (S (S _)) = prim__andB64 x y+ | _ = assert_unreachable and : %static {n : Nat} -> Bits n -> Bits n -> Bits n and {n} (MkBits x) (MkBits y) = MkBits (and' {n=nextBytes n} x y)@@ -142,6 +148,7 @@ | S Z = prim__orB16 x y | S (S Z) = prim__orB32 x y | S (S (S _)) = prim__orB64 x y+ | _ = assert_unreachable or : %static {n : Nat} -> Bits n -> Bits n -> Bits n or {n} (MkBits x) (MkBits y) = MkBits (or' {n=nextBytes n} x y)@@ -152,6 +159,7 @@ | S Z = prim__xorB16 x y | S (S Z) = prim__xorB32 x y | S (S (S _)) = prim__xorB64 x y+ | _ = assert_unreachable xor : %static {n : Nat} -> Bits n -> Bits n -> Bits n xor {n} (MkBits x) (MkBits y) = MkBits {n} (xor' {n=nextBytes n} x y)@@ -162,6 +170,7 @@ | S Z = pad16 n prim__addB16 x y | S (S Z) = pad32 n prim__addB32 x y | S (S (S _)) = pad64 n prim__addB64 x y+ | _ = assert_unreachable plus : %static {n : Nat} -> Bits n -> Bits n -> Bits n plus (MkBits x) (MkBits y) = MkBits (plus' x y)@@ -172,6 +181,7 @@ | S Z = pad16 n prim__subB16 x y | S (S Z) = pad32 n prim__subB32 x y | S (S (S _)) = pad64 n prim__subB64 x y+ | _ = assert_unreachable minus : %static {n : Nat} -> Bits n -> Bits n -> Bits n minus (MkBits x) (MkBits y) = MkBits (minus' x y)@@ -182,6 +192,7 @@ | S Z = pad16 n prim__mulB16 x y | S (S Z) = pad32 n prim__mulB32 x y | S (S (S _)) = pad64 n prim__mulB64 x y+ | _ = assert_unreachable times : %static {n : Nat} -> Bits n -> Bits n -> Bits n times (MkBits x) (MkBits y) = MkBits (times' x y)@@ -193,6 +204,7 @@ | S Z = prim__sdivB16 x y | S (S Z) = prim__sdivB32 x y | S (S (S _)) = prim__sdivB64 x y+ | _ = assert_unreachable partial sdiv : %static {n : Nat} -> Bits n -> Bits n -> Bits n@@ -205,6 +217,7 @@ | S Z = prim__udivB16 x y | S (S Z) = prim__udivB32 x y | S (S (S _)) = prim__udivB64 x y+ | _ = assert_unreachable partial udiv : %static {n : Nat} -> Bits n -> Bits n -> Bits n@@ -217,6 +230,7 @@ | S Z = prim__sremB16 x y | S (S Z) = prim__sremB32 x y | S (S (S _)) = prim__sremB64 x y+ | _ = assert_unreachable partial srem : %static {n : Nat} -> Bits n -> Bits n -> Bits n@@ -229,6 +243,7 @@ | S Z = prim__uremB16 x y | S (S Z) = prim__uremB32 x y | S (S (S _)) = prim__uremB64 x y+ | _ = assert_unreachable partial urem : %static {n : Nat} -> Bits n -> Bits n -> Bits n@@ -241,6 +256,7 @@ | S Z = prim__ltB16 x y | S (S Z) = prim__ltB32 x y | S (S (S _)) = prim__ltB64 x y+ | _ = assert_unreachable lte : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int lte {n=n} x y with (nextBytes n)@@ -248,6 +264,7 @@ | S Z = prim__lteB16 x y | S (S Z) = prim__lteB32 x y | S (S (S _)) = prim__lteB64 x y+ | _ = assert_unreachable eq : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int eq {n=n} x y with (nextBytes n)@@ -255,6 +272,7 @@ | S Z = prim__eqB16 x y | S (S Z) = prim__eqB32 x y | S (S (S _)) = prim__eqB64 x y+ | _ = assert_unreachable gte : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int gte {n=n} x y with (nextBytes n)@@ -262,6 +280,7 @@ | S Z = prim__gteB16 x y | S (S Z) = prim__gteB32 x y | S (S (S _)) = prim__gteB64 x y+ | _ = assert_unreachable gt : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int gt {n=n} x y with (nextBytes n)@@ -269,6 +288,7 @@ | S Z = prim__gtB16 x y | S (S Z) = prim__gtB32 x y | S (S (S _)) = prim__gtB64 x y+ | _ = assert_unreachable implementation Eq (Bits n) where (MkBits x) == (MkBits y) = boolOp eq x y@@ -295,12 +315,12 @@ prim__complB32 (x `prim__shlB32` pad) `prim__lshrB32` pad | S (S (S _)) = let pad = getPad {n=3} n in prim__complB64 (x `prim__shlB64` pad) `prim__lshrB64` pad+ | _ = assert_unreachable complement : %static {n : Nat} -> Bits n -> Bits n complement (MkBits x) = MkBits (complement' x) -- TODO: Prove-%assert_total -- can't verify coverage of with block zext' : %static {n : Nat} -> %static {m : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) | (Z, Z) = believe_me x@@ -313,11 +333,11 @@ | (S (S Z), S (S Z)) = believe_me x | (S (S Z), S (S (S _))) = believe_me (prim__zextB32_B64 (believe_me x)) | (S (S (S _)), S (S (S _))) = believe_me x+ | _ = assert_unreachable zeroExtend : %static {n : Nat} -> %static {m : Nat} -> Bits n -> Bits (n+m) zeroExtend (MkBits x) = MkBits (zext' x) -%assert_total intToBits' : %static {n : Nat} -> Integer -> machineTy (nextBytes n) intToBits' {n=n} x with (nextBytes n) | Z = let pad = getPad {n=0} n in@@ -328,6 +348,7 @@ prim__lshrB32 (prim__shlB32 (prim__truncBigInt_B32 x) pad) pad | S (S (S _)) = let pad = getPad {n=3} n in prim__lshrB64 (prim__shlB64 (prim__truncBigInt_B64 x) pad) pad+ | _ = assert_unreachable intToBits : %static {n : Nat} -> Integer -> Bits n intToBits n = MkBits (intToBits' n)@@ -341,6 +362,7 @@ | S Z = prim__zextB16_BigInt x | S (S Z) = prim__zextB32_BigInt x | S (S (S _)) = prim__zextB64_BigInt x+ | _ = assert_unreachable bitsToInt : %static {n : Nat} -> Bits n -> Integer bitsToInt (MkBits x) = bitsToInt' x@@ -353,7 +375,6 @@ -- cast x = MkBits (zeroUnused (natToBits n)) -- TODO: Prove-%assert_total -- can't verify coverage of with block sext' : %static {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) sext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) | (Z, Z) = let pad = getPad {n=0} n in@@ -382,12 +403,12 @@ (prim__zextB32_B64 pad)) | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad)+ | _ = assert_unreachable ----signExtend : Bits n -> Bits (n+m) --signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x)) -- TODO: Prove-%assert_total -- can't verify coverage of with block trunc' : %static {m : Nat} -> %static {n : Nat} -> machineTy (nextBytes (m+n)) -> machineTy (nextBytes n) trunc' {m=m} {n=n} x with (nextBytes n, nextBytes (m+n)) | (Z, Z) = believe_me x@@ -400,6 +421,7 @@ | (S (S Z), S (S Z)) = believe_me x | (S (S Z), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x)) | (S (S (S _)), S (S (S _))) = believe_me x+ | _ = assert_unreachable truncate : %static {m : Nat} -> %static {n : Nat} -> Bits (m+n) -> Bits n truncate (MkBits x) = MkBits (zeroUnused (trunc' x))@@ -419,10 +441,9 @@ bitsToStr : %static {n : Nat} -> Bits n -> String bitsToStr x = pack (helper last x) where- %assert_total helper : %static {n : Nat} -> Fin (S n) -> Bits n -> List Char helper FZ _ = []- helper (FS x) b = (if getBit x b then '1' else '0') :: helper (weaken x) b+ helper (FS x) b = assert_total $ (if getBit x b then '1' else '0') :: helper (weaken x) b implementation Show (Bits n) where show = bitsToStr
libs/base/Data/Mod2.idr view
@@ -24,7 +24,6 @@ rem : Mod2 n -> Mod2 n -> Mod2 n rem = modBin urem -%assert_total public export intToMod : {n : Nat} -> Integer -> Mod2 n intToMod {n=n} x = MkMod2 (intToBits x)@@ -53,10 +52,10 @@ modToStr : Mod2 n -> String modToStr x = pack (reverse (helper x)) where- %assert_total helper : Mod2 n -> List Char- helper x = strIndex "0123456789" (prim__truncBigInt_Int (bitsToInt (cast (x `rem` 10))))- :: (if x < 10 then [] else helper (x `div` 10))+ helper x = assert_total $ + strIndex "0123456789" (prim__truncBigInt_Int (bitsToInt (cast (x `rem` 10))))+ :: (if x < 10 then [] else helper (x `div` 10)) implementation Show (Mod2 n) where
libs/base/Data/Primitives/Views.idr view
@@ -18,11 +18,12 @@ divides : (val : Integer) -> (d : Integer) -> Divides val d divides val 0 = DivByZero divides val d- = let dividend = if d < 0 then -(val `div` abs d)- else val `div` d- remainder = val `mod` d in- believe_me (DivBy {d} {div = dividend} {rem = remainder}- (believe_me (Refl {x = True})))+ = assert_total $+ let dividend = if d < 0 then -(val `div` abs d)+ else val `div` d+ remainder = abs (val - dividend * d) in+ believe_me (DivBy {d} {div = dividend} {rem = remainder}+ (believe_me (Refl {x = True}))) ||| View for recursion over Integers data IntegerRec : Integer -> Type where@@ -54,11 +55,12 @@ divides : (val : Int) -> (d : Int) -> Divides val d divides val 0 = DivByZero divides val d- = let dividend = if d < 0 then -(val `div` abs d)- else val `div` d- remainder = val `mod` d in- believe_me (DivBy {d} {div = dividend} {rem = remainder}- (believe_me (Refl {x = True})))+ = assert_total $+ let dividend = if d < 0 then -(val `div` abs d)+ else val `div` d+ remainder = abs (val - dividend * d) in+ believe_me (DivBy {d} {div = dividend} {rem = remainder}+ (believe_me (Refl {x = True}))) ||| View for recursion over Ints data IntRec : Int -> Type where
libs/base/Data/String.idr view
@@ -70,9 +70,8 @@ Just $ (w * ex + f * ex) mkDouble Nothing = Nothing - %assert_total intPow : Integer -> Integer -> Double- intPow base exp = if exp > 0 then (num base exp) else 1 / (num base exp)+ intPow base exp = assert_total $ if exp > 0 then (num base exp) else 1 / (num base exp) where num base 0 = 1 num base e = if e < 0
libs/base/Language/Reflection/Utils.idr view
@@ -122,13 +122,13 @@ _ == _ = False implementation Show TTUExp where- showPrec d (UVar i) = showCon d "UVar" $ showArg i+ showPrec d (UVar ns i) = showCon d "UVar" $ showArg ns ++ showArg i showPrec d (UVal i) = showCon d "UVal" $ showArg i implementation Eq TTUExp where- (UVar i) == (UVar j) = i == j- (UVal i) == (UVal j) = i == j- x == y = False+ (UVar nsi i) == (UVar nsj j) = nsi == nsj && i == j+ (UVal i) == (UVal j) = i == j+ x == y = False implementation Show NativeTy where show IT8 = "IT8"@@ -235,33 +235,35 @@ implementation Show TT where showPrec = my_show- where %assert_total my_show : Prec -> TT -> String- my_show d (P nt n t) = showCon d "P" $ showArg nt ++ showArg n ++ showArg t- my_show d (V i) = showCon d "V" $ showArg i- my_show d (Bind n b t) = showCon d "Bind" $ showArg n ++ showArg b ++ showArg t- my_show d (App t1 t2) = showCon d "App" $ showArg t1 ++ showArg t2- my_show d (TConst c) = showCon d "TConst" $ showArg c+ where my_show : Prec -> TT -> String+ my_show d (P nt n t) = assert_total $ showCon d "P" $ showArg nt ++ showArg n ++ showArg t+ my_show d (V i) = assert_total $ showCon d "V" $ showArg i+ my_show d (Bind n b t) = assert_total $ showCon d "Bind" $ showArg n ++ showArg b ++ showArg t+ my_show d (App t1 t2) = assert_total $ showCon d "App" $ showArg t1 ++ showArg t2+ my_show d (TConst c) = assert_total $ showCon d "TConst" $ showArg c my_show d Erased = "Erased"- my_show d (TType u) = showCon d "TType" $ showArg u+ my_show d (TType u) = assert_total $ showCon d "TType" $ showArg u+ my_show d (UType u) = "UType" +implementation Eq Universe where+ Reflection.NullType == Reflection.NullType = True+ Reflection.UniqueType == Reflection.UniqueType = True+ Reflection.AllTypes == Reflection.AllTypes = True+ _ == _ = False+ implementation Eq TT where a == b = equalp a b- where %assert_total equalp : TT -> TT -> Bool- equalp (P nt n t) (P nt' n' t') = nt == nt' && n == n' && t == t'- equalp (V i) (V i') = i == i'- equalp (Bind n b t) (Bind n' b' t') = n == n' && b == b' && t == t'- equalp (App t1 t2) (App t1' t2') = t1 == t1' && t2 == t2'+ where equalp : TT -> TT -> Bool+ equalp (P nt n t) (P nt' n' t') = assert_total $ nt == nt' && n == n' && t == t'+ equalp (V i) (V i') = assert_total $ i == i'+ equalp (Bind n b t) (Bind n' b' t') = assert_total $ n == n' && b == b' && t == t'+ equalp (App t1 t2) (App t1' t2') = assert_total $ t1 == t1' && t2 == t2' equalp (TConst c) (TConst c') = c == c' equalp Erased Erased = True equalp (TType u) (TType u') = u == u'+ equalp (UType u) (UType u') = u == u' equalp x y = False -implementation Eq Universe where- Reflection.NullType == Reflection.NullType = True- Reflection.UniqueType == Reflection.UniqueType = True- Reflection.AllTypes == Reflection.AllTypes = True- _ == _ = False- total forget : TT -> Maybe Raw forget tm = fe [] tm@@ -288,12 +290,13 @@ implementation Show Raw where showPrec = my_show- where %assert_total my_show : Prec -> Raw -> String- my_show d (Var n) = showCon d "Var" $ showArg n- my_show d (RBind n b tm) = showCon d "RBind" $ showArg n ++ showArg b ++ " " ++ my_show App tm- my_show d (RApp tm tm') = showCon d "RApp" $ " " ++ my_show App tm ++ " " ++ my_show App tm'+ where my_show : Prec -> Raw -> String+ my_show d (Var n) = assert_total $ showCon d "Var" $ showArg n+ my_show d (RBind n b tm) = assert_total $ showCon d "RBind" $ showArg n ++ showArg b ++ " " ++ my_show App tm+ my_show d (RApp tm tm') = assert_total $ showCon d "RApp" $ " " ++ my_show App tm ++ " " ++ my_show App tm' my_show d RType = "RType"- my_show d (RConstant c) = showCon d "RConstant" $ showArg c+ my_show d (RConstant c) = assert_total $ showCon d "RConstant" $ showArg c+ my_show d (RUType u) = "RUType" implementation Show Err where@@ -329,7 +332,7 @@ showPrec d (NonCollapsiblePostulate n) = showCon d "NonCollapsiblePostulate" $ showArg n showPrec d (AlreadyDefined n) = showCon d "AlreadyDefined" $ showArg n showPrec d (ProofSearchFail err) = showCon d "ProofSearchFail" $ showArg err- showPrec d (NoRewriting tm) = showCon d "NoRewriting" $ showArg tm+ showPrec d (NoRewriting ltm rtm typ) = showCon d "NoRewriting" $ showArg ltm ++ showArg rtm ++ showArg typ showPrec d (ProviderError x) = showCon d "ProviderError" $ showArg x showPrec d (LoadingFailed x err) = showCon d "LoadingFailed" $ showArg x ++ showArg err
libs/base/System/Concurrency/Raw.idr view
@@ -9,11 +9,14 @@ %access export ||| Send a message of any type to the thread with the given thread id-||| Returns 1 if the message was sent successfully, 0 otherwise-sendToThread : (thread_id : Ptr) -> a -> IO Int-sendToThread {a} dest val- = foreign FFI_C "idris_sendMessage" (Ptr -> Ptr -> Raw a -> IO Int)- prim__vm dest (MkRaw val)+||| 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+sendToThread {a} dest channel val+ = foreign FFI_C "idris_sendMessage" (Ptr -> Int -> Ptr -> Raw a -> IO Int)+ prim__vm channel dest (MkRaw val) ||| Check for messages in the process inbox checkMsgs : IO Bool@@ -31,21 +34,32 @@ null <- nullPtr msgs return (not null) -||| Check for messages in the process inbox.-||| Returns either 'Nothing', if none, or 'Just pid' as pid of sender.-listenMsgs : IO (Maybe Ptr)-listenMsgs = do sender <- foreign FFI_C "idris_checkMessages" (Ptr -> IO Ptr)+private+sender : Ptr -> IO Ptr+sender msg = foreign FFI_C "idris_getSender" (Ptr -> IO Ptr) msg++private+channel_id : Ptr -> IO Int+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 +||| of sender and new channel id.+listenMsgs : IO (Maybe (Ptr, Int))+listenMsgs = do msg <- foreign FFI_C "idris_checkInitMessages" (Ptr -> IO Ptr) prim__vm- null <- nullPtr sender- return (if null- then Nothing- else Just sender)+ null <- nullPtr msg+ if null then pure Nothing+ else do s_id <- sender msg+ c_id <- channel_id msg+ pure (Just (s_id, c_id)) -||| Check for messages from a specific sender in the process inbox-checkMsgsFrom : Ptr -> IO Bool-checkMsgsFrom sender- = do msgs <- foreign FFI_C "idris_checkMessagesFrom" (Ptr -> Ptr -> IO Ptr)- prim__vm sender+||| 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 + = do msgs <- foreign FFI_C "idris_checkMessagesFrom" (Ptr -> Int -> Ptr -> IO Ptr)+ prim__vm channel sender null <- nullPtr msgs return (not null) @@ -60,23 +74,31 @@ return x ||| Check inbox for messages. If there are none, blocks until a message-||| arrives. Return pair of sender's ID and the message.+||| arrives. Return triple of sender's ID, channel ID, and the message. ||| Note that this is not at all type safe! It is intended to be used in ||| a type safe wrapper.-getMsgWithSender : IO (Ptr, a)+getMsgWithSender : IO (Ptr, Int, a) getMsgWithSender {a} = do m <- foreign FFI_C "idris_recvMessage" (Ptr -> IO Ptr) prim__vm MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m- vm <- foreign FFI_C "idris_getSender" (Ptr -> IO Ptr) m+ vm <- sender m+ chan <- channel_id m foreign FFI_C "idris_freeMsg" (Ptr -> IO ()) m- return (vm, x)+ return (vm, chan, x) -getMsgFrom : Ptr -> IO a-getMsgFrom {a} sender +||| Check inbox for messages on a particular channel. If there are none,+||| blocks until a message arrives. Returns `Nothing` if the sender isn't+||| alive+getMsgFrom : Ptr -> (channel : Int) -> IO (Maybe a)+getMsgFrom {a} sender channel = do m <- foreign FFI_C "idris_recvMessageFrom"- (Ptr -> Ptr -> IO Ptr) prim__vm sender- MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m- foreign FFI_C "idris_freeMsg" (Ptr -> IO ()) m- return x+ (Ptr -> Int -> Ptr -> IO Ptr) prim__vm channel sender+ null <- nullPtr m+ if null + then pure Nothing+ else do+ MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m+ foreign FFI_C "idris_freeMsg" (Ptr -> IO ()) m+ pure (Just x)
+ libs/base/System/Concurrency/Sessions.idr view
@@ -0,0 +1,63 @@+module System.Concurrency.Sessions++import System.Concurrency.Raw++||| A Session is a connection between two processes. Sessions can be created+||| either using 'listen' to wait for an incoming connection, or 'connect'+||| which initiates a connection to another process.+||| Sessions cannot be passed between processes.+export+data Session : Type where+ MkConc : (pid : Ptr) -> (ch_id : Int) -> Session++||| A PID is a process identifier, as returned by `spawn`+export+data PID : Type where+ MkPID : (pid : Ptr) -> PID++||| Spawn a process in a new thread, returning the process ID+export+spawn : IO () -> IO PID+spawn proc = do pid <- fork proc+ pure (MkPID pid)++||| Create a channel which connects this process to another process+export+connect : (proc : PID) -> IO (Maybe Session)+connect (MkPID pid) = do ch_id <- sendToThread pid 0 ()+ if (ch_id /= 0)+ then pure (Just (MkConc pid ch_id))+ else pure Nothing++||| Listen for incoming connections. If another process has initiated a+||| communication with this process, returns a channel +export+listen : (timeout : Int) -> IO (Maybe Session)+listen timeout = do checkMsgsTimeout timeout+ Just (client, ch_id) <- listenMsgs+ | Nothing => pure Nothing+ getMsgFrom {a = ()} client ch_id -- remove init message+ pure (Just (MkConc client ch_id))++||| Send a message on a channel. Returns whether the message was successfully+||| sent to the process at the other end of the channel. This will fail if+||| the process on the channel is no longer running.+||| This is unsafe because there is no type checking, so there must be+||| a protocol (externally checked) which ensures that the message send+||| is of type expected by the receiver.+export+unsafeSend : Session -> (val : a) -> IO Bool+unsafeSend (MkConc pid ch_id) val+ = do ok <- sendToThread pid ch_id val+ pure (ok /= 0)++||| Receive a message on a channel, with an explicit type.+||| Blocks if there is nothing to receive. Returns `Nothing` if the+||| process on the channel is no longer running.+||| This is unsafe because there is no type checking, so there must be+||| a protocol (externally checked) which ensures that the message received+||| is of the type given by the sender.+export+unsafeRecv : (a : Type) -> Session -> IO (Maybe a)+unsafeRecv a (MkConc pid ch_id) = getMsgFrom {a} pid ch_id+
libs/base/base.ipkg view
@@ -31,5 +31,5 @@ Control.Category, Control.Arrow, Control.Catchable, Control.IOExcept, - System.Concurrency.Raw+ System.Concurrency.Raw, System.Concurrency.Sessions
libs/contrib/Data/Heap.idr view
@@ -61,11 +61,10 @@ largest : Nat largest = maximum (size left) $ maximum (size centre) (size right) -%assert_total -- relies on orderBySize doing the right thing merge : Ord a => MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a merge Empty right = right merge left Empty = left-merge (Node ls ll le lr) (Node rs rl re rr) =+merge (Node ls ll le lr) (Node rs rl re rr) = assert_total $ -- relies on orderBySize doing the right thing if le < re then let (largest, b, c) = orderBySize ll lr (Node rs rl re rr) in Node mergedSize largest le (merge b c)@@ -99,9 +98,9 @@ toList Empty = [] toList (Node s l e r) = toList' (Node s l e r) Refl where- %assert_total -- relies on deleteMinimum making heap smaller toList' : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> List a- toList' heap p = findMinimum heap p :: (Heap.toList (deleteMinimum heap p))+ toList' heap p = assert_total $ -- relies on deleteMinimum making heap smaller+ findMinimum heap p :: (Heap.toList (deleteMinimum heap p)) fromList : Ord a => List a -> MaxiphobicHeap a fromList = foldr insert empty
libs/contrib/Network/Socket.idr view
@@ -1,6 +1,7 @@-||| Time to do this properly. ||| Low-Level C Sockets bindings for Idris. Used by higher-level, cleverer things.-||| (C) SimonJF, MIT Licensed, 2014+|||+||| Original (C) SimonJF, MIT Licensed, 2014+||| Modified (C) The Idris Community, 2015, 2016 module Network.Socket %include C "idris_net.h"@@ -8,119 +9,155 @@ %include C "sys/socket.h" %include C "netdb.h" +-- ------------------------------------------------------------ [ Type Aliases ]+ public export ByteLength : Type ByteLength = Int +public export+ResultCode : Type+ResultCode = Int++||| Protocol Number.+|||+||| Generally good enough to just set it to 0.+public export+ProtocolNumber : Type+ProtocolNumber = Int++||| SocketError: Error thrown by a socket operation+public export+SocketError : Type+SocketError = Int++||| SocketDescriptor: Native C Socket Descriptor+public export+SocketDescriptor : Type+SocketDescriptor = Int++public export+Port : Type+Port = Int++-- --------------------------------------------------------------- [ Constants ]++||| Backlog used within listen() call -- number of incoming calls+public export+BACKLOG : Int+BACKLOG = 20++-- FIXME: This *must* be pulled in from C+public export+EAGAIN : Int+EAGAIN = 11++-- -------------------------------------------------------------- [ Interfaces ]+ export interface ToCode a where toCode : a -> Int +-- --------------------------------------------------------- [ Socket Families ]+ ||| Socket Families ||| ||| The ones that people might actually use. We're not going to need US ||| Government proprietary ones. public export-data SocketFamily =+data SocketFamily : Type where ||| Unspecified- AF_UNSPEC |+ AF_UNSPEC : SocketFamily+ ||| IP / UDP etc. IPv4- AF_INET |+ AF_INET : SocketFamily+ ||| IP / UDP etc. IPv6- AF_INET6+ AF_INET6 : SocketFamily export-implementation Show SocketFamily where+Show SocketFamily where show AF_UNSPEC = "AF_UNSPEC" show AF_INET = "AF_INET" show AF_INET6 = "AF_INET6" export-implementation ToCode SocketFamily where+ToCode SocketFamily where toCode AF_UNSPEC = 0 toCode AF_INET = 2 toCode AF_INET6 = 10 getSocketFamily : Int -> Maybe SocketFamily-getSocketFamily i = Prelude.List.lookup i [(0, AF_UNSPEC), (2, AF_INET), (10, AF_INET6)]+getSocketFamily i =+ Prelude.List.lookup i [ (0, AF_UNSPEC)+ , (2, AF_INET)+ , (10, AF_INET6)+ ] +-- ------------------------------------------------------------ [ Socket Types ] ||| Socket Types. public export-data SocketType =+data SocketType : Type where ||| Not a socket, used in certain operations- NotASocket |+ NotASocket : SocketType+ ||| TCP- Stream |+ Stream : SocketType+ ||| UDP- Datagram |+ Datagram : SocketType+ ||| Raw sockets- RawSocket+ RawSocket : SocketType export-implementation Show SocketType where+Show SocketType where show NotASocket = "Not a socket" show Stream = "Stream" show Datagram = "Datagram" show RawSocket = "Raw" export-implementation ToCode SocketType where+ToCode SocketType where toCode NotASocket = 0 toCode Stream = 1 toCode Datagram = 2 toCode RawSocket = 3 +-- ---------------------------------------------------------------- [ Pointers ]+ data RecvStructPtr = RSPtr Ptr data RecvfromStructPtr = RFPtr Ptr export data BufPtr = BPtr Ptr+ export data SockaddrPtr = SAPtr Ptr -||| Protocol Number.-|||-||| Generally good enough to just set it to 0.-public export-ProtocolNumber : Type-ProtocolNumber = Int+-- --------------------------------------------------------------- [ Addresses ] -||| SocketError: Error thrown by a socket operation+||| Network Addresses public export-SocketError : Type-SocketError = Int+data SocketAddress : Type where+ IPv4Addr : Int -> Int -> Int -> Int -> SocketAddress -||| SocketDescriptor: Native C Socket Descriptor-public export-SocketDescriptor : Type-SocketDescriptor = Int+ ||| Not implemented (yet)+ IPv6Addr : SocketAddress -public export-data SocketAddress = IPv4Addr Int Int Int Int- | IPv6Addr -- Not implemented (yet)- | Hostname String- | InvalidAddress -- Used when there's a parse error+ Hostname : String -> SocketAddress + ||| Used when there's a parse error+ InvalidAddress : SocketAddress+ export-implementation Show SocketAddress where+Show SocketAddress where show (IPv4Addr i1 i2 i3 i4) = concat $ Prelude.List.intersperse "." (map show [i1, i2, i3, i4])- show IPv6Addr = "NOT IMPLEMENTED YET"- show (Hostname host) = host- show InvalidAddress = "Invalid"--public export-Port : Type-Port = Int--||| Backlog used within listen() call -- number of incoming calls-public export-BACKLOG : Int-BACKLOG = 20+ show IPv6Addr = "NOT IMPLEMENTED YET"+ show (Hostname host) = host+ show InvalidAddress = "Invalid" --- FIXME: This *must* be pulled in from C-public export-EAGAIN : Int-EAGAIN = 11+-- --------------------------------------------------------- [ UDP Information ] -- TODO: Expand to non-string payloads export@@ -128,8 +165,8 @@ constructor MkUDPRecvData remote_addr : SocketAddress remote_port : Port- recv_data : String- data_len : Int+ recv_data : String+ data_len : Int export record UDPAddrInfo where@@ -137,6 +174,8 @@ remote_addr : SocketAddress remote_port : Port +-- ---------------------------------------------------------- [ Socket Utilies ]+ ||| Frees a given pointer export sock_free : BufPtr -> IO ()@@ -153,26 +192,35 @@ sock_alloc : ByteLength -> IO BufPtr sock_alloc bl = map BPtr $ foreign FFI_C "idrnet_malloc" (Int -> IO Ptr) bl +-- ----------------------------------------------------------------- [ Sockets ] ||| The metadata about a socket export record Socket where constructor MkSocket- descriptor : SocketDescriptor- family : SocketFamily- socketType : SocketType+ descriptor : SocketDescriptor+ family : SocketFamily+ socketType : SocketType protocolNumber : ProtocolNumber ++-- ----------------------------------------------------- [ Network Socket API. ]+ ||| Creates a UNIX socket with the given family, socket type and protocol ||| number. Returns either a socket or an error. export-socket : SocketFamily -> SocketType -> ProtocolNumber -> IO (Either SocketError Socket)+socket : (fam : SocketFamily)+ -> (ty : SocketType)+ -> (pnum : ProtocolNumber)+ -> IO (Either SocketError Socket) socket sf st pn = do- socket_res <- foreign FFI_C "socket" (Int -> Int -> Int -> IO Int) (toCode sf) (toCode st) pn- if socket_res == -1 then -- error- map Left getErrno- else- return $ Right (MkSocket socket_res sf st pn)+ socket_res <- foreign FFI_C "socket"+ (Int -> Int -> Int -> IO Int)+ (toCode sf) (toCode st) pn + if socket_res == -1+ then map Left getErrno+ else return $ Right (MkSocket socket_res sf st pn)+ ||| Close a socket export close : Socket -> IO ()@@ -186,199 +234,378 @@ ||| Binds a socket to the given socket address and port. ||| Returns 0 on success, an error code otherwise. export-bind : Socket -> (Maybe SocketAddress) -> Port -> IO Int+bind : (sock : Socket)+ -> (addr : Maybe SocketAddress)+ -> (port : Port)+ -> IO Int bind sock addr port = do bind_res <- foreign FFI_C "idrnet_bind" (Int -> Int -> Int -> String -> Int -> IO Int) (descriptor sock) (toCode $ family sock) (toCode $ socketType sock) (saString addr) port- if bind_res == (-1) then -- error- getErrno- else return 0 -- Success+ if bind_res == (-1)+ then getErrno+ else return 0 ||| Connects to a given address and port. ||| Returns 0 on success, and an error number on error. export-connect : Socket -> SocketAddress -> Port -> IO Int+connect : (sock : Socket)+ -> (addr : SocketAddress)+ -> (port : Port)+ -> IO ResultCode connect sock addr port = do conn_res <- foreign FFI_C "idrnet_connect" (Int -> Int -> Int -> String -> Int -> IO Int) (descriptor sock) (toCode $ family sock) (toCode $ socketType sock) (show addr) port- if conn_res == (-1) then- getErrno- else return 0 + if conn_res == (-1)+ then getErrno+ else return 0+ ||| Listens on a bound socket.+|||+||| @sock The socket to listen on. export-listen : Socket -> IO Int+listen : (sock : Socket) -> IO Int listen sock = do listen_res <- foreign FFI_C "listen" (Int -> Int -> IO Int) (descriptor sock) BACKLOG- if listen_res == (-1) then- getErrno- else return 0+ if listen_res == (-1)+ then getErrno+ else return 0 ||| Parses a textual representation of an IPv4 address into a SocketAddress parseIPv4 : String -> SocketAddress-parseIPv4 str = case splitted of- (i1 :: i2 :: i3 :: i4 :: _) => IPv4Addr i1 i2 i3 i4- _ => InvalidAddress- where toInt' : String -> Integer- toInt' = cast- toInt : String -> Int- toInt s = fromInteger $ toInt' s- splitted : List Int- splitted = map toInt (Prelude.Strings.split (\c => c == '.') str)+parseIPv4 str =+ case splitted of+ (i1 :: i2 :: i3 :: i4 :: _) => IPv4Addr i1 i2 i3 i4+ otherwise => InvalidAddress+ where+ toInt' : String -> Integer+ toInt' = cast + toInt : String -> Int+ toInt s = fromInteger $ toInt' s++ splitted : List Int+ splitted = map toInt (Prelude.Strings.split (\c => c == '.') str)+ ||| Retrieves a socket address from a sockaddr pointer getSockAddr : SockaddrPtr -> IO SocketAddress getSockAddr (SAPtr ptr) = do- addr_family_int <- foreign FFI_C "idrnet_sockaddr_family" (Ptr -> IO Int) ptr- -- putStrLn $ "Addr family int: " ++ (show addr_family_int)+ addr_family_int <- foreign FFI_C "idrnet_sockaddr_family"+ (Ptr -> IO Int)+ ptr+ -- ASSUMPTION: Foreign call returns a valid int assert_total (case getSocketFamily addr_family_int of Just AF_INET => do- ipv4_addr <- foreign FFI_C "idrnet_sockaddr_ipv4" (Ptr -> IO String) ptr+ ipv4_addr <- foreign FFI_C "idrnet_sockaddr_ipv4"+ (Ptr -> IO String)+ ptr+ return $ parseIPv4 ipv4_addr Just AF_INET6 => return IPv6Addr Just AF_UNSPEC => return InvalidAddress) +||| Accept a connection on the provided socket.+|||+||| Returns on failure a `SocketError`+||| Returns on success a pairing of:+||| + `Socket` :: The socket representing the connection.+||| + `SocketAddress` :: The+|||+||| @sock The socket used to establish connection. export-accept : Socket -> IO (Either SocketError (Socket, SocketAddress))+accept : (sock : Socket)+ -> IO (Either SocketError (Socket, SocketAddress)) accept sock = do+ -- We need a pointer to a sockaddr structure. This is then passed into -- idrnet_accept and populated. We can then query it for the SocketAddr and free it.- sockaddr_ptr <- foreign FFI_C "idrnet_create_sockaddr" (IO Ptr)- accept_res <- foreign FFI_C "idrnet_accept" (Int -> Ptr -> IO Int) (descriptor sock) sockaddr_ptr- if accept_res == (-1) then- map Left getErrno- else do- let (MkSocket _ fam ty p_num) = sock- sockaddr <- getSockAddr (SAPtr sockaddr_ptr)- sockaddr_free (SAPtr sockaddr_ptr)- return $ Right ((MkSocket accept_res fam ty p_num), sockaddr) + sockaddr_ptr <- foreign FFI_C "idrnet_create_sockaddr"+ (IO Ptr)++ accept_res <- foreign FFI_C "idrnet_accept"+ (Int -> Ptr -> IO Int)+ (descriptor sock) sockaddr_ptr+ if accept_res == (-1)+ then map Left getErrno+ else do+ let (MkSocket _ fam ty p_num) = sock+ sockaddr <- getSockAddr (SAPtr sockaddr_ptr)+ sockaddr_free (SAPtr sockaddr_ptr)+ return $ Right ((MkSocket accept_res fam ty p_num), sockaddr)++||| Send data on the specified socket.+|||+||| Returns on failure a `SocketError`.+||| Returns on success the `ResultCode`.+|||+||| @sock The socket on which to send the message.+||| @msg The data to send. export-send : Socket -> String -> IO (Either SocketError ByteLength)+send : (sock : Socket)+ -> (msg : String)+ -> IO (Either SocketError ResultCode) send sock dat = do- send_res <- foreign FFI_C "idrnet_send" (Int -> String -> IO Int) (descriptor sock) dat- if send_res == (-1) then- map Left getErrno- else- return $ Right send_res+ send_res <- foreign FFI_C "idrnet_send"+ (Int -> String -> IO Int)+ (descriptor sock) dat + if send_res == (-1)+ then map Left getErrno+ else return $ Right send_res+ freeRecvStruct : RecvStructPtr -> IO ()-freeRecvStruct (RSPtr p) = foreign FFI_C "idrnet_free_recv_struct" (Ptr -> IO ()) p+freeRecvStruct (RSPtr p) =+ foreign FFI_C "idrnet_free_recv_struct"+ (Ptr -> IO ())+ p +||| Utility to extract data. freeRecvfromStruct : RecvfromStructPtr -> IO ()-freeRecvfromStruct (RFPtr p) = foreign FFI_C "idrnet_free_recvfrom_struct" (Ptr -> IO ()) p+freeRecvfromStruct (RFPtr p) =+ foreign FFI_C "idrnet_free_recvfrom_struct"+ (Ptr -> IO ())+ p ++||| Receive data on the specified socket.+|||+||| Returns on failure a `SocketError`+||| Returns on success a pairing of:+||| + `String` :: The payload.+||| + `ResultCode` :: The result of the underlying function.+|||+||| @sock The socket on which to receive the message.+||| @len How much of the data to send. export-recv : Socket -> Int -> IO (Either SocketError (String, ByteLength))+recv : (sock : Socket)+ -> (len : ByteLength)+ -> IO (Either SocketError (String, ResultCode)) recv sock len = do -- Firstly make the request, get some kind of recv structure which -- contains the result of the recv and possibly the retrieved payload- recv_struct_ptr <- foreign FFI_C "idrnet_recv" (Int -> Int -> IO Ptr) (descriptor sock) len- recv_res <- foreign FFI_C "idrnet_get_recv_res" (Ptr -> IO Int) recv_struct_ptr- if recv_res == (-1) then do- errno <- getErrno- freeRecvStruct (RSPtr recv_struct_ptr)- return $ Left errno- else- if recv_res == 0 then do- freeRecvStruct (RSPtr recv_struct_ptr)- return $ Left 0- else do- payload <- foreign FFI_C "idrnet_get_recv_payload" (Ptr -> IO String) recv_struct_ptr- freeRecvStruct (RSPtr recv_struct_ptr)- return $ Right (payload, recv_res)+ recv_struct_ptr <- foreign FFI_C "idrnet_recv"+ (Int -> Int -> IO Ptr)+ (descriptor sock) len+ recv_res <- foreign FFI_C "idrnet_get_recv_res"+ (Ptr -> IO Int)+ recv_struct_ptr + if recv_res == (-1)+ then do+ errno <- getErrno+ freeRecvStruct (RSPtr recv_struct_ptr)+ return $ Left errno+ else+ if recv_res == 0+ then do+ freeRecvStruct (RSPtr recv_struct_ptr)+ return $ Left 0+ else do+ payload <- foreign FFI_C "idrnet_get_recv_payload"+ (Ptr -> IO String)+ recv_struct_ptr+ freeRecvStruct (RSPtr recv_struct_ptr)+ return $ Right (payload, recv_res)+ ||| Sends the data in a given memory location-sendBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)+|||+||| Returns on failure a `SocketError`+||| Returns on success the `ResultCode`+|||+||| @sock The socket on which to send the message.+||| @ptr The location containing the data to send.+||| @len How much of the data to send.+sendBuf : (sock : Socket)+ -> (ptr : BufPtr)+ -> (len : ByteLength)+ -> IO (Either SocketError ResultCode) sendBuf sock (BPtr ptr) len = do- send_res <- foreign FFI_C "idrnet_send_buf" (Int -> Ptr -> Int -> IO Int) (descriptor sock) ptr len- if send_res == (-1) then- map Left getErrno- else- return $ Right send_res+ send_res <- foreign FFI_C "idrnet_send_buf"+ (Int -> Ptr -> Int -> IO Int)+ (descriptor sock) ptr len -recvBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)+ if send_res == (-1)+ then map Left getErrno+ else return $ Right send_res++||| Receive data from a given memory location.+|||+||| Returns on failure a `SocketError`+||| Returns on success the `ResultCode`+|||+||| @sock The socket on which to receive the message.+||| @ptr The location containing the data to receive.+||| @len How much of the data to receive.+recvBuf : (sock : Socket)+ -> (ptr : BufPtr)+ -> (len : ByteLength)+ -> IO (Either SocketError ResultCode) recvBuf sock (BPtr ptr) len = do- recv_res <- foreign FFI_C "idrnet_recv_buf" (Int -> Ptr -> Int -> IO Int) (descriptor sock) ptr len- if (recv_res == (-1)) then- map Left getErrno- else- return $ Right recv_res+ recv_res <- foreign FFI_C "idrnet_recv_buf"+ (Int -> Ptr -> Int -> IO Int)+ (descriptor sock) ptr len + if (recv_res == (-1))+ then map Left getErrno+ else return $ Right recv_res++||| Send a message.+|||+||| Returns on failure a `SocketError`+||| Returns on success the `ResultCode`+|||+||| @sock The socket on which to send the message.+||| @addr Address of the recipient.+||| @port The port on which to send the message.+||| @msg The message to send. export-sendTo : Socket -> SocketAddress -> Port -> String -> IO (Either SocketError ByteLength)+sendTo : (sock : Socket)+ -> (addr : SocketAddress)+ -> (port : Port)+ -> (msg : String)+ -> IO (Either SocketError ByteLength) sendTo sock addr p dat = do sendto_res <- foreign FFI_C "idrnet_sendto" (Int -> String -> String -> Int -> Int -> IO Int) (descriptor sock) dat (show addr) p (toCode $ family sock)- if sendto_res == (-1) then- map Left getErrno- else- return $ Right sendto_res -sendToBuf : Socket -> SocketAddress -> Port -> BufPtr -> ByteLength -> IO (Either SocketError ByteLength)+ if sendto_res == (-1)+ then map Left getErrno+ else return $ Right sendto_res++||| Send a message stored in some buffer.+|||+||| Returns on failure a `SocketError`+||| Returns on success the `ResultCode`+|||+||| @sock The socket on which to send the message.+||| @addr Address of the recipient.+||| @port The port on which to send the message.+||| @ptr A Pointer to the buffer containing the message.+||| @len The size of the message.+sendToBuf : (sock : Socket)+ -> (addr : SocketAddress)+ -> (port : Port)+ -> (ptr : BufPtr)+ -> (len : ByteLength)+ -> IO (Either SocketError ResultCode) sendToBuf sock addr p (BPtr dat) len = do sendto_res <- foreign FFI_C "idrnet_sendto_buf" (Int -> Ptr -> Int -> String -> Int -> Int -> IO Int) (descriptor sock) dat len (show addr) p (toCode $ family sock)- if sendto_res == (-1) then- map Left getErrno- else- return $ Right sendto_res + if sendto_res == (-1)+ then map Left getErrno+ else return $ Right sendto_res++||| Utility function to get the payload of the sent message as a `String`. foreignGetRecvfromPayload : RecvfromStructPtr -> IO String-foreignGetRecvfromPayload (RFPtr p)- = foreign FFI_C "idrnet_get_recvfrom_payload" (Ptr -> IO String) p+foreignGetRecvfromPayload (RFPtr p) =+ foreign FFI_C "idrnet_get_recvfrom_payload"+ (Ptr -> IO String)+ p +||| Utility function to return senders socket address. foreignGetRecvfromAddr : RecvfromStructPtr -> IO SocketAddress foreignGetRecvfromAddr (RFPtr p) = do- sockaddr_ptr <- map SAPtr $ foreign FFI_C "idrnet_get_recvfrom_sockaddr" (Ptr -> IO Ptr) p+ sockaddr_ptr <- map SAPtr $ foreign FFI_C "idrnet_get_recvfrom_sockaddr"+ (Ptr -> IO Ptr)+ p getSockAddr sockaddr_ptr +||| Utility function to return sender's IPV4 port. foreignGetRecvfromPort : RecvfromStructPtr -> IO Port foreignGetRecvfromPort (RFPtr p) = do- sockaddr_ptr <- foreign FFI_C "idrnet_get_recvfrom_sockaddr" (Ptr -> IO Ptr) p- port <- foreign FFI_C "idrnet_sockaddr_ipv4_port" (Ptr -> IO Int) sockaddr_ptr+ sockaddr_ptr <- foreign FFI_C "idrnet_get_recvfrom_sockaddr"+ (Ptr -> IO Ptr)+ p+ port <- foreign FFI_C "idrnet_sockaddr_ipv4_port"+ (Ptr -> IO Int)+ sockaddr_ptr return port ++||| Receive a message.+|||+||| Returns on failure a `SocketError`.+||| Returns on success a triple of+||| + `UDPAddrInfo` :: The address of the sender.+||| + `String` :: The payload.+||| + `Int` :: Result value from underlying function.+|||+||| @sock The channel on which to receive.+||| @len Size of the expected message.+||| export-recvFrom : Socket -> ByteLength -> IO (Either SocketError (UDPAddrInfo, String, ByteLength))+recvFrom : (sock : Socket)+ -> (len : ByteLength)+ -> IO (Either SocketError (UDPAddrInfo, String, ResultCode)) recvFrom sock bl = do- recv_ptr <- foreign FFI_C "idrnet_recvfrom" (Int -> Int -> IO Ptr)+ recv_ptr <- foreign FFI_C "idrnet_recvfrom"+ (Int -> Int -> IO Ptr) (descriptor sock) bl+ let recv_ptr' = RFPtr recv_ptr- if !(nullPtr recv_ptr) then- map Left getErrno- else do- result <- foreign FFI_C "idrnet_get_recvfrom_res" (Ptr -> IO Int) recv_ptr- if result == -1 then do- freeRecvfromStruct recv_ptr'- map Left getErrno++ if !(nullPtr recv_ptr)+ then map Left getErrno else do- payload <- foreignGetRecvfromPayload recv_ptr'- port <- foreignGetRecvfromPort recv_ptr'- addr <- foreignGetRecvfromAddr recv_ptr'- freeRecvfromStruct recv_ptr'- return $ Right (MkUDPAddrInfo addr port, payload, result)+ result <- foreign FFI_C "idrnet_get_recvfrom_res"+ (Ptr -> IO Int)+ recv_ptr+ if result == -1+ then do+ freeRecvfromStruct recv_ptr'+ map Left getErrno+ else do+ payload <- foreignGetRecvfromPayload recv_ptr'+ port <- foreignGetRecvfromPort recv_ptr'+ addr <- foreignGetRecvfromAddr recv_ptr'+ freeRecvfromStruct recv_ptr'+ return $ Right (MkUDPAddrInfo addr port, payload, result) -recvFromBuf : Socket -> BufPtr -> ByteLength -> IO (Either SocketError (UDPAddrInfo, ByteLength))+||| Receive a message placed on a 'known' buffer.+|||+||| Returns on failure a `SocketError`.+||| Returns on success a pair of+||| + `UDPAddrInfo` :: The address of the sender.+||| + `Int` :: Result value from underlying function.+|||+||| @sock The channel on which to receive.+||| @ptr Pointer to the buffer to place the message.+||| @len Size of the expected message.+|||+recvFromBuf : (sock : Socket)+ -> (ptr : BufPtr)+ -> (len : ByteLength)+ -> IO (Either SocketError (UDPAddrInfo, ResultCode)) recvFromBuf sock (BPtr ptr) bl = do- recv_ptr <- foreign FFI_C "idrnet_recvfrom_buf" (Int -> Ptr -> Int -> IO Ptr) (descriptor sock) ptr bl+ recv_ptr <- foreign FFI_C "idrnet_recvfrom_buf"+ (Int -> Ptr -> Int -> IO Ptr)+ (descriptor sock) ptr bl+ let recv_ptr' = RFPtr recv_ptr- if !(nullPtr recv_ptr) then- map Left getErrno- else do- result <- foreign FFI_C "idrnet_get_recvfrom_res" (Ptr -> IO Int) recv_ptr- if result == -1 then do- freeRecvfromStruct recv_ptr'- map Left getErrno++ if !(nullPtr recv_ptr)+ then map Left getErrno else do- port <- foreignGetRecvfromPort recv_ptr'- addr <- foreignGetRecvfromAddr recv_ptr'- freeRecvfromStruct recv_ptr'- return $ Right (MkUDPAddrInfo addr port, result + 1)+ result <- foreign FFI_C "idrnet_get_recvfrom_res"+ (Ptr -> IO Int)+ recv_ptr+ if result == -1+ then do+ freeRecvfromStruct recv_ptr'+ map Left getErrno+ else do+ port <- foreignGetRecvfromPort recv_ptr'+ addr <- foreignGetRecvfromAddr recv_ptr'+ freeRecvfromStruct recv_ptr'+ return $ Right (MkUDPAddrInfo addr port, result + 1)++-- --------------------------------------------------------------------- [ EOF ]
libs/contrib/System/Concurrency/Process.idr view
@@ -38,8 +38,8 @@ ||| Returns whether the send was unsuccessful. export send : ProcID msg -> msg -> Process msg Bool-send (MkPID p) m = Lift (do x <- sendToThread p (prim__vm, m)- return (x == 1))+send (MkPID p) m = Lift (do x <- sendToThread p 0 (prim__vm, m)+ return (x /= 0)) ||| Return whether a message is waiting in the queue export@@ -49,7 +49,7 @@ ||| Return whether a message is waiting in the queue from a specific sender export msgWaitingFrom : ProcID msg -> Process msg Bool-msgWaitingFrom (MkPID p) = Lift (checkMsgsFrom p)+msgWaitingFrom (MkPID p) = Lift (checkMsgsFrom p 0) ||| Receive a message - blocks if there is no message waiting export@@ -60,12 +60,14 @@ get = getMsg ||| Receive a message from specific sender - blocks if there is no message waiting+||| Fails if the sender is no longer running export-recvFrom : ProcID msg -> Process msg msg-recvFrom (MkPID p) {msg} = do (senderid, m) <- Lift get- return m- where get : IO (Ptr, msg)- get = getMsgFrom p+recvFrom : ProcID msg -> Process msg (Maybe msg)+recvFrom (MkPID p) {msg} = do Just (senderid, m) <- Lift get+ | pure Nothing+ pure (Just m)+ where get : IO (Maybe (Ptr, msg))+ get = getMsgFrom p 0 ||| receive a message, and return with the sender's process ID. export
libs/effects/Effects.idr view
@@ -448,19 +448,19 @@ -- ----------------------------------------------- [ some higher order things ] -mapE : (a -> {xs} EffM m b) -> List a -> {xs} EffM m (List b)+mapE : (a -> EffM m b xs (\_ => xs)) -> List a -> EffM m (List b) xs (\_ => xs) mapE f [] = pure [] mapE f (x :: xs) = [| f x :: mapE f xs |] -mapVE : (a -> {xs} EffM m b) ->+mapVE : (a -> EffM m b xs (\_ => xs)) -> Vect n a ->- {xs} EffM m (Vect n b)+ EffM m (Vect n b) xs (\_ => xs) mapVE f [] = pure [] mapVE f (x :: xs) = [| f x :: mapVE f xs |] -when : Bool -> Lazy ({xs} EffM m ()) -> {xs} EffM m ()+when : Bool -> Lazy (EffM m () xs (\_ => xs)) -> EffM m () xs (\_ => xs) when True e = Force e when False e = pure ()
libs/effects/effects.ipkg view
@@ -1,6 +1,6 @@ package effects -opts = "--nobasepkgs -i ../prelude -i ../base"+opts = "--nobasepkgs --typeintype -i ../prelude -i ../base" modules = Effects , Effect.Default
libs/prelude/Builtins.idr view
@@ -132,6 +132,7 @@ ||| Lazily evaluated values. ||| At run time, the delayed value will only be computed when required by ||| a case split.+%error_reverse Lazy : Type -> Type Lazy t = Delayed LazyValue t @@ -139,6 +140,7 @@ ||| A value which may be infinite is accepted by the totality checker if ||| it appears under a data constructor. At run time, the delayed value will ||| only be computed when required by a case split.+%error_reverse Inf : Type -> Type Inf t = Delayed Infinite t @@ -170,17 +172,22 @@ assert_total : a -> a assert_total x = x +||| Assert to the totality checker that the case using this expression+||| is unreachable+assert_unreachable : a+-- compiled as primitive+ ||| Subvert the type checker. This function is abstract, so it will not reduce in ||| the type checker. Use it with care - it can result in segfaults or worse!-export %assert_total -- need to pretend+export believe_me : a -> b-believe_me x = prim__believe_me _ _ x+believe_me x = assert_total (prim__believe_me _ _ x) ||| Subvert the type checker. This function *will* reduce in the type checker. ||| Use it with extreme care - it can result in segfaults or worse!-public export %assert_total+public export really_believe_me : a -> b-really_believe_me x = prim__believe_me _ _ x+really_believe_me x = assert_total (prim__believe_me _ _ x) ||| Deprecated alias for `Double`, for the purpose of backwards ||| compatibility. Idris does not support 32 bit floats at present.
libs/prelude/Language/Reflection.idr view
@@ -573,7 +573,7 @@ data TTUExp = ||| Universe variable- UVar Int |+ UVar String Int | ||| Explicit universe level UVal Int %name TTUExp uexp@@ -1026,12 +1026,12 @@ implementation Quotable TTUExp TT where quotedTy = `(TTUExp)- quote (UVar x) = `(UVar ~(quote x))+ quote (UVar ns x) = `(UVar ~(quote ns) ~(quote x)) quote (UVal x) = `(UVal ~(quote x)) implementation Quotable TTUExp Raw where quotedTy = `(TTUExp)- quote (UVar x) = `(UVar ~(quote {t=Raw} x))+ quote (UVar ns x) = `(UVar ~(quote ns) ~(quote {t=Raw} x)) quote (UVal x) = `(UVal ~(quote {t=Raw} x)) implementation Quotable NativeTy TT where
libs/prelude/Language/Reflection/Errors.idr view
@@ -43,7 +43,7 @@ | NonCollapsiblePostulate TTName | AlreadyDefined TTName | ProofSearchFail Err- | NoRewriting TT+ | NoRewriting TT TT TT | ProviderError String | LoadingFailed String Err
libs/prelude/Prelude.idr view
@@ -130,6 +130,13 @@ pow x Z = 1 pow x (S n) = x * (pow x n) +-- XXX these should probably also go somewhere else (in an interface somewhere?)+shiftR : Int -> Int -> Int+shiftR = prim__ashrInt++shiftL : Int -> Int -> Int+shiftL = prim__shlInt+ ---- Ranges natRange : Nat -> List Nat
libs/prelude/Prelude/File.idr view
@@ -6,6 +6,7 @@ import Prelude.Monad import Prelude.Chars import Prelude.Strings+import Prelude.Nat import Prelude.Cast import Prelude.Bool import Prelude.Basics@@ -26,11 +27,12 @@ ||| An error from a file operation -- This is built in idris_mkFileError() in rts/idris_stdfgn.c. Make sure -- the values correspond!-data FileError = FileReadError+ +data FileError = GenericFileError Int -- errno+ | FileReadError | FileWriteError | FileNotFound | PermissionDenied- | GenericFileError Int -- errno private strError : Int -> String@@ -134,6 +136,22 @@ closeFile (FHandle h) = do_fclose h private+do_getFileSize : Ptr -> IO Int+do_getFileSize h = foreign FFI_C "fileSize" (Ptr -> IO Int) h++||| 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+ return (Left err)+ else return (Right s) ++private do_fread : Ptr -> IO' l String do_fread h = prim_fread h @@ -233,22 +251,28 @@ return (p > 0) ||| Read the contents of a file into a string--- might be reading something infinitely long like /dev/null ...-covering export-readFile : String -> IO (Either FileError String)+||| This checks the size of the file before beginning to read, and only+||| reads that many bytes, to ensure that it remains a total function if+||| the file is appended to while being read.+||| Returns an error if filepath is not a normal file.+export+readFile : (filepath : String) -> IO (Either FileError String) readFile fn = do Right h <- openFile fn Read | Left err => return (Left err)- c <- readFile' h ""+ Right max <- fileSize h+ | Left err => return (Left err)+ c <- readFile' h max "" closeFile h return c where- covering- readFile' : File -> String -> IO (Either FileError String)- readFile' h contents =+ readFile' : File -> Int -> String -> IO (Either FileError String)+ readFile' h max contents = do x <- fEOF h- if not x then do Right l <- fGetLine h+ if not x && max > 0+ then do Right l <- fGetLine h | Left err => return (Left err)- readFile' h (contents ++ l)+ assert_total $+ readFile' h (max - cast (length l)) (contents ++ l) else return (Right contents) ||| Write a string to a file
libs/prelude/Prelude/Foldable.idr view
@@ -9,9 +9,30 @@ %access public export %default total +||| The `Foldable` interface describes how you can iterate over the+||| elements in a parameterised type and combine the elements+||| together, using a provided function, into a single result.+|||+||| @t The type of the 'Foldable' parameterised type. interface Foldable (t : Type -> Type) where- foldr : (elem -> acc -> acc) -> acc -> t elem -> acc- foldl : (acc -> elem -> acc) -> acc -> t elem -> acc++ ||| Successivly combine the elements in a parameterised type using+ ||| the provided function, starting with the element that is in the+ ||| final position i.e. the right-most position.+ |||+ ||| @func The function used to 'fold' an element into the accumulated result.+ ||| @input The parameterised type.+ ||| @init The starting value the results are being combined into.+ foldr : (func : elem -> acc -> acc) -> (init : acc) -> (input : t elem) -> acc++ ||| The same as `foldr` but begins the folding from the element at+ ||| the initial position in the data structure i.e. the left-most+ ||| position.+ |||+ ||| @func The function used to 'fold' an element into the accumulated result.+ ||| @input The parameterised type.+ ||| @init The starting value the results are being combined into.+ foldl : (func : acc -> elem -> acc) -> (init : acc) -> (input : t elem) -> acc foldl f z t = foldr (flip (.) . flip f) id t z ||| Combine each element of a structure into a monoid
libs/prelude/Prelude/List.idr view
@@ -411,11 +411,10 @@ ||| transpose (transpose [[], [1, 2]]) = [[1, 2]] ||| ||| TODO: Solution which satisfies the totality checker?-%assert_total transpose : List (List a) -> List (List a) transpose [] = [] transpose ([] :: xss) = transpose xss-transpose ((x::xs) :: xss) = (x :: (mapMaybe head' xss)) :: (transpose (xs :: (map (drop 1) xss)))+transpose ((x::xs) :: xss) = assert_total $ (x :: (mapMaybe head' xss)) :: (transpose (xs :: (map (drop 1) xss))) -------------------------------------------------------------------------------- -- Membership tests
libs/prelude/Prelude/Stream.idr view
@@ -14,13 +14,13 @@ ||| An infinite stream data Stream : Type -> Type where- (::) : (e : a) -> Inf (Stream a) -> Stream a+ (::) : (value : elem) -> Inf (Stream elem) -> Stream elem -- Hints for interactive editing %name Stream xs,ys,zs,ws -- Usage hints for erasure analysis-%used Stream.(::) e+%used Stream.(::) value Functor Stream where map f (x::xs) = f x :: map f xs@@ -42,7 +42,6 @@ ||| Drop the first n elements from the stream ||| @ n how many elements to drop-%assert_total drop : (n : Nat) -> Stream a -> Stream a drop Z xs = xs drop (S k) (x::xs) = drop k xs
man/idris.1 view
@@ -1,6 +1,6 @@ .\" Manpage for Idris. .\" Contact <> to correct errors or typos.-.TH man 1 "25 March 2016" "0.11" "Idris man page"+.TH man 1 "25 March 2016" "0.12" "Idris man page" .SH NAME idris -\ a general purpose pure functional programming language with dependent types. .SH SYNOPSIS
rts/idris_rts.c view
@@ -44,6 +44,7 @@ memset(vm->inbox, 0, 1024*sizeof(VAL)); vm->inbox_end = vm->inbox + 1024; vm->inbox_write = vm->inbox;+ vm->inbox_nextid = 1; // The allocation lock must be reentrant. The lock exists to ensure that // no memory is allocated during the message sending process, but we also@@ -825,7 +826,7 @@ } // Add a message to another VM's message queue-int idris_sendMessage(VM* sender, VM* dest, VAL msg) {+int idris_sendMessage(VM* sender, int channel_id, VM* dest, VAL msg) { // FIXME: If GC kicks in in the middle of the copy, we're in trouble. // Probably best check there is enough room in advance. (How?) @@ -861,6 +862,14 @@ } dest->inbox_write->msg = dmsg;+ if (channel_id == 0) {+ // Set lowest bit to indicate this message is initiating a channel+ channel_id = 1 + ((dest->inbox_nextid++) << 1);+ } else {+ channel_id = channel_id << 1;+ }+ dest->inbox_write->channel_id = channel_id;+ dest->inbox_write->sender = sender; dest->inbox_write++; @@ -873,26 +882,39 @@ pthread_mutex_unlock(&(dest->inbox_lock)); // printf("Sending [unlock]...\n");- return 1;+ return channel_id >> 1; } VM* idris_checkMessages(VM* vm) {- return idris_checkMessagesFrom(vm, NULL);+ return idris_checkMessagesFrom(vm, 0, NULL); } -VM* idris_checkMessagesFrom(VM* vm, VM* sender) {+Msg* idris_checkInitMessages(VM* vm) { Msg* msg; for (msg = vm->inbox; msg < vm->inbox_end && msg->msg != NULL; ++msg) {+ if (msg->channel_id && 1 == 1) { // init bit set+ return msg;+ }+ }+ return 0;+}++VM* idris_checkMessagesFrom(VM* vm, int channel_id, VM* sender) {+ Msg* msg;++ for (msg = vm->inbox; msg < vm->inbox_end && msg->msg != NULL; ++msg) { if (sender == NULL || msg->sender == sender) {- return msg->sender;+ if (channel_id == 0 || channel_id == msg->channel_id >> 1) {+ return msg->sender;+ } } } return 0; } VM* idris_checkMessagesTimeout(VM* vm, int delay) {- VM* sender = idris_checkMessagesFrom(vm, NULL);+ VM* sender = idris_checkMessagesFrom(vm, 0, NULL); if (sender != NULL) { return sender; }@@ -910,16 +932,18 @@ (void)(status); //don't emit 'unused' warning pthread_mutex_unlock(&vm->inbox_block); - return idris_checkMessagesFrom(vm, NULL);+ return idris_checkMessagesFrom(vm, 0, NULL); } -Msg* idris_getMessageFrom(VM* vm, VM* sender) {+Msg* idris_getMessageFrom(VM* vm, int channel_id, VM* sender) { Msg* msg; for (msg = vm->inbox; msg < vm->inbox_write; ++msg) { if (sender == NULL || msg->sender == sender) {- return msg;+ if (channel_id == 0 || channel_id == msg->channel_id >> 1) {+ return msg;+ } } } return NULL;@@ -927,18 +951,20 @@ // block until there is a message in the queue Msg* idris_recvMessage(VM* vm) {- return idris_recvMessageFrom(vm, NULL);+ return idris_recvMessageFrom(vm, 0, NULL); } -Msg* idris_recvMessageFrom(VM* vm, VM* sender) {+Msg* idris_recvMessageFrom(VM* vm, int channel_id, VM* sender) { Msg* msg; Msg* ret = malloc(sizeof(Msg)); struct timespec timeout; int status;+ + if (sender && sender->active == 0) { return NULL; } // No VM to receive from pthread_mutex_lock(&vm->inbox_block);- msg = idris_getMessageFrom(vm, sender);+ msg = idris_getMessageFrom(vm, channel_id, sender); while (msg == NULL) { // printf("No message yet\n");@@ -949,7 +975,7 @@ &timeout); (void)(status); //don't emit 'unused' warning // printf("Waiting [unlock]... %d\n", status);- msg = idris_getMessageFrom(vm, sender);+ msg = idris_getMessageFrom(vm, channel_id, sender); } pthread_mutex_unlock(&vm->inbox_block); @@ -991,6 +1017,10 @@ VM* idris_getSender(Msg* msg) { return msg->sender;+}++int idris_getChannel(Msg* msg) {+ return msg->channel_id >> 1; } void idris_freeMsg(Msg* msg) {
rts/idris_rts.h view
@@ -76,6 +76,9 @@ struct Msg_t { struct VM* sender;+ // An identifier to say which conversation this message is part of.+ // Lowest bit is set if the id is the first message in a conversation.+ int channel_id; VAL msg; }; @@ -101,6 +104,7 @@ Msg* inbox; // Block of memory for storing messages Msg* inbox_end; // End of block of memory+ int inbox_nextid; // Next channel id Msg* inbox_write; // Location of next message to write int processes; // Number of child processes@@ -310,23 +314,27 @@ VAL copyTo(VM* newVM, VAL x); // Add a message to another VM's message queue-int idris_sendMessage(VM* sender, VM* dest, VAL msg);+int idris_sendMessage(VM* sender, int channel_id, VM* dest, VAL msg); // Check whether there are any messages in the queue and return PID of // sender if so (null if not) VM* idris_checkMessages(VM* vm);+// Check whether there are any messages which are initiating a conversation+// in the queue and return the message if so (without removing it)+Msg* idris_checkInitMessages(VM* vm); // Check whether there are any messages in the queue-VM* idris_checkMessagesFrom(VM* vm, VM* sender);+VM* idris_checkMessagesFrom(VM* vm, int channel_id, VM* sender); // Check whether there are any messages in the queue, and wait if not VM* idris_checkMessagesTimeout(VM* vm, int timeout); // block until there is a message in the queue Msg* idris_recvMessage(VM* vm); // block until there is a message in the queue-Msg* idris_recvMessageFrom(VM* vm, VM* sender);+Msg* idris_recvMessageFrom(VM* vm, int channel_id, VM* sender); // Query/free structure used to return message data (recvMessage will malloc, // so needs an explicit free) VAL idris_getMsg(Msg* msg); VM* idris_getSender(Msg* msg);+int idris_getChannel(Msg* msg); void idris_freeMsg(Msg* msg); void dumpVal(VAL r);
rts/idris_stdfgn.c view
@@ -5,6 +5,7 @@ #include <fcntl.h> #include <errno.h>+#include <sys/stat.h> #include <stdio.h> #include <time.h> @@ -40,6 +41,18 @@ return ferror(f); } +int fileSize(void* h) {+ FILE* f = (FILE*)h;+ int fd = fileno(f);++ struct stat buf;+ if (fstat(fd, &buf) == 0) {+ return (int)(buf.st_size);+ } else {+ return -1;+ }+}+ int idris_writeStr(void* h, char* str) { FILE* f = (FILE*)h; if (fputs(str, f)) {@@ -103,13 +116,13 @@ // Make sure this corresponds to the FileError structure in // Prelude.File case ENOENT:- idris_constructor(result, vm, 2, 0, 0);+ idris_constructor(result, vm, 3, 0, 0); break; case EACCES:- idris_constructor(result, vm, 3, 0, 0);+ idris_constructor(result, vm, 4, 0, 0); break; default:- idris_constructor(result, vm, 4, 1, 0);+ idris_constructor(result, vm, 0, 1, 0); idris_setConArg(result, 0, MKINT((intptr_t)errno)); break; }
rts/idris_stdfgn.h view
@@ -12,6 +12,9 @@ void fileClose(void* h); int fileEOF(void* h); int fileError(void* h);+// Returns a negative number if not a file (e.g. directory or device)+int fileSize(void* h);+ // return 0 on success int idris_writeStr(void*h, char* str); // construct a file error structure (see Prelude.File) from errno@@ -19,6 +22,7 @@ void* do_popen(const char* cmd, const char* mode); int fpoll(void* h);+ int idris_eqPtr(void* x, void* y); int isNull(void* ptr);
src/IRTS/BCImp.hs view
@@ -1,7 +1,11 @@+{-|+Module : IRTS.BCImp+Description : Bytecode for a register/variable based VM (e.g. for generating code in an imperative language where we let the language deal with GC)+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module IRTS.BCImp where---- Bytecode for a register/variable based VM (e.g. for generating code in an--- imperative language where we let the language deal with GC) import IRTS.Lang import IRTS.Simplified
src/IRTS/Bytecode.hs view
@@ -1,16 +1,12 @@-module IRTS.Bytecode where+{-|+Module : IRTS.Bytecode+Description : Bytecode for a stack based VM (e.g. for generating C code with an accurate hand written GC) --- Bytecode for a stack based VM (e.g. for generating C code with an accurate--- hand written GC)+Copyright :+License : BSD3+Maintainer : The Idris Community. -import IRTS.Lang-import IRTS.Simplified-import IRTS.Defunctionalise-import Idris.Core.TT-import Data.Maybe -{- We have:- BASE: Current stack frame's base TOP: Top of stack OLDBASE: Passed in to each function, the previous stack frame's base@@ -22,27 +18,35 @@ returns) are stored. -}+module IRTS.Bytecode where ++import IRTS.Lang+import IRTS.Simplified+import IRTS.Defunctionalise+import Idris.Core.TT+import Data.Maybe+ data Reg = RVal | L Int | T Int | Tmp deriving (Show, Eq) -data BC = - -- reg1 = reg2+data BC =+ -- | reg1 = reg2 ASSIGN Reg Reg - -- reg = const+ -- | reg = const | ASSIGNCONST Reg Const - -- reg1 = reg2 (same as assign, it seems)+ -- | reg1 = reg2 (same as assign, it seems) | UPDATE Reg Reg - -- reg = constructor, where constructor consists of a tag and+ -- | reg = constructor, where constructor consists of a tag and -- values from registers, e.g. (cons tag args) -- the 'Maybe Reg', if set, is a register which can be overwritten -- (i.e. safe for mutable update), though this can be ignored | MKCON Reg (Maybe Reg) Int [Reg] - -- Matching on value of reg: usually (but not always) there are+ -- | Matching on value of reg: usually (but not always) there are -- constructors, hence "Int" for patterns (that's a tag on which -- we should match), and the following [BC] is just a list of -- instructions for the corresponding case. The last argument is@@ -53,57 +57,57 @@ | CASE Bool Reg [(Int, [BC])] (Maybe [BC]) - -- get a value from register, which should be a constructor, and+ -- | get a value from register, which should be a constructor, and -- put its arguments into the stack, starting from (base + int1) -- and onwards; second Int provides arity | PROJECT Reg Int Int - -- probably not used+ -- | probably not used | PROJECTINTO Reg Reg Int -- project argument from one reg into another - -- same as CASE, but there's an exact value (not constructor) in reg+ -- | same as CASE, but there's an exact value (not constructor) in reg | CONSTCASE Reg [(Const, [BC])] (Maybe [BC]) - -- just call a function, passing MYOLDBASE (see below) to it+ -- | just call a function, passing MYOLDBASE (see below) to it | CALL Name - -- same, perhaps exists just for TCO+ -- | same, perhaps exists just for TCO | TAILCALL Name - -- set reg to (apply string args), + -- | set reg to (apply string args), | FOREIGNCALL Reg FDesc FDesc [(FDesc, Reg)] - -- move this number of elements from TOP to BASE+ -- | move this number of elements from TOP to BASE | SLIDE Int - -- set BASE = OLDBASE+ -- | set BASE = OLDBASE | REBASE - -- reserve n more stack items (i.e. check there's space, grow if+ -- | reserve n more stack items (i.e. check there's space, grow if -- necessary) | RESERVE Int - -- move the top of stack up+ -- | move the top of stack up | ADDTOP Int - -- set TOP = BASE + n+ -- | set TOP = BASE + n | TOPBASE Int - -- set BASE = TOP + n+ -- | set BASE = TOP + n | BASETOP Int - -- set MYOLDBASE = BASE, where MYOLDBASE is a function-local+ -- | set MYOLDBASE = BASE, where MYOLDBASE is a function-local -- variable, set to OLDBASE by default, and passed on function -- call to called functions as their OLDBASE | STOREOLD - -- reg = apply primitive_function args+ -- | reg = apply primitive_function args | OP Reg PrimFn [Reg] - -- clear reg+ -- | clear reg | NULL Reg - -- throw an error+ -- | throw an error | ERROR String deriving Show @@ -138,7 +142,7 @@ bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg] ++ clean r -- bc reg (SUpdate x sc) r = bc reg sc r -- can't update, just do it-bc reg (SCon atloc i _ vs) r +bc reg (SCon atloc i _ vs) r = MKCON reg (getAllocLoc atloc) i (map getL vs) : clean r where getL (Loc x) = L x getAllocLoc (Just (Loc x)) = Just (L x)@@ -184,5 +188,3 @@ defaultAlt reg [] r = Nothing defaultAlt reg (SDefaultCase e : _) r = Just (bc reg e r) defaultAlt reg (_ : xs) r = defaultAlt reg xs r--
src/IRTS/CodegenC.hs view
@@ -1,3 +1,10 @@+{-|+Module : IRTS.CodegenC+Description : The default code generator for Idris, generating C code.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module IRTS.CodegenC (codegenC) where import Idris.AbsSyntax@@ -41,17 +48,17 @@ where mkLib l = "-l" ++ l incdir i = "-I" ++ i -codegenC' :: [(Name, SDecl)] ->- String -> -- output file name- OutputType -> -- generate executable if True, only .o if False- [FilePath] -> -- include files- [String] -> -- extra object files- [String] -> -- extra compiler flags (libraries)- [String] -> -- extra compiler flags (anything)- [ExportIFace] ->- Bool -> -- interfaces too (so make a .o instead)- DbgLevel ->- IO ()+codegenC' :: [(Name, SDecl)]+ -> String -- ^ output file name+ -> OutputType -- ^ generate executable if True, only .o if False+ -> [FilePath] -- ^ include files+ -> [String] -- ^ extra object files+ -> [String] -- ^ extra compiler flags (libraries)+ -> [String] -- ^ extra compiler flags (anything)+ -> [ExportIFace]+ -> Bool -- ^ interfaces too (so make a .o instead)+ -> DbgLevel+ -> IO () codegenC' defs out exec incs objs libs flags exports iface dbg = do -- print defs let bc = map toBC defs@@ -801,7 +808,7 @@ genWrapper :: (FDesc, Int) -> String genWrapper (desc, tag) | (toFType desc) == FFunctionIO =- error $ "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"+ error "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n" genWrapper (desc, tag) = ret ++ " " ++ wrapperName tag ++ "(" ++ renderArgs argList ++")\n" ++ "{\n" ++
src/IRTS/CodegenCommon.hs view
@@ -1,3 +1,10 @@+{-|+Module : IRTS.CodegenCommon+Description : Common data structures required for all code generators.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module IRTS.CodegenCommon where import Idris.Core.TT@@ -7,25 +14,28 @@ data DbgLevel = NONE | DEBUG | TRACE deriving Eq data OutputType = Raw | Object | Executable deriving (Eq, Show) --- Everything which might be needed in a code generator - a CG can choose which--- level of Decls to generate code from (simplified, defunctionalised or merely--- lambda lifted) and has access to the list of object files, libraries, etc.+-- | Everything which might be needed in a code generator.+--+-- A CG can choose which level of Decls to generate code from+-- (simplified, defunctionalised or merely lambda lifted) and has+-- access to the list of object files, libraries, etc. -data CodegenInfo = CodegenInfo { outputFile :: String,- outputType :: OutputType,- targetTriple :: String,- targetCPU :: String,- includes :: [FilePath],- importDirs :: [FilePath],- compileObjs :: [String],- compileLibs :: [String],- compilerFlags :: [String],- debugLevel :: DbgLevel,- simpleDecls :: [(Name, SDecl)],- defunDecls :: [(Name, DDecl)],- liftDecls :: [(Name, LDecl)],- interfaces :: Bool,- exportDecls :: [ExportIFace]- }+data CodegenInfo = CodegenInfo {+ outputFile :: String+ , outputType :: OutputType+ , targetTriple :: String+ , targetCPU :: String+ , includes :: [FilePath]+ , importDirs :: [FilePath]+ , compileObjs :: [String]+ , compileLibs :: [String]+ , compilerFlags :: [String]+ , debugLevel :: DbgLevel+ , simpleDecls :: [(Name, SDecl)]+ , defunDecls :: [(Name, DDecl)]+ , liftDecls :: [(Name, LDecl)]+ , interfaces :: Bool+ , exportDecls :: [ExportIFace]+ } type CodeGenerator = CodegenInfo -> IO ()
src/IRTS/CodegenJavaScript.hs view
@@ -1,6 +1,16 @@+{-|+Module : IRTS.CodegenJavaScript+Description : The JavaScript code generator.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-}-module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where+module IRTS.CodegenJavaScript (codegenJavaScript+ , codegenNode+ , JSTarget(..)+ ) where import IRTS.JavaScript.AST
src/IRTS/Compiler.hs view
@@ -1,3 +1,10 @@+{-|+Module : IRTS.Compiler+Description : Coordinates the compilation process.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards, TypeSynonymInstances, CPP #-} module IRTS.Compiler(compile, generate) where@@ -32,13 +39,15 @@ import Control.Applicative import Control.Monad.State-import Data.Maybe-import Data.List-import Data.Ord-import Data.IntSet (IntSet)-import qualified Data.IntSet as IS-import qualified Data.Map as M-import qualified Data.Set as S++import Data.Maybe+import Data.List+import Data.Ord+import Data.IntSet (IntSet)+import qualified Data.IntSet as IS+import qualified Data.Map as M+import qualified Data.Set as S+ import System.Process import System.IO import System.Exit@@ -145,7 +154,7 @@ irMain :: TT Name -> Idris LDecl irMain tm = do- i <- irTerm M.empty [] tm+ i <- irTerm (sMN 0 "runMain") M.empty [] tm return $ LFun [] (sMN 0 "runMain") [] (LForce i) mkDecls :: [Name] -> Idris [(Name, LDecl)]@@ -209,10 +218,10 @@ declArgs args inl n x = LFun (if inl then [Inline] else []) n args x mkLDecl n (Function tm _)- = declArgs [] True n <$> irTerm M.empty [] tm+ = declArgs [] True n <$> irTerm n M.empty [] tm mkLDecl n (CaseOp ci _ _ _ pats cd)- = declArgs [] (case_inlinable ci || caseName n) n <$> irTree args sc+ = declArgs [] (case_inlinable ci || caseName n) n <$> irTree n args sc where (args, sc) = cases_runtime cd @@ -235,8 +244,8 @@ type Vars = M.Map Name VarInfo -irTerm :: Vars -> [Name] -> Term -> Idris LExp-irTerm vs env tm@(App _ f a) = do+irTerm :: Name -> Vars -> [Name] -> Term -> Idris LExp+irTerm top vs env tm@(App _ f a) = do ist <- getIState case unApply tm of (P _ n _, args)@@ -248,12 +257,16 @@ (P _ (UN u) _, [_, arg]) | u == txt "unsafePerformPrimIO"- -> irTerm vs env arg+ -> irTerm top vs env arg + (P _ (UN u) _, _)+ | u == txt "assert_unreachable"+ -> return $ LError $ "ABORT: Reached an unreachable case in " ++ show top+ -- TMP HACK - until we get inlining. (P _ (UN r) _, [_, _, _, _, _, arg]) | r == txt "replace"- -> irTerm vs env arg+ -> irTerm top vs env arg -- 'void' doesn't have any pattern clauses and only gets called on -- erased things in higher order contexts (also a TMP HACK...)@@ -268,42 +281,42 @@ (P _ (UN l) _, [_, arg]) | l == txt "force"- -> LForce <$> irTerm vs env arg+ -> LForce <$> irTerm top vs env arg -- Laziness, the new way (P _ (UN l) _, [_, _, arg]) | l == txt "Delay"- -> LLazyExp <$> irTerm vs env arg+ -> LLazyExp <$> irTerm top vs env arg (P _ (UN l) _, [_, _, arg]) | l == txt "Force"- -> LForce <$> irTerm vs env arg+ -> LForce <$> irTerm top vs env arg (P _ (UN a) _, [_, _, _, arg]) | a == txt "assert_smaller"- -> irTerm vs env arg+ -> irTerm top vs env arg (P _ (UN a) _, [_, arg]) | a == txt "assert_total"- -> irTerm vs env arg+ -> irTerm top vs env arg (P _ (UN p) _, [_, arg]) | p == txt "par"- -> do arg' <- irTerm vs env arg+ -> do arg' <- irTerm top vs env arg return $ LOp LPar [LLazyExp arg'] (P _ (UN pf) _, [arg]) | pf == txt "prim_fork"- -> do arg' <- irTerm vs env arg+ -> do arg' <- irTerm top vs env arg return $ LOp LFork [LLazyExp arg'] (P _ (UN m) _, [_,size,t]) | m == txt "malloc"- -> irTerm vs env t+ -> irTerm top vs env t (P _ (UN tm) _, [_,t]) | tm == txt "trace_malloc"- -> irTerm vs env t -- TODO+ -> irTerm top vs env t -- TODO -- This case is here until we get more general inlining. It's just -- a really common case, and the laziness hurts...@@ -315,9 +328,9 @@ , b == txt "Bool" , p == txt "Prelude" -> do- x' <- irTerm vs env x- t' <- irTerm vs env t- e' <- irTerm vs env e+ x' <- irTerm top vs env x+ t' <- irTerm top vs env t+ e' <- irTerm top vs env e return (LCase Shared x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e' ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'@@ -366,7 +379,7 @@ -- exactly saturated EQ | isNewtype- -> irTerm vs env (head argsPruned)+ -> irTerm top vs env (head argsPruned) | otherwise -- not newtype, plain data ctor -> buildApp (LV $ Glob n) argsPruned@@ -375,7 +388,7 @@ LT | isNewtype -- newtype , length argsPruned == 1 -- and we already have the value -> padLams . (\tm [] -> tm) -- the [] asserts there are no unerased args- <$> irTerm vs env (head argsPruned)+ <$> irTerm top vs env (head argsPruned) | isNewtype -- newtype but the value is not among args yet -> return . padLams $ \[vn] -> LApp False (LV $ Glob n) [LV $ Glob vn]@@ -389,7 +402,7 @@ -- an external name applied to arguments (P _ n _, args) | S.member (n, length args) (idris_externs ist) -> do- LOp (LExternal n) <$> mapM (irTerm vs env) args+ LOp (LExternal n) <$> mapM (irTerm top vs env) args -- a name applied to arguments (P _ n _, args) -> do@@ -397,23 +410,23 @@ -- if it's a primitive that is already saturated, -- compile to the corresponding op here already to save work Just (arity, op) | length args == arity- -> LOp op <$> mapM (irTerm vs env) args+ -> LOp op <$> mapM (irTerm top vs env) args -- otherwise, just apply the name _ -> applyName n ist args -- turn de bruijn vars into regular named references and try again- (V i, args) -> irTerm vs env $ mkApp (P Bound (env !! i) Erased) args+ (V i, args) -> irTerm top vs env $ mkApp (P Bound (env !! i) Erased) args (f, args) -> LApp False- <$> irTerm vs env f- <*> mapM (irTerm vs env) args+ <$> irTerm top vs env f+ <*> mapM (irTerm top vs env) args where buildApp :: LExp -> [Term] -> Idris LExp buildApp e [] = return e- buildApp e xs = LApp False e <$> mapM (irTerm vs env) xs+ buildApp e xs = LApp False e <$> mapM (irTerm top vs env) xs applyToNames :: LExp -> [Name] -> LExp applyToNames tm [] = tm@@ -428,7 +441,7 @@ applyName :: Name -> IState -> [Term] -> Idris LExp applyName n ist args =- LApp False (LV $ Glob n) <$> mapM (irTerm vs env . erase) (zip [0..] args)+ LApp False (LV $ Glob n) <$> mapM (irTerm top vs env . erase) (zip [0..] args) where erase (i, x) | i >= arity || i `elem` used = x@@ -450,31 +463,31 @@ used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist) fst4 (x,_,_,_,_) = x -irTerm vs env (P _ n _) = return $ LV (Glob n)-irTerm vs env (V i)+irTerm top vs env (P _ n _) = return $ LV (Glob n)+irTerm top vs env (V i) | i >= 0 && i < length env = return $ LV (Glob (env!!i)) | otherwise = ifail $ "bad de bruijn index: " ++ show i -irTerm vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm vs (n':env) sc+irTerm top vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm top vs (n':env) sc where n' = uniqueName n env -irTerm vs env (Bind n (Let _ v) sc)- = LLet n <$> irTerm vs env v <*> irTerm vs (n : env) sc+irTerm top vs env (Bind n (Let _ v) sc)+ = LLet n <$> irTerm top vs env v <*> irTerm top vs (n : env) sc -irTerm vs env (Bind _ _ _) = return $ LNothing+irTerm top vs env (Bind _ _ _) = return $ LNothing -irTerm vs env (Proj t (-1)) = do- t' <- irTerm vs env t+irTerm top vs env (Proj t (-1)) = do+ t' <- irTerm top vs env t return $ LOp (LMinus (ATInt ITBig)) [t', LConst (BI 1)] -irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i-irTerm vs env (Constant TheWorld) = return $ LNothing-irTerm vs env (Constant c) = return $ LConst c-irTerm vs env (TType _) = return $ LNothing-irTerm vs env Erased = return $ LNothing-irTerm vs env Impossible = return $ LNothing+irTerm top vs env (Proj t i) = LProj <$> irTerm top vs env t <*> pure i+irTerm top vs env (Constant TheWorld) = return LNothing+irTerm top vs env (Constant c) = return (LConst c)+irTerm top vs env (TType _) = return LNothing+irTerm top vs env Erased = return LNothing+irTerm top vs env Impossible = return LNothing doForeign :: Vars -> [Name] -> [Term] -> Idris LExp doForeign vs env (ret : fname : world : args)@@ -485,9 +498,9 @@ where splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits = do let l' = toFDesc l- r' <- irTerm vs env r+ r' <- irTerm (sMN 0 "__foreignCall") vs env r return (l', r')- splitArg _ = ifail $ "Badly formed foreign function call"+ splitArg _ = ifail "Badly formed foreign function call" toFDesc (Constant (Str str)) = FStr str toFDesc tm@@ -499,24 +512,24 @@ deNS n = n doForeign vs env xs = ifail "Badly formed foreign function call" -irTree :: [Name] -> SC -> Idris LExp-irTree args tree = do+irTree :: Name -> [Name] -> SC -> Idris LExp+irTree top args tree = do logCodeGen 3 $ "Compiling " ++ show args ++ "\n" ++ show tree- LLam args <$> irSC M.empty tree+ LLam args <$> irSC top M.empty tree -irSC :: Vars -> SC -> Idris LExp-irSC vs (STerm t) = irTerm vs [] t-irSC vs (UnmatchedCase str) = return $ LError str+irSC :: Name -> Vars -> SC -> Idris LExp+irSC top vs (STerm t) = irTerm top vs [] t+irSC top vs (UnmatchedCase str) = return $ LError str -irSC vs (ProjCase tm alts) = do- tm' <- irTerm vs [] tm- alts' <- mapM (irAlt vs tm') alts+irSC top vs (ProjCase tm alts) = do+ tm' <- irTerm top vs [] tm+ alts' <- mapM (irAlt top vs tm') alts return $ LCase Shared tm' alts' -- Transform matching on Delay to applications of Force.-irSC vs (Case up n [ConCase (UN delay) i [_, _, n'] sc])+irSC top vs (Case up n [ConCase (UN delay) i [_, _, n'] sc]) | delay == txt "Delay"- = do sc' <- irSC vs $ mkForce n' n sc+ = do sc' <- irSC top vs $ mkForce n' n sc return $ LLet n' (LForce (LV (Glob n))) sc' -- There are two transformations in this case:@@ -541,7 +554,7 @@ -- Hence, we check whether the variables are used at all -- and erase the casesplit if they are not. ---irSC vs (Case up n [alt]) = do+irSC top vs (Case up n [alt]) = do replacement <- case alt of ConCase cn a ns sc -> do detag <- fgetState (opt_detaggable . ist_optimisation cn)@@ -552,9 +565,9 @@ _ -> return Nothing case replacement of- Just sc -> irSC vs sc+ Just sc -> irSC top vs sc _ -> do- alt' <- irAlt vs (LV (Glob n)) alt+ alt' <- irAlt top vs (LV (Glob n)) alt return $ case namesBoundIn alt' `usedIn` subexpr alt' of [] -> subexpr alt' -- strip the unused top-most case _ -> LCase up (LV (Glob n)) [alt']@@ -585,13 +598,13 @@ -- This work-around is not entirely optimal; the best approach would be -- to ensure that such case trees don't arise in the first place. ---irSC vs (Case up n alts@[ConCase cn a ns sc, DefaultCase sc']) = do+irSC top vs (Case up n alts@[ConCase cn a ns sc, DefaultCase sc']) = do detag <- fgetState (opt_detaggable . ist_optimisation cn) if detag- then irSC vs (Case up n [ConCase cn a ns sc])- else LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts+ then irSC top vs (Case up n [ConCase cn a ns sc])+ else LCase up (LV (Glob n)) <$> mapM (irAlt top vs (LV (Glob n))) alts -irSC vs sc@(Case up n alts) = do+irSC top vs sc@(Case up n alts) = do -- check that neither alternative needs the newtype optimisation, -- see comment above goneWrong <- or <$> mapM isDetaggable alts@@ -599,20 +612,20 @@ $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc) -- everything okay- LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts+ LCase up (LV (Glob n)) <$> mapM (irAlt top vs (LV (Glob n))) alts where isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn isDetaggable _ = return False -irSC vs ImpossibleCase = return LNothing+irSC top vs ImpossibleCase = return LNothing -irAlt :: Vars -> LExp -> CaseAlt -> Idris LAlt+irAlt :: Name -> Vars -> LExp -> CaseAlt -> Idris LAlt -- this leaves out all unused arguments of the constructor-irAlt vs _ (ConCase n t args sc) = do+irAlt top vs _ (ConCase n t args sc) = do used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n) let usedArgs = [a | (i,a) <- zip [0..] args, i `elem` used]- LConCase (-1) n usedArgs <$> irSC (methodVars `M.union` vs) sc+ LConCase (-1) n usedArgs <$> irSC top (methodVars `M.union` vs) sc where methodVars = case n of SN (InstanceCtorN className)@@ -622,9 +635,9 @@ _ -> M.empty -- not an instance constructor -irAlt vs _ (ConstCase x rhs)- | matchable x = LConstCase x <$> irSC vs rhs- | matchableTy x = LDefaultCase <$> irSC vs rhs+irAlt top vs _ (ConstCase x rhs)+ | matchable x = LConstCase x <$> irSC top vs rhs+ | matchableTy x = LDefaultCase <$> irSC top vs rhs where matchable (I _) = True matchable (BI _) = True@@ -648,14 +661,14 @@ matchableTy _ = False -irAlt vs tm (SucCase n rhs) = do- rhs' <- irSC vs rhs+irAlt top vs tm (SucCase n rhs) = do+ rhs' <- irSC top vs rhs return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig)) [tm, LConst (BI 1)]) rhs') -irAlt vs _ (ConstCase c rhs)+irAlt top vs _ (ConstCase c rhs) = ifail $ "Can't match on (" ++ show c ++ ")" -irAlt vs _ (DefaultCase rhs)- = LDefaultCase <$> irSC vs rhs+irAlt top vs _ (DefaultCase rhs)+ = LDefaultCase <$> irSC top vs rhs
src/IRTS/Defunctionalise.hs view
@@ -1,8 +1,29 @@-{-# LANGUAGE PatternGuards #-}+{-|+Module : IRTS.Defunctionalise+Description : Defunctionalise Idris' IR.+Copyright :+License : BSD3+Maintainer : The Idris Community. -module IRTS.Defunctionalise(module IRTS.Defunctionalise,- module IRTS.Lang) where+To defunctionalise: +1. Create a data constructor for each function+2. Create a data constructor for each underapplication of a function+3. Convert underapplications to their corresponding constructors+4. Create an EVAL function which calls the appropriate function for data constructors+ created as part of step 1+5. Create an APPLY function which adds an argument to each underapplication (or calls+ APPLY again for an exact application)+6. Wrap overapplications in chains of APPLY+7. Wrap unknown applications (i.e. applications of local variables) in chains of APPLY+8. Add explicit EVAL to case, primitives, and foreign calls++-}+{-# LANGUAGE PatternGuards #-}+module IRTS.Defunctionalise(module IRTS.Defunctionalise+ , module IRTS.Lang+ ) where+ import IRTS.Lang import Idris.Core.TT import Idris.Core.CaseTree@@ -61,19 +82,6 @@ where fnData (n, LFun _ _ args _) = Just (n, length args) fnData _ = Nothing --- To defunctionalise:------ 1 Create a data constructor for each function--- 2 Create a data constructor for each underapplication of a function--- 3 Convert underapplications to their corresponding constructors--- 4 Create an EVAL function which calls the appropriate function for data constructors--- created as part of step 1--- 5 Create an APPLY function which adds an argument to each underapplication (or calls--- APPLY again for an exact application)--- 6 Wrap overapplications in chains of APPLY--- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY--- 8 Add explicit EVAL to case, primitives, and foreign calls- addApps :: LDefs -> (Name, LDecl) -> State ([Name], [(Name, Int)]) (Name, DDecl) addApps defs o@(n, LConstructor _ t a) = return (n, DConstructor n t a)@@ -111,7 +119,7 @@ alts' <- mapM (aaAlt env) alts return $ DCase up e' alts' aa env (LConst c) = return $ DConst c- aa env (LForeign t n args) + aa env (LForeign t n args) = do args' <- mapM (aaF env) args return $ DForeign t n args' aa env (LOp LFork args) = liftM (DOp LFork) (mapM (aa env) args)@@ -133,7 +141,7 @@ = return $ DApp tc n args | length args < ar = do (ens, ans) <- get- let alln = map (\x -> (n, x)) [length args .. ar] + let alln = map (\x -> (n, x)) [length args .. ar] put (ens, alln ++ ans) return $ DApp tc (mkUnderCon n (ar - length args)) args | length args > ar@@ -146,14 +154,14 @@ return $ DApp False (mkFnCon n) args | length args < ar = do (ens, ans) <- get- let alln = map (\x -> (n, x)) [length args .. ar] + let alln = map (\x -> (n, x)) [length args .. ar] put (ens, alln ++ ans) return $ DApp False (mkUnderCon n (ar - length args)) args | length args > ar = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args) chainAPPLY f [] = f--- chainAPPLY f (a : b : as) +-- chainAPPLY f (a : b : as) -- = chainAPPLY (DApp False (sMN 0 "APPLY2") [f, a, b]) as chainAPPLY f (a : as) = chainAPPLY (DApp False (sMN 0 "APPLY") [f, a]) as @@ -223,7 +231,7 @@ (DApp False (mkUnderCon fname (ar - (n + 1))) (map (DV . Glob) (take n (genArgs 0) ++ [sMN 0 "arg"])))))- : + : if (ar - (n + 2) >=0 ) then (nm, n, Apply2Case (DConCase (-1) nm (take n (genArgs 0)) (DApp False (mkUnderCon fname (ar - (n + 2)))@@ -263,7 +271,7 @@ mkBigCase (sMN 0 "APPLY") 256 (DV (Glob (sMN 0 "fn"))) (cases ++- [DDefaultCase + [DDefaultCase (DApp False (sMN 0 "APPLY") [DApp False (sMN 0 "APPLY") [DV (Glob (sMN 0 "fn")),@@ -320,9 +328,8 @@ showAlt env (DConstCase c e) = show c ++ " => " ++ show' env e showAlt env (DDefaultCase e) = "_ => " ++ show' env e --- Divide up a large case expression so that each has a maximum of+-- | Divide up a large case expression so that each has a maximum of -- 'max' branches- mkBigCase cn max arg branches | length branches <= max = DChkCase arg branches | otherwise = -- DChkCase arg branches -- until I think of something...@@ -368,5 +375,3 @@ = show fn ++ "(" ++ showSep ", " (map show args) ++ ") = \n\t" ++ show exp ++ "\n" showDef (x, DConstructor n t a) = "Constructor " ++ show n ++ " " ++ show t--
src/IRTS/DumpBC.hs view
@@ -1,3 +1,10 @@+{-|+Module : IRTS.DumpBC+Description : Serialise Idris to its IBC format.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module IRTS.DumpBC where import IRTS.Lang
src/IRTS/Exports.hs view
@@ -1,3 +1,10 @@+{-|+Module : IRTS.Exports+Description : Deal with external things.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module IRTS.Exports(findExports, getExpNames) where
src/IRTS/Inliner.hs view
@@ -1,3 +1,10 @@+{-|+Module : IRTS.Inliner+Description : Inline expressions.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module IRTS.Inliner where import Idris.Core.TT@@ -19,4 +26,3 @@ evalD _ e = ev e where ev e = Just e-
src/IRTS/JavaScript/AST.hs view
@@ -1,3 +1,10 @@+{-|+Module : IRTS.JavaScript.AST+Description : Data structures and functions used with the JavaScript codegen.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} module IRTS.JavaScript.AST where@@ -92,7 +99,7 @@ where ffiParse :: String -> [FFI] ffiParse "" = []- ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]+ ffiParse ['%'] = [FFIError "FFI - Invalid positional argument"] ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss ffiParse ('%':s:ss) | isDigit s =
src/IRTS/Lang.hs view
@@ -1,3 +1,10 @@+{-|+Module : IRTS.Lang+Description : Internal representation of Idris' constructs.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards, DeriveFunctor #-} module IRTS.Lang where@@ -19,19 +26,19 @@ -- ASSUMPTION: All variable bindings have unique names here -- Constructors commented as lifted are not present in the LIR provided to the different backends. data LExp = LV LVar- | LApp Bool LExp [LExp] -- True = tail call- | LLazyApp Name [LExp] -- True = tail call- | LLazyExp LExp -- lifted out before compiling- | LForce LExp -- make sure Exp is evaluted- | LLet Name LExp LExp -- name just for pretty printing- | LLam [Name] LExp -- lambda, lifted out before compiling- | LProj LExp Int -- projection- | LCon (Maybe LVar) -- Location to reallocate, if available+ | LApp Bool LExp [LExp] -- True = tail call+ | LLazyApp Name [LExp] -- True = tail call+ | LLazyExp LExp -- lifted out before compiling+ | LForce LExp -- make sure Exp is evaluted+ | LLet Name LExp LExp -- name just for pretty printing+ | LLam [Name] LExp -- lambda, lifted out before compiling+ | LProj LExp Int -- projection+ | LCon (Maybe LVar) -- Location to reallocate, if available Int Name [LExp] | LCase CaseType LExp [LAlt] | LConst Const- | LForeign FDesc -- Function descriptor (usually name as string)- FDesc -- Return type descriptor+ | LForeign FDesc -- Function descriptor (usually name as string)+ FDesc -- Return type descriptor [(FDesc, LExp)] -- first LExp is the FFI type description | LOp PrimFn [LExp] | LNothing@@ -206,7 +213,7 @@ lift env (LOp f args) = do args' <- mapM (lift env) args return (LOp f args') lift env (LError str) = return $ LError str-lift env LNothing = return $ LNothing+lift env LNothing = return LNothing allocUnique :: LDefs -> (Name, LDecl) -> (Name, LDecl) allocUnique defs p@(n, LConstructor _ _ _) = p
src/IRTS/LangOpts.hs view
@@ -1,3 +1,10 @@+{-|+Module : IRTS.LangOpts+Description : Transformations to apply to Idris' IR.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards, DeriveFunctor #-} module IRTS.LangOpts where@@ -20,17 +27,19 @@ put (i + 1) return $ sMN i "in" --- Inline inside a declaration. Variables are still Name at this stage.--- Need to preserve uniqueness of variable names in the resulting definition,--- so invent a new name for every variable we encounter+-- | Inline inside a declaration.+--+-- Variables are still Name at this stage. Need to preserve+-- uniqueness of variable names in the resulting definition, so invent+-- a new name for every variable we encounter doInline :: LDefs -> LDecl -> LDecl doInline defs d@(LConstructor _ _ _) = d-doInline defs (LFun opts topn args exp) +doInline defs (LFun opts topn args exp) = let res = evalState (inlineWith [topn] (map (\n -> (n, LV (Glob n))) args) exp) 0 in LFun opts topn args res where inlineWith :: [Name] -> [(Name, LExp)] -> LExp -> State Int LExp- inlineWith done env var@(LV (Glob n)) + inlineWith done env var@(LV (Glob n)) = case lookup n env of Just t -> return t Nothing -> return var@@ -39,7 +48,7 @@ inlineWith done env (LLazyExp e) = LLazyExp <$> inlineWith done env e -- Extend the environment for Let and Lam so that bound names aren't -- expanded with any top level argument definitions they shadow- inlineWith done env (LLet n val sc) + inlineWith done env (LLet n val sc) = do n' <- nextN LLet n' <$> inlineWith done env val <*> inlineWith done ((n, LV (Glob n')) : env) sc@@ -51,7 +60,7 @@ inlineWith done env (LProj exp i) = LProj <$> inlineWith done env exp <*> return i inlineWith done env (LCon loc i n es) = LCon loc i n <$> mapM (inlineWith done env) es- inlineWith done env (LCase ty e alts) + inlineWith done env (LCase ty e alts) = LCase ty <$> inlineWith done env e <*> mapM (inlineWithAlt done env) alts inlineWith done env (LOp f es) = LOp f <$> mapM (inlineWith done env) es -- the interesting case!@@ -72,8 +81,7 @@ inlineWithAlt done env (LConCase i n es rhs) = do ns' <- mapM (\n -> do n' <- nextN return (n, n')) es- LConCase i n (map snd ns') <$> + LConCase i n (map snd ns') <$> inlineWith done (map (\ (n,n') -> (n, LV (Glob n'))) ns' ++ env) rhs inlineWithAlt done env (LConstCase c e) = LConstCase c <$> inlineWith done env e inlineWithAlt done env (LDefaultCase e) = LDefaultCase <$> inlineWith done env e-
src/IRTS/Portable.hs view
@@ -1,5 +1,11 @@+{-|+Module : IRTS.Portable+Description : Serialise Idris' IR to JSON.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE OverloadedStrings #-}- module IRTS.Portable (writePortable) where import Data.Aeson
src/IRTS/Simplified.hs view
@@ -1,3 +1,10 @@+{-|+Module : IRTS.Simplified+Description : Simplified expressions, where functions/constructors can only be applied to variables.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module IRTS.Simplified(simplifyDefs, SDecl(..), SExp(..), SAlt(..)) where import IRTS.Defunctionalise@@ -9,9 +16,6 @@ import Debug.Trace --- Simplified expressions, where functions/constructors can only be applied--- to variables- data SExp = SV LVar | SApp Bool Name [LVar] | SLet LVar SExp SExp@@ -210,7 +214,7 @@ Just i -> do lvar i; return (Loc i) Nothing -> case lookupCtxtExact n ctxt of Just (DConstructor _ i ar) ->- failsc $ "can't pass constructor here"+ failsc "can't pass constructor here" Just _ -> return (Glob n) Nothing -> failsc $ "No such variable " ++ show n ++ " in " ++ show tm ++ " " ++ show envTop@@ -231,4 +235,3 @@ return (SConstCase c e') scalt env (SDefaultCase e) = do e' <- sc env e return (SDefaultCase e')-
src/IRTS/System.hs view
@@ -1,6 +1,21 @@+{-|+Module : IRTS.System+Description : Utilities for interacting with the System.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE CPP #-}-module IRTS.System(getDataFileName, getDataDir, getTargetDir,getCC,getLibFlags,getIdrisLibDir,- getIncFlags, getEnvFlags, version) where+module IRTS.System( getDataFileName+ , getDataDir+ , getTargetDir+ , getCC+ , getLibFlags+ , getIdrisLibDir+ , getIncFlags+ , getEnvFlags+ , version+ ) where import Data.List.Split
src/Idris/ASTUtils.hs view
@@ -1,39 +1,49 @@-module Idris.ASTUtils(Field(), cg_usedpos, ctxt_lookup, fgetState, fmodifyState,- fputState, idris_fixities, ist_callgraph, ist_optimisation,- known_classes, known_terms, opt_detaggable, opt_inaccessible, - opts_idrisCmdline, repl_definitions) where+{-|+Module : Idris.ASTUtils+Description : This implements just a few basic lens-like concepts to ease state updates. Similar to fclabels in approach, just without the extra dependency.+Copyright :+License : BSD3+Maintainer : The Idris Community. --- This implements just a few basic lens-like concepts to ease state updates.--- Similar to fclabels in approach, just without the extra dependency.------ We don't include an explicit export list--- because everything here is meant to be exported.------ Short synopsis:--- --------------------- f :: Idris ()--- f = do--- -- these two steps:--- detaggable <- fgetState (opt_detaggable . ist_optimisation typeName)--- fputState (opt_detaggable . ist_optimisation typeName) (not detaggable)------ -- are equivalent to:--- fmodifyState (opt_detaggable . ist_optimisation typeName) not------ -- of course, the long accessor can be put in a variable;--- -- everything is first-class--- let detag n = opt_detaggable . ist_optimisation n--- fputState (detag n1) True--- fputState (detag n2) False------ -- Note that all these operations handle missing items consistently--- -- and transparently, as prescribed by the default values included--- -- in the definitions of the ist_* functions.--- ----- -- Especially, it's no longer necessary to have initial values of--- -- data structures copied (possibly inconsistently) all over the compiler.+This implements just a few basic lens-like concepts to ease state updates.+Similar to fclabels in approach, just without the extra dependency. +We don't include an explicit export list+because everything here is meant to be exported.++Short synopsis:+---------------+@+f :: Idris ()+f = do+ -- these two steps:+ detaggable <- fgetState (opt_detaggable . ist_optimisation typeName)+ fputState (opt_detaggable . ist_optimisation typeName) (not detaggable)++ -- are equivalent to:+ fmodifyState (opt_detaggable . ist_optimisation typeName) not++ -- of course, the long accessor can be put in a variable;+ -- everything is first-class+ let detag n = opt_detaggable . ist_optimisation n+ fputState (detag n1) True+ fputState (detag n2) False++ -- Note that all these operations handle missing items consistently+ -- and transparently, as prescribed by the default values included+ -- in the definitions of the ist_* functions.+ --+ -- Especially, it's no longer necessary to have initial values of+ -- data structures copied (possibly inconsistently) all over the compiler.+@+-}+module Idris.ASTUtils(+ Field(), cg_usedpos, ctxt_lookup, fgetState, fmodifyState+ , fputState, idris_fixities, ist_callgraph, ist_optimisation+ , known_classes, known_terms, opt_detaggable, opt_inaccessible+ , opts_idrisCmdline, repl_definitions+ ) where+ import Control.Category import Control.Applicative import Control.Monad.State.Class@@ -65,8 +75,9 @@ fmodifyState :: MonadState s m => Field s a -> (a -> a) -> m () fmodifyState field f = modify $ fmodify field f --- Exact-name context lookup; uses Nothing for deleted values (read+write!).--- +-- | Exact-name context lookup; uses Nothing for deleted values+-- (read+write!).+-- -- Reading a non-existing value yields Nothing, -- writing Nothing deletes the value (if it existed). ctxt_lookup :: Name -> Field (Ctxt a) (Maybe a)@@ -93,7 +104,7 @@ -- OptInfo ---------- --- the optimisation record for the given (exact) name+-- | the optimisation record for the given (exact) name ist_optimisation :: Name -> Field IState OptInfo ist_optimisation n = maybe_default Optimise@@ -103,7 +114,7 @@ . ctxt_lookup n . Field idris_optimisation (\v ist -> ist{ idris_optimisation = v }) --- two fields of the optimisation record+-- | two fields of the optimisation record opt_inaccessible :: Field OptInfo [(Int, Name)] opt_inaccessible = Field inaccessible (\v opt -> opt{ inaccessible = v }) @@ -111,10 +122,7 @@ opt_detaggable = Field detaggable (\v opt -> opt{ detaggable = v }) --- CGInfo-------------- callgraph record for the given (exact) name+-- | callgraph record for the given (exact) name ist_callgraph :: Name -> Field IState CGInfo ist_callgraph n = maybe_default CGInfo@@ -126,18 +134,16 @@ cg_usedpos :: Field CGInfo [(Int, [UsageReason])] cg_usedpos = Field usedpos (\v cg -> cg{ usedpos = v }) --- Commandline flags----------------------+-- | Commandline flags opts_idrisCmdline :: Field IState [Opt] opts_idrisCmdline = Field opt_cmdline (\v opts -> opts{ opt_cmdline = v }) . Field idris_options (\v ist -> ist{ idris_options = v }) --- TT Context----------------- This has a terrible name, but I'm not sure of a better one that isn't--- confusingly close to tt_ctxt+-- | TT Context+--+-- This has a terrible name, but I'm not sure of a better one that+-- isn't confusingly close to tt_ctxt known_terms :: Field IState (Ctxt (Def, Injectivity, Accessibility, Totality, MetaInformation)) known_terms = Field (definitions . tt_ctxt) (\v state -> state {tt_ctxt = (tt_ctxt state) {definitions = v}})@@ -146,11 +152,10 @@ known_classes = Field idris_classes (\v state -> state {idris_classes = idris_classes state}) --- Names defined at the repl-----------------------------+-- | Names defined at the repl repl_definitions :: Field IState [Name] repl_definitions = Field idris_repl_defs (\v state -> state {idris_repl_defs = v}) --- Fixity declarations in an IState+-- | Fixity declarations in an IState idris_fixities :: Field IState [FixDecl] idris_fixities = Field idris_infixes (\v state -> state {idris_infixes = v})
src/Idris/AbsSyntax.hs view
@@ -1,7 +1,17 @@+{-|+Module : Idris.AbsSyntax+Description : Provides Idris' core data definitions and utility code.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, TypeSynonymInstances, PatternGuards #-} -module Idris.AbsSyntax(module Idris.AbsSyntax, module Idris.AbsSyntaxTree) where+module Idris.AbsSyntax(+ module Idris.AbsSyntax+ , module Idris.AbsSyntaxTree+ ) where import Idris.Core.TT import Idris.Core.Evaluate@@ -145,8 +155,8 @@ idris_language_extensions = ErrorReflection : idris_language_extensions i } --- Transforms are organised by the function being applied on the lhs of the--- transform, to make looking up appropriate transforms quicker+-- | Transforms are organised by the function being applied on the lhs+-- of the transform, to make looking up appropriate transforms quicker addTrans :: Name -> (Term, Term) -> Idris () addTrans basefn t = do i <- getIState@@ -331,8 +341,8 @@ [TIPartial] -> return True _ -> return False --- | Adds error handlers for a particular function and argument. If names are--- ambiguous, all matching handlers are updated.+-- | Adds error handlers for a particular function and argument. If+-- names are ambiguous, all matching handlers are updated. addFunctionErrorHandlers :: Name -> Name -> [Name] -> Idris () addFunctionErrorHandlers f arg hs = do i <- getIState@@ -350,7 +360,7 @@ undefined --lookup arg =<< lookupCtxtExact f (idris_function_errorhandlers i) --- Trace all the names in a call graph starting at the given name+-- | Trace all the names in a call graph starting at the given name getAllNames :: Name -> Idris [Name] getAllNames n = allNames [] n @@ -429,7 +439,7 @@ -- Dodgy hack 1: Put integer instances first in the list so they are -- resolved by default. ----- Dodgy hack 2: put constraint chasers (@@) last+-- Dodgy hack 2: put constraint chasers (ParentN) last addInstance :: Bool -- ^ whether the name is an Integer instance -> Bool -- ^ whether to include the instance in instance search -> Name -- ^ the name of the class@@ -451,17 +461,15 @@ insI i (n : ns) | chaser (fst n) = (i, res) : n : ns | otherwise = n : insI i ns - chaser (UN nm)- | ('@':'@':_) <- str nm = True+ chaser (SN (ParentN _ _)) = True chaser (NS n _) = chaser n chaser _ = False --- Add a privileged implementation - one which instance search will happily--- resolve immediately if it is type correct--- This is used for naming parent implementations when defining an--- implementation with constraints.--- Returns the old list, so we can revert easily at the end of a block-+-- | Add a privileged implementation - one which instance search will+-- happily resolve immediately if it is type correct This is used for+-- naming parent implementations when defining an implementation with+-- constraints. Returns the old list, so we can revert easily at the+-- end of a block addOpenImpl :: [Name] -> Idris [Name] addOpenImpl ns = do ist <- getIState ns' <- mapM (checkValid ist) ns@@ -530,7 +538,7 @@ resetNameIdx = do i <- getIState put (i { idris_nameIdx = (0, emptyContext) }) --- Used to preserve sharing of names+-- | Used to preserve sharing of names addNameIdx :: Name -> Idris (Int, Name) addNameIdx n = do i <- getIState let (i', x) = addNameIdx' i n@@ -575,7 +583,7 @@ setSO :: Maybe String -> Idris () setSO s = do i <- getIState- putIState $ (i { compiled_so = s })+ putIState (i { compiled_so = s }) getIState :: Idris IState getIState = get@@ -597,7 +605,8 @@ withContext_ :: (IState -> Ctxt a) -> Name -> (a -> Idris ()) -> Idris () withContext_ ctx name action = withContext ctx name () action --- | A version of liftIO that puts errors into the exception type of the Idris monad+-- | A version of liftIO that puts errors into the exception type of+-- the Idris monad runIO :: IO a -> Idris a runIO x = liftIO (tryIOError x) >>= either (throwError . Msg . show) return -- TODO: create specific Idris exceptions for specific IO errors such as "openFile: does not exist"@@ -608,11 +617,13 @@ getName :: Idris Int getName = do i <- getIState; let idx = idris_name i;- putIState $ (i { idris_name = idx + 1 })+ putIState (i { idris_name = idx + 1 }) return idx --- InternalApp keeps track of the real function application for making case splits from, not the application the--- programmer wrote, which doesn't have the whole context in any case other than top level definitions+-- | InternalApp keeps track of the real function application for+-- making case splits from, not the application the programmer wrote,+-- which doesn't have the whole context in any case other than top+-- level definitions addInternalApp :: FilePath -> Int -> PTerm -> Idris () addInternalApp fp l t = do i <- getIState@@ -637,16 +648,17 @@ -- TODO: What if it's not there? else return Placeholder --- Pattern definitions are only used for coverage checking, so erase them--- when we're done+-- | Pattern definitions are only used for coverage checking, so erase+-- them when we're done clearOrigPats :: Idris () clearOrigPats = do i <- get let ps = idris_patdefs i let ps' = mapCtxt (\ (_,miss) -> ([], miss)) ps put (i { idris_patdefs = ps' }) --- Erase types from Ps in the context (basically ending up with what's in--- the .ibc, which is all we need after all the analysis is done)+-- | Erase types from Ps in the context (basically ending up with+-- what's in the .ibc, which is all we need after all the analysis is+-- done) clearPTypes :: Idris () clearPTypes = do i <- get let ctxt = tt_ctxt i@@ -674,20 +686,24 @@ _ -> return True setContext :: Context -> Idris ()-setContext ctxt = do i <- getIState; putIState $ (i { tt_ctxt = ctxt } )+setContext ctxt = do i <- getIState; putIState (i { tt_ctxt = ctxt } ) updateContext :: (Context -> Context) -> Idris ()-updateContext f = do i <- getIState; putIState $ (i { tt_ctxt = f (tt_ctxt i) } )+updateContext f = do i <- getIState; putIState (i { tt_ctxt = f (tt_ctxt i) } ) addConstraints :: FC -> (Int, [UConstraint]) -> Idris () addConstraints fc (v, cs)- = do i <- getIState- let ctxt = tt_ctxt i- let ctxt' = ctxt { next_tvar = v }- let ics = insertAll (zip cs (repeat fc)) (idris_constraints i)- putIState $ i { tt_ctxt = ctxt', idris_constraints = ics }+ = do tit <- typeInType+ when (not tit) $ do+ i <- getIState+ let ctxt = tt_ctxt i+ let ctxt' = ctxt { next_tvar = v }+ let ics = insertAll (zip cs (repeat fc)) (idris_constraints i)+ putIState $ i { tt_ctxt = ctxt', idris_constraints = ics } where insertAll [] c = c+ insertAll ((ULE (UVal 0) _, fc) : cs) ics = insertAll cs ics+ insertAll ((ULE x y, fc) : cs) ics | x == y = insertAll cs ics insertAll ((c, fc) : cs) ics = insertAll cs $ S.insert (ConstraintFC c fc) ics @@ -866,8 +882,8 @@ removeOptimise opt = do opts <- getOptimise setOptimise ((nub opts) \\ [opt]) --- Set appropriate optimisation set for the given level. We only have--- one optimisation that is configurable at the moment, however!+-- | Set appropriate optimisation set for the given level. We only+-- have one optimisation that is configurable at the moment, however! setOptLevel :: Int -> Idris () setOptLevel n | n <= 0 = setOptimise [] setOptLevel 1 = setOptimise []@@ -1350,12 +1366,11 @@ ty cn decls expandInstanceScope ist dec ps ns d = d --- Calculate a priority for a type, for deciding elaboration order+-- | Calculate a priority for a type, for deciding elaboration order -- * if it's just a type variable or concrete type, do it early (0) -- * if there's only type variables and injective constructors, do it next (1) -- * if there's a function type, next (2) -- * finally, everything else (3)- getPriority :: IState -> PTerm -> Int getPriority i tm = 1 -- pri tm where@@ -1501,7 +1516,7 @@ getName (PExp _ _ _ (PRef _ _ n)) = return n getName _ = [] --- Add implicit bindings from using block, and bind any missing names+-- | Add implicit bindings from using block, and bind any missing names addUsingImpls :: SyntaxInfo -> Name -> FC -> PTerm -> Idris PTerm addUsingImpls syn n fc t = do ist <- getIState@@ -1531,7 +1546,7 @@ -- if all of args in ns, then add it doAdd (UImplicit n ty : cs) ns t | elem n ns- = PPi (Imp [] Dynamic False Nothing False) n NoFC ty (doAdd cs ns t)+ = PPi impl_gen n NoFC ty (doAdd cs ns t) | otherwise = doAdd cs ns t -- bind the free names which weren't in the using block@@ -1539,7 +1554,7 @@ bindFree (n:ns) tm | elem n (map iname uimpls) = bindFree ns tm | otherwise- = PPi (Imp [InaccessibleArg] Dynamic False Nothing False) n NoFC Placeholder (bindFree ns tm)+ = PPi (impl_gen { pargopts = [InaccessibleArg] }) n NoFC Placeholder (bindFree ns tm) getArgnames (PPi _ n _ c sc) = n : getArgnames sc@@ -1623,8 +1638,8 @@ notFound kns (SN (WhereN _ _ _) : ns) = notFound kns ns -- Known already notFound kns (n:ns) = if elem n kns then notFound kns ns else Just n --- Even if auto_implicits is off, we need to call this so we record which--- arguments are implicit+-- | Even if auto_implicits is off, we need to call this so we record+-- which arguments are implicit implicitise :: Bool -> SyntaxInfo -> [Name] -> IState -> PTerm -> (PTerm, [PArg]) implicitise auto syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $ let (declimps, ns') = execState (imps True [] tm) ([], [])@@ -1724,12 +1739,12 @@ pibind using [] sc = sc pibind using (n:ns) sc = case lookup n using of- Just ty -> PPi (Imp [] Dynamic False (Just (Impl False True)) False)+ Just ty -> PPi impl_gen n NoFC ty (pibind using ns sc)- Nothing -> PPi (Imp [InaccessibleArg] Dynamic False (Just (Impl False True)) False)+ Nothing -> PPi (impl_gen { pargopts = [InaccessibleArg] }) n NoFC Placeholder (pibind using ns sc) --- Add implicit arguments in function calls+-- | Add implicit arguments in function calls addImplPat :: IState -> PTerm -> PTerm addImplPat = addImpl' True [] [] [] @@ -1739,10 +1754,10 @@ addImplBoundInf :: IState -> [Name] -> [Name] -> PTerm -> PTerm addImplBoundInf ist ns inf = addImpl' False ns inf [] ist --- | Add the implicit arguments to applications in the term--- [Name] gives the names to always expend, even when under a binder of--- that name (this is to expand methods with implicit arguments in dependent--- type classes).+-- | Add the implicit arguments to applications in the term [Name]+-- gives the names to always expend, even when under a binder of that+-- name (this is to expand methods with implicit arguments in+-- dependent type classes). addImpl :: [Name] -> IState -> PTerm -> PTerm addImpl = addImpl' False [] [] @@ -1843,13 +1858,12 @@ sc' = ai inpat qq ((n, Just ty):env) ds sc in PLam fc n nfc ty' sc' ai inpat qq env ds (PLet fc n nfc ty val sc)- = case lookupDef n (tt_ctxt ist) of- [] -> let ty' = ai inpat qq env ds ty- val' = ai inpat qq env ds val- sc' = ai inpat qq ((n, Just ty):env) ds sc in- PLet fc n nfc ty' val' sc'- defs ->- ai inpat qq env ds (PCase fc val [(PRef fc [] n, sc)])+ = if canBeDConName n (tt_ctxt ist)+ then ai inpat qq env ds (PCase fc val [(PRef fc [] n, sc)])+ else let ty' = ai inpat qq env ds ty+ val' = ai inpat qq env ds val+ sc' = ai inpat qq ((n, Just ty):env) ds sc in+ PLet fc n nfc ty' val' sc' ai inpat qq env ds (PPi p n nfc ty sc) = let ty' = ai inpat qq env ds ty env' = if n `elem` imp_meths then env@@ -1925,9 +1939,9 @@ case ns' of [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f')) (insertImpl ns as)- [] -> if f `elem` (map fst (idris_metavars ist))- then Right $ PApp fc (PRef ffc [ffc] f) as- else Right $ mkPApp fc (length as) (PRef ffc [ffc] f) as+ [] -> case metaVar f (map fst (idris_metavars ist)) of+ Just f' -> Right $ PApp fc (PRef ffc [ffc] f') as+ Nothing -> Right $ mkPApp fc (length as) (PRef ffc [ffc] f) as alts -> Right $ PAlternative [] (ExactlyOne True) $ map (\(f', ns) -> mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f'))@@ -1938,6 +1952,12 @@ isImpName f f' | f `elem` imp_meths = f | otherwise = f' + -- If it's a metavariable name, try to qualify it from the list of+ -- unsolved metavariables+ metaVar f (mvn : ns) | f == nsroot mvn = Just mvn+ metaVar f (_ : ns) = metaVar f ns+ metaVar f [] = Nothing+ trimAlts [] alts = alts trimAlts ns alts = filter (\(x, _) -> any (\d -> d `isPrefixOf` nspace x) ns) alts@@ -2006,8 +2026,8 @@ | n == n' = Just (t, reverse acc ++ gs) find n (g : gs) acc = find n gs (g : acc) --- return True if the second argument is an implicit argument which is--- expected in the implicits, or if it's not an implicit+-- | return True if the second argument is an implicit argument which+-- is expected in the implicits, or if it's not an implicit impIn :: [PArg] -> PArg -> Bool impIn ps (PExp _ _ _ _) = True impIn ps (PConstraint _ _ _ _) = True@@ -2115,11 +2135,12 @@ appRest fc f [] = f appRest fc f (a : as) = appRest fc (PApp fc f [a]) as --- Find 'static' argument positions+++-- | Find 'static' argument positions -- (the declared ones, plus any names in argument position in the declared -- statics) -- FIXME: It's possible that this really has to happen after elaboration- findStatics :: IState -> PTerm -> (PTerm, [Bool]) findStatics ist tm = let (ns, ss) = fs tm in runState (pos ns ss tm) []@@ -2350,8 +2371,8 @@ update oldn | n == oldn = n' | otherwise = oldn --- | Rename any binders which are repeated (so that we don't have to mess--- about with shadowing anywhere else).+-- | Rename any binders which are repeated (so that we don't have to+-- mess about with shadowing anywhere else). mkUniqueNames :: [Name] -> [(Name, Name)] -> PTerm -> PTerm mkUniqueNames env shadows tm = evalState (mkUniq 0 initMap tm) (S.fromList env) where
src/Idris/AbsSyntaxTree.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.AbsSyntaxTree+Description : Core data definitions used in Idris.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, DeriveDataTypeable, TypeSynonymInstances, PatternGuards #-} @@ -48,27 +55,33 @@ data ElabWhat = ETypes | EDefns | EAll deriving (Show, Eq) --- Data to pass to recursively called elaborators; e.g. for where blocks,+-- | Data to pass to recursively called elaborators; e.g. for where blocks, -- paramaterised declarations, etc.-+-- -- rec_elabDecl is used to pass the top level elaborator into other elaborators, -- so that we can have mutually recursive elaborators in separate modules without -- having to muck about with cyclic modules.-data ElabInfo = EInfo { params :: [(Name, PTerm)],- inblock :: Ctxt [Name], -- names in the block, and their params- liftname :: Name -> Name,- namespace :: Maybe [String],- elabFC :: Maybe FC,- -- We may, recursively, collect transformations to- -- do on the rhs, e.g. rewriting recursive calls to- -- functions defined by 'with'- rhs_trans :: PTerm -> PTerm,- rec_elabDecl :: ElabWhat -> ElabInfo -> PDecl ->- Idris () }+data ElabInfo = EInfo {+ params :: [(Name, PTerm)]+ , inblock :: Ctxt [Name] -- ^ names in the block, and their params+ , liftname :: Name -> Name+ , namespace :: [String]+ , elabFC :: Maybe FC+ , constraintNS :: String -- ^ filename for adding to constraint variables+ , pe_depth :: Int + -- | We may, recursively, collect transformations to do on the rhs,+ -- e.g. rewriting recursive calls to functions defined by 'with'+ , rhs_trans :: PTerm -> PTerm+ , rec_elabDecl :: ElabWhat -> ElabInfo -> PDecl -> Idris ()+ }+ toplevel :: ElabInfo-toplevel = EInfo [] emptyContext id Nothing Nothing id (\_ _ _ -> fail "Not implemented")+toplevel = EInfo [] emptyContext id [] Nothing "(toplevel)" 0 id (\_ _ _ -> fail "Not implemented") +toplevelWith :: String -> ElabInfo+toplevelWith ns = EInfo [] emptyContext id [] Nothing ns 0 id (\_ _ _ -> fail "Not implemented")+ eInfoNames :: ElabInfo -> [Name] eInfoNames info = map fst (params info) ++ M.keys (inblock info) @@ -90,13 +103,13 @@ , opt_importdirs :: [FilePath] , opt_triple :: String , opt_cpu :: String- , opt_cmdline :: [Opt] -- remember whole command line+ , opt_cmdline :: [Opt] -- ^ remember whole command line , opt_origerr :: Bool , opt_autoSolve :: Bool -- ^ automatically apply "solve" tactic in prover- , opt_autoImport :: [FilePath] -- ^ e.g. Builtins+Prelude+ , opt_autoImport :: [FilePath] -- ^ List of modules to auto import i.e. `Builtins+Prelude` , opt_optimise :: [Optimisation] , opt_printdepth :: Maybe Int- , opt_evaltypes :: Bool -- ^ normalise types in :t+ , opt_evaltypes :: Bool -- ^ normalise types in `:t` , opt_desugarnats :: Bool , opt_autoimpls :: Bool } deriving (Show, Eq)@@ -130,39 +143,43 @@ } data PPOption = PPOption {- ppopt_impl :: Bool -- ^^ whether to show implicits+ ppopt_impl :: Bool -- ^ whether to show implicits , ppopt_desugarnats :: Bool- , ppopt_pinames :: Bool -- ^^ whether to show names in pi bindings- , ppopt_depth :: Maybe Int-} deriving (Show)+ , ppopt_pinames :: Bool -- ^ whether to show names in pi bindings+ , ppopt_depth :: Maybe Int+ } deriving (Show) -data Optimisation = PETransform -- partial eval and associated transforms+data Optimisation = PETransform -- ^ partial eval and associated transforms deriving (Show, Eq) defaultOptimise = [PETransform] -- | Pretty printing options with default verbosity. defaultPPOption :: PPOption-defaultPPOption = PPOption { ppopt_impl = False,- ppopt_desugarnats = False,- ppopt_pinames = False,- ppopt_depth = Just 200 }+defaultPPOption = PPOption {+ ppopt_impl = False+ , ppopt_desugarnats = False+ , ppopt_pinames = False+ , ppopt_depth = Just 200+ } -- | Pretty printing options with the most verbosity. verbosePPOption :: PPOption-verbosePPOption = PPOption { ppopt_impl = True,- ppopt_desugarnats = True,- ppopt_pinames = True,- ppopt_depth = Just 200 }+verbosePPOption = PPOption {+ ppopt_impl = True+ , ppopt_desugarnats = True+ , ppopt_pinames = True+ , ppopt_depth = Just 200+ } -- | Get pretty printing options from the big options record. ppOption :: IOption -> PPOption ppOption opt = PPOption {- ppopt_impl = opt_showimp opt,- ppopt_pinames = False,- ppopt_depth = opt_printdepth opt,- ppopt_desugarnats = opt_desugarnats opt-}+ ppopt_impl = opt_showimp opt+ , ppopt_pinames = False+ , ppopt_depth = opt_printdepth opt+ , ppopt_desugarnats = opt_desugarnats opt+ } -- | Get pretty printing options from an idris state record. ppOptionIst :: IState -> PPOption@@ -171,13 +188,13 @@ data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord) -- | The output mode in use-data OutputMode = RawOutput Handle -- ^ Print user output directly to the handle+data OutputMode = RawOutput Handle -- ^ Print user output directly to the handle | IdeMode Integer Handle -- ^ Send IDE output for some request ID to the handle deriving Show -- | How wide is the console? data ConsoleWidth = InfinitelyWide -- ^ Have pretty-printer assume that lines should not be broken- | ColsWide Int -- ^ Manually specified - must be positive+ | ColsWide Int -- ^ Manually specified - must be positive | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise deriving (Show, Eq) @@ -189,98 +206,106 @@ -- | The global state used in the Idris monad data IState = IState {- tt_ctxt :: Context, -- ^ All the currently defined names and their terms- idris_constraints :: S.Set ConstraintFC,- -- ^ A list of universe constraints and their corresponding source locations- idris_infixes :: [FixDecl], -- ^ Currently defined infix operators- idris_implicits :: Ctxt [PArg],- idris_statics :: Ctxt [Bool],- idris_classes :: Ctxt ClassInfo,- idris_openimpls :: [Name], -- ^ Privileged implementations, will resolve immediately- idris_records :: Ctxt RecordInfo,- idris_dsls :: Ctxt DSL,- idris_optimisation :: Ctxt OptInfo,- idris_datatypes :: Ctxt TypeInfo,- idris_namehints :: Ctxt [Name],- idris_patdefs :: Ctxt ([([(Name, Term)], Term, Term)], [PTerm]), -- not exported- -- ^ list of lhs/rhs, and a list of missing clauses- idris_flags :: Ctxt [FnOpt],- idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos- idris_docstrings :: Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]),- idris_moduledocs :: Ctxt (Docstring DocTerm),- -- ^ module documentation is saved in a special MN so the context- -- mechanism can be used for disambiguation- idris_tyinfodata :: Ctxt TIData,- idris_fninfo :: Ctxt FnInfo,- idris_transforms :: Ctxt [(Term, Term)],- idris_autohints :: Ctxt [Name],- idris_totcheck :: [(FC, Name)], -- names to check totality on- idris_defertotcheck :: [(FC, Name)], -- names to check at the end- idris_totcheckfail :: [(FC, String)],- idris_options :: IOption,- idris_name :: Int,- idris_lineapps :: [((FilePath, Int), PTerm)],- -- ^ Full application LHS on source line- idris_metavars :: [(Name, (Maybe Name, Int, [Name], Bool, Bool))],- -- ^ The currently defined but not proven metavariables. The Int- -- is the number of vars to display as a context, the Maybe Name- -- is its top-level function, the [Name] is the list of local variables- -- available for proof search and the Bools are whether :p is- -- allowed, and whether the variable is definable at all- -- (Metavariables are not definable if they are applied in a term which- -- still has hole bindings)- idris_coercions :: [Name],- idris_errRev :: [(Term, Term)],- syntax_rules :: SyntaxRules,- syntax_keywords :: [String],- imported :: [FilePath], -- ^ The imported modules- idris_scprims :: [(Name, (Int, PrimFn))],- idris_objs :: [(Codegen, FilePath)],- idris_libs :: [(Codegen, String)],- idris_cgflags :: [(Codegen, String)],- idris_hdrs :: [(Codegen, String)],- idris_imported :: [(FilePath, Bool)], -- ^ Imported ibc file names, whether public- proof_list :: [(Name, (Bool, [String]))],- errSpan :: Maybe FC,- parserWarnings :: [(FC, Err)],- lastParse :: Maybe Name,- indent_stack :: [Int],- brace_stack :: [Maybe Int],- lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?- idris_parsedSpan :: Maybe FC,- hide_list :: Ctxt Accessibility,- default_access :: Accessibility,- default_total :: DefaultTotality,- ibc_write :: [IBCWrite],- compiled_so :: Maybe String,- idris_dynamic_libs :: [DynamicLib],- idris_language_extensions :: [LanguageExt],- idris_outputmode :: OutputMode,- idris_colourRepl :: Bool,- idris_colourTheme :: ColourTheme,- idris_errorhandlers :: [Name], -- ^ Global error handlers- idris_nameIdx :: (Int, Ctxt (Int, Name)),- idris_function_errorhandlers :: Ctxt (M.Map Name (S.Set Name)), -- ^ Specific error handlers- module_aliases :: M.Map [T.Text] [T.Text],- idris_consolewidth :: ConsoleWidth, -- ^ How many chars wide is the console?- idris_postulates :: S.Set Name,- idris_externs :: S.Set (Name, Int),- idris_erasureUsed :: [(Name, Int)], -- ^ Function/constructor name, argument position is used- idris_whocalls :: Maybe (M.Map Name [Name]),- idris_callswho :: Maybe (M.Map Name [Name]),- idris_repl_defs :: [Name], -- ^ List of names that were defined in the repl, and can be re-/un-defined- elab_stack :: [(Name, Bool)], -- ^ Stack of names currently being elaborated, Bool set if it's an instance- -- (instances appear twice; also as a funtion name)- idris_symbols :: M.Map Name Name, -- ^ Symbol table (preserves sharing of names)- idris_exports :: [Name], -- ^ Functions with ExportList- idris_highlightedRegions :: [(FC, OutputAnnotation)], -- ^ Highlighting information to output- idris_parserHighlights :: [(FC, OutputAnnotation)], -- ^ Highlighting information from the parser- idris_deprecated :: Ctxt String, -- ^ Deprecated names and explanation- idris_inmodule :: S.Set Name, -- ^ Names defined in current module- idris_ttstats :: M.Map Term (Int, Term),- idris_fragile :: Ctxt String -- ^ Fragile names and explanation.- }+ tt_ctxt :: Context -- ^ All the currently defined names and their terms+ , idris_constraints :: S.Set ConstraintFC -- ^ A list of universe constraints and their corresponding source locations+ , idris_infixes :: [FixDecl] -- ^ Currently defined infix operators+ , idris_implicits :: Ctxt [PArg]+ , idris_statics :: Ctxt [Bool]+ , idris_classes :: Ctxt ClassInfo+ , idris_openimpls :: [Name] -- ^ Privileged implementations, will resolve immediately+ , idris_records :: Ctxt RecordInfo+ , idris_dsls :: Ctxt DSL+ , idris_optimisation :: Ctxt OptInfo+ , idris_datatypes :: Ctxt TypeInfo+ , idris_namehints :: Ctxt [Name] + -- | list of lhs/rhs, and a list of missing clauses. These are not+ -- exported.+ , idris_patdefs :: Ctxt ([([(Name, Term)], Term, Term)], [PTerm])+ , idris_flags :: Ctxt [FnOpt]+ , idris_callgraph :: Ctxt CGInfo -- ^ name, args used in each pos+ , idris_docstrings :: Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)])++ -- | module documentation is saved in a special MN so the context+ -- mechanism can be used for disambiguation.+ , idris_moduledocs :: Ctxt (Docstring DocTerm)+ , idris_tyinfodata :: Ctxt TIData+ , idris_fninfo :: Ctxt FnInfo+ , idris_transforms :: Ctxt [(Term, Term)]+ , idris_autohints :: Ctxt [Name]+ , idris_totcheck :: [(FC, Name)] -- ^ names to check totality on+ , idris_defertotcheck :: [(FC, Name)] -- ^ names to check at the end+ , idris_totcheckfail :: [(FC, String)]+ , idris_options :: IOption+ , idris_name :: Int+ , idris_lineapps :: [((FilePath, Int), PTerm)] -- ^ Full application LHS on source line++ -- | The currently defined but not proven metavariables. The Int is+ -- the number of vars to display as a context, the Maybe Name is its+ -- top-level function, the [Name] is the list of local variables+ -- available for proof search and the Bools are whether :p is+ -- allowed, and whether the variable is definable at all+ -- (Metavariables are not definable if they are applied in a term+ -- which still has hole bindings)+ , idris_metavars :: [(Name, (Maybe Name, Int, [Name], Bool, Bool))]+ , idris_coercions :: [Name]+ , idris_errRev :: [(Term, Term)]+ , syntax_rules :: SyntaxRules+ , syntax_keywords :: [String]+ , imported :: [FilePath] -- ^ The imported modules+ , idris_scprims :: [(Name, (Int, PrimFn))]+ , idris_objs :: [(Codegen, FilePath)]+ , idris_libs :: [(Codegen, String)]+ , idris_cgflags :: [(Codegen, String)]+ , idris_hdrs :: [(Codegen, String)]+ , idris_imported :: [(FilePath, Bool)] -- ^ Imported ibc file names, whether public+ , proof_list :: [(Name, (Bool, [String]))]+ , errSpan :: Maybe FC+ , parserWarnings :: [(FC, Err)]+ , lastParse :: Maybe Name+ , indent_stack :: [Int]+ , brace_stack :: [Maybe Int]+ , lastTokenSpan :: Maybe FC -- ^ What was the span of the latest token parsed?+ , idris_parsedSpan :: Maybe FC+ , hide_list :: Ctxt Accessibility+ , default_access :: Accessibility+ , default_total :: DefaultTotality+ , ibc_write :: [IBCWrite]+ , compiled_so :: Maybe String+ , idris_dynamic_libs :: [DynamicLib]+ , idris_language_extensions :: [LanguageExt]+ , idris_outputmode :: OutputMode+ , idris_colourRepl :: Bool+ , idris_colourTheme :: ColourTheme+ , idris_errorhandlers :: [Name] -- ^ Global error handlers+ , idris_nameIdx :: (Int, Ctxt (Int, Name))+ , idris_function_errorhandlers :: Ctxt (M.Map Name (S.Set Name)) -- ^ Specific error handlers+ , module_aliases :: M.Map [T.Text] [T.Text]+ , idris_consolewidth :: ConsoleWidth -- ^ How many chars wide is the console?+ , idris_postulates :: S.Set Name+ , idris_externs :: S.Set (Name, Int)+ , idris_erasureUsed :: [(Name, Int)] -- ^ Function/constructor name, argument position is used+ , idris_whocalls :: Maybe (M.Map Name [Name])+ , idris_callswho :: Maybe (M.Map Name [Name])++ -- | List of names that were defined in the repl, and can be re-/un-defined+ , idris_repl_defs :: [Name]++ -- | Stack of names currently being elaborated, Bool set if it's an+ -- instance (instances appear twice; also as a funtion name)+ , elab_stack :: [(Name, Bool)]+++ , idris_symbols :: M.Map Name Name -- ^ Symbol table (preserves sharing of names)+ , idris_exports :: [Name] -- ^ Functions with ExportList+ , idris_highlightedRegions :: [(FC, OutputAnnotation)] -- ^ Highlighting information to output+ , idris_parserHighlights :: [(FC, OutputAnnotation)] -- ^ Highlighting information from the parser+ , idris_deprecated :: Ctxt String -- ^ Deprecated names and explanation+ , idris_inmodule :: S.Set Name -- ^ Names defined in current module+ , idris_ttstats :: M.Map Term (Int, Term)+ , idris_fragile :: Ctxt String -- ^ Fragile names and explanation.+ }+ -- Required for parsers library, and therefore trifecta instance Show IState where show = const "{internal state}"@@ -295,20 +320,22 @@ type SCGEntry = (Name, [Maybe (Int, SizeChange)]) type UsageReason = (Name, Int) -- fn_name, its_arg_number -data CGInfo = CGInfo { calls :: [Name],- scg :: [SCGEntry],- usedpos :: [(Int, [UsageReason])]- }- deriving Show+data CGInfo = CGInfo {+ calls :: [Name]+ , scg :: [SCGEntry]+ , usedpos :: [(Int, [UsageReason])]+ } deriving Show {-! deriving instance Binary CGInfo deriving instance NFData CGInfo !-} -primDefs = [sUN "unsafePerformPrimIO",- sUN "mkLazyForeignPrim",- sUN "mkForeignPrim",- sUN "void"]+primDefs = [ sUN "unsafePerformPrimIO"+ , sUN "mkLazyForeignPrim"+ , sUN "mkForeignPrim"+ , sUN "void"+ , sUN "assert_unreachable"+ ] -- information that needs writing for the current module's .ibc file data IBCWrite = IBCFix FixDecl@@ -323,7 +350,7 @@ | IBCMetavar Name | IBCSyntax Syntax | IBCKeyword String- | IBCImport (Bool, FilePath) -- True = import public+ | IBCImport (Bool, FilePath) -- ^ True = import public | IBCImportDir FilePath | IBCObj Codegen FilePath | IBCLib Codegen String@@ -341,7 +368,7 @@ | IBCCG Name | IBCDoc Name | IBCCoercion Name- | IBCDef Name -- i.e. main context+ | IBCDef Name -- ^ The main context. | IBCNameHint (Name, Name) | IBCLineApp FilePath Int PTerm | IBCErrorHandler Name@@ -356,6 +383,7 @@ | IBCAutoHint Name Name | IBCDeprecate Name String | IBCFragile Name String+ | IBCConstraint FC UConstraint deriving Show -- | The initial state for the compiler@@ -373,9 +401,13 @@ emptyContext S.empty M.empty emptyContext --- | The monad for the main REPL - reading and processing files and updating--- global state (hence the IO inner monad).---type Idris = WriterT [Either String (IO ())] (State IState a))+-- | The monad for the main REPL - reading and processing files and+-- updating global state (hence the IO inner monad).+--+-- @+-- type Idris = WriterT [Either String (IO ())] (State IState a))+-- @+-- type Idris = StateT IState (ExceptT Err IO) catchError :: Idris a -> (Err -> Idris a) -> Idris a@@ -441,10 +473,10 @@ | MakeWith Bool Int Name | MakeCase Bool Int Name | MakeLemma Bool Int Name- | DoProofSearch Bool -- update file- Bool -- recursive search- Int -- depth- Name -- top level name+ | DoProofSearch Bool -- update file+ Bool -- recursive search+ Int -- depth+ Name -- top level name [Name] -- hints | SetOpt Opt | UnsetOpt Opt@@ -459,7 +491,7 @@ | WhoCalls Name | CallsWho Name | Browse [String]- | MakeDoc String -- IdrisDoc+ | MakeDoc String -- IdrisDoc | Warranty | PrintDef Name | PPrint OutputFmt Int PTerm@@ -538,7 +570,7 @@ | ErrContext | ShowImpl | Verbose- | Port String -- REPL TCP port+ | Port String -- ^ REPL TCP port | IBCSubDir String | ImportDir String | PkgBuild String@@ -546,7 +578,7 @@ | PkgClean String | PkgCheck String | PkgREPL String- | PkgMkDoc String -- IdrisDoc+ | PkgMkDoc String -- IdrisDoc | PkgTest String | PkgIndex FilePath | WarnOnly@@ -572,20 +604,26 @@ | UseConsoleWidth ConsoleWidth | DumpHighlights | DesugarNats- | NoElimDeprecationWarnings -- ^ Don't show deprecation warnings for %elim+ | NoElimDeprecationWarnings -- ^ Don't show deprecation warnings for %elim | NoOldTacticDeprecationWarnings -- ^ Don't show deprecation warnings for old-style tactics deriving (Show, Eq) -data ElabShellCmd = EQED | EAbandon | EUndo | EProofState | EProofTerm- | EEval PTerm | ECheck PTerm | ESearch PTerm+data ElabShellCmd = EQED+ | EAbandon+ | EUndo+ | EProofState+ | EProofTerm+ | EEval PTerm+ | ECheck PTerm+ | ESearch PTerm | EDocStr (Either Name Const) deriving (Show, Eq) -- Parsed declarations -data Fixity = Infixl { prec :: Int }- | Infixr { prec :: Int }- | InfixN { prec :: Int }+data Fixity = Infixl { prec :: Int }+ | Infixr { prec :: Int }+ | InfixN { prec :: Int } | PrefixN { prec :: Int } deriving Eq {-!@@ -594,9 +632,9 @@ !-} instance Show Fixity where- show (Infixl i) = "infixl " ++ show i- show (Infixr i) = "infixr " ++ show i- show (InfixN i) = "infix " ++ show i+ show (Infixl i) = "infixl " ++ show i+ show (Infixr i) = "infixr " ++ show i+ show (InfixN i) = "infix " ++ show i show (PrefixN i) = "prefix " ++ show i data FixDecl = Fix Fixity String@@ -621,22 +659,25 @@ deriving instance NFData Static !-} --- Mark bindings with their explicitness, and laziness-data Plicity = Imp { pargopts :: [ArgOpt],- pstatic :: Static,- pparam :: Bool,- pscoped :: Maybe ImplicitInfo, -- Nothing, if top level- pinsource :: Bool -- Explicitly written in source+-- ^ Mark bindings with their explicitness, and laziness+data Plicity = Imp { pargopts :: [ArgOpt]+ , pstatic :: Static+ , pparam :: Bool+ , pscoped :: Maybe ImplicitInfo -- ^ Nothing, if top level+ , pinsource :: Bool -- ^ Explicitly written in source }- | Exp { pargopts :: [ArgOpt],- pstatic :: Static,- pparam :: Bool } -- this is a param (rather than index)- | Constraint { pargopts :: [ArgOpt],- pstatic :: Static }- | TacImp { pargopts :: [ArgOpt],- pstatic :: Static,- pscript :: PTerm }- deriving (Show, Eq, Data, Typeable)+ | Exp { pargopts :: [ArgOpt]+ , pstatic :: Static+ , pparam :: Bool -- ^ this is a param (rather than index)+ }+ | Constraint { pargopts :: [ArgOpt]+ , pstatic :: Static+ }+ | TacImp { pargopts :: [ArgOpt]+ , pstatic :: Static+ , pscript :: PTerm+ }+ deriving (Show, Eq, Data, Typeable) {-! deriving instance Binary Plicity@@ -645,12 +686,16 @@ is_scoped :: Plicity -> Maybe ImplicitInfo is_scoped (Imp _ _ _ s _) = s-is_scoped _ = Nothing+is_scoped _ = Nothing -impl = Imp [] Dynamic False (Just (Impl False True)) False+-- Top level implicit+impl = Imp [] Dynamic False (Just (Impl False True False)) False+-- Machine generated top level implicit+impl_gen = Imp [] Dynamic False (Just (Impl False True True)) False -forall_imp = Imp [] Dynamic False (Just (Impl False False)) False-forall_constraint = Imp [] Dynamic False (Just (Impl True False)) False+-- Scoped implicits+forall_imp = Imp [] Dynamic False (Just (Impl False False True)) False+forall_constraint = Imp [] Dynamic False (Just (Impl True False True)) False expl = Exp [] Dynamic False expl_param = Exp [] Dynamic True@@ -659,21 +704,23 @@ tacimpl t = TacImp [] Dynamic t -data FnOpt = Inlinable -- always evaluate when simplifying+data FnOpt = Inlinable -- ^ always evaluate when simplifying | TotalFn | PartialFn | CoveringFn | Coinductive | AssertTotal- | Dictionary -- type class dictionary, eval only when- -- a function argument, and further evaluation resutls- | Implicit -- implicit coercion- | NoImplicit -- do not apply implicit coercions- | CExport String -- export, with a C name- | ErrorHandler -- ^^ an error handler for use with the ErrorReflection extension- | ErrorReverse -- ^^ attempt to reverse normalise before showing in error- | Reflection -- a reflecting function, compile-time only- | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names- | Constructor -- Data constructor type- | AutoHint -- use in auto implicit search- | PEGenerated -- generated by partial evaluator++ -- | type class dictionary, eval only when a function+ -- argument, and further evaluation results.+ | Dictionary+ | Implicit -- ^ implicit coercion+ | NoImplicit -- ^ do not apply implicit coercions+ | CExport String -- ^ export, with a C name+ | ErrorHandler -- ^ an error handler for use with the ErrorReflection extension+ | ErrorReverse -- ^ attempt to reverse normalise before showing in error+ | Reflection -- ^ a reflecting function, compile-time only+ | Specialise [(Name, Maybe Int)] -- ^ specialise it, freeze these names+ | Constructor -- ^ Data constructor type+ | AutoHint -- ^ use in auto implicit search+ | PEGenerated -- ^ generated by partial evaluator deriving (Show, Eq) {-! deriving instance Binary FnOpt@@ -699,67 +746,84 @@ -- | Top-level declarations such as compiler directives, definitions, -- datatypes and typeclasses. data PDecl' t- = PFix FC Fixity [String] -- ^ Fixity declaration- | PTy (Docstring (Either Err t)) [(Name, Docstring (Either Err t))] SyntaxInfo FC FnOpts Name FC t -- ^ Type declaration (last FC is precise name location)+ -- | Fixity declaration+ = PFix FC Fixity [String]+ -- | Type declaration (last FC is precise name location)+ | PTy (Docstring (Either Err t)) [(Name, Docstring (Either Err t))] SyntaxInfo FC FnOpts Name FC t+ -- | Postulate, second FC is precise name location | PPostulate Bool -- external def if true- (Docstring (Either Err t)) SyntaxInfo FC FC FnOpts Name t -- ^ Postulate, second FC is precise name location- | PClauses FC FnOpts Name [PClause' t] -- ^ Pattern clause- | PCAF FC Name t -- ^ Top level constant- | PData (Docstring (Either Err t)) [(Name, Docstring (Either Err t))] SyntaxInfo FC DataOpts (PData' t) -- ^ Data declaration.- | PParams FC [(Name, t)] [PDecl' t] -- ^ Params block- | POpenInterfaces FC [Name] [PDecl' t] -- ^ Open block/declaration+ (Docstring (Either Err t)) SyntaxInfo FC FC FnOpts Name t+ -- | Pattern clause+ | PClauses FC FnOpts Name [PClause' t]+ -- | Top level constant+ | PCAF FC Name t+ -- | Data declaration.+ | PData (Docstring (Either Err t)) [(Name, Docstring (Either Err t))] SyntaxInfo FC DataOpts (PData' t)+ -- | Params block+ | PParams FC [(Name, t)] [PDecl' t]+ -- | Open block/declaration+ | POpenInterfaces FC [Name] [PDecl' t]+ -- | New namespace, where FC is accurate location of the namespace+ -- in the file | PNamespace String FC [PDecl' t]- -- ^ New namespace, where FC is accurate location of the- -- namespace in the file- | PRecord (Docstring (Either Err t)) SyntaxInfo FC DataOpts- Name -- Record name- FC -- Record name precise location- [(Name, FC, Plicity, t)] -- Parameters, where FC is precise name span- [(Name, Docstring (Either Err t))] -- Param Docs- [(Maybe (Name, FC), Plicity, t, Maybe (Docstring (Either Err t)))] -- Fields- (Maybe (Name, FC)) -- Optional constructor name and location- (Docstring (Either Err t)) -- Constructor doc- SyntaxInfo -- Constructor SyntaxInfo- -- ^ Record declaration- | PClass (Docstring (Either Err t)) SyntaxInfo FC- [(Name, t)] -- constraints- Name -- class name- FC -- accurate location of class name- [(Name, FC, t)] -- parameters and precise locations- [(Name, Docstring (Either Err t))] -- parameter docstrings- [(Name, FC)] -- determining parameters and precise locations- [PDecl' t] -- declarations- (Maybe (Name, FC)) -- instance constructor name and location- (Docstring (Either Err t)) -- instance constructor docs- -- ^ Type class: arguments are documentation, syntax info, source location, constraints,- -- class name, class name location, parameters, method declarations, optional constructor name- | PInstance- (Docstring (Either Err t)) -- Instance docs- [(Name, Docstring (Either Err t))] -- Parameter docs- SyntaxInfo- FC [(Name, t)] -- constraints- [Name] -- parent dictionaries to search for constraints- Accessibility- FnOpts- Name -- class- FC -- precise location of class- [t] -- parameters- [(Name, t)] -- Extra names in scope in the body- t -- full instance type- (Maybe Name) -- explicit name- [PDecl' t]- -- ^ Instance declaration: arguments are documentation, syntax info, source- -- location, constraints, class name, parameters, full instance- -- type, optional explicit name, and definitions+ -- | Record name.+ | PRecord (Docstring (Either Err t)) SyntaxInfo FC DataOpts+ Name -- Record name+ FC -- Record name precise location+ [(Name, FC, Plicity, t)] -- Parameters, where FC is precise name span+ [(Name, Docstring (Either Err t))] -- Param Docs+ [(Maybe (Name, FC), Plicity, t, Maybe (Docstring (Either Err t)))] -- Fields+ (Maybe (Name, FC)) -- Optional constructor name and location+ (Docstring (Either Err t)) -- Constructor doc+ SyntaxInfo -- Constructor SyntaxInfo++ -- | Type class: arguments are documentation, syntax info, source+ -- location, constraints, class name, class name location,+ -- parameters, method declarations, optional constructor name+ | PClass (Docstring (Either Err t)) SyntaxInfo FC+ [(Name, t)] -- constraints+ Name -- class name+ FC -- accurate location of class name+ [(Name, FC, t)] -- parameters and precise locations+ [(Name, Docstring (Either Err t))] -- parameter docstrings+ [(Name, FC)] -- determining parameters and precise locations+ [PDecl' t] -- declarations+ (Maybe (Name, FC)) -- instance constructor name and location+ (Docstring (Either Err t)) -- instance constructor docs++ -- | Instance declaration: arguments are documentation, syntax+ -- info, source location, constraints, class name, parameters, full+ -- instance type, optional explicit name, and definitions+ | PInstance (Docstring (Either Err t)) -- Instance docs+ [(Name, Docstring (Either Err t))] -- Parameter docs+ SyntaxInfo+ FC [(Name, t)] -- constraints+ [Name] -- parent dictionaries to search for constraints+ Accessibility+ FnOpts+ Name -- class+ FC -- precise location of class+ [t] -- parameters+ [(Name, t)] -- Extra names in scope in the body+ t -- full instance type+ (Maybe Name) -- explicit name+ [PDecl' t] | PDSL Name (DSL' t) -- ^ DSL declaration- | PSyntax FC Syntax -- ^ Syntax definition+ | PSyntax FC Syntax -- ^ Syntax definition | PMutual FC [PDecl' t] -- ^ Mutual block- | PDirective Directive -- ^ Compiler directive.- | PProvider (Docstring (Either Err t)) SyntaxInfo FC FC (ProvideWhat' t) Name -- ^ Type provider. The first t is the type, the second is the term. The second FC is precise highlighting location.- | PTransform FC Bool t t -- ^ Source-to-source transformation rule. If- -- bool is True, lhs and rhs must be convertible- | PRunElabDecl FC t [String] -- ^ FC is decl-level, for errors, and- -- Strings represent the namespace+ | PDirective Directive -- ^ Compiler directive.++ -- | Type provider. The first t is the type, the second is the+ -- term. The second FC is precise highlighting location.+ | PProvider (Docstring (Either Err t)) SyntaxInfo FC FC (ProvideWhat' t) Name++ -- | Source-to-source transformation rule. If bool is True, lhs and+ -- rhs must be convertible.+ | PTransform FC Bool t t++ -- | FC is decl-level, for errors, and Strings represent the+ -- namespace+ | PRunElabDecl FC t [String] deriving Functor {-! deriving instance Binary PDecl'@@ -773,7 +837,9 @@ | DInclude Codegen String | DHide Name | DFreeze Name+ | DThaw Name | DInjective Name+ | DSetTotal Name -- assert totality after checking | DAccess Accessibility | DDefault DefaultTotality | DLogging Integer@@ -792,18 +858,19 @@ | RClausesInstrs Name [([(Name, Term)], Term, Term)] | RAddInstance Name Name | RDatatypeDeclInstrs Name [PArg]+ -- | Datatype, constructors | RDatatypeDefnInstrs Name Type [(Name, [PArg], Type)]- -- ^ Datatype, constructors + -- | For elaborator state data EState = EState {- case_decls :: [(Name, PDecl)],- delayed_elab :: [(Int, Elab' EState ())],- new_tyDecls :: [RDeclInstructions],- highlighting :: [(FC, OutputAnnotation)],- auto_binds :: [Name], -- names bound as auto implicits- implicit_warnings :: [(FC, Name)] -- Implicit warnings to report (location and global name)- }+ case_decls :: [(Name, PDecl)]+ , delayed_elab :: [(Int, Elab' EState ())]+ , new_tyDecls :: [RDeclInstructions]+ , highlighting :: [(FC, OutputAnnotation)]+ , auto_binds :: [Name] -- ^ names bound as auto implicits+ , implicit_warnings :: [(FC, Name)] -- ^ Implicit warnings to report (location and global name)+ } initEState :: EState initEState = EState [] [] [] [] [] []@@ -835,20 +902,23 @@ !-} -- | Data declaration-data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype- d_name_fc :: FC, -- ^ The precise location of the type constructor name- d_tcon :: t, -- ^ Type constructor- d_cons :: [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, t, FC, [Name])] -- ^ Constructors- }- -- ^ Data declaration- | PLaterdecl { d_name :: Name, d_name_fc :: FC, d_tcon :: t }- -- ^ "Placeholder" for data whose constructors are defined later- deriving Functor+data PData' t =+ -- | Data declaration+ PDatadecl { d_name :: Name -- ^ The name of the datatype+ , d_name_fc :: FC -- ^ The precise location of the type constructor name+ , d_tcon :: t -- ^ Type constructor+ , d_cons :: [(Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, t, FC, [Name])] -- ^ Constructors+ }+ -- | "Placeholder" for data whose constructors are defined later+ | PLaterdecl { d_name :: Name+ , d_name_fc :: FC+ , d_tcon :: t+ } deriving Functor -- | Transform the FCs in a PData and its associated terms. The first--- function transforms the general-purpose FCs, and the second transforms--- those that are used for semantic source highlighting, so they can be--- treated specially.+-- function transforms the general-purpose FCs, and the second+-- transforms those that are used for semantic source highlighting, so+-- they can be treated specially. mapPDataFC :: (FC -> FC) -> (FC -> FC) -> PData -> PData mapPDataFC f g (PDatadecl n nfc tycon ctors) = PDatadecl n (g nfc) (mapPTermFC f g tycon) (map ctorFC ctors)@@ -1030,56 +1100,76 @@ -- (map (updateDNs ns) ds) -- updateDNs ns c = c -data PunInfo = IsType | IsTerm | TypeOrTerm deriving (Eq, Show, Data, Typeable)+data PunInfo = IsType+ | IsTerm+ | TypeOrTerm+ deriving (Eq, Show, Data, Typeable) -- | High level language terms-data PTerm = PQuote Raw -- ^ Inclusion of a core term into the high-level language- | PRef FC [FC] Name -- ^ A reference to a variable. The FC is its precise source location for highlighting. The list of FCs is a collection of additional highlighting locations.- | PInferRef FC [FC] Name -- ^ A name to be defined later- | PPatvar FC Name -- ^ A pattern variable- | PLam FC Name FC PTerm PTerm -- ^ A lambda abstraction. Second FC is name span.- | PPi Plicity Name FC PTerm PTerm -- ^ (n : t1) -> t2, where the FC is for the precise location of the variable- | PLet FC Name FC PTerm PTerm PTerm -- ^ A let binding (second FC is precise name location)- | PTyped PTerm PTerm -- ^ Term with explicit type- | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x- | PWithApp FC PTerm PTerm -- ^ Application plus a 'with' argument- | PAppImpl PTerm [ImplicitInfo] -- ^ Implicit argument application (introduced during elaboration only)- | PAppBind FC PTerm [PArg] -- ^ implicitly bound application- | PMatchApp FC Name -- ^ Make an application by type matching- | PIfThenElse FC PTerm PTerm PTerm -- ^ Conditional expressions - elaborated to an overloading of ifThenElse- | PCase FC PTerm [(PTerm, PTerm)] -- ^ A case expression. Args are source location, scrutinee, and a list of pattern/RHS pairs- | PTrue FC PunInfo -- ^ Unit type..?- | PResolveTC FC -- ^ Solve this dictionary by type class resolution+data PTerm = PQuote Raw -- ^ Inclusion of a core term into the+ -- high-level language+ | PRef FC [FC] Name+ -- ^ A reference to a variable. The FC is its precise+ -- source location for highlighting. The list of FCs is a+ -- collection of additional highlighting locations.+ | PInferRef FC [FC] Name -- ^ A name to be defined later+ | PPatvar FC Name -- ^ A pattern variable+ | PLam FC Name FC PTerm PTerm -- ^ A lambda abstraction. Second FC is name span.+ | PPi Plicity Name FC PTerm PTerm -- ^ (n : t1) -> t2, where the FC is for the precise location of the variable+ | PLet FC Name FC PTerm PTerm PTerm -- ^ A let binding (second FC is precise name location)+ | PTyped PTerm PTerm -- ^ Term with explicit type+ | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x+ | PWithApp FC PTerm PTerm -- ^ Application plus a 'with' argument+ | PAppImpl PTerm [ImplicitInfo] -- ^ Implicit argument application (introduced during elaboration only)+ | PAppBind FC PTerm [PArg] -- ^ implicitly bound application+ | PMatchApp FC Name -- ^ Make an application by type matching+ | PIfThenElse FC PTerm PTerm PTerm -- ^ Conditional expressions - elaborated to an overloading of ifThenElse+ | PCase FC PTerm [(PTerm, PTerm)] -- ^ A case expression. Args are source location, scrutinee, and a list of pattern/RHS pairs+ | PTrue FC PunInfo -- ^ Unit type..?+ | PResolveTC FC -- ^ Solve this dictionary by type class resolution | PRewrite FC (Maybe Name) PTerm PTerm (Maybe PTerm)- -- ^ "rewrite" syntax, with optional rewriting function- -- and optional result type- | PPair FC [FC] PunInfo PTerm PTerm -- ^ A pair (a, b) and whether it's a product type or a pair (solved by elaboration). The list of FCs is its punctuation.- | PDPair FC [FC] PunInfo PTerm PTerm PTerm -- ^ A dependent pair (tm : a ** b) and whether it's a sigma type or a pair that inhabits one (solved by elaboration). The [FC] is its punctuation.- | PAs FC Name PTerm -- ^ @-pattern, valid LHS only+ -- ^ "rewrite" syntax, with optional rewriting function and+ -- optional result type+ | PPair FC [FC] PunInfo PTerm PTerm+ -- ^ A pair (a, b) and whether it's a product type or a+ -- pair (solved by elaboration). The list of FCs is its+ -- punctuation.+ | PDPair FC [FC] PunInfo PTerm PTerm PTerm+ -- ^ A dependent pair (tm : a ** b) and whether it's a+ -- sigma type or a pair that inhabits one (solved by+ -- elaboration). The [FC] is its punctuation.+ | PAs FC Name PTerm -- ^ @-pattern, valid LHS only | PAlternative [(Name, Name)] PAltType [PTerm] -- ^ (| A, B, C|). Includes unapplied unique name mappings for mkUniqueNames.- | PHidden PTerm -- ^ Irrelevant or hidden pattern- | PType FC -- ^ 'Type' type- | PUniverse Universe -- ^ Some universe- | PGoal FC PTerm Name PTerm -- ^ quoteGoal, used for %reflection functions- | PConstant FC Const -- ^ Builtin types- | Placeholder -- ^ Underscore- | PDoBlock [PDo] -- ^ Do notation- | PIdiom FC PTerm -- ^ Idiom brackets+ | PHidden PTerm -- ^ Irrelevant or hidden pattern+ | PType FC -- ^ 'Type' type+ | PUniverse Universe -- ^ Some universe+ | PGoal FC PTerm Name PTerm -- ^ quoteGoal, used for %reflection functions+ | PConstant FC Const -- ^ Builtin types+ | Placeholder -- ^ Underscore+ | PDoBlock [PDo] -- ^ Do notation+ | PIdiom FC PTerm -- ^ Idiom brackets | PReturn FC- | PMetavar FC Name -- ^ A metavariable, ?name, and its precise location- | PProof [PTactic] -- ^ Proof script- | PTactics [PTactic] -- ^ As PProof, but no auto solving- | PElabError Err -- ^ Error to report on elaboration- | PImpossible -- ^ Special case for declaring when an LHS can't typecheck- | PCoerced PTerm -- ^ To mark a coerced argument, so as not to coerce twice- | PDisamb [[T.Text]] PTerm -- ^ Preferences for explicit namespaces- | PUnifyLog PTerm -- ^ dump a trace of unifications when building term- | PNoImplicits PTerm -- ^ never run implicit converions on the term- | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term])- | PUnquote PTerm -- ^ ~Term- | PQuoteName Name Bool FC -- ^ `{n} where the FC is the precise highlighting for the name in particular. If the Bool is False, then it's `{{n}} and the name won't be resolved.- | PRunElab FC PTerm [String] -- ^ %runElab tm - New-style proof script. Args are location, script, enclosing namespace.- | PConstSugar FC PTerm -- ^ A desugared constant. The FC is a precise source location that will be used to highlight it later.+ | PMetavar FC Name -- ^ A metavariable, ?name, and its precise location+ | PProof [PTactic] -- ^ Proof script+ | PTactics [PTactic] -- ^ As PProof, but no auto solving+ | PElabError Err -- ^ Error to report on elaboration+ | PImpossible -- ^ Special case for declaring when an LHS can't typecheck+ | PCoerced PTerm -- ^ To mark a coerced argument, so as not to coerce twice+ | PDisamb [[T.Text]] PTerm -- ^ Preferences for explicit namespaces+ | PUnifyLog PTerm -- ^ dump a trace of unifications when building term+ | PNoImplicits PTerm -- ^ never run implicit converions on the term+ | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term])+ | PUnquote PTerm -- ^ ~Term+ | PQuoteName Name Bool FC+ -- ^ `{n} where the FC is the precise highlighting for+ -- the name in particular. If the Bool is False, then+ -- it's `{{n}} and the name won't be resolved.+ | PRunElab FC PTerm [String]+ -- ^ %runElab tm - New-style proof script. Args are+ -- location, script, enclosing namespace.+ | PConstSugar FC PTerm+ -- ^ A desugared constant. The FC is a precise source+ -- location that will be used to highlight it later. deriving (Eq, Data, Typeable) data PAltType = ExactlyOne Bool -- ^ flag sets whether delay is allowed@@ -1249,9 +1339,9 @@ type PTactic = PTactic' PTerm data PDo' t = DoExp FC t- | DoBind FC Name FC t -- ^ second FC is precise name location+ | DoBind FC Name FC t -- ^ second FC is precise name location | DoBindP FC t t [(t,t)]- | DoLet FC Name FC t t -- ^ second FC is precise name location+ | DoLet FC Name FC t t -- ^ second FC is precise name location | DoLetP FC t t deriving (Eq, Functor, Data, Typeable) {-!@@ -1262,9 +1352,9 @@ instance Sized a => Sized (PDo' a) where size (DoExp fc t) = 1 + size fc + size t size (DoBind fc nm nfc t) = 1 + size fc + size nm + size nfc + size t- size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts- size (DoLet fc nm nfc l r) = 1 + size fc + size nm + size l + size r- size (DoLetP fc l r) = 1 + size fc + size l + size r+ size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts+ size (DoLet fc nm nfc l r) = 1 + size fc + size nm + size l + size r+ size (DoLetP fc l r) = 1 + size fc + size l + size r type PDo = PDo' PTerm @@ -1272,33 +1362,40 @@ -- things early which will help give a more concrete type to other -- variables, e.g. a before (interpTy a). -data PArg' t = PImp { priority :: Int,- machine_inf :: Bool, -- true if the machine inferred it- argopts :: [ArgOpt],- pname :: Name,- getTm :: t }- | PExp { priority :: Int,- argopts :: [ArgOpt],- pname :: Name,- getTm :: t }- | PConstraint { priority :: Int,- argopts :: [ArgOpt],- pname :: Name,- getTm :: t }- | PTacImplicit { priority :: Int,- argopts :: [ArgOpt],- pname :: Name,- getScript :: t,- getTm :: t }- deriving (Show, Eq, Functor, Data, Typeable)+data PArg' t = PImp { priority :: Int+ , machine_inf :: Bool -- ^ true if the machine inferred it+ , argopts :: [ArgOpt]+ , pname :: Name+ , getTm :: t+ }+ | PExp { priority :: Int+ , argopts :: [ArgOpt]+ , pname :: Name+ , getTm :: t+ }+ | PConstraint { priority :: Int+ , argopts :: [ArgOpt]+ , pname :: Name+ , getTm :: t+ }+ | PTacImplicit { priority :: Int+ , argopts :: [ArgOpt]+ , pname :: Name+ , getScript :: t+ , getTm :: t+ }+ deriving (Show, Eq, Functor, Data, Typeable) -data ArgOpt = AlwaysShow | HideDisplay | InaccessibleArg | UnknownImp- deriving (Show, Eq, Data, Typeable)+data ArgOpt = AlwaysShow+ | HideDisplay+ | InaccessibleArg+ | UnknownImp+ deriving (Show, Eq, Data, Typeable) instance Sized a => Sized (PArg' a) where size (PImp p _ l nm trm) = 1 + size nm + size trm size (PExp p l nm trm) = 1 + size nm + size trm- size (PConstraint p l nm trm) = 1 + size nm +size nm + size trm+ size (PConstraint p l nm trm) = 1 + size nm + size nm + size trm size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm {-!@@ -1375,28 +1472,30 @@ -- Type class data -data ClassInfo = CI { instanceCtorName :: Name,- class_methods :: [(Name, (Bool, FnOpts, PTerm))], -- flag whether it's a "data" method- class_defaults :: [(Name, (Name, PDecl))], -- method name -> default impl- class_default_superclasses :: [PDecl],- class_params :: [Name],- class_instances :: [(Name, Bool)], -- the Bool is whether to include in instance search, so named instances are excluded- class_determiners :: [Int] }- deriving Show+data ClassInfo = CI {+ instanceCtorName :: Name+ , class_methods :: [(Name, (Bool, FnOpts, PTerm))] -- ^ flag whether it's a "data" method+ , class_defaults :: [(Name, (Name, PDecl))] -- ^ method name -> default impl+ , class_default_superclasses :: [PDecl]+ , class_params :: [Name]+ , class_instances :: [(Name, Bool)] -- ^ the Bool is whether to include in instance search, so named instances are excluded+ , class_determiners :: [Int]+ } deriving Show {-! deriving instance Binary ClassInfo deriving instance NFData ClassInfo !-} -- Record data-data RecordInfo = RI { record_parameters :: [(Name,PTerm)],- record_constructor :: Name,- record_projections :: [Name] }- deriving Show+data RecordInfo = RI {+ record_parameters :: [(Name,PTerm)]+ , record_constructor :: Name+ , record_projections :: [Name]+ } deriving Show -- Type inference data -data TIData = TIPartial -- ^ a function with a partially defined type+data TIData = TIPartial -- ^ a function with a partially defined type | TISolution [Term] -- ^ possible solutions to a metavariable in a type deriving Show @@ -1408,27 +1507,28 @@ deriving instance NFData FnInfo !-} -data OptInfo = Optimise { inaccessible :: [(Int,Name)], -- includes names for error reporting- detaggable :: Bool }- deriving Show+data OptInfo = Optimise {+ inaccessible :: [(Int,Name)] -- includes names for error reporting+ , detaggable :: Bool+ } deriving Show {-! deriving instance Binary OptInfo deriving instance NFData OptInfo !-} -- | Syntactic sugar info-data DSL' t = DSL { dsl_bind :: t,- dsl_return :: t,- dsl_apply :: t,- dsl_pure :: t,- dsl_var :: Maybe t,- index_first :: Maybe t,- index_next :: Maybe t,- dsl_lambda :: Maybe t,- dsl_let :: Maybe t,- dsl_pi :: Maybe t- }- deriving (Show, Functor)+data DSL' t = DSL {+ dsl_bind :: t+ , dsl_return :: t+ , dsl_apply :: t+ , dsl_pure :: t+ , dsl_var :: Maybe t+ , index_first :: Maybe t+ , index_next :: Maybe t+ , dsl_lambda :: Maybe t+ , dsl_let :: Maybe t+ , dsl_pi :: Maybe t+ } deriving (Show, Functor) {-! deriving instance Binary DSL' deriving instance NFData DSL'@@ -1436,7 +1536,9 @@ type DSL = DSL' PTerm -data SynContext = PatternSyntax | TermSyntax | AnySyntax+data SynContext = PatternSyntax+ | TermSyntax+ | AnySyntax deriving Show {-! deriving instance Binary SynContext@@ -1536,24 +1638,25 @@ deriving instance NFData Using !-} -data SyntaxInfo = Syn { using :: [Using],- syn_params :: [(Name, PTerm)],- syn_namespace :: [String],- no_imp :: [Name],- imp_methods :: [Name], -- class methods. When expanding- -- implicits, these should be expanded even under- -- binders- decoration :: Name -> Name,- inPattern :: Bool,- implicitAllowed :: Bool,- constraintAllowed :: Bool,- maxline :: Maybe Int,- mut_nesting :: Int,- dsl_info :: DSL,- syn_in_quasiquote :: Int,- syn_toplevel :: Bool,- withAppAllowed :: Bool }- deriving Show+data SyntaxInfo = Syn {+ using :: [Using]+ , syn_params :: [(Name, PTerm)]+ , syn_namespace :: [String]+ , no_imp :: [Name]+ , imp_methods :: [Name]+ -- ^ class methods. When expanding implicits, these should be+ -- expanded even under binders+ , decoration :: Name -> Name+ , inPattern :: Bool+ , implicitAllowed :: Bool+ , constraintAllowed :: Bool+ , maxline :: Maybe Int+ , mut_nesting :: Int+ , dsl_info :: DSL+ , syn_in_quasiquote :: Int+ , syn_toplevel :: Bool+ , withAppAllowed :: Bool+ } deriving Show {-! deriving instance NFData SyntaxInfo deriving instance Binary SyntaxInfo@@ -1571,13 +1674,14 @@ -- For inferring types of things bi = fileFC "builtin"+primfc = fileFC "(primitive)" inferTy = sMN 0 "__Infer" inferCon = sMN 0 "__infer"-inferDecl = PDatadecl inferTy NoFC+inferDecl = PDatadecl inferTy primfc (PType bi)- [(emptyDocstring, [], inferCon, NoFC, PPi impl (sMN 0 "iType") NoFC (PType bi) (- PPi expl (sMN 0 "ival") NoFC (PRef bi [] (sMN 0 "iType"))+ [(emptyDocstring, [], inferCon, primfc, PPi impl (sMN 0 "iType") primfc (PType bi) (+ PPi expl (sMN 0 "ival") primfc (PRef bi [] (sMN 0 "iType")) (PRef bi [] inferTy)), bi, [])] inferOpts = [] @@ -1590,7 +1694,7 @@ getInferTerm tm = tm -- error ("getInferTerm " ++ show tm) getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc- where toTy (Lam t) = Pi Nothing t (TType (UVar 0))+ where toTy (Lam t) = Pi Nothing t (TType (UVar [] 0)) toTy (PVar t) = PVTy t toTy b = b getInferType (App _ (App _ _ ty) _) = ty@@ -1631,12 +1735,12 @@ "\n\n" ++ "You may need to use `(~=~)` to explicitly request heterogeneous equality." -eqDecl = PDatadecl eqTy NoFC (piBindp impl [(n "A", PType bi), (n "B", PType bi)]+eqDecl = PDatadecl eqTy primfc (piBindp impl [(n "A", PType bi), (n "B", PType bi)] (piBind [(n "x", PRef bi [] (n "A")), (n "y", PRef bi [] (n "B"))] (PType bi))) [(reflDoc, reflParamDoc,- eqCon, NoFC, PPi impl (n "A") NoFC (PType bi) (- PPi impl (n "x") NoFC (PRef bi [] (n "A"))+ eqCon, primfc, PPi impl (n "A") primfc (PType bi) (+ PPi impl (n "x") primfc (PRef bi [] (n "A")) (PApp bi (PRef bi [] eqTy) [pimp (n "A") Placeholder False, pimp (n "B") Placeholder False, pexp (PRef bi [] (n "x")),@@ -1693,9 +1797,9 @@ instance Pretty PTerm OutputAnnotation where pretty = prettyImp defaultPPOption --- | Colourise annotations according to an Idris state. It ignores the names--- in the annotation, as there's no good way to show extended information on a--- terminal.+-- | Colourise annotations according to an Idris state. It ignores the+-- names in the annotation, as there's no good way to show extended+-- information on a terminal. annotationColour :: IState -> OutputAnnotation -> Maybe IdrisColour annotationColour ist _ | not (idris_colourRepl ist) = Nothing annotationColour ist (AnnConst c) =@@ -1724,8 +1828,8 @@ annotationColour ist _ = Nothing --- | Colourise annotations according to an Idris state. It ignores the names--- in the annotation, as there's no good way to show extended+-- | Colourise annotations according to an Idris state. It ignores the+-- names in the annotation, as there's no good way to show extended -- information on a terminal. Note that strings produced this way will -- not be coloured on Windows, so the use of the colour rendering -- functions in Idris.Output is to be preferred.@@ -1735,9 +1839,10 @@ isPostulateName :: Name -> IState -> Bool isPostulateName n ist = S.member n (idris_postulates ist) --- | Pretty-print a high-level closed Idris term with no information about precedence/associativity-prettyImp :: PPOption -- ^^ pretty printing options- -> PTerm -- ^^ the term to pretty-print+-- | Pretty-print a high-level closed Idris term with no information+-- about precedence/associativity+prettyImp :: PPOption -- ^ pretty printing options+ -> PTerm -- ^ the term to pretty-print -> Doc OutputAnnotation prettyImp impl = pprintPTerm impl [] [] [] @@ -1747,12 +1852,13 @@ prettyIst :: IState -> PTerm -> Doc OutputAnnotation prettyIst ist = pprintPTerm (ppOptionIst ist) [] [] (idris_infixes ist) --- | Pretty-print a high-level Idris term in some bindings context with infix info-pprintPTerm :: PPOption -- ^^ pretty printing options- -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit- -> [Name] -- ^^ names to always show in pi, even if not used- -> [FixDecl] -- ^^ Fixity declarations- -> PTerm -- ^^ the term to pretty-print+-- | Pretty-print a high-level Idris term in some bindings context+-- with infix info.+pprintPTerm :: PPOption -- ^ pretty printing options+ -> [(Name, Bool)] -- ^ the currently-bound names and whether they are implicit+ -> [Name] -- ^ names to always show in pi, even if not used+ -> [FixDecl] -- ^ Fixity declarations+ -> PTerm -- ^ the term to pretty-print -> Doc OutputAnnotation pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd where@@ -1764,7 +1870,7 @@ text "![" <> pretty r <> text "]" prettySe d p bnd (PPatvar fc n) = pretty n prettySe d p bnd e- | Just str <- slist d p bnd e = depth d $ str+ | Just str <- slist d p bnd e = depth d str | Just n <- snat ppo d p e = depth d $ annotate (AnnData "Nat" "") (text (show n)) prettySe d p bnd (PRef fc _ n) = prettyName True (ppopt_impl ppo) bnd n prettySe d p bnd (PLam fc n nfc ty sc) =@@ -2125,8 +2231,8 @@ basename (NS n _) = basename n basename n = n --- | Determine whether a name was the one inserted for a hole or--- guess by the delaborator+-- | Determine whether a name was the one inserted for a hole or guess+-- by the delaborator isHoleName :: Name -> Bool isHoleName (UN n) = n == T.pack "[__]" isHoleName _ = False@@ -2136,12 +2242,11 @@ containsHole pterm = or [isHoleName n | PRef _ _ n <- take 1000 $ universe pterm] -- | Pretty-printer helper for names that attaches the correct annotations-prettyName- :: Bool -- ^^ whether the name should be parenthesised if it is an infix operator- -> Bool -- ^^ whether to show namespaces- -> [(Name, Bool)] -- ^^ the current bound variables and whether they are implicit- -> Name -- ^^ the name to pprint- -> Doc OutputAnnotation+prettyName :: Bool -- ^ whether the name should be parenthesised if it is an infix operator+ -> Bool -- ^ whether to show namespaces+ -> [(Name, Bool)] -- ^ the current bound variables and whether they are implicit+ -> Name -- ^ the name to pprint+ -> Doc OutputAnnotation prettyName infixParen showNS bnd n | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_" | (UN n') <- n, T.unpack n' == "_" = text "_"@@ -2228,11 +2333,11 @@ -- | Show Idris name-showName :: Maybe IState -- ^^ the Idris state, for information about names and colours- -> [(Name, Bool)] -- ^^ the bound variables and whether they're implicit- -> PPOption -- ^^ pretty printing options- -> Bool -- ^^ whether to colourise- -> Name -- ^^ the term to show+showName :: Maybe IState -- ^ the Idris state, for information about names and colours+ -> [(Name, Bool)] -- ^ the bound variables and whether they're implicit+ -> PPOption -- ^ pretty printing options+ -> Bool -- ^ whether to colourise+ -> Name -- ^ the term to show -> String showName ist bnd ppo colour n = case ist of Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n@@ -2256,8 +2361,8 @@ -- (like error messages). Thus, unknown vars are colourised as implicits. | otherwise -> colouriseImplicit t name -showTm :: IState -- ^^ the Idris state, for information about identifiers and colours- -> PTerm -- ^^ the term to show+showTm :: IState -- ^ the Idris state, for information about identifiers and colours+ -> PTerm -- ^ the term to show -> String showTm ist = displayDecorated (consoleDecorate ist) . renderPretty 0.8 100000 .
src/Idris/Apropos.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Apropos+Description : Search loaded Idris code and named modules for things.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Idris.Apropos (apropos, aproposModules) where import Idris.AbsSyntax
src/Idris/CaseSplit.hs view
@@ -1,11 +1,31 @@+{-|+Module : Idris.CaseSplit+Description : Module to provide case split functionality.+Copyright :+License : BSD3+Maintainer : The Idris Community.++Given a pattern clause and a variable 'n', elaborate the clause and find the+type of 'n'.++Make new pattern clauses by replacing 'n' with all the possibly constructors+applied to '_', and replacing all other variables with '_' in order to+resolve other dependencies.++Finally, merge the generated patterns with the original, by matching.+Always take the "more specific" argument when there is a discrepancy, i.e.+names over '_', patterns over names, etc.++-} {-# LANGUAGE PatternGuards #-} -module Idris.CaseSplit(splitOnLine, replaceSplits,- getClause, getProofClause,- mkWith,- nameMissing,- getUniq, nameRoot) where--- splitting a variable in a pattern clause+module Idris.CaseSplit(+ splitOnLine, replaceSplits+ , getClause, getProofClause+ , mkWith+ , nameMissing+ , getUniq, nameRoot+ ) where import Idris.AbsSyntax import Idris.AbsSyntaxTree (Idris, IState, PTerm)@@ -36,25 +56,11 @@ import Debug.Trace -{---Given a pattern clause and a variable 'n', elaborate the clause and find the-type of 'n'.--Make new pattern clauses by replacing 'n' with all the possibly constructors-applied to '_', and replacing all other variables with '_' in order to-resolve other dependencies.--Finally, merge the generated patterns with the original, by matching.-Always take the "more specific" argument when there is a discrepancy, i.e.-names over '_', patterns over names, etc.--}---- Given a variable to split, and a term application, return a list of--- variable updates, paired with a flag to say whether the given update--- typechecks (False = impossible)--- if the flag is 'False' the splits should be output with the 'impossible'--- flag, otherwise they should be output as normal+-- | Given a variable to split, and a term application, return a list+-- of variable updates, paired with a flag to say whether the given+-- update typechecks (False = impossible) if the flag is 'False' the+-- splits should be output with the 'impossible' flag, otherwise they+-- should be output as normal split :: Name -> PTerm -> Idris (Bool, [[(Name, PTerm)]]) split n t' = do ist <- getIState@@ -62,7 +68,7 @@ mapM_ (\n -> setAccessibility n Public) (allNamesIn t') -- ETyDecl rather then ELHS because there'll be explicit type -- matching- (tm, ty, pats) <- elabValBind recinfo ETyDecl True (addImplPat ist t')+ (tm, ty, pats) <- elabValBind (recinfo (fileFC "casesplit")) ETyDecl True (addImplPat ist t') -- ASSUMPTION: tm is in normal form after elabValBind, so we don't -- need to do anything special to find out what family each argument -- is in@@ -170,8 +176,8 @@ put (ms { namemap = ((n', n) : namemap ms) }) addNameMap _ = return () --- If any names are unified, make sure they stay unified. Always prefer--- user provided name (first pattern)+-- | If any names are unified, make sure they stay unified. Always+-- prefer user provided name (first pattern) mergePat' ist (PPatvar fc n) new t = mergePat' ist (PRef fc [] n) new t mergePat' ist old (PPatvar fc n) t@@ -207,10 +213,13 @@ argTys :: IState -> PTerm -> [Maybe Name] argTys ist (PRef fc hls n) = case lookupTy n (tt_ctxt ist) of- [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing+ [ty] -> let ty' = normalise (tt_ctxt ist) [] ty in+ map (tyName . snd) (getArgTys ty') ++ repeat Nothing _ -> repeat Nothing where tyName (Bind _ (Pi _ _ _) _) = Just (sUN "->")- tyName t | (P _ n _, _) <- unApply t = Just n+ tyName t | (P _ d _, [_, ty]) <- unApply t,+ d == sUN "Delayed" = tyName ty+ | (P _ n _, _) <- unApply t = Just n | otherwise = Nothing argTys _ _ = repeat Nothing @@ -236,11 +245,11 @@ -- tidyVar t = t elabNewPat :: PTerm -> Idris (Bool, PTerm)-elabNewPat t = idrisCatch (do (tm, ty) <- elabVal recinfo ELHS t+elabNewPat t = idrisCatch (do (tm, ty) <- elabVal (recinfo (fileFC "casesplit")) ELHS t i <- getIState return (True, delab i tm)) (\e -> do i <- getIState- logElab 5 $ "Not a valid split:\n" ++ showTmImpls t ++ "\n" + logElab 5 $ "Not a valid split:\n" ++ showTmImpls t ++ "\n" ++ pshow i e return (False, t)) @@ -289,7 +298,7 @@ updateRHSs 1 (map (rep ist (expandBraces l)) ups) where rep ist str [] = str ++ "\n"- rep ist str ((n, tm) : ups) + rep ist str ((n, tm) : ups) = rep ist (updatePat False (show n) (nshow (resugar ist tm)) str) ups updateRHSs i [] = return []@@ -352,7 +361,7 @@ updatePat start n tm (c:rest) = c : updatePat (not ((isAlphaNum c) || c == '_')) n tm rest addBrackets tm | ' ' `elem` tm- , not (isPrefixOf "(" tm && isSuffixOf ")" tm) + , not (isPrefixOf "(" tm && isSuffixOf ")" tm) = "(" ++ tm ++ ")" | otherwise = tm @@ -373,14 +382,14 @@ -- Show a name for use in pattern definitions on the lhs showLHSName :: Name -> String-showLHSName n = let fn = show n in +showLHSName n = let fn = show n in if any (flip elem opChars) fn then "(" ++ fn ++ ")" else fn -- Show a name for the purpose of generating a metavariable name on the rhs showRHSName :: Name -> String-showRHSName n = let fn = show n in +showRHSName n = let fn = show n in if any (flip elem opChars) fn then "op" else fn
src/Idris/Chaser.hs view
@@ -1,4 +1,15 @@-module Idris.Chaser(buildTree, getImports, getModuleFiles, ModuleTree(..)) where+{-|+Module : Idris.Chaser+Description : Module chaser to determine cycles and import modules.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+module Idris.Chaser(+ buildTree, getImports+ , getModuleFiles+ , ModuleTree(..)+ ) where import Idris.Core.TT import Idris.Parser@@ -28,10 +39,9 @@ latest tm [] = tm latest tm (m : ms) = latest (max tm (mod_time m)) (ms ++ mod_deps m) --- Given a module tree, return the list of files to be loaded. If any--- module has a descendent which needs reloading, return its source, otherwise--- return the IBC-+-- | Given a module tree, return the list of files to be loaded. If+-- 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] ()@@ -66,7 +76,7 @@ then getSrc x : updateToSrc path xs else x : updateToSrc path xs --- Strip quotes and the backslash escapes that Haskeline adds+-- | Strip quotes and the backslash escapes that Haskeline adds extractFileName :: String -> String extractFileName ('"':xs) = takeWhile (/= '"') xs extractFileName ('\'':xs) = takeWhile (/= '\'') xs@@ -80,10 +90,11 @@ getIModTime (IDR i) = getModificationTime i getIModTime (LIDR i) = getModificationTime i -getImports :: [(FilePath, [ImportInfo])] -> [FilePath] -> - Idris [(FilePath, [ImportInfo])]+getImports :: [(FilePath, [ImportInfo])]+ -> [FilePath]+ -> Idris [(FilePath, [ImportInfo])] getImports acc [] = return acc-getImports acc (f : fs) = do +getImports acc (f : fs) = do i <- getIState let file = extractFileName f ibcsd <- valIBCSubDir i@@ -97,7 +108,7 @@ exist <- runIO $ doesFileExist parsef if exist then do src_in <- runIO $ readSource parsef- src <- if lit fp then tclift $ unlit parsef src_in + src <- if lit fp then tclift $ unlit parsef src_in else return src_in (_, _, modules, _) <- parseImports parsef src clearParserWarnings@@ -113,31 +124,32 @@ fname (LIDR fn) = fn fname (IBC _ src) = fname src -buildTree :: [FilePath] -> -- already guaranteed built- [(FilePath, [ImportInfo])] -> -- import lists (don't reparse)- FilePath -> Idris [ModuleTree]+buildTree :: [FilePath] -- ^ already guaranteed built+ -> [(FilePath, [ImportInfo])] -- ^ import lists (don't reparse)+ -> FilePath+ -> Idris [ModuleTree] buildTree built importlists fp = evalStateT (btree [] fp) [] where- addFile :: FilePath -> [ModuleTree] -> + addFile :: FilePath -> [ModuleTree] -> StateT [(FilePath, [ModuleTree])] Idris [ModuleTree] addFile f m = do fs <- get put ((f, m) : fs) return m - btree :: [FilePath] -> FilePath -> + btree :: [FilePath] -> FilePath -> StateT [(FilePath, [ModuleTree])] Idris [ModuleTree] btree stk f = do i <- lift getIState let file = extractFileName f lift $ logLvl 1 $ "CHASING " ++ show file ++ " (" ++ show fp ++ ")" ibcsd <- lift $ valIBCSubDir i- ids <- lift $ allImportDirs- fp <- lift $ findImport ids ibcsd file+ ids <- lift allImportDirs+ fp <- lift $ findImport ids ibcsd file lift $ logLvl 1 $ "Found " ++ show fp mt <- lift $ runIO $ getIModTime fp if (file `elem` built) then return [MTree fp False mt []]- else if file `elem` stk then + else if file `elem` stk then do lift $ tclift $ tfail (Msg $ "Cycle detected in imports: " ++ showSep " -> " (reverse (file : stk)))
src/Idris/CmdOptions.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.CmdOptions+Description : CLI for the Idris executable.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE Arrows #-} module Idris.CmdOptions where @@ -219,7 +226,7 @@ parseLogCats s = case lastMay (readP_to_S (doParse) s) of Just (xs, _) -> return xs- _ -> fail $ "Incorrect categories specified"+ _ -> fail "Incorrect categories specified" where doParse :: ReadP [LogCat] doParse = do
src/Idris/Colours.hs view
@@ -1,10 +1,18 @@+{-|+Module : Idris.Colours+Description : Support for colours within Idris.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Idris.Colours (- IdrisColour(..),- ColourTheme(..),- defaultTheme,- colouriseKwd, colouriseBound, colouriseImplicit, colourisePostulate,- colouriseType, colouriseFun, colouriseData, colouriseKeyword,- colourisePrompt, colourise, ColourType(..), hStartColourise, hEndColourise) where+ IdrisColour(..)+ , ColourTheme(..)+ , defaultTheme+ , colouriseKwd, colouriseBound, colouriseImplicit, colourisePostulate+ , colouriseType, colouriseFun, colouriseData, colouriseKeyword+ , colourisePrompt, colourise, ColourType(..), hStartColourise, hEndColourise+ ) where import System.Console.ANSI import System.IO (Handle)
src/Idris/Completion.hs view
@@ -1,4 +1,10 @@--- | Support for command-line completion at the REPL and in the prover+{-|+Module : Idris.Completion+Description : Support for command-line completion at the REPL and in the prover.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Idris.Completion (replCompletion, proverCompletion) where import Idris.Core.Evaluate (ctxtAlist)@@ -33,8 +39,6 @@ -- | Convert a name into a string usable for completion. Filters out names -- that users probably don't want to see. nameString :: Name -> Maybe String-nameString (UN nm)- | not (tnull nm) && (thead nm == '@' || thead nm == '#') = Nothing nameString (UN n) = Just (str n) nameString (NS n _) = nameString n nameString _ = Nothing@@ -144,7 +148,7 @@ completeArg (OptionalArg a) = completeArg a completeArg (SeqArgs a b) = completeArg a completeArg _ = noCompletion (prev, next)- completeCmdName = return $ ("", completeWith commands cmd)+ completeCmdName = return ("", completeWith commands cmd) -- | Complete REPL commands and defined identifiers replCompletion :: CompletionFunc Idris@@ -164,7 +168,7 @@ completeTactic :: [String] -> String -> CompletionFunc Idris completeTactic as tac (prev, next) = fromMaybe completeTacName . fmap completeArg $ lookup tac tacticArgs- where completeTacName = return $ ("", completeWith tactics tac)+ where completeTacName = return ("", completeWith tactics tac) completeArg Nothing = noCompletion (prev, next) completeArg (Just NameTArg) = noCompletion (prev, next) -- this is for binding new names! completeArg (Just ExprTArg) = completeExpr as (prev, next)
src/Idris/Core/Binary.hs view
@@ -1,6 +1,11 @@+{-|+Module : Idris.Core.Binary+Description : Binary instances for the core datatypes+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}--{-| Binary instances for the core datatypes -} module Idris.Core.Binary where import Control.Applicative ((<*>), (<$>))@@ -141,8 +146,10 @@ put n put (ProofSearchFail e) = do putWord8 25 put e- put (NoRewriting t) = do putWord8 26- put t+ put (NoRewriting l r t) = do putWord8 26+ put l+ put r+ put t put (At fc e) = do putWord8 27 put fc put e@@ -232,7 +239,8 @@ 23 -> fmap NonCollapsiblePostulate get 24 -> fmap AlreadyDefined get 25 -> fmap ProofSearchFail get- 26 -> fmap NoRewriting get+ 26 -> do l <- get; r <- get; t <- get+ return $ NoRewriting l r t 27 -> do x <- get ; y <- get return $ At x y 28 -> do w <- get; x <- get ; y <- get ; z <- get@@ -271,7 +279,7 @@ instance Binary FC where put x =- case x of + case x of (FC x1 (x2, x3) (x4, x5)) -> do putWord8 0 put x1 put (x2 * 65536 + x3)@@ -485,11 +493,11 @@ instance Binary ImplicitInfo where put x = case x of- Impl x1 x2 -> do put x1; put x2+ Impl x1 x2 x3 -> do put x1; put x2 get = do x1 <- get x2 <- get- return (Impl x1 x2)+ return (Impl x1 x2 False) instance (Binary b) => Binary (Binder b) where put x@@ -587,15 +595,17 @@ -- record concrete levels only, for now instance Binary UExp where put x = case x of- UVar t -> do putWord8 0- put ((-1) :: Int) -- TMP HACK!- UVal t -> do putWord8 1 + UVar ns t -> do putWord8 0+ put ns+ put t+ UVal t -> do putWord8 1 put t get = do i <- getWord8 case i of 0 -> do x1 <- get- return (UVar x1)+ x2 <- get+ return (UVar x1 x2) 1 -> do x1 <- get return (UVal x1) _ -> error "Corrupted binary data for UExp"@@ -653,7 +663,7 @@ x2 <- getWord8 return (Proj x1 ((fromEnum x2)-1)) 6 -> return Erased- 7 -> do x1 <- get + 7 -> do x1 <- get return (TType x1) 8 -> return Impossible 9 -> do x1 <- get@@ -661,4 +671,3 @@ 10 -> do x1 <- get return (UType x1) _ -> error "Corrupted binary data for TT"-
src/Idris/Core/CaseTree.hs view
@@ -1,9 +1,31 @@+{-|+Module : Idris.Core.CaseTree+Description : Module to define and interact with case trees.+Copyright :+License : BSD3+Maintainer : The Idris Community.++Note: The case-tree elaborator only produces (Case n alts)-cases;+in other words, it never inspects anything else than variables.++ProjCase is a special powerful case construct that allows inspection+of compound terms. Occurrences of ProjCase arise no earlier than+in the function `prune` as a means of optimisation+of already built case trees.++While the intermediate representation (follows in the pipeline, named LExp)+allows casing on arbitrary terms, here we choose to maintain the distinction+in order to allow for better optimisation opportunities.++-} {-# LANGUAGE PatternGuards, DeriveFunctor, TypeSynonymInstances #-} -module Idris.Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..), ErasureInfo,- Phase(..), CaseTree, CaseType(..),- simpleCase, small, namesUsed, findCalls, findUsedArgs,- substSC, substAlt, mkForce) where+module Idris.Core.CaseTree (+ CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..), ErasureInfo+ , Phase(..), CaseTree, CaseType(..)+ , simpleCase, small, namesUsed, findCalls, findCalls', findUsedArgs+ , substSC, substAlt, mkForce+ ) where import Idris.Core.TT @@ -18,18 +40,6 @@ data CaseDef = CaseDef [Name] !SC [Term] deriving Show --- Note: The case-tree elaborator only produces (Case n alts)-cases;--- in other words, it never inspects anything else than variables.------ ProjCase is a special powerful case construct that allows inspection--- of compound terms. Occurrences of ProjCase arise no earlier than--- in the function `prune` as a means of optimisation--- of already built case trees.------ While the intermediate representation (follows in the pipeline, named LExp)--- allows casing on arbitrary terms, here we choose to maintain the distinction--- in order to allow for better optimisation opportunities.--- data SC' t = Case CaseType Name [CaseAlt' t] -- ^ invariant: lowest tags first | ProjCase t [CaseAlt' t] -- ^ special case for projections/thunk-forcing before inspection | STerm !t@@ -140,7 +150,10 @@ -- in each argument position for the call, in order to help reduce -- compilation time, and trace all unused arguments findCalls :: SC -> [Name] -> [(Name, [[Name]])]-findCalls sc topargs = nub $ nu' topargs sc where+findCalls = findCalls' False++findCalls' :: Bool -> SC -> [Name] -> [(Name, [[Name]])]+findCalls' ignoreasserts sc topargs = nub $ nu' topargs sc where nu' ps (Case _ n alts) = nub (concatMap (nua (n : ps)) alts) nu' ps (ProjCase t alts) = nub $ nut ps t ++ concatMap (nua ps) alts nu' ps (STerm t) = nub $ nut ps t@@ -156,8 +169,11 @@ | otherwise = [(n, [])] -- tmp nut ps fn@(App _ f a) | (P _ n _, args) <- unApply fn- = if n `elem` ps then nut ps f ++ nut ps a- else [(n, map argNames args)] ++ concatMap (nut ps) args+ = if ignoreasserts && n == sUN "assert_total" + then []+ else if n `elem` ps + then nut ps f ++ nut ps a+ else [(n, map argNames args)] ++ concatMap (nut ps) args | (P (TCon _ _) n _, _) <- unApply fn = [] | otherwise = nut ps f ++ nut ps a nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc
src/Idris/Core/Constraints.hs view
@@ -1,7 +1,13 @@--- | Check universe constraints.+{-|+Module : Idris.Core.Constraints+Description : Check universe constraints.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Idris.Core.Constraints ( ucheck ) where -import Idris.Core.TT ( TC(..), UExp(..), UConstraint(..), FC(..), +import Idris.Core.TT ( TC(..), UExp(..), UConstraint(..), FC(..), ConstraintFC(..), Err'(..) ) import Control.Applicative@@ -9,18 +15,47 @@ import Data.List ( partition ) import qualified Data.Map.Strict as M import qualified Data.Set as S-+import Debug.Trace -- | Check that a list of universe constraints can be satisfied. ucheck :: S.Set ConstraintFC -> TC ()-ucheck = void . solve 10 . S.filter (not . ignore)+ucheck = void . solve 10 . S.filter (not . ignore) . dropUnused where -- TODO: remove the first ignore clause once Idris.Core.Binary:598 is dealt with- ignore (ConstraintFC c _) | any (== Var (-1)) (varsIn c) = True+ ignore (ConstraintFC c _) | any (== Var [] (-1)) (varsIn c) = True ignore (ConstraintFC (ULE a b) _) = a == b ignore _ = False -newtype Var = Var Int+dropUnused :: S.Set ConstraintFC -> S.Set ConstraintFC+dropUnused xs = let cs = S.toList xs+ onlhs = countLHS M.empty cs in+ addIfUsed S.empty onlhs cs+ where+ -- Count the number of times a variable occurs on the LHS of a constraint+ countLHS ms [] = ms+ countLHS ms (c : cs) = let lhvar = getLHS (uconstraint c)+ num = case M.lookup lhvar ms of+ Nothing -> 1+ Just v -> v + 1 in+ countLHS (M.insert lhvar num ms) cs++ -- Only keep a constraint if the variable on the RHS is used elsewhere+ -- on the LHS of a constraint+ addIfUsed cs' lhs [] = cs'+ addIfUsed cs' lhs (c : cs)+ = let rhvar = getRHS (uconstraint c) in+ case M.lookup rhvar lhs of+ Nothing -> addIfUsed cs' lhs cs+ Just v -> addIfUsed (S.insert c cs') lhs cs++ getLHS (ULT x _) = x+ getLHS (ULE x _) = x++ getRHS (ULT _ x) = x+ getRHS (ULE _ x) = x+++data Var = Var String Int deriving (Eq, Ord, Show) data Domain = Domain Int Int@@ -66,12 +101,12 @@ , cons_rhs = constraintsRHS } - lhs (ULT (UVar x) _) = Just (Var x)- lhs (ULE (UVar x) _) = Just (Var x)+ lhs (ULT (UVar ns x) _) = Just (Var ns x)+ lhs (ULE (UVar ns x) _) = Just (Var ns x) lhs _ = Nothing - rhs (ULT _ (UVar x)) = Just (Var x)- rhs (ULE _ (UVar x)) = Just (Var x)+ rhs (ULT _ (UVar ns x)) = Just (Var ns x)+ rhs (ULE _ (UVar ns x)) = Just (Var ns x) rhs _ = Nothing -- | a map from variables to the list of constraints the variable occurs in. (in the LHS of a constraint)@@ -142,38 +177,38 @@ -- | look up the domain of a variable from the state. -- for convenience, this function also accepts UVal's and returns a singleton domain for them. domainOf :: MonadState SolverState m => UExp -> m Domain- domainOf (UVar var) = gets (fst . (M.! Var var) . domainStore)+ domainOf (UVar ns var) = gets (fst . (M.! Var ns var) . domainStore) domainOf (UVal val) = return (Domain val val) asPair :: Domain -> (Int, Int) asPair (Domain x y) = (x, y) updateUpperBoundOf :: ConstraintFC -> UExp -> Int -> StateT SolverState TC ()- updateUpperBoundOf suspect (UVar var) upper = do+ updateUpperBoundOf suspect (UVar ns var) upper = do doms <- gets domainStore- let (oldDom@(Domain lower _), suspects) = doms M.! Var var+ let (oldDom@(Domain lower _), suspects) = doms M.! Var ns var let newDom = Domain lower upper when (wipeOut newDom) $ lift $ Error $- UniverseError (ufc suspect) (UVar var)+ UniverseError (ufc suspect) (UVar ns var) (asPair oldDom) (asPair newDom) (suspect : S.toList suspects)- modify $ \ st -> st { domainStore = M.insert (Var var) (newDom, S.insert suspect suspects) doms }- addToQueueRHS (uconstraint suspect) (Var var)+ modify $ \ st -> st { domainStore = M.insert (Var ns var) (newDom, S.insert suspect suspects) doms }+ addToQueueRHS (uconstraint suspect) (Var ns var) updateUpperBoundOf _ UVal{} _ = return () updateLowerBoundOf :: ConstraintFC -> UExp -> Int -> StateT SolverState TC ()- updateLowerBoundOf suspect (UVar var) lower = do+ updateLowerBoundOf suspect (UVar ns var) lower = do doms <- gets domainStore- let (oldDom@(Domain _ upper), suspects) = doms M.! Var var+ let (oldDom@(Domain _ upper), suspects) = doms M.! Var ns var let newDom = Domain lower upper when (wipeOut newDom) $ lift $ Error $- UniverseError (ufc suspect) (UVar var)+ UniverseError (ufc suspect) (UVar ns var) (asPair oldDom) (asPair newDom) (suspect : S.toList suspects)- modify $ \ st -> st { domainStore = M.insert (Var var) (newDom, S.insert suspect suspects) doms }- addToQueueLHS (uconstraint suspect) (Var var)+ modify $ \ st -> st { domainStore = M.insert (Var ns var) (newDom, S.insert suspect suspects) doms }+ addToQueueLHS (uconstraint suspect) (Var ns var) updateLowerBoundOf _ UVal{} _ = return () -- | add all constraints (with the given var on the lhs) to the queue@@ -218,5 +253,5 @@ -- | variables in a constraint varsIn :: UConstraint -> [Var]-varsIn (ULT a b) = [ Var v | UVar v <- [a,b] ]-varsIn (ULE a b) = [ Var v | UVar v <- [a,b] ]+varsIn (ULT a b) = [ Var ns v | UVar ns v <- [a,b] ]+varsIn (ULE a b) = [ Var ns v | UVar ns v <- [a,b] ]
src/Idris/Core/DeepSeq.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Core.DeepSeq+Description : Marshalling information for TT.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE BangPatterns, ViewPatterns #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} @@ -147,7 +154,7 @@ rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` () rnf (AlreadyDefined x1) = rnf x1 `seq` () rnf (ProofSearchFail x1) = rnf x1 `seq` ()- rnf (NoRewriting x1) = rnf x1 `seq` ()+ rnf (NoRewriting x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (Elaborating x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()@@ -167,7 +174,7 @@ rnf (SubReport x1) = rnf x1 `seq` () instance NFData ImplicitInfo where- rnf (Impl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (Impl x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () instance (NFData b) => NFData (Binder b) where rnf (Lam x1) = rnf x1 `seq` ()@@ -181,7 +188,7 @@ rnf (PVTy x1) = rnf x1 `seq` () instance NFData UExp where- rnf (UVar x1) = rnf x1 `seq` ()+ rnf (UVar x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (UVal x1) = rnf x1 `seq` () instance NFData NameType where@@ -241,14 +248,14 @@ rnf Hidden = () rnf Private = () - + instance NFData Totality where rnf (Total x1) = rnf x1 `seq` () rnf Productive = () rnf (Partial x1) = rnf x1 `seq` () rnf Unchecked = () rnf Generated = ()- + instance NFData PReason where rnf (Other x1) = rnf x1 `seq` () rnf Itself = ()@@ -274,7 +281,7 @@ instance NFData CaseInfo where rnf (CaseInfo x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()- + instance NFData CaseDefs where rnf (CaseDefs x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()
src/Idris/Core/Elaborate.hs view
@@ -1,15 +1,20 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-}--{- A high level language of tactic composition, for building- elaborators from a high level language into the core theory.+{-|+Module : Idris.Core.Elaborate+Description : A high level language of tactic composition, for building elaborators from a high level language into the core theory.+Copyright :+License : BSD3+Maintainer : The Idris Community. - This is our interface to proof construction, rather than- ProofState, because this gives us a language to build derived- tactics out of the primitives.+This is our interface to proof construction, rather than ProofState,+because this gives us a language to build derived tactics out of the+primitives. -} -module Idris.Core.Elaborate(module Idris.Core.Elaborate,- module Idris.Core.ProofState) where+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-}+module Idris.Core.Elaborate (+ module Idris.Core.Elaborate+ , module Idris.Core.ProofState+ ) where import Idris.Core.ProofState import Idris.Core.ProofTerm(bound_in, getProofTerm, mkProofTerm, bound_in_term,@@ -51,7 +56,7 @@ let p' = p { dontunify = n : dontunify p } put (ES (p', a) s m) --- Add a name that's okay to use in proof search (typically either because +-- Add a name that's okay to use in proof search (typically either because -- it was given explicitly on the lhs, or intrduced as an explicit lambda -- or let binding) addPSname :: Name -> Elab' aux ()@@ -78,11 +83,11 @@ getNameFrom :: Name -> Elab' aux Name getNameFrom n = do (ES (p, a) s e) <- get let next = nextname p- let p' = p { nextname = next + 1 } + let p' = p { nextname = next + 1 } put (ES (p', a) s e) let n' = case n of UN x -> MN (next+100) x- MN i x -> if i == 99999 + MN i x -> if i == 99999 then MN (next+500) x else MN (next+100) x NS (UN x) s -> MN (next+100) x@@ -97,7 +102,7 @@ initNextNameFrom :: [Name] -> Elab' aux () initNextNameFrom ns = do ES (p, a) s e <- get- let n' = maxName (nextname p) ns + let n' = maxName (nextname p) ns put (ES (p { nextname = n' }, a) s e) where maxName m ((MN i _) : xs) = maxName (max m i) xs@@ -124,7 +129,7 @@ erunAux :: FC -> Elab' aux a -> Elab' aux (a, aux)-erunAux f elab +erunAux f elab = do s <- get case runStateT elab s of OK (a, s') -> do put s'@@ -146,6 +151,7 @@ execElab a e ps = execStateT e (ES (ps, a) "" Nothing) initElaborator :: Name -- ^ the name of what's to be elaborated+ -> String -- ^ the current source file -> Context -- ^ the current global context -> Ctxt TypeInfo -- ^ the value of the idris_datatypes field of IState -> Int -- ^ the value of the idris_name field of IState@@ -153,9 +159,9 @@ -> ProofState initElaborator = newProof -elaborate :: Context -> Ctxt TypeInfo -> Int -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)-elaborate ctxt datatypes globalNames n ty d elab =- do let ps = initElaborator n ctxt datatypes globalNames ty+elaborate :: String -> Context -> Ctxt TypeInfo -> Int -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)+elaborate tcns ctxt datatypes globalNames n ty d elab =+ do let ps = initElaborator n tcns ctxt datatypes globalNames ty (a, ES ps' str _) <- runElab d elab ps return $! (a, str) @@ -489,16 +495,16 @@ tm <- get_term case holes p of [] -> return ()- (h : hs) -> + (h : hs) -> do let outer = findOuter h [] tm let p' = p { dotted = (h, outer) : dotted p }--- trace ("DOTTING " ++ show (h, outer) ++ "\n" ++ +-- trace ("DOTTING " ++ show (h, outer) ++ "\n" ++ -- show tm) $ put $ ES (p', a) s m where findOuter h env (P _ n _) | h == n = env findOuter h env (Bind n b sc)- = union (foB b) + = union (foB b) (findOuter h env (instantiate (P Bound n (binderTy b)) sc)) where foB (Guess t v) = union (findOuter h env t) (findOuter h (n:env) v) foB (Let t v) = union (findOuter h env t) (findOuter h env v)@@ -506,8 +512,8 @@ findOuter h env (App _ f a) = union (findOuter h env f) (findOuter h env a) findOuter h env _ = []- + get_dotterm :: Elab' aux [(Name, [Name])] get_dotterm = do ES (p, a) s m <- get return (dotted p)@@ -566,8 +572,8 @@ env <- get_env -- let claims = getArgs ty imps -- claims <- mkClaims (normalise ctxt env ty) imps []- claims <- -- trace (show (fn, imps, ty, map fst env, normalise ctxt env (finalise ty))) $ - mkClaims (finalise ty) + claims <- -- trace (show (fn, imps, ty, map fst env, normalise ctxt env (finalise ty))) $+ mkClaims (finalise ty) (normalise ctxt env (finalise ty)) imps [] (map fst env) ES (p, a) s prev <- get@@ -583,7 +589,7 @@ -> [(Name, Name)] -- ^ Accumulator for produced claims -> [Name] -- ^ Hypotheses -> Elab' aux [(Name, Name)] -- ^ The names of the arguments and their holes, resp.- mkClaims (Bind n' (Pi _ t_in _) sc) (Bind _ _ scn) (i : is) claims hs = + mkClaims (Bind n' (Pi _ t_in _) sc) (Bind _ _ scn) (i : is) claims hs = do let t = rebind hs t_in n <- getNameFrom (mkMN n') -- when (null claims) (start_unify n)@@ -648,8 +654,9 @@ fillt (raw_apply fn (map (Var . snd) args)) ulog <- getUnifyLog g <- goal- traceWhen ulog ("Goal " ++ show g ++ " -- when elaborating " ++ show fn) $- end_unify+ traceWhen ulog+ ("Goal " ++ show g ++ " -- when elaborating " ++ show fn)+ end_unify return $! (map (\(argName, argHole) -> (argName, updateUnify unify argHole)) args) where updateUnify us n = case lookup n us of Just (P _ t _) -> t@@ -657,7 +664,7 @@ getNonUnify acc [] _ = acc getNonUnify acc _ [] = acc- getNonUnify acc ((i,_):is) ((a, t):as) + getNonUnify acc ((i,_):is) ((a, t):as) | i = getNonUnify acc is as | otherwise = getNonUnify (t : acc) is as @@ -758,7 +765,7 @@ do a <- getNameFrom (sMN 0 "__argTy") b <- getNameFrom (sMN 0 "__retTy") f <- getNameFrom (sMN 0 "f")- s <- getNameFrom (sMN 0 "s")+ s <- getNameFrom (sMN 0 "is") claim a RType claim b RType claim f (RBind (sMN 0 "_aX") (Pi Nothing (Var a) RType) (Var b))@@ -787,12 +794,12 @@ end_unify dep_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux ()-dep_app fun arg str = +dep_app fun arg str = do a <- getNameFrom (sMN 0 "__argTy") b <- getNameFrom (sMN 0 "__retTy") fty <- getNameFrom (sMN 0 "__fnTy") f <- getNameFrom (sMN 0 "f")- s <- getNameFrom (sMN 0 "s")+ s <- getNameFrom (sMN 0 "ds") claim a RType claim fty RType claim f (Var fty)@@ -800,13 +807,13 @@ g <- goal start_unify s claim s (Var a)- + prep_fill f [s] focus f; attack; fun end_unify fty <- goal solve- focus s; attack; + focus s; attack; ctxt <- get_context env <- get_env case normalise ctxt env fty of@@ -856,7 +863,7 @@ ((x, y, _, env, inerr, while, _) : _) -> let (xp, yp) = getProvenance inerr env' = map (\(x, b) -> (x, binderTy b)) env in- lift $ tfail $ + lift $ tfail $ case err of Nothing -> CantUnify False (x, xp) (y, yp) inerr env' 0 Just e -> e@@ -867,7 +874,7 @@ try t1 t2 = try' t1 t2 False handleError :: (Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a-handleError p t1 t2 +handleError p t1 t2 = do s <- get ps <- get_probs case runStateT t1 s of@@ -907,7 +914,7 @@ recoverableErr _ = True tryCatch :: Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a-tryCatch t1 t2 +tryCatch t1 t2 = do s <- get ps <- get_probs ulog <- getUnifyLog@@ -953,7 +960,7 @@ ivs <- get_instances case prunStateT pmax True ps (if constrok then Nothing else Just ivs) x s of- OK ((v, newps, probs), s') -> + OK ((v, newps, probs), s') -> do let cs' = if (newps < pmax) then [do put s'; return $! v] else (do put s'; return $! v) : cs@@ -980,7 +987,7 @@ if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0)) then case reverse (problems p) of ((_,_,_,_,e,_,_):_) -> Error e- else if ibad + else if ibad then Error (InternalMsg "Constraint introduced in disambiguation") else OK ((v, newpmax, problems p), s') Error e -> Error e
src/Idris/Core/Evaluate.hs view
@@ -1,8 +1,15 @@+{-|+Module : Idris.Core.Evaluate+Description : Evaluate Idris expressions.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns, PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} -module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, +module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll, normaliseBlocking, toValue, quoteTerm, rt_simplify, simplify, specialise, hnf, convEq, convEq', Def(..), CaseInfo(..), CaseDefs(..),@@ -12,7 +19,7 @@ addDatatype, addCasedef, simplifyCasedef, addOperator, lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact, lookupP, lookupP_all, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal,- mapDefCtxt, + mapDefCtxt, lookupTotal, lookupTotalExact, lookupInjectiveExact, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, canBeDConName, isTConName, isConName, isFnName, Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions,@@ -103,7 +110,7 @@ quote 0 val) initEval toValue :: Context -> Env -> TT Name -> Value-toValue ctxt env t +toValue ctxt env t = evalState (eval False ctxt [] (map finalEntry env) t []) initEval quoteTerm :: Value -> TT Name@@ -175,24 +182,25 @@ unbindEnv :: EnvTT n -> TT n -> TT n unbindEnv [] tm = tm unbindEnv (_:bs) (Bind n b sc) = unbindEnv bs sc-unbindEnv env tm = error $ "Impossible case occurred: couldn't unbind env."+unbindEnv env tm = error "Impossible case occurred: couldn't unbind env." usable :: Bool -- specialising+ -> Int -- Reduction depth limit (when simplifying/at REPL) -> Name -> [(Name, Int)] -> Eval (Bool, [(Name, Int)]) -- usable _ _ ns@((MN 0 "STOP", _) : _) = return (False, ns)-usable False n [] = return (True, [])-usable True n ns+usable False depthlimit n [] = return (True, [])+usable True depthlimit n ns = do ES ls num b <- get if b then return (False, ns) else case lookup n ls of Just 0 -> return (False, ns) Just i -> return (True, ns) _ -> return (False, ns)-usable False n ns+usable False depthlimit n ns = case lookup n ns of Just 0 -> return (False, ns) Just i -> return $ (True, (n, abs (i-1)) : filter (\ (n', _) -> n/=n') ns)- _ -> return $ (True, (n, 100) : filter (\ (n', _) -> n/=n') ns)+ _ -> return $ (True, (n, depthlimit) : filter (\ (n', _) -> n/=n') ns) fnCount :: Int -> Name -> Eval ()@@ -246,7 +254,8 @@ ev ntimes_in stk top env (P Ref n ty) | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty) | otherwise- = do (u, ntimes) <- usable spec n ntimes_in+ = do let limit = if simpl then 100 else 10000+ (u, ntimes) <- usable spec limit n ntimes_in let red = u && (tcReducible n ctxt || spec || atRepl || runtime || sUN "assert_total" `elem` stk) if red then@@ -304,7 +313,7 @@ -- block reduction immediately under codata (and not forced) ev ntimes stk top env (App _ (App _ (App _ d@(P _ (UN dly) _) l@(P _ (UN lco) _)) t) arg)- | dly == txt "Delay" && lco == txt "LazyCodata" && not (simpl || atRepl)+ | dly == txt "Delay" && lco == txt "Infinite" && not simpl = do let (f, _) = unApply arg let ntimes' = case f of P _ fn _ -> (fn, 0) : ntimes@@ -370,7 +379,8 @@ [] -> return f _ -> return $ unload env f args | otherwise- = do (u, ntimes) <- usable spec n ntimes_in+ = do let limit = if simpl then 100 else 10000+ (u, ntimes) <- usable spec limit n ntimes_in let red = u && (tcReducible n ctxt || spec || atRepl || runtime || sUN "assert_total" `elem` stk) if red then@@ -548,8 +558,8 @@ quote :: Int -> a -> Eval (TT Name) instance Quote Value where- quote i (VP nt n v) = liftM (P nt n) (quote i v)- quote i (VV x) = return $ V x+ quote i (VP nt n v) = liftM (P nt n) (quote i v)+ quote i (VV x) = return $ V x quote i (VBind _ n b sc) = do sc' <- sc (VTmp i) b' <- quoteB b liftM (Bind n b') (quote (i+1) sc')@@ -561,10 +571,10 @@ let sc'' = pToV (sMN vd "vlet") (addBinder sc') return (Bind n (Let t' v') sc'') quote i (VApp f a) = liftM2 (App MaybeHoles) (quote i f) (quote i a)- quote i (VType u) = return $ TType u- quote i (VUType u) = return $ UType u- quote i VErased = return $ Erased- quote i VImpossible = return $ Impossible+ quote i (VType u) = return (TType u)+ quote i (VUType u) = return (UType u)+ quote i VErased = return Erased+ quote i VImpossible = return Impossible quote i (VProj v j) = do v' <- quote i v return (Proj v' j) quote i (VConstant c) = return $ Constant c@@ -596,9 +606,9 @@ | x `elem` holes || y `elem` holes = return True | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True | otherwise = sameDefs ps x y- ceq ps x (Bind n (Lam t) (App _ y (V 0))) + ceq ps x (Bind n (Lam t) (App _ y (V 0))) = ceq ps x (substV (P Bound n t) y)- ceq ps (Bind n (Lam t) (App _ x (V 0))) y + ceq ps (Bind n (Lam t) (App _ x (V 0))) y = ceq ps (substV (P Bound n t) x) y ceq ps x (Bind n (Lam t) (App _ y (P Bound n' _))) | n == n' = ceq ps x y@@ -626,9 +636,11 @@ ceqB ps b b' = ceq ps (binderTy b) (binderTy b') ceq ps (App _ fx ax) (App _ fy ay) = liftM2 (&&) (ceq ps fx fy) (ceq ps ax ay) ceq ps (Constant x) (Constant y) = return (x == y)- ceq ps (TType x) (TType y) = do (v, cs) <- get- put (v, ULE x y : cs)- return True+ ceq ps (TType x) (TType y) | x == y = return True+ ceq ps (TType (UVal 0)) (TType y) = return True+ ceq ps (TType x) (TType y) = do (v, cs) <- get+ put (v, ULE x y : cs)+ return True ceq ps (UType AllTypes) x = return (isUsableUniverse x) ceq ps x (UType AllTypes) = return (isUsableUniverse x) ceq ps (UType u) (UType v) = return (u == v)@@ -746,9 +758,9 @@ -- Hidden => Programs can't access the name at all -- Public => Programs can access the name and use at will -- Frozen => Programs can access the name, which doesn't reduce--- Private => Programs can't access the name, doesn't reduce internally +-- Private => Programs can't access the name, doesn't reduce internally -data Accessibility = Hidden | Public | Frozen | Private +data Accessibility = Hidden | Public | Frozen | Private deriving (Eq, Ord) {-! deriving instance NFData Accessibility@@ -993,7 +1005,7 @@ -- | Get the pair of a fully-qualified name and its type, if there is a unique one matching the name used as a key. lookupTyNameExact :: Name -> Context -> Maybe (Name, Type)-lookupTyNameExact n ctxt = listToMaybe [ (nm, v) | (nm, v) <- lookupTyName n ctxt, nm == n ] +lookupTyNameExact n ctxt = listToMaybe [ (nm, v) | (nm, v) <- lookupTyName n ctxt, nm == n ] -- | Get the types that match some name lookupTy :: Name -> Context -> [Type]@@ -1048,7 +1060,7 @@ lookupP_all :: Bool -> Bool -> Name -> Context -> [Term] lookupP_all all exact n ctxt- = do (n', def) <- names + = do (n', def) <- names p <- case def of (Function ty tm, inj, a, _, _) -> return (P Ref n' ty, a) (TyDecl nt ty, _, a, _, _) -> return (P nt n' ty, a)@@ -1060,7 +1072,7 @@ _ -> return (fst p) where names = let ns = lookupCtxtName n (definitions ctxt) in- if exact + if exact then filter (\ (n', d) -> n' == n) ns else ns
src/Idris/Core/Execute.hs view
@@ -1,3 +1,11 @@+{-|+Module : Idris.Core.Execute+Description : Execute Idris code and deal with FFI.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+ {-# LANGUAGE PatternGuards, ExistentialQuantification, CPP #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Core.Execute (execute) where@@ -112,7 +120,7 @@ return $ normalise ctxt env' tm where toBinder (n, v) = do v' <- toTT v return (n, Let Erased v')-toTT (EHandle _) = execFail $ Msg "Can't convert handles back to TT after execution." +toTT (EHandle _) = execFail $ Msg "Can't convert handles back to TT after execution." toTT (EPtr ptr) = execFail $ Msg "Can't convert pointers back to TT after execution." unApplyV :: ExecVal -> (ExecVal, [ExecVal])@@ -251,7 +259,7 @@ let restArgs = drop arity args execApp env ctxt (mkEApp c args') restArgs -execApp env ctxt f@(EP _ n _) args +execApp env ctxt f@(EP _ n _) args | Just (res, rest) <- getOp n args = do r <- res execApp env ctxt r rest execApp env ctxt f@(EP _ n _) args =@@ -368,6 +376,15 @@ "The argument to fileClose should be a file handle, but it was " ++ show handle ++ ". Are all cases covered?"+ | Just (FFun "fileSize" [(_,handle)] _) <- foreignFromTT arity ty fn xs+ = case handle of+ EHandle h -> do size <- execIO $ hFileSize h+ let res = ioWrap (EConstant (I (fromInteger size)))+ execApp env ctxt res (drop arity xs)+ _ -> execFail . Msg $+ "The argument to fileSize should be a file handle, but it was " +++ show handle +++ ". Are all cases covered?" | Just (FFun "isNull" [(_, ptr)] _) <- foreignFromTT arity ty fn xs = case ptr of@@ -388,7 +405,7 @@ -- Right now, there's no way to send command-line arguments to the executor, -- so just return 0.-execForeign env ctxt arity ty fn xs onfail +execForeign env ctxt arity ty fn xs onfail | Just (FFun "idris_numArgs" _ _) <- foreignFromTT arity ty fn xs = let res = ioWrap . EConstant . I $ 0 in execApp env ctxt res (drop arity xs)@@ -410,8 +427,8 @@ = Just (toFDesc l, r) splitArg _ = Nothing -toFDesc tm - | (EP _ n _, []) <- unApplyV tm = FCon (deNS n) +toFDesc tm+ | (EP _ n _, []) <- unApplyV tm = FCon (deNS n) | (EP _ n _, as) <- unApplyV tm = FApp (deNS n) (map toFDesc as) toFDesc _ = FUnknown @@ -432,7 +449,7 @@ delay = sUN "Delay" force = sUN "Force" --- | Look up primitive operations in the global table and transform +-- | Look up primitive operations in the global table and transform -- them into ExecVal functions getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal, [ExecVal]) getOp fn (_ : _ : x : xs) | fn == pbm = Just (return x, xs)@@ -463,14 +480,14 @@ getOp fn (_ : arg : xs) | fn == prf = Just $ (execFail (Msg "Can't use prim__readFile on a raw pointer in the executor."), xs)-getOp n args = do (arity, prim) <- getPrim n primitives - if (length args >= arity) +getOp n args = do (arity, prim) <- getPrim n primitives+ if (length args >= arity) then do res <- applyPrim prim (take arity args) Just (res, drop arity args) else Nothing where getPrim :: Name -> [Prim] -> Maybe (Int, [ExecVal] -> Maybe ExecVal) getPrim n [] = Nothing- getPrim n ((Prim pn _ arity def _ _) : prims) + getPrim n ((Prim pn _ arity def _ _) : prims) | n == pn = Just (arity, execPrim def) | otherwise = getPrim n prims @@ -534,15 +551,15 @@ data Foreign = FFun String [(FDesc, ExecVal)] FDesc deriving Show toFType :: FDesc -> FType-toFType (FCon c) +toFType (FCon c) | c == sUN "C_Str" = FString | c == sUN "C_Float" = FArith ATFloat | c == sUN "C_Ptr" = FPtr | c == sUN "C_MPtr" = FManagedPtr | c == sUN "C_Unit" = FUnit-toFType (FApp c [_,ity]) +toFType (FApp c [_,ity]) | c == sUN "C_IntT" = FArith (toAType ity)- where toAType (FCon i) + where toAType (FCon i) | i == sUN "C_IntChar" = ATInt ITChar | i == sUN "C_IntNative" = ATInt ITNative | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)@@ -551,14 +568,14 @@ | i == sUN "C_IntBits64" = ATInt (ITFixed IT64) toAType t = error (show t ++ " not defined in toAType") -toFType (FApp c [_]) +toFType (FApp c [_]) | c == sUN "C_Any" = FAny toFType t = error (show t ++ " not defined in toFType") call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal) call (FFun name argTypes retType) args = do fn <- findForeign name- maybe (return Nothing) + maybe (return Nothing) (\f -> Just . ioWrap <$> call' f args (toFType retType)) fn where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal call' (Fun _ h) args (FArith (ATInt ITNative)) = do
src/Idris/Core/ProofState.hs view
@@ -1,12 +1,22 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-}+{-|+Module : Idris.Core.ProofState+Description : Proof state implementation.+Copyright :+License : BSD3+Maintainer : The Idris Community. -{- Implements a proof state, some primitive tactics for manipulating- proofs, and some high level commands for introducing new theorems,- evaluation/checking inside the proof system, etc. --}+Implements a proof state, some primitive tactics for manipulating+proofs, and some high level commands for introducing new theorems,+evaluation/checking inside the proof system, etc.+-} -module Idris.Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,- Tactic(..), Goal(..), processTactic, nowElaboratingPS, doneElaboratingAppPS,- doneElaboratingArgPS, dropGiven, keepGiven, getProvenance) where+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-}+module Idris.Core.ProofState(+ ProofState(..), newProof, envAtFocus, goalAtFocus+ , Tactic(..), Goal(..), processTactic, nowElaboratingPS+ , doneElaboratingAppPS, doneElaboratingArgPS, dropGiven+ , keepGiven, getProvenance+ ) where import Idris.Core.Typecheck import Idris.Core.Evaluate@@ -50,7 +60,8 @@ unifylog :: Bool, done :: Bool, recents :: [Name],- while_elaborating :: [FailContext]+ while_elaborating :: [FailContext],+ constraint_ns :: String } data Tactic = Attack@@ -134,7 +145,7 @@ pretty (thname ps) <+> colon <+> text " no more goals." pretty ps | (h : hs) <- holes ps = let tm = pterm ps- OK g = goal (Just h) tm + OK g = goal (Just h) tm nm = thname ps in let wkEnv = premises g in text "Other goals" <+> colon <+> pretty hs <+>@@ -160,9 +171,9 @@ qshow :: Fails -> String qshow fs = show (map (\ (x, y, hs, env, _, _, t) -> (t, map fst env, x, y, hs)) fs) -match_unify' :: Context -> Env -> - (TT Name, Maybe Provenance) -> +match_unify' :: Context -> Env -> (TT Name, Maybe Provenance) ->+ (TT Name, Maybe Provenance) -> StateT TState TC [(Name, TT Name)] match_unify' ctxt env (topx, xfrom) (topy, yfrom) = do ps <- get@@ -184,7 +195,7 @@ return u Error e -> traceWhen (unifylog ps) ("No match " ++ show e) $- do put (ps { problems = (topx, topy, True, + do put (ps { problems = (topx, topy, True, env, e, while, Match) : problems ps }) return []@@ -217,9 +228,9 @@ solvedIn y x (_ : xs) = solvedIn y x xs dropSwaps (p : xs) = p : dropSwaps xs -unify' :: Context -> Env -> - (TT Name, Maybe Provenance) -> +unify' :: Context -> Env -> (TT Name, Maybe Provenance) ->+ (TT Name, Maybe Provenance) -> StateT TState TC [(Name, TT Name)] unify' ctxt env (topx, xfrom) (topy, yfrom) = do ps <- get@@ -309,19 +320,20 @@ addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" }) newProof :: Name -- ^ the name of what's to be elaborated+ -> String -- ^ current source file -> Context -- ^ the current global context -> Ctxt TypeInfo -- ^ the value of the idris_datatypes field of IState -> Int -- ^ the value of the idris_name field of IState -> Type -- ^ the goal type -> ProofState-newProof n ctxt datatypes globalNames ty =+newProof n tcns ctxt datatypes globalNames ty = let h = holeName 0 ty' = vToP ty in PS n [h] [] 1 globalNames (mkProofTerm (Bind h (Hole ty') (P Bound h ty'))) ty [] (h, []) [] [] Nothing [] [] [] [] [] []- Nothing ctxt datatypes "" False False [] []+ Nothing ctxt datatypes "" False False [] [] tcns type TState = ProofState -- [TacticAction]) type RunTactic = RunTactic' TState@@ -330,7 +342,7 @@ envAtFocus ps | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps) return (premises g)- | otherwise = fail "No holes"+ | otherwise = fail $ "No holes in " ++ show (getProofTerm (pterm ps)) goalAtFocus :: ProofState -> TC (Binder Type) goalAtFocus ps@@ -458,7 +470,7 @@ (mkApp (P Ref n ty) (map getP (reverse env')))) where mkTy [] t = t- mkTy ((n,b) : bs) t = Bind n (Pi Nothing (binderTy b) (TType (UVar 0))) (mkTy bs t)+ mkTy ((n,b) : bs) t = Bind n (Pi Nothing (binderTy b) (TType (UVar [] 0))) (mkTy bs t) getP (n, b) = P Bound n (binderTy b) defer dropped n ctxt env _ = fail "Can't defer a non-hole focus."@@ -539,7 +551,7 @@ do (val, valty) <- lift $ check ctxt env guess -- let valtyn = normalise ctxt env valty -- let tyn = normalise ctxt env ty- ns <- match_unify' ctxt env (valty, Just $ SourceTerm val) + ns <- match_unify' ctxt env (valty, Just $ SourceTerm val) (ty, Just ExpectedType) ps <- get let (uh, uns) = unified ps@@ -558,7 +570,7 @@ complete_fill ctxt env (Bind x (Guess ty val) sc) = do let guess = forget val (val', valty) <- lift $ check ctxt env guess- ns <- unify' ctxt env (valty, Just $ SourceTerm val') + ns <- unify' ctxt env (valty, Just $ SourceTerm val') (ty, Just ExpectedType) ps <- get let (uh, uns) = unified ps@@ -577,7 +589,7 @@ dropdots <- case lookup x (notunified ps) of Just tm -> -- trace ("NEED MATCH: " ++ show (x, tm, val) ++ "\nIN " ++ show (pterm ps)) $- do match_unify' ctxt env (tm, Just InferredVal) + do match_unify' ctxt env (tm, Just InferredVal) (val, Just GivenVal) return [x] _ -> return []@@ -608,12 +620,12 @@ tryLock hs t@(P _ n _) = (t, not $ n `elem` hs) tryLock hs t@(Bind n (Hole _) sc) = (t, False) tryLock hs t@(Bind n (Guess _ _) sc) = (t, False)- tryLock hs t@(Bind n (Let ty val) sc) + tryLock hs t@(Bind n (Let ty val) sc) = let (ty', tyl) = tryLock hs ty (val', vall) = tryLock hs val (sc', scl) = tryLock hs sc in (Bind n (Let ty' val') sc', tyl && vall && scl)- tryLock hs t@(Bind n b sc) + tryLock hs t@(Bind n b sc) = let (bt', btl) = tryLock hs (binderTy b) (val', vall) = tryLock hs val (sc', scl) = tryLock hs sc in@@ -673,9 +685,9 @@ forall :: Name -> Maybe ImplicitInfo -> Raw -> RunTactic forall n impl ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do (tyv, tyt) <- lift $ check ctxt env ty- unify' ctxt env (tyt, Nothing) (TType (UVar 0), Nothing)- unify' ctxt env (t, Nothing) (TType (UVar 0), Nothing)- return $ Bind n (Pi impl tyv (TType (UVar 0))) (Bind x (Hole t) (P Bound x t))+ unify' ctxt env (tyt, Nothing) (TType (UVar [] 0), Nothing)+ unify' ctxt env (t, Nothing) (TType (UVar [] 0), Nothing)+ return $ Bind n (Pi impl tyv (TType (UVar [] 0))) (Bind x (Hole t) (P Bound x t)) forall n impl ty ctxt env _ = fail "Can't pi bind here" patvar :: Name -> RunTactic@@ -753,8 +765,8 @@ case lookupTy (SN (tacn tnm)) ctxt of [elimTy] -> do param_pos <- case lookupMetaInformation tnm ctxt of- [DataMI param_pos] -> return param_pos- m | length tyargs > 0 -> fail $ "Invalid meta information for " ++ show tnm ++ " where the metainformation is " ++ show m ++ " and definition is" ++ show (lookupDef tnm ctxt)+ [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@@ -762,8 +774,8 @@ let args' = drop (length params) args let propTy = head args' let restargs = init $ tail args'- let consargs = take (length restargs - length indicies) $ restargs- let indxargs = drop (length restargs - length indicies) $ restargs+ let consargs = take (length restargs - length indicies) restargs+ let indxargs = drop (length restargs - length indicies) restargs let scr = last $ tail args' let indxnames = makeIndexNames indicies currentNames <- query $ allTTNames . getProofTerm . pterm@@ -778,7 +790,7 @@ action (\ps -> ps {holes = holes ps \\ [x], recents = x : recents ps }) mapM_ addConsHole (reverse consargs')- let res' = forget $ res+ let res' = forget res (scv, sct) <- lift $ check ctxt env res' let (scv', _) = specialise ctxt env [] scv return scv'@@ -895,7 +907,7 @@ updateEnv [] e = e updateEnv ns [] = []-updateEnv ns ((n, b) : env) +updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env updateProv ns (SourceTerm t) = SourceTerm $ updateSolvedTerm ns t@@ -907,7 +919,7 @@ updateError ns (ElaboratingArg f a env e) = ElaboratingArg f a env (updateError ns e) updateError ns (CantUnify b (l,lp) (r,rp) e xs sc)- = CantUnify b (updateSolvedTerm ns l, fmap (updateProv ns) lp) + = CantUnify b (updateSolvedTerm ns l, fmap (updateProv ns) lp) (updateSolvedTerm ns r, fmap (updateProv ns) rp) (updateError ns e) xs sc updateError ns e = e @@ -940,7 +952,7 @@ setReady (x, y, _, env, err, c, at) = (x, y, True, env, err, c, at) -updateProblems :: ProofState -> [(Name, TT Name)] -> Fails +updateProblems :: ProofState -> [(Name, TT Name)] -> Fails -> ([(Name, TT Name)], Fails) -- updateProblems ctxt [] ps inj holes = ([], ps) updateProblems ps updates probs = rec 10 updates probs@@ -966,8 +978,8 @@ (lp, rp) = getProvenance err err' = updateError ns err env' = updateEnv ns env in- if newx || newy || ready || - any (\n -> n `elem` inj) (refsIn x ++ refsIn y) then + if newx || newy || ready ||+ any (\n -> n `elem` inj) (refsIn x ++ refsIn y) then case unify ctxt env' (x', lp) (y', rp) inj hs usupp while of OK (v, []) -> traceWhen ulog ("DID " ++ show (x',y',ready,v,dont)) $ let v' = filter (\(n, _) -> n `notElem` dont) v in@@ -980,11 +992,11 @@ updateNs ns (x, y, t, env, err, fc, fa) = let (x', newx) = updateSolvedTerm' ns x (y', newy) = updateSolvedTerm' ns y in- (x', y', newx || newy, + (x', y', newx || newy, updateEnv ns env, updateError ns err, fc, fa) -- attempt to solve remaining problems with match_unify-matchProblems :: Bool -> ProofState -> [(Name, TT Name)] -> Fails +matchProblems :: Bool -> ProofState -> [(Name, TT Name)] -> Fails -> ([(Name, TT Name)], Fails) matchProblems all ps updates probs = up updates probs where hs = holes ps@@ -1010,7 +1022,7 @@ processTactic :: Tactic -> ProofState -> TC (ProofState, String) processTactic QED ps = case holes ps of [] -> do let tm = {- normalise (context ps) [] -} getProofTerm (pterm ps)- (tm', ty', _) <- recheck (context ps) [] (forget tm) tm+ (tm', ty', _) <- recheck (constraint_ns ps) (context ps) [] (forget tm) tm return (ps { done = True, pterm = mkProofTerm tm' }, "Proof complete: " ++ showEnv [] tm') _ -> fail "Still holes to fill."@@ -1073,7 +1085,8 @@ [] -> case t of Focus _ -> return (ps, "") -- harmless to refocus when done, since -- 'focus' doesn't fail- _ -> fail $ "Nothing to fill in."+ _ -> fail $ "Proof done, nothing to run tactic on: " ++ show t +++ "\n" ++ show (getProofTerm (pterm ps)) (h:_) -> do ps' <- execStateT (process t h) ps let (ns_in, probs') = case solved ps' of@@ -1085,7 +1098,7 @@ -- apply them here let ns' = dropGiven (dontunify ps') ns_in (holes ps') let pterm'' = updateSolved ns' (pterm ps')- traceWhen (unifylog ps) + traceWhen (unifylog ps) ("Updated problems after solve " ++ qshow probs' ++ "\n" ++ "(Toplevel) Dropping holes: " ++ show (map fst ns') ++ "\n" ++ "Holes were: " ++ show (holes ps')) $@@ -1139,4 +1152,3 @@ mktac (MoveLast n) = movelast n mktac (UnifyGoal r) = unifyGoal r mktac (UnifyTerms x y) = unifyTerms x y-
src/Idris/Core/ProofTerm.hs view
@@ -1,16 +1,20 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-}--{- | Implements a proof state, some primitive tactics for manipulating-proofs, and some high level commands for introducing new theorems,-evaluation/checking inside the proof system, etc.+{-|+Module : Idris.Core.ProofTerm+Description : Proof term. implementation and utilities.+Copyright :+License : BSD3+Maintainer : The Idris Community. -} -module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm,- resetProofTerm,- updateSolved, updateSolvedTerm, updateSolvedTerm',- bound_in, bound_in_term, refocus, updsubst,- Hole, RunTactic',- goal, atHole) where+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-}+module Idris.Core.ProofTerm(+ ProofTerm, Goal(..), mkProofTerm, getProofTerm+ , resetProofTerm+ , updateSolved, updateSolvedTerm, updateSolvedTerm'+ , bound_in, bound_in_term, refocus, updsubst+ , Hole, RunTactic'+ , goal, atHole+ ) where import Idris.Core.Typecheck import Idris.Core.Evaluate@@ -72,7 +76,7 @@ -- are crossed, and the actual binding term. findHole :: Name -> Env -> Term -> Maybe (TermPath, Env, Term) findHole n env t = fh' env Top t where- fh' env path tm@(Bind x h sc) + fh' env path tm@(Bind x h sc) | hole h && n == x = Just (path, env, tm) fh' env path (App Complete _ _) = Nothing fh' env path (App s f a)@@ -114,7 +118,7 @@ -- First look for the hole in the proof term as-is | Just (p', env', tm') <- findHole n env tm = PT (replaceTop p' path) env' tm' ups- -- If it's not there, rebuild and look from the top + -- If it's not there, rebuild and look from the top | Just (p', env', tm') <- findHole n [] (rebuildTerm tm (updateSolvedPath ups path)) = PT p' env' tm' [] | otherwise = pt@@ -128,7 +132,7 @@ mkProofTerm tm = PT Top [] tm [] getProofTerm :: ProofTerm -> Term-getProofTerm (PT path _ sub ups) = rebuildTerm sub (updateSolvedPath ups path) +getProofTerm (PT path _ sub ups) = rebuildTerm sub (updateSolvedPath ups path) resetProofTerm :: ProofTerm -> ProofTerm resetProofTerm = mkProofTerm . getProofTerm@@ -183,11 +187,11 @@ if ut then (P nt n ty', True) else (t, False) updateSolved' xs t = (t, False) - updateSolvedB' xs b@(Let t v) = let (t', ut) = updateSolved' xs t + updateSolvedB' xs b@(Let t v) = let (t', ut) = updateSolved' xs t (v', uv) = updateSolved' xs v in if ut || uv then (Let t' v', True) else (b, False)- updateSolvedB' xs b@(Guess t v) = let (t', ut) = updateSolved' xs t + updateSolvedB' xs b@(Guess t v) = let (t', ut) = updateSolved' xs t (v', uv) = updateSolved' xs v in if ut || uv then (Guess t' v', True) else (b, False)@@ -261,7 +265,7 @@ updateSolvedPath ns t@(AppR Complete _ _) = t updateSolvedPath ns (AppL s p r) = AppL s (updateSolvedPath ns p) (updateSolvedTerm ns r) updateSolvedPath ns (AppR s l p) = AppR s (updateSolvedTerm ns l) (updateSolvedPath ns p)-updateSolvedPath ns (InBind n b sc) +updateSolvedPath ns (InBind n b sc) = InBind n (updateSolvedPathB b) (updateSolvedTerm ns sc) where updateSolvedPathB (Binder b) = Binder (fmap (updateSolvedPath ns) b)@@ -277,18 +281,18 @@ updateSolvedPath ns (InScope n b sc) = InScope n (fmap (updateSolvedTerm ns) b) (updateSolvedPath ns sc) -updateSolved :: [(Name, Term)] -> ProofTerm -> ProofTerm -updateSolved xs pt@(PT path env sub ups) - = PT path -- (updateSolvedPath xs path) - (updateEnv xs (filter (\(n, t) -> n `notElem` map fst xs) env)) - (updateSolvedTerm xs sub) +updateSolved :: [(Name, Term)] -> ProofTerm -> ProofTerm+updateSolved xs pt@(PT path env sub ups)+ = PT path -- (updateSolvedPath xs path)+ (updateEnv xs (filter (\(n, t) -> n `notElem` map fst xs) env))+ (updateSolvedTerm xs sub) (ups ++ xs) goal :: Hole -> ProofTerm -> TC Goal-goal h pt@(PT path env sub ups) +goal h pt@(PT path env sub ups) -- | OK ginf <- g env sub = return ginf | otherwise = g [] (rebuildTerm sub (updateSolvedPath ups path))- where + where g :: Env -> Term -> TC Goal g env (Bind n b@(Guess _ _) sc) | same h n = return $ GD env b@@ -297,7 +301,7 @@ g env (Bind n b sc) | hole b && same h n = return $ GD env b | otherwise = g ((n, b):env) sc `mplus` gb env b- g env (App Complete f a) = fail "Can't find hole" + g env (App Complete f a) = fail "Can't find hole" g env (App _ f a) = g env a `mplus` g env f g env t = fail "Can't find hole" @@ -305,9 +309,9 @@ gb env (Guess t v) = g env v `mplus` g env t gb env t = g env (binderTy t) -atHole :: Hole -> RunTactic' a -> Context -> Env -> ProofTerm -> +atHole :: Hole -> RunTactic' a -> Context -> Env -> ProofTerm -> StateT a TC (ProofTerm, Bool)-atHole h f c e pt -- @(PT path env sub) +atHole h f c e pt -- @(PT path env sub) = do let PT path env sub ups = refocus h pt (tm, u) <- atH f c env sub return (PT path env tm ups, u)@@ -362,4 +366,3 @@ bi b = bound_in_term (binderTy b) bound_in_term (App _ f a) = bound_in_term f ++ bound_in_term a bound_in_term _ = []-
src/Idris/Core/TT.hs view
@@ -1,8 +1,12 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor, - DeriveDataTypeable, PatternGuards #-}-{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}-{-| TT is the core language of Idris. The language has:+{-|+Module : Idris.Core.TT+Description : The core language of Idris, TT.+Copyright :+License : BSD3+Maintainer : The Idris Community. +TT is the core language of Idris. The language has:+ * Full dependent types * A hierarchy of universes, with cumulativity: Type : Type1, Type1 : Type2, ...@@ -18,30 +22,34 @@ * We have a simple collection of tactics which we use to elaborate source programs with implicit syntax into fully explicit terms. -}--module Idris.Core.TT(AppStatus(..), ArithTy(..), Binder(..), Const(..), Ctxt(..),- ConstraintFC(..), DataOpt(..), DataOpts(..), Datatype(..),- Env(..), EnvTT(..), Err(..), Err'(..), ErrorReportPart(..),- FC(..), FC'(..), ImplicitInfo(..), IntTy(..), Name(..),- NameOutput(..), NameType(..), NativeTy(..), OutputAnnotation(..),- Provenance(..), Raw(..), SpecialName(..), TC(..), Term(..),- TermSize(..), TextFormatting(..), TT(..),Type(..), TypeInfo(..),- UConstraint(..), UCs(..), UExp(..), Universe(..),- addAlist, addBinder, addDef, allTTNames, arity, bindAll,- bindingOf, bindTyArgs, caseName, constDocs, constIsType, deleteDefExact,- discard, emptyContext, emptyFC, explicitNames, fc_end, fc_fname,- fc_start, fcIn, fileFC, finalise, fmapMB, forget, forgetEnv,- freeNames, getArgTys, getRetTy, implicitable, instantiate,- intTyName, isInjective, isTypeConst, liftPats, lookupCtxt,- lookupCtxtExact, lookupCtxtName, mapCtxt, mkApp, nativeTyWidth,- nextName, noOccurrence, nsroot, occurrences, orderPats,- pEraseType, pmap, pprintRaw, pprintTT, prettyEnv, psubst, pToV,- pToVs, pureTerm, raw_apply, raw_unapply, refsIn, safeForget,- safeForgetEnv, showCG, showEnv, showEnvDbg, showSep,- sInstanceN, sMN, sNS, spanFC, str, subst, substNames, substTerm,- substV, sUN, tcname, termSmallerThan, tfail, thead, tnull,- toAlist, traceWhen, txt, unApply, uniqueBinders, uniqueName,- uniqueNameFrom, uniqueNameSet, unList, updateDef, vToP, weakenTm) where+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor,+ DeriveDataTypeable, PatternGuards #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+module Idris.Core.TT(+ AppStatus(..), ArithTy(..), Binder(..), Const(..), Ctxt(..)+ , ConstraintFC(..), DataOpt(..), DataOpts(..), Datatype(..)+ , Env(..), EnvTT(..), Err(..), Err'(..), ErrorReportPart(..)+ , FC(..), FC'(..), ImplicitInfo(..), IntTy(..), Name(..)+ , NameOutput(..), NameType(..), NativeTy(..), OutputAnnotation(..)+ , Provenance(..), Raw(..), SpecialName(..), TC(..), Term(..)+ , TermSize(..), TextFormatting(..), TT(..),Type(..), TypeInfo(..)+ , UConstraint(..), UCs(..), UExp(..), Universe(..)+ , addAlist, addBinder, addDef, allTTNames, arity, bindAll+ , bindingOf, bindTyArgs, caseName, constDocs, constIsType, deleteDefExact+ , discard, emptyContext, emptyFC, explicitNames, fc_end, fc_fname+ , fc_start, fcIn, fileFC, finalise, fmapMB, forget, forgetEnv+ , freeNames, getArgTys, getRetTy, implicitable, instantiate, internalNS+ , intTyName, isInjective, isTypeConst, lookupCtxt+ , lookupCtxtExact, lookupCtxtName, mapCtxt, mkApp, nativeTyWidth+ , nextName, noOccurrence, nsroot, occurrences+ , pEraseType, pmap, pprintRaw, pprintTT, prettyEnv, psubst, pToV+ , pToVs, pureTerm, raw_apply, raw_unapply, refsIn, safeForget+ , safeForgetEnv, showCG, showEnv, showEnvDbg, showSep+ , sInstanceN, sMN, sNS, spanFC, str, subst, substNames, substTerm+ , substV, sUN, tcname, termSmallerThan, tfail, thead, tnull+ , toAlist, traceWhen, txt, unApply, uniqueBinders, uniqueName+ , uniqueNameFrom, uniqueNameSet, unList, updateDef, vToP, weakenTm+ ) where -- Work around AMP without CPP import Prelude (Eq(..), Show(..), Ord(..), Functor(..), Monad(..), String, Int,@@ -287,7 +295,7 @@ | NonCollapsiblePostulate Name | AlreadyDefined Name | ProofSearchFail (Err' t)- | NoRewriting t+ | NoRewriting t t t | At FC (Err' t) | Elaborating String Name (Maybe t) (Err' t) | ElaboratingArg Name Name [(Name, Name)] (Err' t)@@ -317,7 +325,7 @@ instance Monad TC where return x = OK x- x >>= k = bindTC x k + x >>= k = bindTC x k fail e = Error (InternalMsg e) instance MonadPlus TC where@@ -357,7 +365,7 @@ size (NoTypeDecl name) = size name size (NotInjective l c r) = size l + size c + size r size (CantResolve _ trm _) = size trm- size (NoRewriting trm) = size trm+ size (NoRewriting l r t) = size l + size r + size t size (CantResolveAlts _) = 1 size (IncompleteTerm trm) = size trm size ProgramLineComment = 1@@ -386,7 +394,7 @@ show (At f e) = show f ++ ":" ++ show e show (ElaboratingArg f x prev e) = "Elaborating " ++ show f ++ " arg " ++ show x ++ ": " ++ show e- show (Elaborating what n ty e) = "Elaborating " ++ what ++ show n ++ + show (Elaborating what n ty e) = "Elaborating " ++ what ++ show n ++ showType ty ++ ":" ++ show e where showType Nothing = ""@@ -590,8 +598,7 @@ -- |Return True if the argument 'Name' should be interpreted as the name of a -- typeclass.-tcname (UN xs) | T.null xs = False- | otherwise = T.head xs == '@'+tcname (UN xs) = False tcname (NS n _) = tcname n tcname (SN (InstanceN _ _)) = True tcname (SN (MethodN _)) = True@@ -845,7 +852,8 @@ deriving instance NFData Raw !-} -data ImplicitInfo = Impl { tcinstance :: Bool, toplevel_imp :: Bool }+data ImplicitInfo = Impl { tcinstance :: Bool, toplevel_imp :: Bool,+ machine_gen :: Bool } deriving (Show, Eq, Ord, Data, Typeable) {-!@@ -937,8 +945,11 @@ -- WELL TYPED TERMS --------------------------------------------------------- +internalNS :: String+internalNS = "(internal)"+ -- | Universe expressions for universe checking-data UExp = UVar Int -- ^ universe variable+data UExp = UVar String Int -- ^ universe variable, with source file to disambiguate | UVal Int -- ^ explicit universe level deriving (Eq, Ord, Data, Typeable) {-!@@ -949,8 +960,9 @@ size _ = 1 instance Show UExp where- show (UVar x) | x < 26 = [toEnum (x + fromEnum 'a')]- | otherwise = toEnum ((x `mod` 26) + fromEnum 'a') : show (x `div` 26)+ show (UVar ns x) + | x < 26 = ns ++ "." ++ [toEnum (x + fromEnum 'a')]+ | otherwise = ns ++ "." ++ toEnum ((x `mod` 26) + fromEnum 'a') : show (x `div` 26) show (UVal x) = show x -- show (UMax l r) = "max(" ++ show l ++ ", " ++ show r ++")" @@ -964,7 +976,7 @@ deriving (Show, Data, Typeable) instance Eq ConstraintFC where- x == y = uconstraint x == uconstraint y + x == y = uconstraint x == uconstraint y instance Ord ConstraintFC where compare x y = compare (uconstraint x) (uconstraint y)@@ -1294,11 +1306,25 @@ TT n {-^ template term -} -> TT n substTerm old new = st where- st t | t == old = new+ st t | eqAlpha [] t old = new st (App s f a) = App s (st f) (st a) st (Bind x b sc) = Bind x (fmap st b) (st sc) st t = t + eqAlpha as (P _ x _) (P _ y _) + = x == y || (x, y) `elem` as || (y, x) `elem` as+ eqAlpha as (V x) (V y) = x == y+ eqAlpha as (Bind x xb xs) (Bind y yb ys)+ = eqAlphaB as xb yb && eqAlpha ((x, y) : as) xs ys+ eqAlpha as (App _ fx ax) (App _ fy ay) = eqAlpha as fx fy && eqAlpha as ax ay+ eqAlpha as x y = x == y++ eqAlphaB as (Let xt xv) (Let yt yv)+ = eqAlpha as xt yt && eqAlpha as xv yv+ eqAlphaB as (Guess xt xv) (Guess yt yv)+ = eqAlpha as xt yt && eqAlpha as xv yv+ eqAlphaB as bx by = eqAlpha as (binderTy bx) (binderTy by) + -- | Return number of occurrences of V 0 or bound name i the term occurrences :: Eq n => n -> TT n -> Int occurrences n t = execState (no' 0 t) 0@@ -1676,30 +1702,6 @@ weakenTmEnv :: Int -> EnvTT n -> EnvTT n weakenTmEnv i = map (\ (n, b) -> (n, fmap (weakenTm i) b)) --- | Gather up all the outer 'PVar's and 'Hole's in an expression and reintroduce--- them in a canonical order-orderPats :: Term -> Term-orderPats tm = op [] tm- where- op [] (App s f a) = App s f (op [] a) -- for Infer terms-- op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc- op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc- op ps (Bind n (Pi i t k) sc) = op ((n, Pi i t k) : ps) sc- op ps sc = bindAll (sortP ps) sc-- sortP ps = pick [] (reverse ps)-- pick acc [] = reverse acc- pick acc ((n, t) : ps) = pick (insert n t acc) ps-- insert n t [] = [(n, t)]- insert n t ((n',t') : ps)- | n `elem` (refsIn (binderTy t') ++- concatMap refsIn (map (binderTy . snd) ps))- = (n', t') : insert n t ps- | otherwise = (n,t):(n',t'):ps- refsIn :: TT Name -> [Name] refsIn (P _ n _) = [n] refsIn (Bind n b t) = nub $ nb b ++ refsIn t@@ -1708,45 +1710,6 @@ nb t = refsIn (binderTy t) refsIn (App s f a) = nub (refsIn f ++ refsIn a) refsIn _ = []---- Make sure all the pattern bindings are as far out as possible-liftPats :: Term -> Term-liftPats tm = let (tm', ps) = runState (getPats tm) [] in- orderPats $ bindPats (reverse ps) tm'- where- bindPats [] tm = tm- bindPats ((n, t):ps) tm- | n `notElem` map fst ps = Bind n (PVar t) (bindPats ps tm)- | otherwise = bindPats ps tm-- getPats :: Term -> State [(Name, Type)] Term- getPats (Bind n (PVar t) sc) = do ps <- get- put ((n, t) : ps)- getPats sc- getPats (Bind n (Guess t v) sc) = do t' <- getPats t- v' <- getPats v- sc' <- getPats sc- return (Bind n (Guess t' v') sc')- getPats (Bind n (Let t v) sc) = do t' <- getPats t- v' <- getPats v- sc' <- getPats sc- return (Bind n (Let t' v') sc')- getPats (Bind n (Pi i t k) sc) = do t' <- getPats t- k' <- getPats k- sc' <- getPats sc- return (Bind n (Pi i t' k') sc')- getPats (Bind n (Lam t) sc) = do t' <- getPats t- sc' <- getPats sc- return (Bind n (Lam t') sc')- getPats (Bind n (Hole t) sc) = do t' <- getPats t- sc' <- getPats sc- return (Bind n (Hole t') sc')--- getPats (App s f a) = do f' <- getPats f- a' <- getPats a- return (App s f' a')- getPats t = return t allTTNames :: Eq n => TT n -> [n] allTTNames = nub . allNamesIn
src/Idris/Core/Typecheck.hs view
@@ -1,3 +1,11 @@+{-|+Module : Idris.Core.Typecheck+Description : Idris' type checker.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, PatternGuards #-} @@ -50,14 +58,22 @@ where isType' tm | isUniverse tm = return () | otherwise = fail (showEnv env tm ++ " is not a Type") -recheck :: Context -> Env -> Raw -> Term -> TC (Term, Type, UCs)+convType :: String -> Context -> Env -> Term -> StateT UCs TC ()+convType tcns ctxt env tm =+ do (v, cs) <- get+ put (v + 1, cs)+ case normalise ctxt env tm of+ UType _ -> return ()+ _ -> convertsC ctxt env tm (TType (UVar tcns v))++recheck :: String -> Context -> Env -> Raw -> Term -> TC (Term, Type, UCs) recheck = recheck_borrowing False [] -recheck_borrowing :: Bool -> [Name] -> Context -> Env -> Raw -> Term ->+recheck_borrowing :: Bool -> [Name] -> String -> Context -> Env -> Raw -> Term -> TC (Term, Type, UCs)-recheck_borrowing uniq_check bs ctxt env tm orig+recheck_borrowing uniq_check bs tcns ctxt env tm orig = let v = next_tvar ctxt in- case runStateT (check' False ctxt env tm) (v, []) of -- holes banned+ case runStateT (check' False tcns ctxt env tm) (v, []) of -- holes banned Error (IncompleteTerm _) -> Error $ IncompleteTerm orig Error e -> Error e OK ((tm, ty), constraints) ->@@ -66,10 +82,11 @@ check :: Context -> Env -> Raw -> TC (Term, Type) check ctxt env tm- = evalStateT (check' True ctxt env tm) (0, []) -- Holes allowed+ -- Holes allowed, so constraint namespace doesn't matter+ = evalStateT (check' True [] ctxt env tm) (0, []) -check' :: Bool -> Context -> Env -> Raw -> StateT UCs TC (Term, Type)-check' holes ctxt env top = chk (TType (UVar (-5))) env top where+check' :: Bool -> String -> Context -> Env -> Raw -> StateT UCs TC (Term, Type)+check' holes tcns ctxt env top = chk (TType (UVar tcns (-5))) Nothing env top where smaller (UType NullType) _ = UType NullType smaller _ (UType NullType) = UType NullType@@ -81,20 +98,21 @@ | otherwise = Complete chk :: Type -> -- uniqueness level+ Maybe UExp -> -- universe for kind Env -> Raw -> StateT UCs TC (Term, Type)- chk u env (Var n)+ chk u lvl env (Var n) | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty) -- If we're elaborating, we don't want the private names; if we're -- checking an already elaborated term, we do- | [P nt n' ty] <- lookupP_all (not holes) False n ctxt + | [P nt n' ty] <- lookupP_all (not holes) False n ctxt = return (P nt n' ty, ty) -- If the names are ambiguous, require it to be fully qualified- | [P nt n' ty] <- lookupP_all (not holes) True n ctxt + | [P nt n' ty] <- lookupP_all (not holes) True n ctxt = return (P nt n' ty, ty) | otherwise = do lift $ tfail $ NoSuchVariable n- chk u env ap@(RApp f RType) | not holes+ chk u lvl env ap@(RApp f RType) | not holes -- special case to reduce constraintss- = do (fv, fty) <- chk u env f+ = do (fv, fty) <- chk u Nothing env f let fty' = case uniqueBinders (map fst env) (finalise fty) of ty@(Bind x (Pi i s k) t) -> ty _ -> uniqueBinders (map fst env)@@ -104,26 +122,26 @@ case fty' of Bind x (Pi i (TType v') k) t -> do (v, cs) <- get- put (v+1, ULT (UVar v) v' : cs)+ put (v+1, ULT (UVar tcns v) v' : cs) let apty = simplify initContext env- (Bind x (Let (TType v') (TType (UVar v))) t)- return (App Complete fv (TType (UVar v)), apty)+ (Bind x (Let (TType v') (TType (UVar tcns v))) t)+ return (App Complete fv (TType (UVar tcns v)), apty) Bind x (Pi i s k) t ->- do (av, aty) <- chk u env RType + do (av, aty) <- chk u Nothing env RType convertsC ctxt env aty s let apty = simplify initContext env (Bind x (Let aty av) t) return (App astate fv av, apty) t -> lift $ tfail $ NonFunctionType fv fty- chk u env ap@(RApp f a)- = do (fv, fty) <- chk u env f+ chk u lvl env ap@(RApp f a)+ = do (fv, fty) <- chk u Nothing env f let fty' = case uniqueBinders (map fst env) (finalise fty) of ty@(Bind x (Pi i s k) t) -> ty _ -> uniqueBinders (map fst env) $ case hnf ctxt env fty of ty@(Bind x (Pi i s k) t) -> ty _ -> normalise ctxt env fty- (av, aty) <- chk u env a+ (av, aty) <- chk u Nothing env a case fty' of Bind x (Pi i s k) t -> do convertsC ctxt env aty s@@ -131,13 +149,13 @@ (Bind x (Let aty av) t) return (App astate fv av, apty) t -> lift $ tfail $ NonFunctionType fv fty- chk u env RType+ chk u lvl env RType | holes = return (TType (UVal 0), TType (UVal 0)) | otherwise = do (v, cs) <- get- let c = ULT (UVar v) (UVar (v+1))+ let c = ULT (UVar tcns v) (UVar tcns (v+1)) put (v+2, (c:cs))- return (TType (UVar v), TType (UVar (v+1)))- chk u env (RUType un)+ return (TType (UVar tcns v), TType (UVar tcns (v+1)))+ chk u lvl env (RUType un) | holes = return (UType un, TType (UVal 0)) | otherwise = do -- TODO! Issue #1715 on the issue tracker. -- https://github.com/idris-lang/Idris-dev/issues/1715@@ -146,8 +164,8 @@ -- put (v+2, (c:cs)) -- return (TType (UVar v), TType (UVar (v+1))) return (UType un, TType (UVal 0))- chk u env (RConstant Forgot) = return (Erased, Erased)- chk u env (RConstant c) = return (Constant c, constType c)+ chk u lvl env (RConstant Forgot) = return (Erased, Erased)+ chk u lvl env (RConstant c) = return (Constant c, constType c) where constType (I _) = Constant (AType (ATInt ITNative)) constType (BI _) = Constant (AType (ATInt ITBig)) constType (Fl _) = Constant (AType ATFloat)@@ -160,19 +178,28 @@ constType TheWorld = Constant WorldType constType Forgot = Erased constType _ = TType (UVal 0)- chk u env (RBind n (Pi i s k) t)- = do (sv, st) <- chk u env s+ chk u lvl env (RBind n (Pi i s k) t)+ = do (sv, st) <- chk u Nothing env s (v, cs) <- get- (kv, kt) <- chk u env k -- no need to validate these constraints, they are independent+ (kv, kt) <- chk u Nothing env k -- no need to validate these constraints, they are independent put (v+1, cs)- let maxu = UVar v- (tv, tt) <- chk st ((n, Pi i sv kv) : env) t+ let maxu = case lvl of+ Nothing -> UVar tcns v+ Just v' -> v'+ (tv, tt) <- chk st (Just maxu) ((n, Pi i sv kv) : env) t++-- convertsC ctxt env st (TType maxu)+-- convertsC ctxt env tt (TType maxu)+-- when holes $ put (v, cs)+-- return (Bind n (Pi i (uniqueBinders (map fst env) sv) (TType maxu))+-- (pToV n tv), TType maxu)+ case (normalise ctxt env st, normalise ctxt env tt) of (TType su, TType tu) -> do when (not holes) $ do (v, cs) <- get- put (v, ULE su maxu : + put (v, ULE su maxu : ULE tu maxu : cs)- let k' = TType (UVar v) `smaller` st `smaller` kv `smaller` u+ let k' = TType (UVar tcns v) `smaller` st `smaller` kv `smaller` u return (Bind n (Pi i (uniqueBinders (map fst env) sv) k') (pToV n tv), k') (un, un') ->@@ -195,70 +222,62 @@ mostUnique (Pi _ _ pk : es) k = mostUnique es (smaller pk k) mostUnique (_ : es) k = mostUnique es k - chk u env (RBind n b sc)+ chk u lvl env (RBind n b sc) = do (b', bt') <- checkBinder b- (scv, sct) <- chk (smaller bt' u) ((n, b'):env) sc+ (scv, sct) <- chk (smaller bt' u) Nothing ((n, b'):env) sc discharge n b' bt' (pToV n scv) (pToV n sct) where checkBinder (Lam t)- = do (tv, tt) <- chk u env t+ = do (tv, tt) <- chk u Nothing env t let tv' = normalise ctxt env tv- let tt' = normalise ctxt env tt- lift $ isType ctxt env tt'- return (Lam tv, tt')+ convType tcns ctxt env tt+ return (Lam tv, tt) checkBinder (Let t v)- = do (tv, tt) <- chk u env t- (vv, vt) <- chk u env v+ = do (tv, tt) <- chk u Nothing env t+ (vv, vt) <- chk u Nothing env v let tv' = normalise ctxt env tv- let tt' = normalise ctxt env tt convertsC ctxt env vt tv- lift $ isType ctxt env tt'- return (Let tv vv, tt')+ convType tcns ctxt env tt+ return (Let tv vv, tt) checkBinder (NLet t v)- = do (tv, tt) <- chk u env t- (vv, vt) <- chk u env v+ = do (tv, tt) <- chk u Nothing env t+ (vv, vt) <- chk u Nothing env v let tv' = normalise ctxt env tv- let tt' = normalise ctxt env tt convertsC ctxt env vt tv- lift $ isType ctxt env tt'- return (NLet tv vv, tt')+ convType tcns ctxt env tt+ return (NLet tv vv, tt) checkBinder (Hole t) | not holes = lift $ tfail (IncompleteTerm undefined) | otherwise- = do (tv, tt) <- chk u env t+ = do (tv, tt) <- chk u Nothing env t let tv' = normalise ctxt env tv- let tt' = normalise ctxt env tt- lift $ isType ctxt env tt'- return (Hole tv, tt')+ convType tcns ctxt env tt+ return (Hole tv, tt) checkBinder (GHole i ns t)- = do (tv, tt) <- chk u env t+ = do (tv, tt) <- chk u Nothing env t let tv' = normalise ctxt env tv- let tt' = normalise ctxt env tt- lift $ isType ctxt env tt'- return (GHole i ns tv, tt')+ convType tcns ctxt env tt+ return (GHole i ns tv, tt) checkBinder (Guess t v) | not holes = lift $ tfail (IncompleteTerm undefined) | otherwise- = do (tv, tt) <- chk u env t- (vv, vt) <- chk u env v+ = do (tv, tt) <- chk u Nothing env t+ (vv, vt) <- chk u Nothing env v let tv' = normalise ctxt env tv- let tt' = normalise ctxt env tt convertsC ctxt env vt tv- lift $ isType ctxt env tt'- return (Guess tv vv, tt')+ convType tcns ctxt env tt+ return (Guess tv vv, tt) checkBinder (PVar t)- = do (tv, tt) <- chk u env t+ = do (tv, tt) <- chk u Nothing env t let tv' = normalise ctxt env tv- let tt' = normalise ctxt env tt- lift $ isType ctxt env tt'+ convType tcns ctxt env tt -- Normalised version, for erasure purposes (it's easier -- to tell if it's a collapsible variable)- return (PVar tv, tt')+ return (PVar tv, tt) checkBinder (PVTy t)- = do (tv, tt) <- chk u env t+ = do (tv, tt) <- chk u Nothing env t let tv' = normalise ctxt env tv- let tt' = normalise ctxt env tt- lift $ isType ctxt env tt'- return (PVTy tv, tt')+ convType tcns ctxt env tt+ return (PVTy tv, tt) discharge n (Lam t) bt scv sct = return (Bind n (Lam t) scv, Bind n (Pi Nothing t bt) sct)@@ -324,9 +343,7 @@ StateT [(Name, (UniqueUse, Universe))] TC () chkBinderName env n b = do let rawty = forgetEnv (map fst env) (binderTy b)- (_, kind) <- lift $ check ctxt env rawty -- FIXME: Cache in binder?- -- Issue #1714 on the issue tracker- -- https://github.com/idris-lang/Idris-dev/issues/1714+ (_, kind) <- lift $ check ctxt env rawty case kind of UType UniqueType -> do ns <- get if n `elem` borrowed
src/Idris/Core/Unify.hs view
@@ -1,7 +1,23 @@+{-|+Module : Idris.Core.Unify+Description : Idris' unification code.+Copyright :+License : BSD3+Maintainer : The Idris Community.++Unification is applied inside the theorem prover. We're looking for holes+which can be filled in, by matching one term's normal form against another.+Returns a list of hole names paired with the term which solves them, and+a list of things which need to be injective.++-} {-# LANGUAGE PatternGuards #-} -module Idris.Core.Unify(match_unify, unify, Fails, FailContext(..), FailAt(..),- unrecoverable) where+module Idris.Core.Unify(+ match_unify, unify+ , Fails, FailContext(..), FailAt(..)+ , unrecoverable+ ) where import Idris.Core.TT import Idris.Core.Evaluate@@ -12,14 +28,8 @@ import Data.List import Debug.Trace --- Unification is applied inside the theorem prover. We're looking for holes--- which can be filled in, by matching one term's normal form against another.--- Returns a list of hole names paired with the term which solves them, and--- a list of things which need to be injective.- -- terms which need to be injective, with the things we're trying to unify -- at the time- data FailAt = Match | Unify deriving (Show, Eq) @@ -62,14 +72,14 @@ -- Solve metavariables by matching terms against each other -- Not really unification, of course! -match_unify :: Context -> Env -> - (TT Name, Maybe Provenance) -> +match_unify :: Context -> Env ->+ (TT Name, Maybe Provenance) -> (TT Name, Maybe Provenance) -> [Name] -> [Name] -> [FailContext] -> TC [(Name, TT Name)] match_unify ctxt env (topx, xfrom) (topy, yfrom) inj holes from = case runStateT (un [] (renameBindersTm env topx) (renameBindersTm env topy)) (UI 0 []) of- OK (v, UI _ []) -> + OK (v, UI _ []) -> do v' <- trimSolutions (topx, xfrom) (topy, yfrom) from env v return (map (renameBinders env) v') res ->@@ -136,10 +146,10 @@ let r = recoverable (normalise ctxt env (binderTy x)) (normalise ctxt env (binderTy y)) let err = cantUnify from r (topx, xfrom) (topy, yfrom)- (CantUnify r (binderTy x, Nothing) + (CantUnify r (binderTy x, Nothing) (binderTy y, Nothing) (Msg "") (errEnv env) s) (errEnv env) s- put (UI s ((binderTy x, binderTy y, + put (UI s ((binderTy x, binderTy y, False, env, err, from, Match) : f)) return []@@ -236,13 +246,13 @@ followSols vs ((n, P _ t _) : ns) | Just t' <- lookup t ns = do vs' <- case t' of- P _ tn _ -> + P _ tn _ -> if (n, tn) `elem` vs then -- cycle- tfail (cantUnify from False (topx, xfrom) (topy, yfrom) + tfail (cantUnify from False (topx, xfrom) (topy, yfrom) (Msg "") (errEnv env) 0) else return ((n, tn) : vs) _ -> return vs- followSols vs' ((n, t') : ns) + followSols vs' ((n, t') : ns) followSols vs (n : ns) = do ns' <- followSols vs ns return $ n : ns' @@ -260,9 +270,9 @@ hasv (Bind x b sc) = hasv (binderTy b) || hasv sc hasv _ = False -unify :: Context -> Env -> - (TT Name, Maybe Provenance) -> +unify :: Context -> Env -> (TT Name, Maybe Provenance) ->+ (TT Name, Maybe Provenance) -> [Name] -> [Name] -> [Name] -> [FailContext] -> TC ([(Name, TT Name)], Fails) unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =@@ -281,7 +291,7 @@ (UI 0 []) of OK (v, UI _ fails) -> do v' <- trimSolutions (topx, xfrom) (topy, yfrom) from env v--- trace ("OK " ++ show (topxn, topyn, v, holes)) $ +-- trace ("OK " ++ show (topxn, topyn, v, holes)) $ return (map (renameBinders env) v', reverse fails) -- Error e@(CantUnify False _ _ _ _ _) -> tfail e Error e -> tfail e@@ -292,7 +302,7 @@ injective (P (DCon _ _ _) _ _) = True injective (P (TCon _ _) _ _) = True- injective (P Ref n _) + injective (P Ref n _) | Just i <- lookupInjectiveExact n ctxt = i injective (App _ f a) = injective f -- && injective a injective _ = False@@ -410,8 +420,8 @@ all rigid args, containsOnly (mapMaybe getname args) (mapMaybe getV args) tm -- && TODO: tm does not refer to any variables other than those- -- in 'args' - = -- trace ("PATTERN RULE SOLVE: " ++ show (mv, tm, env, bindLams args (substEnv env tm))) $ + -- in 'args'+ = -- trace ("PATTERN RULE SOLVE: " ++ show (mv, tm, env, bindLams args (substEnv env tm))) $ checkCycle bnames (mv, eta [] $ bindLams args (substEnv env tm)) where rigid (V i) = True rigid (P _ t _) = t `elem` map fst env &&@@ -425,14 +435,14 @@ getname _ = Nothing containsOnly args vs (V i) = i `elem` vs- containsOnly args vs (P Bound n ty) + containsOnly args vs (P Bound n ty) = n `elem` args && containsOnly args vs ty- containsOnly args vs (P _ n ty) + containsOnly args vs (P _ n ty) = not (holeIn env n || n `elem` holes) && containsOnly args vs ty- containsOnly args vs (App _ f a) + containsOnly args vs (App _ f a) = containsOnly args vs f && containsOnly args vs a- containsOnly args vs (Bind _ b sc) + containsOnly args vs (Bind _ b sc) = containsOnly args vs (binderTy b) && containsOnly args (0 : map (+1) vs) sc containsOnly args vs _ = True@@ -440,14 +450,14 @@ bindLams [] tm = tm bindLams (a : as) tm = bindLam a (bindLams as tm) - bindLam (V i) tm = Bind (fst (env !! i)) - (Lam (binderTy (snd (env !! i)))) + bindLam (V i) tm = Bind (fst (env !! i))+ (Lam (binderTy (snd (env !! i)))) tm bindLam (P _ n ty) tm = Bind n (Lam ty) tm bindLam _ tm = error "Can't happen [non rigid bindLam]" substEnv [] tm = tm- substEnv ((n, t) : env) tm + substEnv ((n, t) : env) tm = substEnv env (substV (P Bound n (binderTy t)) tm) -- remove any unnecessary lambdas (helps with type class@@ -484,14 +494,14 @@ un' env fn bnames (App _ f x) (Bind n (Pi i t k) y) | noOccurrence n y && injectiveApp f = do ux <- un' env False bnames x y- uf <- un' env False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))+ uf <- un' env False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar [] 0))) (Bind n (Pi i t k) (V 1))) combine env bnames ux uf un' env fn bnames (Bind n (Pi i t k) y) (App _ f x) | noOccurrence n y && injectiveApp f = do ux <- un' env False bnames y x- uf <- un' env False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))+ uf <- un' env False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar [] 0))) (Bind n (Pi i t k) (V 1))) f combine env bnames ux uf @@ -532,7 +542,7 @@ let ax' = hnormalise hf ctxt env (substNames hf ax) let ay' = hnormalise hf ctxt env (substNames hf ay) -- Don't normalise if we don't have to- ha <- uplus (un' env False bnames (substNames hf ax) + ha <- uplus (un' env False bnames (substNames hf ax) (substNames hf ay)) (un' env False bnames ax' ay') sc 1@@ -607,7 +617,7 @@ = do UI s f <- get let r = recoverable (normalise ctxt env x) (normalise ctxt env y) let err = cantUnify from r- (topx, xfrom) (topy, yfrom) + (topx, xfrom) (topy, yfrom) (CantUnify r (x, Nothing) (y, Nothing) (Msg "") (errEnv env) s) (errEnv env) s put (UI s ((topx, topy, True, env, err, from, Unify) : f)) return []@@ -616,7 +626,7 @@ unifyFail x y = do UI s f <- get let r = recoverable (normalise ctxt env x) (normalise ctxt env y) let err = cantUnify from r- (topx, xfrom) (topy, yfrom) + (topx, xfrom) (topy, yfrom) (CantUnify r (x, Nothing) (y, Nothing) (Msg "") (errEnv env) s) (errEnv env) s put (UI s ((topx, topy, True, env, err, from, Unify) : f)) lift $ tfail err@@ -636,14 +646,14 @@ uB env bnames (Pi _ tx _) (Pi _ ty _) = do sc 1; un' env False bnames tx ty uB env bnames (Hole tx) (Hole ty) = un' env False bnames tx ty uB env bnames (PVar tx) (PVar ty) = un' env False bnames tx ty- uB env bnames x y + uB env bnames x y = do UI s f <- get let r = recoverable (normalise ctxt env (binderTy x)) (normalise ctxt env (binderTy y)) let err = cantUnify from r (topx, xfrom) (topy, yfrom) (CantUnify r (binderTy x, Nothing) (binderTy y, Nothing) (Msg "") (errEnv env) s) (errEnv env) s- put (UI s ((binderTy x, binderTy y, + put (UI s ((binderTy x, binderTy y, False, env, err, from, Unify) : f)) return [] -- lift $ tfail err
src/Idris/Core/WHNF.hs view
@@ -1,13 +1,19 @@+{-|+Module : Idris.Core.WHNF+Description : Reduction to Weak Head Normal Form+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+ {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}---- | Reduction to Weak Head Normal Form module Idris.Core.WHNF(whnf, WEnv) where import Idris.Core.TT import Idris.Core.CaseTree import Idris.Core.Evaluate hiding (quote)-import qualified Idris.Core.Evaluate as Evaluate +import qualified Idris.Core.Evaluate as Evaluate import Debug.Trace @@ -15,7 +21,7 @@ -- evaluated in (i.e. it's a thunk) type StackEntry = (Term, WEnv) data WEnv = WEnv Int -- number of free variables- [(Term, WEnv)] + [(Term, WEnv)] deriving Show type Stack = [StackEntry]@@ -48,14 +54,14 @@ do_whnf ctxt env tm = eval env [] tm where eval :: WEnv -> Stack -> Term -> WHNF- eval wenv@(WEnv d env) stk (V i) + eval wenv@(WEnv d env) stk (V i) | i < length env = let (tm, env') = env !! i in eval env' stk tm | otherwise = error "Can't happen: WHNF scope error"- eval wenv@(WEnv d env) stk (Bind n (Let t v) sc) + eval wenv@(WEnv d env) stk (Bind n (Let t v) sc) = eval (WEnv d ((v, wenv) : env)) stk sc eval (WEnv d env) [] (Bind n b sc) = WBind n b (sc, WEnv (d + 1) env)- eval (WEnv d env) ((tm, tenv) : stk) (Bind n b sc) + eval (WEnv d env) ((tm, tenv) : stk) (Bind n b sc) = eval (WEnv d ((tm, tenv) : env)) stk sc eval env stk (P nt n ty) = apply env nt n ty stk@@ -71,7 +77,7 @@ eval env stk (UType u) = unload (WUType u) stk apply :: WEnv -> NameType -> Name -> Type -> Stack -> WHNF- apply env nt n ty stk + apply env nt n ty stk = let wp = case nt of DCon t a u -> WDCon t a u n (ty, env) TCon t a -> WTCon t a n (ty, env)@@ -79,12 +85,12 @@ _ -> WPRef n (ty, env) in case lookupDefExact n ctxt of- Just (CaseOp ci _ _ _ _ cd) -> + Just (CaseOp ci _ _ _ _ cd) -> let (ns, tree) = cases_compiletime cd in case evalCase env ns tree stk of Just w -> w Nothing -> unload wp stk- Just (Operator _ i op) -> + Just (Operator _ i op) -> if i <= length stk then case runOp env op (take i stk) (drop i stk) of Just v -> v@@ -97,7 +103,7 @@ unload f (a : as) = unload (WApp f a) as runOp :: WEnv -> ([Value] -> Maybe Value) -> Stack -> Stack -> Maybe WHNF- runOp env op stk rest + runOp env op stk rest = do vals <- mapM tmtoValue stk case op vals of Just (VConstant c) -> Just $ unload (WConstant c) rest@@ -110,14 +116,14 @@ _ -> Nothing tmtoValue :: (Term, WEnv) -> Maybe Value- tmtoValue (tm, tenv) + tmtoValue (tm, tenv) = case eval tenv [] tm of WConstant c -> Just (VConstant c) _ -> let tm' = quoteEnv tenv tm in Just (toValue ctxt [] tm') evalCase :: WEnv -> [Name] -> SC -> Stack -> Maybe WHNF- evalCase wenv@(WEnv d env) ns tree args + evalCase wenv@(WEnv d env) ns tree args | length ns > length args = Nothing | otherwise = let args' = take (length ns) args rest = drop (length ns) args in@@ -125,25 +131,25 @@ let wtm = pToVs (map fst amap) tm Just $ eval (WEnv d (map snd amap)) rest wtm - evalTree :: WEnv -> [(Name, (Term, WEnv))] -> SC -> + evalTree :: WEnv -> [(Name, (Term, WEnv))] -> SC -> Maybe (Term, [(Name, (Term, WEnv))]) evalTree env amap (STerm tm) = Just (tm, amap) evalTree env amap (Case _ n alts) = case lookup n amap of- Just (tm, tenv) -> findAlt env amap + Just (tm, tenv) -> findAlt env amap (deconstruct (eval tenv [] tm) []) alts _ -> Nothing evalTree _ _ _ = Nothing deconstruct :: WHNF -> Stack -> (WHNF, Stack) deconstruct (WApp f arg) stk = deconstruct f (arg : stk)- deconstruct t stk = (t, stk) + deconstruct t stk = (t, stk) - findAlt :: WEnv -> [(Name, (Term, WEnv))] -> (WHNF, Stack) -> + findAlt :: WEnv -> [(Name, (Term, WEnv))] -> (WHNF, Stack) -> [CaseAlt] -> Maybe (Term, [(Name, (Term, WEnv))])- findAlt env amap (WDCon tag _ _ _ _, args) alts - | Just (ns, sc) <- findTag tag alts + findAlt env amap (WDCon tag _ _ _ _, args) alts+ | Just (ns, sc) <- findTag tag alts = let amap' = updateAmap (zip ns args) amap in evalTree env amap' sc | Just sc <- findDefault alts@@ -159,7 +165,7 @@ findTag i [] = Nothing findTag i (ConCase n j ns sc : xs) | i == j = Just (ns, sc) findTag i (_ : xs) = findTag i xs- + findDefault :: [CaseAlt] -> Maybe SC findDefault [] = Nothing findDefault (DefaultCase sc : xs) = Just sc@@ -182,7 +188,7 @@ quote :: WHNF -> Term quote (WDCon t a u n (ty, env)) = P (DCon t a u) n (quoteEnv env ty) quote (WTCon t a n (ty, env)) = P (TCon t a) n (quoteEnv env ty)-quote (WPRef n (ty, env)) = P Ref n (quoteEnv env ty) +quote (WPRef n (ty, env)) = P Ref n (quoteEnv env ty) quote (WBind n ty (sc, env)) = Bind n ty (quoteEnv env sc) quote (WApp f (a, env)) = App Complete (quote f) (quoteEnv env a) quote (WConstant c) = Constant c@@ -195,7 +201,7 @@ quoteEnv :: WEnv -> Term -> Term quoteEnv (WEnv d ws) tm = qe' d ws tm where- qe' d ts (V i) + qe' d ts (V i) | i < d = V i | otherwise = let (tm, env) = ts !! (i - d) in quoteEnv env tm@@ -206,4 +212,3 @@ qe' d ts (P nt n ty) = P nt n (qe' d ts ty) qe' d ts (Proj tm i) = Proj (qe' d ts tm) i qe' d ts tm = tm-
src/Idris/Coverage.hs view
@@ -1,6 +1,11 @@-{-# LANGUAGE PatternGuards #-}-{-| The coverage and totality checkers for Idris are in this module.+{-|+Module : Idris.Coverage+Description : The coverage and totality checkers for Idris are in this module.+Copyright :+License : BSD3+Maintainer : The Idris Community. -}+{-# LANGUAGE PatternGuards #-} module Idris.Coverage where import Idris.Core.TT@@ -35,6 +40,12 @@ toTT (PApp _ t args) = do t' <- toTT t args' <- mapM (toTT . getTm) args return $ mkApp t' args'+ toTT (PDPair _ _ _ l _ r) = do l' <- toTT l+ r' <- toTT r+ return $ mkApp (P Ref sigmaCon Erased) [Erased, Erased, l', r']+ toTT (PPair _ _ _ l r) = do l' <- toTT l+ r' <- toTT r+ return $ mkApp (P Ref pairCon Erased) [Erased, Erased, l', r'] -- For alternatives, pick the first and drop the namespaces. It doesn't -- really matter which is taken since matching will ignore the namespace. toTT (PAlternative _ _ (a : as)) = toTT a@@ -73,7 +84,7 @@ logCoverage 5 $ show (map length argss) ++ "\n" ++ show (map length all_args) logCoverage 10 $ show argss ++ "\n" ++ show all_args logCoverage 3 $ "Original: \n" ++- showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs)+ showSep "\n" (map (\t -> showTmImpls (delab' i t True True)) xs) -- add an infinite supply of explicit arguments to update the possible -- cases for (the return type may be variadic, or function type, so -- there may be more case splitting that the idris_implicits record@@ -101,7 +112,7 @@ -- anything based on earlier values genPH :: IState -> Type -> [Bool] genPH ist (Bind n (Pi _ ty _) sc) = notConcrete ist ty : genPH ist sc- genPH ist ty = [] + genPH ist ty = [] notConcrete ist t | (P _ n _, args) <- unApply t, not (isConName n (tt_ctxt ist)) = True@@ -315,9 +326,8 @@ upd :: t -> PArg' t -> PArg' t upd p' p = p { getTm = p' } --- Check whether function and all descendants cover all cases (partial is--- okay, as long as it's due to recursion)-+-- | Check whether function and all descendants cover all cases+-- (partial is okay, as long as it's due to recursion) checkAllCovering :: FC -> [Name] -> Name -> Name -> Idris () checkAllCovering fc done top n | not (n `elem` done) = do i <- get@@ -334,16 +344,16 @@ x -> return () -- stop if total checkAllCovering _ _ _ _ = return () --- | Check if, in a given group of type declarations mut_ns,--- the constructor cn : ty is strictly positive,--- and update the context accordingly-checkPositive :: [Name] -- ^ the group of type declarations+-- | Check if, in a given group of type declarations mut_ns, the+-- constructor cn : ty is strictly positive, and update the context+-- accordingly+checkPositive :: [Name] -- ^ the group of type declarations -> (Name, Type) -- ^ the constructor -> Idris Totality checkPositive mut_ns (cn, ty') = do i <- getIState let ty = delazy' True (normalise (tt_ctxt i) [] ty')- let p = cp ty+ let p = cp i ty let tot = if p then Total (args ty) else Partial NotPositive let ctxt' = setTotal cn tot (tt_ctxt i) putIState (i { tt_ctxt = ctxt' })@@ -353,23 +363,32 @@ where args t = [0..length (getArgTys t)-1] - cp (Bind n (Pi _ aty _) sc) = posArg aty && cp sc- cp t | (P _ n' _, args) <- unApply t,- n' `elem` mut_ns = all noRec args- cp _ = True+ cp i (Bind n (Pi _ aty _) sc)+ = posArg i aty && cp i sc+ cp i t | (P _ n' _ , args) <- unApply t,+ n' `elem` mut_ns = all noRec args+ cp i _ = True - posArg (Bind _ (Pi _ nty _) sc)- | (P _ n' _, args) <- unApply nty- = n' `notElem` mut_ns && all noRec args && posArg sc- posArg t | (P _ n' _, args) <- unApply t,- n' `elem` mut_ns = all noRec args- posArg _ = True+ posArg ist (Bind _ (Pi _ nty _) sc) = noRec nty && posArg ist sc+ posArg ist t = posParams ist t noRec arg = all (\x -> x `notElem` mut_ns) (allTTNames arg) + -- If the type appears recursively in a parameter argument, that's+ -- fine, otherwise if it appears in an argument it's not fine.+ posParams ist t | (P _ n _, args) <- unApply t+ = case lookupCtxtExact n (idris_datatypes ist) of+ Just ti -> checkParamsOK (param_pos ti) 0 args+ Nothing -> and (map (posParams ist) args)+ posParams ist t = noRec t --- | Calculate the totality of a function from its patterns.--- Either follow the size change graph (if inductive) or check for+ checkParamsOK ppos i [] = True+ checkParamsOK ppos i (p : ps)+ | i `elem` ppos = checkParamsOK ppos (i + 1) ps+ | otherwise = noRec p && checkParamsOK ppos (i + 1) ps++-- | Calculate the totality of a function from its patterns. Either+-- follow the size change graph (if inductive) or check for -- productivity (if coinductive) calcTotality :: FC -> Name -> [([Name], Term, Term)] -> Idris Totality calcTotality fc n pats@@ -451,17 +470,44 @@ checkDeclTotality :: (FC, Name) -> Idris Totality checkDeclTotality (fc, n) = do logCoverage 2 $ "Checking " ++ show n ++ " for totality"--- buildSCG (fc, n)--- logCoverage 2 $ "Built SCG" i <- getIState- let opts = case lookupCtxt n (idris_flags i) of- [fs] -> fs+ let opts = case lookupCtxtExact n (idris_flags i) of+ Just fs -> fs _ -> [] when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n t <- checkTotality [] fc n return t +-- If the name calls something which is partial, set it as partial+verifyTotality :: (FC, Name) -> Idris ()+verifyTotality (fc, n)+ = do logCoverage 2 $ "Checking " ++ show n ++ "'s descendents are total"+ ist <- getIState+ case lookupTotalExact n (tt_ctxt ist) of+ Just (Total _) -> do+ let ns = getNames (tt_ctxt ist) + case getPartial ist [] ns of+ Nothing -> return ()+ Just bad -> do let t' = Partial (Other bad) + logCoverage 2 $ "Set to " ++ show t'+ setTotality n t'+ addIBC (IBCTotal n t')+ _ -> return ()+ where+ getNames ctxt = case lookupDefExact n ctxt of+ Just (CaseOp _ _ _ _ _ defs)+ -> let (top, def) = cases_compiletime defs in+ map fst (findCalls' True def top)+ _ -> []++ getPartial ist [] [] = Nothing+ getPartial ist bad [] = Just bad+ getPartial ist bad (n : ns) + = case lookupTotalExact n (tt_ctxt ist) of+ Just (Partial _) -> getPartial ist (n : bad) ns+ _ -> getPartial ist bad ns+ -- | Calculate the size change graph for this definition -- -- SCG for a function f consists of a list of:@@ -508,7 +554,7 @@ scgPat (lhs, rhs) = let lhs' = delazy lhs rhs' = delazy rhs (f, pargs) = unApply (dePat lhs') in- findCalls [] Toplevel (dePat rhs') (patvars lhs') + findCalls [] Toplevel (dePat rhs') (patvars lhs') (zip pargs [0..]) findCalls cases Delayed ap@(P _ n _) pvs args@@ -522,23 +568,25 @@ | (P _ n _, _) <- unApply ap, Just opts <- lookupCtxtExact n (idris_flags ist), AssertTotal `elem` opts = []- -- under a guarded call to "Delay LazyCodata", we are 'Delayed', so don't+ -- under a guarded call to "Delay Infinite", we are 'Delayed', so don't -- check under guarded constructors. | (P _ (UN del) _, [_,_,arg]) <- unApply ap, Guarded <- guarded,- del == txt "Delay" + del == txt "Delay" = findCalls cases Delayed arg pvs pargs | (P _ n _, args) <- unApply ap, Delayed <- guarded,- n == topfn -- Under a delayed recursive call to the top level function,- -- just check the arguments- = concatMap (\x -> findCalls cases Unguarded x pvs pargs) args- | (P _ n _, args) <- unApply ap,- Delayed <- guarded, isConName n (tt_ctxt ist)- = -- Still under a 'Delay' and constructor guarded, so check + = -- Still under a 'Delay' and constructor guarded, so check -- just the arguments to the constructor, remaining Delayed concatMap (\x -> findCalls cases guarded x pvs pargs) args+ | (P _ ifthenelse _, [_, _, t, e]) <- unApply ap,+ ifthenelse == sNS (sUN "ifThenElse") ["Bool", "Prelude"]+ -- Continue look inside if...then...else blocks+ -- TODO: Consider whether we should do this for user defined ifThenElse+ -- rather than just the one in the Prelude as a special case+ = findCalls cases guarded t pvs pargs +++ findCalls cases guarded e pvs pargs | (P _ n _, args) <- unApply ap, caseName n && n /= topfn, notPartial (lookupTotalExact n (tt_ctxt ist))@@ -550,8 +598,12 @@ if n `notElem` cases then findCallsCase (n : cases) guarded n args pvs pargs else []+ | (P _ n _, args) <- unApply ap,+ Delayed <- guarded+ -- Under a delayed recursive call just check the arguments+ = concatMap (\x -> findCalls cases Unguarded x pvs pargs) args | (P _ n _, args) <- unApply ap- -- Ordinary call, not under a delay. + -- Ordinary call, not under a delay. -- If n is a constructor, set 'args' as Guarded = let nguarded = case guarded of Unguarded -> Unguarded@@ -579,20 +631,20 @@ -- are okay for building the size change findCallsCase cases guarded n args pvs pargs = case lookupDefExact n (tt_ctxt ist) of- Just (CaseOp _ _ _ pats _ cd) -> + Just (CaseOp _ _ _ pats _ cd) -> concatMap (fccPat cases pvs pargs args guarded) (rights pats) Nothing -> [] - fccPat cases pvs pargs args g (lhs, rhs) + fccPat cases pvs pargs args g (lhs, rhs) = let lhs' = delazy lhs rhs' = delazy rhs- (f, pargs_case) = unApply (dePat lhs') + (f, pargs_case) = unApply (dePat lhs') -- pargs is a pair of a term, and the argument position that -- term appears in. If any of the arguments to the case block -- are also on the lhs, we also want those patterns to appear -- in the parg list so that we'll spot patterns which are -- smaller than then- newpargs = newPArg args pargs + newpargs = newPArg args pargs -- Now need to update the rhs of the case with the names in the -- outer definition: In rhs', wherever we see what's in pargs_case, -- replace it with the corresponding thing in pargs@@ -602,11 +654,11 @@ findCalls cases g newrhs pvs pargs' where doCaseSubs [] tm = tm- doCaseSubs ((x, x') : cs) tm + doCaseSubs ((x, x') : cs) tm = doCaseSubs (subIn x x' cs) (substTerm x x' tm)- + subIn x x' [] = []- subIn x x' ((l, r) : cs) + subIn x x' ((l, r) : cs) = (substTerm x x' l, substTerm x x' r) : subIn x x' cs addPArg (Just (t, i) : ts) (t' : ts') = (t', i) : addPArg ts ts'@@ -639,7 +691,7 @@ as == txt "assert_smaller" && arg == p = Just (i, Smaller) | smaller Nothing a (p, Nothing) = Just (i, Smaller)- | otherwise = checkSize a ps + | otherwise = checkSize a ps checkSize a [] = Nothing -- the smaller thing we find must be defined in the same group of mutally@@ -692,7 +744,7 @@ -- (Unchecked is okay as we'll spot problems here) let tot = map (checkMP ist n (getArity ist n)) ms logCoverage 4 $ "Generated " ++ show (length tot) ++ " paths"- logCoverage 5 $ "Paths for " ++ show n ++ " yield " ++ + logCoverage 5 $ "Paths for " ++ show n ++ " yield " ++ (showSep "\n" (map show (zip ms tot))) return (noPartial tot) [] -> do logCoverage 5 $ "No paths for " ++ show n@@ -706,8 +758,7 @@ mkMultiPaths :: IState -> MultiPath -> [SCGEntry] -> [MultiPath] mkMultiPaths ist path [] = [reverse path]-mkMultiPaths ist path cg- = concat (map extend cg)+mkMultiPaths ist path cg = concatMap extend cg where extend (nextf, args) | (nextf, args) `elem` path = [ reverse ((nextf, args) : path) ] | [Unchecked] <- lookupTotal nextf (tt_ctxt ist)@@ -826,5 +877,3 @@ mapM_ buildSCG (idris_totcheck ist) mapM_ checkDeclTotality (idris_totcheck ist) clear_totcheck--
src/Idris/DSL.hs view
@@ -1,3 +1,11 @@+{-|+Module : Idris.DSL+Description : Code to deal with DSL blocks.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+ {-# LANGUAGE PatternGuards #-} module Idris.DSL where@@ -16,7 +24,7 @@ debindApp syn t = debind (dsl_bind (dsl_info syn)) t dslify :: SyntaxInfo -> IState -> PTerm -> PTerm-dslify syn i = transform dslifyApp +dslify syn i = transform dslifyApp where dslifyApp (PApp fc (PRef _ _ f) [a]) | [d] <- lookupCtxt f (idris_dsls i)@@ -225,5 +233,3 @@ bindAll [] tm = tm bindAll ((n, fc, t) : bs) tm = PApp fc b [pexp t, pexp (PLam fc n NoFC Placeholder (bindAll bs tm))]--
src/Idris/DataOpts.hs view
@@ -1,9 +1,14 @@+{-|+Module : Idris.DataOpts+Description : Optimisations for Idris code i.e. Forcing, detagging and collapsing.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module Idris.DataOpts(applyOpts) where --- Forcing, detagging and collapsing- import Idris.AbsSyntax import Idris.AbsSyntaxTree import Idris.Core.TT@@ -87,7 +92,7 @@ applyOpts (Proj t i) = Proj <$> applyOpts t <*> pure i applyOpts t = return t --- Need to saturate arguments first to ensure that optimisation happens uniformly+-- | Need to saturate arguments first to ensure that optimisation happens uniformly applyDataOptRT :: Name -> Int -> Int -> Bool -> [Term] -> Term applyDataOptRT n tag arity uniq args | length args == arity = doOpts n args
src/Idris/DeepSeq.hs view
@@ -1,6 +1,16 @@+{-|+Module : Idris.DeepSeq+Description : Specify how to marshall Idris' IR.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} -module Idris.DeepSeq(module Idris.DeepSeq, module Idris.Core.DeepSeq) where+module Idris.DeepSeq(+ module Idris.DeepSeq+ , module Idris.Core.DeepSeq+ ) where import Idris.Core.DeepSeq import Idris.Docstrings@@ -308,6 +318,7 @@ rnf (IBCDeprecate n1 n2) = rnf n1 `seq` rnf n2 `seq` () rnf (IBCRecord x) = rnf x `seq` () rnf (IBCFragile n1 n2) = rnf n1 `seq` rnf n2 `seq` ()+ rnf (IBCConstraint n1 n2) = rnf n1 `seq` rnf n2 `seq` () instance NFData a => NFData (D.Block a) where
src/Idris/Delaborate.hs view
@@ -1,9 +1,17 @@+{-|+Module : Idris.Delaborate+Description : Convert core TT back into high level syntax, primarily for display purposes.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}-module Idris.Delaborate (annName, bugaddr, delab, delab', delabMV, delabSugared, delabTy, delabTy', fancifyAnnots, pprintDelab, pprintNoDelab, pprintDelabTy, pprintErr, resugar) where---- Convert core TT back into high level syntax, primarily for display--- purposes.+module Idris.Delaborate (+ annName, bugaddr, delab, delab', delabMV, delabSugared+ , delabTy, delabTy', fancifyAnnots, pprintDelab, pprintNoDelab+ , pprintDelabTy, pprintErr, resugar+ ) where import Util.Pretty @@ -253,12 +261,12 @@ pprintProv i e ExpectedType = text "Expected type" pprintProv i e InferredVal = text "Inferred value" pprintProv i e GivenVal = text "Given value"-pprintProv i e (SourceTerm tm) - = text "Type of " <> +pprintProv i e (SourceTerm tm)+ = text "Type of " <> annotate (AnnTerm (zip (map fst e) (repeat False)) tm) (pprintTerm' i (zip (map fst e) (repeat False)) (delabSugared i tm))-pprintProv i e (TooManyArgs tm) - = text "Is " <> +pprintProv i e (TooManyArgs tm)+ = text "Is " <> annotate (AnnTerm (zip (map fst e) (repeat False)) tm) (pprintTerm' i (zip (map fst e) (repeat False)) (delabSugared i tm)) <> text " applied to too many arguments?"@@ -277,14 +285,14 @@ (x, y) = addImplicitDiffs (delabSugared i x_ns) (delabSugared i y_ns) in text "Type mismatch between" <> indented (annTm x_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) sc- ++ zip nms (repeat False)) x)) + ++ zip nms (repeat False)) x)) <> case xprov of Nothing -> empty Just t -> text " (" <> pprintProv i sc t <> text ")" <$> text "and" <> indented (annTm y_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) sc- ++ zip nms (repeat False)) y)) + ++ zip nms (repeat False)) y)) <> case yprov of Nothing -> empty Just t -> text " (" <> pprintProv i sc t <> text ")"@@ -301,7 +309,7 @@ else empty pprintErr' i (CantConvert x_in y_in env) = let (x_ns, y_ns, nms) = renameMNs x_in y_in- (x, y) = addImplicitDiffs (delabSugared i (flagUnique x_ns)) + (x, y) = addImplicitDiffs (delabSugared i (flagUnique x_ns)) (delabSugared i (flagUnique y_ns)) in text "Type mismatch between" <> indented (annTm x_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) env)@@ -346,17 +354,17 @@ text "Can't verify injectivity of" <+> annTm p (pprintTerm i (delabSugared i p)) <+> text " when unifying" <+> annTm x (pprintTerm i (delabSugared i x)) <+> text "and" <+> annTm y (pprintTerm i (delabSugared i y))-pprintErr' i (CantResolve _ c e) +pprintErr' i (CantResolve _ c e) = text "Can't find implementation for" <+> pprintTerm i (delabSugared i c) <> case e of Msg "" -> empty _ -> line <> line <> text "Possible cause:" <> indented (pprintErr' i e)-pprintErr' i (InvalidTCArg n t) +pprintErr' i (InvalidTCArg n t) = annTm t (pprintTerm i (delabSugared i t)) <+> text " cannot be a parameter of " <> annName n <$>- text "(Implementation arguments must be injective)"+ text "(Implementation arguments must be type or data constructors)" pprintErr' i (CantResolveAlts as) = text "Can't disambiguate name:" <+> align (cat (punctuate (comma <> space) (map (fmap (fancifyAnnots i True) . annName) as))) pprintErr' i (NoValidAlts as) = text "Can't disambiguate since no name has a suitable type:" <+>@@ -367,13 +375,13 @@ text "Can't match on a function: type is" <+> annTm ty (pprintTerm i (delabSugared i ty)) pprintErr' i (CantMatch t) = text "Can't match on" <+> annTm t (pprintTerm i (delabSugared i t))-pprintErr' i (IncompleteTerm t) +pprintErr' i (IncompleteTerm t) = let missing = getMissing [] [] t in case missing of [] -> text "Incomplete term" <+> annTm t (pprintTerm i (delabSugared i t))- _ -> align (cat (punctuate (comma <> space) + _ -> align (cat (punctuate (comma <> space) (map pprintIncomplete (nub $ getMissing [] [] t))))- where + where pprintIncomplete (tm, arg) | expname arg = text "Can't infer explicit argument to" <+>@@ -396,7 +404,7 @@ getMissing hs env (Bind n (Guess _ _) sc) = getMissing (n : hs) (n : env) sc getMissing hs env (Bind n (Let t v) sc)- = getMissing hs env t ++ + = getMissing hs env t ++ getMissing hs env v ++ getMissing hs (n : env) sc getMissing hs env (Bind n b sc)@@ -408,7 +416,7 @@ getMissingArgs n [] = [] getMissingArgs n (V i : as) | env!!i `elem` hs = (n, env!!i) : getMissingArgs n as- getMissingArgs n (P _ a _ : as) + getMissingArgs n (P _ a _ : as) | a `elem` hs = (n, a) : getMissingArgs n as getMissingArgs n (a : as) = getMissing hs env a ++ getMissingArgs n as getMissing hs env (App _ f a)@@ -444,14 +452,14 @@ pprintErr' i (AlreadyDefined n) = annName n<+> text "is already defined" pprintErr' i (ProofSearchFail e) = pprintErr' i e-pprintErr' i (NoRewriting tm) = text "rewrite did not change type" <+> annTm tm (pprintTerm i (delabSugared i tm))+pprintErr' i (NoRewriting l r tm) = text "rewriting" <+> annTm l (pprintTerm i (delabSugared i l)) <+> text "to" <+> annTm r (pprintTerm i (delabSugared i r)) <+> text "did not change type" <+> annTm tm (pprintTerm i (delabSugared i tm)) pprintErr' i (At f e) = annotate (AnnFC f) (text (show f)) <> colon <> pprintErr' i e pprintErr' i (Elaborating s n ty e) = text "When checking" <+> text s <>- annName' n (showqual i n) <> + annName' n (showqual i n) <> pprintTy ty <$> pprintErr' i e where pprintTy Nothing = colon- pprintTy (Just ty) = text " with expected type" <> + pprintTy (Just ty) = text " with expected type" <> indented (annTm ty (pprintTerm i (delabSugared i ty))) <> line pprintErr' i (ElaboratingArg f x _ e)@@ -540,12 +548,12 @@ where getRenames :: [(Name, Name)] -> [Name] -> State Int [(Name, Name)] getRenames acc [] = return acc- getRenames acc (n@(MN i x) : xs) | rpt x xs + getRenames acc (n@(MN i x) : xs) | rpt x xs = do idx <- get put (idx + 1) let x' = sUN (str x ++ show idx) getRenames ((n, x') : acc) xs- getRenames acc (n@(UN x) : xs) | rpt x xs + getRenames acc (n@(UN x) : xs) | rpt x xs = do idx <- get put (idx + 1) let x' = sUN (str x ++ show idx)@@ -697,4 +705,3 @@ showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n showbasic (SN s) = show s showbasic n = show n-
src/Idris/Directives.hs view
@@ -1,4 +1,10 @@-+{-|+Module : Idris.Directives+Description : Act upon Idris directives.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Idris.Directives(directiveAction) where import Idris.AbsSyntax@@ -42,11 +48,24 @@ mapM_ (\n -> do setAccessibility n Frozen addIBC (IBCAccess n Frozen)) ns+directiveAction (DThaw n') = do+ ns <- allNamespaces n'+ mapM_ (\n -> do+ ctxt <- getContext+ case lookupDefAccExact n False ctxt of+ Just (_, Frozen) -> do setAccessibility n Public+ addIBC (IBCAccess n Public)+ _ -> throwError (Msg (show n ++ " is not frozen"))) ns directiveAction (DInjective n') = do ns <- allNamespaces n' mapM_ (\n -> do setInjectivity n True addIBC (IBCInjective n True)) ns+directiveAction (DSetTotal n') = do+ ns <- allNamespaces n'+ mapM_ (\n -> do+ setTotality n (Total [])+ addIBC (IBCTotal n (Total []))) ns directiveAction (DAccess acc) = do updateIState (\i -> i { default_access = acc }) @@ -58,7 +77,7 @@ added <- addDyLib libs case added of Left lib -> addIBC (IBCDyLib (lib_name lib))- Right msg -> fail $ msg+ Right msg -> fail msg directiveAction (DNameHint ty tyFC ns) = do ty' <- disambiguate ty
src/Idris/Docs.hs view
@@ -1,6 +1,17 @@+{-|+Module : Idris.Docs+Description : Data structures and utilities to work with Idris Documentation.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE DeriveFunctor, PatternGuards, MultiWayIf #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}-module Idris.Docs (pprintDocs, getDocs, pprintConstDocs, pprintTypeDoc, FunDoc, FunDoc'(..), Docs, Docs'(..)) where+module Idris.Docs (+ pprintDocs+ , getDocs, pprintConstDocs, pprintTypeDoc+ , FunDoc, FunDoc'(..), Docs, Docs'(..)+ ) where import Idris.AbsSyntax import Idris.AbsSyntaxTree@@ -149,7 +160,7 @@ vsep (map dumpInstance superclasses))) where params' = zip pNames (repeat False)- + (normalInstances, namedInstances) = partition (\(n, _, _) -> not $ isJust n) instances @@ -318,7 +329,7 @@ namedInst (NS n ns) = fmap (flip NS ns) (namedInst n) namedInst n@(UN _) = Just n namedInst _ = Nothing- + getDInst (PInstance _ _ _ _ _ _ _ _ _ _ _ _ t _ _) = Just t getDInst _ = Nothing @@ -380,4 +391,4 @@ pprintTypeDoc :: IState -> Doc OutputAnnotation pprintTypeDoc ist = prettyIst ist (PType emptyFC) <+> colon <+> type1Doc <+>- nest 4 (line <> text typeDescription) + nest 4 (line <> text typeDescription)
src/Idris/Docstrings.hs view
@@ -1,10 +1,17 @@+{-|+Module : Idris.Docstrings+Description : Wrapper around Markdown library.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+ {-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}---- | Wrapper around Markdown library module Idris.Docstrings (- Docstring(..), Block(..), Inline(..), parseDocstring, renderDocstring, emptyDocstring, nullDocstring, noDocs,- overview, containsText, renderHtml, annotCode, DocTerm(..), renderDocTerm, checkDocstring+ Docstring(..), Block(..), Inline(..), parseDocstring, renderDocstring+ , emptyDocstring, nullDocstring, noDocs, overview, containsText+ , renderHtml, annotCode, DocTerm(..), renderDocTerm, checkDocstring ) where import qualified Cheapskate as C
src/Idris/Elab/AsPat.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.AsPat+Description : Code to elaborate pattern variables.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Idris.Elab.AsPat(desugarAs) where import Idris.Core.TT@@ -30,7 +37,7 @@ return (PApp fc t as') -- only valid on args -- only for 'ExactlyOne' since it means the alternatives will have the -- same form, so we can assume we only need to extract from the first one-collectAs tm@(PAlternative ns (ExactlyOne d) (a : as)) +collectAs tm@(PAlternative ns (ExactlyOne d) (a : as)) = do a' <- collectAs a pats <- get as' <- mapM collectAs as -- just to drop the '@'
src/Idris/Elab/Class.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.Class+Description : Code to elaborate interfaces.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fwarn-missing-signatures #-} module Idris.Elab.Class(elabClass) where@@ -54,14 +61,20 @@ data MArgTy = IA Name | EA Name | CA deriving Show -elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->- FC -> [(Name, PTerm)] ->- Name -> FC -> [(Name, FC, PTerm)] -> [(Name, Docstring (Either Err PTerm))] ->- [(Name, FC)] {- ^ determining params -} ->- [PDecl] {- ^ class body -} ->- Maybe (Name, FC) {- ^ instance ctor name and location -} ->- Docstring (Either Err PTerm) {- ^ instance ctor docs -} ->- Idris ()+elabClass :: ElabInfo+ -> SyntaxInfo+ -> Docstring (Either Err PTerm)+ -> FC+ -> [(Name, PTerm)]+ -> Name+ -> FC+ -> [(Name, FC, PTerm)]+ -> [(Name, Docstring (Either Err PTerm))]+ -> [(Name, FC)] -- ^ determining params+ -> [PDecl] -- ^ class body+ -> Maybe (Name, FC) -- ^ instance ctor name and location+ -> Docstring (Either Err PTerm) -- ^ instance ctor docs+ -> Idris () elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd = do let cn = fromMaybe (SN (InstanceCtorN tn)) (fst <$> mcn) let tty = pibind (map (\(n, _, ty) -> (n, ty)) ps) (PType fc)@@ -79,7 +92,7 @@ mapM_ checkDefaultSuperclassInstance idecls let mnames = map getMName mdecls ist <- getIState- let constraintNames = nub $ + let constraintNames = nub $ concatMap (namesIn [] ist) (map snd constraints) mapM_ (checkConstraintName (map (\(x, _, _) -> x) ps)) constraintNames@@ -125,7 +138,7 @@ (map fst (filter (\(_, (inj, _, _, _, _)) -> inj) imethods)) -- add the default definitions- mapM_ (rec_elabDecl info EAll info) (concat (map (snd.snd) defs))+ mapM_ (rec_elabDecl info EAll info) (concatMap (snd.snd) defs) addIBC (IBCClass tn) sendHighlighting $@@ -151,20 +164,20 @@ checkDefaultSuperclassInstance :: PDecl -> Idris () checkDefaultSuperclassInstance (PInstance _ _ _ fc cs _ _ _ n _ ps _ _ _ _) = do when (not $ null cs) . tclift- $ tfail (At fc (Msg $ "Default superclass instances can't have constraints."))+ $ tfail (At fc (Msg "Default superclass instances can't have constraints.")) i <- getIState let t = PApp fc (PRef fc [] n) (map pexp ps) let isConstrained = any (== t) (map snd constraints) when (not isConstrained) . tclift- $ tfail (At fc (Msg $ "Default instances must be for a superclass constraint on the containing class."))+ $ tfail (At fc (Msg "Default instances must be for a superclass constraint on the containing class.")) return () checkConstraintName :: [Name] -> Name -> Idris () checkConstraintName bound cname- | cname `notElem` bound - = tclift $ tfail (At fc (Msg $ "Name " ++ show cname ++ + | cname `notElem` bound+ = tclift $ tfail (At fc (Msg $ "Name " ++ show cname ++ " is not bound in interface " ++ show tn- ++ " " ++ showSep " " (map show bound))) + ++ " " ++ showSep " " (map show bound))) | otherwise = return () impbind :: [(Name, PTerm)] -> PTerm -> PTerm@@ -185,7 +198,7 @@ (n, (False, nfc, doc, o, (toExp (map (\(pn, _, _) -> pn) ps) (\ l s p -> Imp l s p Nothing True) t'))), (n, (nfc, syn, o, t) ) )- tdecl allmeths (PData doc _ syn _ _ (PLaterdecl n nfc t)) + tdecl allmeths (PData doc _ syn _ _ (PLaterdecl n nfc t)) = do let o = [] t' <- implicit' info syn (map (\(n, _, _) -> n) ps ++ allmeths) n t logElab 2 $ "Data method " ++ show n ++ " : " ++ showTmImpls t'@@ -193,7 +206,7 @@ (n, (True, nfc, doc, o, (toExp (map (\(pn, _, _) -> pn) ps) (\ l s p -> Imp l s p Nothing True) t'))), (n, (nfc, syn, o, t) ) )- tdecl allmeths (PData doc _ syn _ _ _) + tdecl allmeths (PData doc _ syn _ _ _) = ierror $ At fc (Msg "Data definitions not allowed in a class declaration") tdecl _ _ = ierror $ At fc (Msg "Not allowed in a class declaration") @@ -224,8 +237,7 @@ -- Generate a function for chasing a dictionary constraint cfun :: Name -> PTerm -> SyntaxInfo -> [a] -> (Name, PTerm) -> Idris [PDecl' PTerm] cfun cn c syn all (cnm, con)- = do let cfn = sUN ('@':'@':show cn ++ "#" ++ show con)- -- SN (ParentN cn (show con))+ = do let cfn = SN (ParentN cn (txt (show con))) let mnames = take (length all) $ map (\x -> sMN x "meth") [0..] let capp = PApp fc (PRef fc [] cn) (map (pexp . PRef fc []) mnames) let lhs = PApp fc (PRef fc [] cfn) [pconst capp]@@ -292,19 +304,19 @@ -- Also ensure the dictionary is used for lookup of any methods that -- are used in the type insertConstraint :: PTerm -> [Name] -> PTerm -> PTerm- insertConstraint c all sc - = let dictN = sMN 0 "__class" in + insertConstraint c all sc+ = let dictN = sMN 0 "__class" in PPi (constraint { pstatic = Static }) dictN NoFC c (constrainMeths (map basename all) dictN sc)- where + where -- After we insert the constraint into the lookup, we need to -- ensure that the same dictionary is used to resolve lookups -- to the other methods in the class constrainMeths :: [Name] -> Name -> PTerm -> PTerm constrainMeths allM dictN tm = transform (addC allM dictN) tm- + addC allM dictN m@(PRef fc hls n) | n `elem` allM = PApp NoFC m [pconst (PRef NoFC hls dictN)] | otherwise = m
src/Idris/Elab/Clause.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.Clause+Description : Code to elaborate clauses.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module Idris.Elab.Clause where @@ -341,6 +348,13 @@ -- | Find 'static' applications in a term and partially evaluate them. -- Return any new transformation rules elabPE :: ElabInfo -> FC -> Name -> Term -> Idris [(Term, Term)]+-- Don't go deeper than 5 nested partially evaluated definitions in one go+-- (make this configurable? It's a good limit for most cases, certainly for+-- interfaces and polymorphic definitions, but maybe not for DSLs and+-- interpreters in complicated cases.+-- Possibly only worry about the limit if we've specialised the same function+-- a number of times in one go.)+elabPE info fc caller r | pe_depth info > 5 = return [] elabPE info fc caller r = do ist <- getIState let sa = filter (\ap -> fst ap /= caller) $ getSpecApps ist [] r@@ -392,7 +406,7 @@ logElab 3 $ "New name: " ++ show newnm logElab 3 $ "PE definition type : " ++ (show specTy) ++ "\n" ++ show opts- logElab 3 $ "PE definition " ++ show newnm ++ ":\n" +++ logElab 5 $ "PE definition " ++ show newnm ++ ":\n" ++ showSep "\n" (map (\ (lhs, rhs) -> (showTmImpls lhs ++ " = " ++@@ -407,7 +421,8 @@ PClause fc newnm lhs' [] rhs []) (pe_clauses specdecl) trans <- elabTransform info fc False rhs lhs- elabClauses info fc (PEGenerated:opts) newnm def+ elabClauses (info {pe_depth = pe_depth info + 1}) fc+ (PEGenerated:opts) newnm def return [trans] else return []) -- if it doesn't work, just don't specialise. Could happen for lots@@ -482,7 +497,7 @@ i <- getIState let lhs = addImplPat i lhs_in -- if the LHS type checks, it is possible- case elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState+ case elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState (erun fc (buildTC i info ELHS [] fname (allNamesIn lhs_in) (infTerm lhs))) of@@ -492,7 +507,7 @@ sendHighlighting highlights updateIState $ \i -> i { idris_name = newGName } let lhs_tm = orderPats (getInferTerm lhs')- case recheck ctxt' [] (forget lhs_tm) lhs_tm of+ case recheck (constraintNS info) ctxt' [] (forget lhs_tm) lhs_tm of OK _ -> return True err -> return False -- if it's a recoverable error, the case may become possible@@ -512,7 +527,7 @@ else findUnique ctxt ((n, b) : env) sc findUnique _ _ _ = [] --- Return the elaborated LHS/RHS, and the original LHS with implicits added+-- | Return the elaborated LHS/RHS, and the original LHS with implicits added elabClause :: ElabInfo -> FnOpts -> (Int, PClause) -> Idris (Either Term (Term, Term), PTerm) elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])@@ -524,6 +539,8 @@ True -> tclift $ tfail (At fc (Msg $ show lhs_in ++ " is a valid case")) False -> do ptm <- mkPatTm lhs_in+ logElab 5 $ "Elaborated impossible case " ++ showTmImpls lhs +++ "\n" ++ show ptm return (Left ptm, lhs) elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as whereblock) = do let tcgen = Dictionary `elem` opts@@ -538,8 +555,8 @@ -- Check if we have "with" patterns outside of "with" block when (isOutsideWith lhs_in && (not $ null withs)) $- ierror $ (At fc (Elaborating "left hand side of " fname Nothing- (Msg "unexpected patterns outside of \"with\" block")))+ ierror (At fc (Elaborating "left hand side of " fname Nothing+ (Msg "unexpected patterns outside of \"with\" block"))) -- get the parameters first, to pass through to any where block let fn_ty = case lookupTy fname ctxt of@@ -554,7 +571,7 @@ let lhs = mkLHSapp $ stripLinear i $ stripUnmatchable i $ propagateParams i params norm_ty (allNamesIn lhs_in) (addImplPat i lhs_in)- + -- let lhs = mkLHSapp $ -- propagateParams i params fn_ty (addImplPat i lhs_in) logElab 10 (show (params, fn_ty) ++ " " ++ showTmImpls (addImplPat i lhs_in))@@ -563,7 +580,7 @@ "\n" ++ show (fn_ty, fn_is)) ((ElabResult lhs' dlhs [] ctxt' newDecls highlights newGName, probs, inj), _) <-- tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState+ tclift $ elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState (do res <- errAt "left hand side of " fname Nothing (erun fc (buildTC i info ELHS opts fname (allNamesIn lhs_in)@@ -591,7 +608,7 @@ ctxt <- getContext (clhs_c, clhsty) <- if not inf then recheckC_borrowing False (PEGenerated `notElem` opts)- [] fc id [] lhs_tm+ [] (constraintNS info) fc id [] lhs_tm else return (lhs_tm, lhs_ty) let clhs = Idris.Core.Evaluate.simplify ctxt [] clhs_c let borrowed = borrowedNames [] clhs@@ -649,7 +666,7 @@ ctxt <- getContext -- new context with where block added logElab 5 "STARTING CHECK" ((rhs', defer, holes, is, probs, ctxt', newDecls, highlights, newGName), _) <-- tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patRHS") clhsty initEState+ tclift $ elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patRHS") clhsty initEState (do pbinds ist lhs_tm -- proof search can use explicitly written names mapM_ addPSname (allNamesIn lhs_in)@@ -680,7 +697,7 @@ show (map (\ (n, (_,_,t,_)) -> (n, t)) defer) -- If there's holes, set the metavariables as undefinable- def' <- checkDef fc (\n -> Elaborating "deferred type of " n Nothing) (null holes) defer+ def' <- checkDef info fc (\n -> Elaborating "deferred type of " n Nothing) (null holes) defer let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False, null holes))) def' addDeferred def'' @@ -696,7 +713,7 @@ mapM_ (elabCaseBlock winfo opts) is ctxt <- getContext- logElab 5 $ "Rechecking"+ logElab 5 "Rechecking" logElab 6 $ " ==> " ++ show (forget rhs') (crhs, crhsty) -- if there's holes && deferred things, it's okay@@ -704,9 +721,9 @@ -- allow the deferred things to be definable -- (this is just to allow users to inspect intermediate -- things)- <- if (null holes || null def') && not inf + <- if (null holes || null def') && not inf then recheckC_borrowing True (PEGenerated `notElem` opts)- borrowed fc id [] rhs'+ borrowed (constraintNS info) fc id [] rhs' else return (rhs', clhsty) logElab 6 $ " ==> " ++ showEnvDbg [] crhsty ++ " against " ++ showEnvDbg [] clhsty@@ -718,9 +735,11 @@ ctxt <- getContext let constv = next_tvar ctxt+ tit <- typeInType case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of- OK (_, cs) -> when (PEGenerated `notElem` opts) $ do+ OK (_, cs) -> when (PEGenerated `notElem` opts && not tit) $ do addConstraints fc cs+ mapM_ (\c -> addIBC (IBCConstraint fc c)) (snd cs) logElab 6 $ "CONSTRAINTS ADDED: " ++ show cs ++ "\n" ++ show (clhsty, crhsty) return () Error e -> ierror (At fc (CantUnify False (clhsty, Nothing) (crhsty, Nothing) e [] 0))@@ -741,7 +760,7 @@ addIBC (IBCErrRev (crhs, clhs)) addErrRev (crhs, clhs) pop_estack- return $ (Right (clhs, crhs), lhs)+ return (Right (clhs, crhs), lhs) where pinfo :: ElabInfo -> [(Name, PTerm)] -> [Name] -> Int -> ElabInfo pinfo info ns ds i@@ -776,12 +795,9 @@ mkLHSapp t = t decorate (NS x ns)- = NS (SN (WhereN cnum fname x)) ns -- ++ [show cnum])--- = NS (UN ('#':show x)) (ns ++ [show cnum, show fname])+ = NS (SN (WhereN cnum fname x)) ns decorate x = SN (WhereN cnum fname x)--- = NS (SN (WhereN cnum fname x)) [show cnum]--- = NS (UN ('#':show x)) [show cnum, show fname] sepBlocks bs = sepBlocks' [] bs where sepBlocks' ns (d@(PTy _ _ _ _ _ n _ t) : bs)@@ -818,7 +834,7 @@ (addImplPat i lhs_in) logElab 2 ("LHS: " ++ show lhs) (ElabResult lhs' dlhs [] ctxt' newDecls highlights newGName, _) <-- tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState+ tclift $ elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState (errAt "left hand side of with in " fname Nothing (erun fc (buildTC i info ELHS opts fname (allNamesIn lhs_in)@@ -834,14 +850,14 @@ let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty)) let static_names = getStaticNames i lhs_tm logElab 5 (show lhs_tm ++ "\n" ++ show static_names)- (clhs, clhsty) <- recheckC fc id [] lhs_tm+ (clhs, clhsty) <- recheckC (constraintNS info) fc id [] lhs_tm logElab 5 ("Checked " ++ show clhs) let bargs = getPBtys (explicitNames (normalise ctxt [] lhs_tm)) let wval = rhs_trans info $ addImplBound i (map fst bargs) wval_in logElab 5 ("Checking " ++ showTmImpls wval) -- Elaborate wval in this context ((wval', defer, is, ctxt', newDecls, highlights, newGName), _) <-- tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "withRHS")+ tclift $ elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) (sMN 0 "withRHS") (bindTyArgs PVTy bargs infP) initEState (do pbinds i lhs_tm -- proof search can use explicitly written names@@ -858,14 +874,14 @@ sendHighlighting highlights updateIState $ \i -> i { idris_name = newGName } - def' <- checkDef fc iderr True defer+ def' <- checkDef info fc iderr True defer let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False, True))) def' addDeferred def'' mapM_ (elabCaseBlock info opts) is logElab 5 ("Checked wval " ++ show wval') ctxt <- getContext- (cwval, cwvalty) <- recheckC fc id [] (getInferTerm wval')+ (cwval, cwvalty) <- recheckC (constraintNS info) fc id [] (getInferTerm wval') let cwvaltyN = explicitNames (normalise ctxt [] cwvalty) let cwvalN = explicitNames (normalise ctxt [] cwval) logElab 3 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty)@@ -887,7 +903,7 @@ Just (n, nfc) -> Just (uniqueName n (map fst bargs)) -- Highlight explicit proofs- sendHighlighting $ [(fc, AnnBoundName n False) | (n, fc) <- maybeToList pn_in]+ sendHighlighting [(fc, AnnBoundName n False) | (n, fc) <- maybeToList pn_in] logElab 10 ("With type " ++ show (getRetTy cwvaltyN) ++ " depends on " ++ show pdeps ++ " from " ++ show pvars)@@ -900,7 +916,7 @@ let wargname = sMN windex "warg" logElab 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)- let wtype = bindTyArgs (flip (Pi Nothing) (TType (UVar 0))) (bargs_pre +++ let wtype = bindTyArgs (flip (Pi Nothing) (TType (UVar [] 0))) (bargs_pre ++ (wargname, wargtype) : map (abstract wargname wargval wargtype) bargs_post ++ case mpn of@@ -923,7 +939,7 @@ addIBC (IBCImp wname) addIBC (IBCStatic wname) - def' <- checkDef fc iderr True [(wname, (-1, Nothing, wtype, []))]+ def' <- checkDef info fc iderr True [(wname, (-1, Nothing, wtype, []))] let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False, True))) def' addDeferred def'' @@ -956,7 +972,7 @@ ctxt <- getContext -- New context with block added i <- getIState ((rhs', defer, is, ctxt', newDecls, highlights, newGName), _) <-- tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "wpatRHS") clhsty initEState+ tclift $ elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) (sMN 0 "wpatRHS") clhsty initEState (do pbinds i lhs_tm setNextName (ElabResult _ d is ctxt' newDecls highlights newGName) <-@@ -969,13 +985,13 @@ sendHighlighting highlights updateIState $ \i -> i { idris_name = newGName } - def' <- checkDef fc iderr True defer+ def' <- checkDef info fc iderr True defer let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False, True))) def' addDeferred def'' mapM_ (elabCaseBlock info opts) is logElab 5 ("Checked RHS " ++ show rhs')- (crhs, crhsty) <- recheckC fc id [] rhs'- return $ (Right (clhs, crhs), lhs)+ (crhs, crhsty) <- recheckC (constraintNS info) fc id [] rhs'+ return (Right (clhs, crhs), lhs) where getImps (Bind n (Pi _ _ _) t) = pexp Placeholder : getImps t getImps _ = []@@ -983,7 +999,7 @@ mkAuxC pn wname lhs ns ns' (PClauses fc o n cs) = do cs' <- mapM (mkAux pn wname lhs ns ns') cs return $ PClauses fc o wname cs'- mkAuxC pn wname lhs ns ns' d = return $ d+ mkAuxC pn wname lhs ns ns' d = return d mkAux pn wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres) = do i <- getIState@@ -1033,7 +1049,7 @@ | otherwise = Placeholder updateWithTerm :: IState -> Maybe Name -> Name -> PTerm -> [Name] -> [Name] -> PTerm -> PTerm- updateWithTerm ist pn wname toplhs ns_in ns_in' tm + updateWithTerm ist pn wname toplhs ns_in ns_in' tm = mapPT updateApp tm where arity (PApp _ _ as) = length as@@ -1049,13 +1065,13 @@ getApp [] = Nothing currentFn _ tm = tm - updateApp wtm@(PWithApp fcw tm_in warg) = + updateApp wtm@(PWithApp fcw tm_in warg) = let tm = currentFn fname tm_in in case matchClause ist toplhs tm of Left _ -> PElabError (Msg (show fc ++ ":with application does not match top level "))- Right mvars -> + Right mvars -> let ns = map (keepMvar (map fst mvars) fcw) ns_in- ns' = map (keepMvar (map fst mvars) fcw) ns_in' + ns' = map (keepMvar (map fst mvars) fcw) ns_in' wty = lookupTyExact wname (tt_ctxt ist) res = substMatches mvars $ PApp fcw (PRef fcw [] wname)@@ -1097,18 +1113,18 @@ abstract wn wv wty (n, argty) = (n, substTerm wv (P Bound wn wty) argty) --- Apply a transformation to all RHSes and nested RHSs+-- | Apply a transformation to all RHSes and nested RHSs mapRHS :: (PTerm -> PTerm) -> PClause -> PClause-mapRHS f (PClause fc n lhs args rhs ws) +mapRHS f (PClause fc n lhs args rhs ws) = PClause fc n lhs args (f rhs) (map (mapRHSdecl f) ws) mapRHS f (PWith fc n lhs args warg prf ws) = PWith fc n lhs args (f warg) prf (map (mapRHSdecl f) ws)-mapRHS f (PClauseR fc args rhs ws) +mapRHS f (PClauseR fc args rhs ws) = PClauseR fc args (f rhs) (map (mapRHSdecl f) ws) mapRHS f (PWithR fc args warg prf ws) = PWithR fc args (f warg) prf (map (mapRHSdecl f) ws) mapRHSdecl :: (PTerm -> PTerm) -> PDecl -> PDecl-mapRHSdecl f (PClauses fc opt n cs) +mapRHSdecl f (PClauses fc opt n cs) = PClauses fc opt n (map (mapRHS f) cs) mapRHSdecl f t = t
src/Idris/Elab/Data.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.Data+Description : Code to elaborate data structures.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module Idris.Elab.Data(elabData) where @@ -89,10 +96,15 @@ rt -> tclift $ tfail (At fc (Elaborating "type constructor " n Nothing (Msg "Not a valid type constructor"))) cons <- mapM (elabCon cnameinfo syn n codata (getRetTy cty) ckind) dcons ttag <- getName- i <- getIState let as = map (const (Left (Msg ""))) (getArgTys cty)- let params = findParams n (map snd cons)++ ctxt <- getContext+ let params = findParams n (normalise ctxt [] cty) (map snd cons)+ logElab 2 $ "Parameters : " ++ show params+ addParamConstraints fc params cty cons++ i <- getIState -- TI contains information about mutually declared types - this will -- be updated when the mutual block is complete putIState (i { idris_datatypes =@@ -136,7 +148,6 @@ (nfc, AnnName n Nothing Nothing Nothing)) dcons where- checkDefinedAs fc n t i = let defined = tclift $ tfail (At fc (AlreadyDefined n)) ctxt = tt_ctxt i in@@ -179,7 +190,6 @@ ctxt <- getContext let cty' = normalise ctxt [] cty checkUniqueKind ckind expkind- addDataConstraint ckind dkind -- Check that the constructor type is, in fact, a part of the family being defined tyIs n cty'@@ -206,7 +216,7 @@ tyIs con (Bind n b sc) = tyIs con (substV (P Bound n Erased) sc) tyIs con t | (P Bound n' _, _) <- unApply t = if n' /= tn then- tclift $ tfail (At fc (Elaborating "constructor " con Nothing + tclift $ tfail (At fc (Elaborating "constructor " con Nothing (Msg ("Type level variable " ++ show n' ++ " is not " ++ show tn)))) else return () tyIs con t | (P _ n' _, _) <- unApply t@@ -249,13 +259,40 @@ = tclift $ tfail (At fc (UniqueKindError AllTypes n)) checkUniqueKind _ _ = return () - -- Constructor's kind must be <= expected kind- addDataConstraint (TType con) (TType exp)- = do ctxt <- getContext- let v = next_tvar ctxt- addConstraints fc (v, [ULT con exp])- addDataConstraint _ _ = return ()+addParamConstraints :: FC -> [Int] -> Type -> [(Name, Type)] -> Idris ()+addParamConstraints fc ps cty cons+ = case getRetTy cty of+ TType cvar -> mapM_ (addConConstraint ps cvar)+ (map getParamNames cons)+ _ -> return ()+ where+ getParamNames (n, ty) = (ty, getPs ty) + getPs (Bind n (Pi _ _ _) sc)+ = getPs (substV (P Ref n Erased) sc)+ getPs t | (f, args) <- unApply t+ = paramArgs 0 args++ paramArgs i (P _ n _ : args) | i `elem` ps = n : paramArgs (i + 1) args+ paramArgs i (_ : args) = paramArgs (i + 1) args+ paramArgs i [] = []++ addConConstraint ps cvar (ty, pnames) = constraintTy ty+ where+ constraintTy (Bind n (Pi _ ty _) sc)+ = case getRetTy ty of+ TType avar -> do tit <- typeInType+ when (not tit) $ do+ ctxt <- getContext+ let tv = next_tvar ctxt+ let con = if n `elem` pnames+ then ULE avar cvar+ else ULT avar cvar+ addConstraints fc (tv, [con])+ addIBC (IBCConstraint fc con) + _ -> return ()+ constraintTy t = return ()+ type EliminatorState = StateT (Map.Map String Int) Idris -- -- Issue #1616 in the issue tracker.@@ -268,7 +305,7 @@ [(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"+ 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 (splittedTy@(pms, idxs)) = splitPms cnstrs@@ -284,30 +321,30 @@ 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 NoFC eliminatorTy+ 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 emptyFC [TotalFn] elimDeclName eliminatorClauses+ 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 emptyFC elimDeclName -- Remove meta-variable for type+ [] -> 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)"+ elimFC = fileFC $ "(casefun " ++ show n ++ ")" elimDeclName :: Name- elimDeclName = if ind then SN . ElimN $ n else SN . CaseN (FC' emptyFC) $ n+ elimDeclName = if ind then SN . ElimN $ n else SN . CaseN (FC' elimFC) $ n applyNS :: Name -> [String] -> Name applyNS n [] = n@@ -381,7 +418,7 @@ piConstr :: [(Name, Plicity, PTerm)] -> PTerm -> PTerm piConstr [] ty = ty- piConstr ((n, pl, tyb):tyr) ty = PPi pl n NoFC tyb (piConstr tyr 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
src/Idris/Elab/Instance.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.Instance+Description : Code to elaborate instances.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module Idris.Elab.Instance(elabInstance) where @@ -50,21 +57,24 @@ import Util.Pretty(pretty, text) -elabInstance :: ElabInfo -> SyntaxInfo ->- Docstring (Either Err PTerm) ->- [(Name, Docstring (Either Err PTerm))] ->- ElabWhat -> -- phase- FC -> [(Name, PTerm)] -> -- constraints- [Name] -> -- parent dictionary names (optionally)- Accessibility ->- FnOpts ->- Name -> -- the class- FC -> -- precise location of class name- [PTerm] -> -- class parameters (i.e. instance)- [(Name, PTerm)] -> -- Extra arguments in scope (e.g. instance in where block)- PTerm -> -- full instance type- Maybe Name -> -- explicit name- [PDecl] -> Idris ()+elabInstance :: ElabInfo+ -> SyntaxInfo+ -> Docstring (Either Err PTerm)+ -> [(Name, Docstring (Either Err PTerm))]+ -> ElabWhat -- ^ phase+ -> FC+ -> [(Name, PTerm)] -- ^ constraints+ -> [Name] -- ^ parent dictionary names (optionally)+ -> Accessibility+ -> FnOpts+ -> Name -- ^ the class+ -> FC -- ^ precise location of class name+ -> [PTerm] -- ^ class parameters (i.e. instance)+ -> [(Name, PTerm)] -- ^ Extra arguments in scope (e.g. instance in where block)+ -> PTerm -- ^ full instance type+ -> Maybe Name -- ^ explicit name+ -> [PDecl]+ -> Idris () elabInstance info syn doc argDocs what fc cs parents acc opts n nfc ps pextra t expn ds = do ist <- getIState (n, ci) <- case lookupCtxtName n (idris_classes ist) of@@ -81,7 +91,7 @@ let emptyclass = null (class_methods ci) when (what /= EDefns) $ do- nty <- elabType' True info syn doc argDocs fc totopts iname NoFC + nty <- elabType' True info syn doc argDocs fc totopts iname NoFC (piBindp expl_param pextra t) -- if the instance type matches any of the instances we have already, -- and it's not a named instance, then it's overlapping, so report an error@@ -111,7 +121,7 @@ let superclassInstances = map (substInstance ips pnames) (class_default_superclasses ci) undefinedSuperclassInstances <- filterM (fmap not . isOverlapping ist) superclassInstances mapM_ (rec_elabDecl info EAll info) undefinedSuperclassInstances- + ist <- getIState -- Bring variables in instance head into scope when building the -- dictionary@@ -121,11 +131,11 @@ Just ty -> (map (\n -> (n, getTypeIn ist n ty)) headVars, ty) _ -> (zip headVars (repeat Placeholder), Erased) logElab 3 $ "Head var types " ++ show headVarTypes ++ " from " ++ show ty- + let all_meths = map (nsroot . fst) (class_methods ci) let mtys = map (\ (n, (inj, op, t)) -> let t_in = substMatchesShadow ips pnames t- mnamemap = + mnamemap = map (\n -> (n, PApp fc (PRef fc [] (decorate ns iname n)) (map (toImp fc) headVars))) all_meths@@ -137,7 +147,7 @@ logElab 5 ("Before defaults: " ++ show ds ++ "\n" ++ show (map fst (class_methods ci))) let ds_defs = insertDefaults ist iname (class_defaults ci) ns ds logElab 3 ("After defaults: " ++ show ds_defs ++ "\n")- let ds' = reorderDefs (map fst (class_methods ci)) $ ds_defs+ let ds' = reorderDefs (map fst (class_methods ci)) ds_defs logElab 1 ("Reordered: " ++ show ds' ++ "\n") mapM_ (warnMissing ds' ns iname) (map fst (class_methods ci))@@ -182,13 +192,13 @@ Nothing -> [] let prop_params = getParamsInType ist [] ifn_is ifn_ty - logElab 3 $ "Propagating parameters to methods: " + logElab 3 $ "Propagating parameters to methods: " ++ show (iname, prop_params) let wbVals' = map (addParams prop_params) wbVals mapM_ (rec_elabDecl info EAll info) wbVals'- + mapM_ (checkInjectiveDef fc (class_methods ci)) (zip ds' wbVals') pop_estack@@ -207,13 +217,13 @@ mkiname n' ns ps' expn' = case expn' of Nothing -> case ns of- Nothing -> SN (sInstanceN n' (map show ps'))- Just m -> sNS (SN (sInstanceN n' (map show ps'))) m+ [] -> SN (sInstanceN n' (map show ps'))+ m -> sNS (SN (sInstanceN n' (map show ps'))) m Just nm -> nm substInstance ips pnames (PInstance doc argDocs syn _ cs parents acc opts n nfc ps pextra t expn ds)- = PInstance doc argDocs syn fc cs parents acc opts n nfc - (map (substMatchesShadow ips pnames) ps) + = PInstance doc argDocs syn fc cs parents acc opts n nfc+ (map (substMatchesShadow ips pnames) ps) pextra (substMatchesShadow ips pnames t) expn ds @@ -235,7 +245,7 @@ let ty = addImpl [] i ty' ctxt <- getContext (ElabResult tyT _ _ ctxt' newDecls highlights newGName, _) <-- tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) iname (TType (UVal 0)) initEState+ tclift $ elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) iname (TType (UVal 0)) initEState (errAt "type of " iname Nothing (erun fc (build i info ERHS [] iname ty))) setContext ctxt' processTacticDecls info newDecls@@ -243,12 +253,12 @@ updateIState $ \i -> i { idris_name = newGName } ctxt <- getContext- (cty, _) <- recheckC fc id [] tyT+ (cty, _) <- recheckC (constraintNS info) fc id [] tyT let nty = normalise ctxt [] cty return $ any (isJust . findOverlapping i (class_determiners ci) (delab i nty)) (map fst $ class_instances ci) findOverlapping i dets t n- | take 2 (show n) == "@@" = Nothing+ | SN (ParentN _ _) <- n = Nothing | otherwise = case lookupTy n (tt_ctxt i) of [t'] -> let tret = getRetType t@@ -275,10 +285,10 @@ keepDets dets t = t methName (n, _, _, _) = n- toExp n = pexp (PRef fc [] n) + toExp n = pexp (PRef fc [] n) - mkMethApp ps (n, _, _, ty) - = lamBind 0 ty (papp fc (PRef fc [] n) + mkMethApp ps (n, _, _, ty)+ = lamBind 0 ty (papp fc (PRef fc [] n) (ps ++ map (toExp . fst) pextra ++ methArgs 0 ty)) where needed is p = pname p `elem` map pname is@@ -311,7 +321,7 @@ decorate ns iname (NS (UN nm) s) = NS (SN (WhereN 0 iname (SN (MethodN (UN nm))))) ns- decorate ns iname nm + decorate ns iname nm = NS (SN (WhereN 0 iname (SN (MethodN nm)))) ns mkTyDecl (n, op, t, _)@@ -375,7 +385,7 @@ clauseFor m iname ns (PClauses _ _ m' _) = decorate ns iname m == decorate ns iname m' clauseFor m iname ns _ = False- + getHeadVars :: PTerm -> [Name] getHeadVars (PRef _ _ n) | implicitable n = [n] getHeadVars (PApp _ _ args) = concatMap getHeadVars (map getTm args)@@ -383,14 +393,14 @@ getHeadVars (PDPair _ _ _ l t r) = getHeadVars l ++ getHeadVars t ++ getHeadVars t getHeadVars _ = [] --- Implicitly bind variables from the instance head in method types+-- | Implicitly bind variables from the instance head in method types impBind :: [(Name, PTerm)] -> PDecl -> PDecl impBind vs (PTy d ds syn fc opts n fc' t)- = PTy d ds syn fc opts n fc' + = PTy d ds syn fc opts n fc' (doImpBind (filter (\(n, ty) -> n `notElem` boundIn t) vs) t) where doImpBind [] ty = ty- doImpBind ((n, argty) : ns) ty + doImpBind ((n, argty) : ns) ty = PPi impl n NoFC argty (doImpBind ns ty) boundIn (PPi _ n _ _ sc) = n : boundIn sc@@ -404,19 +414,19 @@ toImp fc n = pimp n (PRef fc [] n) True --- Propagate class parameters to method bodies, if they're not already --- there, and they are needed (i.e. appear in method's type)+-- | Propagate class parameters to method bodies, if they're not+-- already there, and they are needed (i.e. appear in method's type) addParams :: [Name] -> PDecl -> PDecl addParams ps (PClauses fc opts n cs) = PClauses fc opts n (map addCParams cs) where addCParams (PClause fc n lhs ws rhs wb) = PClause fc n (addTmParams (dropPs (allNamesIn lhs) ps) lhs) ws rhs wb addCParams (PWith fc n lhs ws sc pn ds)- = PWith fc n (addTmParams (dropPs (allNamesIn lhs) ps) lhs) ws sc pn + = PWith fc n (addTmParams (dropPs (allNamesIn lhs) ps) lhs) ws sc pn (map (addParams ps) ds) addCParams c = c - addTmParams ps (PRef fc hls n) + addTmParams ps (PRef fc hls n) = PApp fc (PRef fc hls n) (map (toImp fc) ps) addTmParams ps (PApp fc ap@(PRef fc' hls n) args) = PApp fc ap (mergePs (map (toImp fc) ps) args)@@ -439,11 +449,10 @@ addParams ps d = d --- Check a given method definition is injective, if the class info--- says it needs to be.--- Takes originally written decl and the one with name decoration, so--- we know which name to look up.-checkInjectiveDef :: FC -> [(Name, (Bool, FnOpts, PTerm))] -> +-- | Check a given method definition is injective, if the class info+-- says it needs to be. Takes originally written decl and the one+-- with name decoration, so we know which name to look up.+checkInjectiveDef :: FC -> [(Name, (Bool, FnOpts, PTerm))] -> (PDecl, PDecl) -> Idris () checkInjectiveDef fc ns (PClauses _ _ n cs, PClauses _ _ elabn _) | Just (True, _, _) <- clookup n ns@@ -452,13 +461,13 @@ Just (CaseOp _ _ _ _ _ cdefs) -> checkInjectiveCase ist (snd (cases_compiletime cdefs)) where- checkInjectiveCase ist (STerm tm) + checkInjectiveCase ist (STerm tm) = checkInjectiveApp ist (fst (unApply tm)) checkInjectiveCase _ _ = notifail checkInjectiveApp ist (P (TCon _ _) n _) = return () checkInjectiveApp ist (P (DCon _ _ _) n _) = return ()- checkInjectiveApp ist (P Ref n _) + checkInjectiveApp ist (P Ref n _) | Just True <- lookupInjectiveExact n (tt_ctxt ist) = return () checkInjectiveApp ist (P Ref n _) = notifail checkInjectiveApp _ _ = notifail
src/Idris/Elab/Provider.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.Provider+Description : Code to elaborate type providers.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module Idris.Elab.Provider(elabProvider) where
src/Idris/Elab/Quasiquote.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.Quasiquote+Description : Code to elaborate quasiquotations.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Idris.Elab.Quasiquote (extractUnquotes) where import Idris.Core.Elaborate hiding (Tactic(..))
src/Idris/Elab/Record.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.Record+Description : Code to elaborate records.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards, ViewPatterns #-} module Idris.Elab.Record(elabRecord) where @@ -35,16 +42,18 @@ -- | Elaborate a record declaration elabRecord :: ElabInfo -> ElabWhat- -> (Docstring (Either Err PTerm)) -- ^ The documentation for the whole declaration- -> SyntaxInfo -> FC -> DataOpts- -> Name -- ^ The name of the type being defined- -> FC -- ^ The precise source location of the tycon name- -> [(Name, FC, Plicity, PTerm)] -- ^ Parameters- -> [(Name, Docstring (Either Err PTerm))] -- ^ Parameter Docs+ -> (Docstring (Either Err PTerm)) -- ^ The documentation for the whole declaration+ -> SyntaxInfo+ -> FC+ -> DataOpts+ -> Name -- ^ The name of the type being defined+ -> FC -- ^ The precise source location of the tycon name+ -> [(Name, FC, Plicity, PTerm)] -- ^ Parameters+ -> [(Name, Docstring (Either Err PTerm))] -- ^ Parameter Docs -> [(Maybe (Name, FC), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))] -- ^ Fields- -> Maybe (Name, FC) -- ^ Constructor Name- -> (Docstring (Either Err PTerm)) -- ^ Constructor Doc- -> SyntaxInfo -- ^ Constructor SyntaxInfo+ -> Maybe (Name, FC) -- ^ Constructor Name+ -> (Docstring (Either Err PTerm)) -- ^ Constructor Doc+ -> SyntaxInfo -- ^ Constructor SyntaxInfo -> Idris () elabRecord info what doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc csyn = do logElab 1 $ "Building data declaration for " ++ show tyn@@ -154,18 +163,20 @@ in (n, nfc, p, t, doc) : (fwnad rest) fwnad [] = [] -elabRecordFunctions :: ElabInfo -> SyntaxInfo -> FC- -> Name -- ^ Record type name+elabRecordFunctions :: ElabInfo+ -> SyntaxInfo+ -> FC+ -> Name -- ^ Record type name -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Parameters -> [(Name, FC, Plicity, PTerm, Docstring (Either Err PTerm))] -- ^ Fields- -> Name -- ^ Constructor Name- -> PTerm -- ^ Target type+ -> Name -- ^ Constructor Name+ -> PTerm -- ^ Target type -> Idris () elabRecordFunctions info rsyn fc tyn params fields dconName target = do logElab 1 $ "Elaborating helper functions for record " ++ show tyn - logElab 1 $ "Fields: " ++ show fieldNames- logElab 1 $ "Params: " ++ show paramNames+ logElab 3 $ "Fields: " ++ show fieldNames+ logElab 3 $ "Params: " ++ show paramNames -- The elaborated constructor type for the data declaration i <- getIState ttConsTy <-@@ -175,8 +186,8 @@ -- The arguments to the constructor let constructorArgs = getArgTys ttConsTy- logElab 1 $ "Cons args: " ++ show constructorArgs- logElab 1 $ "Free fields: " ++ show (filter (not . isFieldOrParam') constructorArgs)+ logElab 3 $ "Cons args: " ++ show constructorArgs+ logElab 3 $ "Free fields: " ++ show (filter (not . isFieldOrParam') constructorArgs) -- If elaborating the constructor has resulted in some new implicit fields we make projection functions for them. let freeFieldsForElab = map (freeField i) (filter (not . isFieldOrParam') constructorArgs) @@ -190,16 +201,16 @@ -- All things we need to elaborate projection functions for, together with a number denoting their position in the constructor. let projectors = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (freeFieldsForElab ++ paramsForElab ++ userFieldsForElab) [0..]] -- Build and elaborate projection functions- elabProj dconName projectors+ elabProj dconName paramNames projectors - logElab 1 $ "Dependencies: " ++ show fieldDependencies+ logElab 3 $ "Dependencies: " ++ show fieldDependencies - logElab 1 $ "Depended on: " ++ show dependedOn+ logElab 3 $ "Depended on: " ++ show dependedOn -- All things we need to elaborate update functions for, together with a number denoting their position in the constructor. let updaters = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (paramsForElab ++ userFieldsForElab) [0..]] -- Build and elaborate update functions- elabUp dconName updaters+ elabUp dconName paramNames updaters where -- | Creates a PArg from a plicity and a name where the term is a Placeholder. placeholderArg :: Plicity -> Name -> PArg@@ -259,20 +270,22 @@ paramName n = n -- | Elaborate the projection functions.- elabProj :: Name -> [(Name, Name, Plicity, PTerm, Docstring (Either Err PTerm), Int)] -> Idris ()- elabProj cn fs = let phArgs = map (uncurry placeholderArg) [(p, n) | (n, _, p, _, _, _) <- fs]+ elabProj :: Name -> [Name] -> [(Name, Name, Plicity, PTerm, Docstring (Either Err PTerm), Int)] -> Idris ()+ elabProj cn paramnames fs + = let phArgs = map (uncurry placeholderArg) [(p, n) | (n, _, p, _, _, _) <- fs] elab = \(n, n', p, t, doc, i) -> -- Use projections in types do let t' = projectInType [(m, m') | (m, m', _, _, _, _) <- fs -- Parameters are already in scope, so just use them , not (m `elem` paramNames)] t- elabProjection info n n' p t' doc rsyn fc target cn phArgs fieldNames i+ elabProjection info n paramnames n' p t' doc rsyn fc target cn phArgs fieldNames i in mapM_ elab fs -- | Elaborate the update functions.- elabUp :: Name -> [(Name, Name, Plicity, PTerm, Docstring (Either Err PTerm), Int)] -> Idris ()- elabUp cn fs = let args = map (uncurry asPRefArg) [(p, n) | (n, _, p, _, _, _) <- fs]- elab = \(n, n', p, t, doc, i) -> elabUpdate info n n' p t doc rsyn fc target cn args fieldNames i (optionalSetter n)+ elabUp :: Name -> [Name] -> [(Name, Name, Plicity, PTerm, Docstring (Either Err PTerm), Int)] -> Idris ()+ elabUp cn paramnames fs + = let args = map (uncurry asPRefArg) [(p, n) | (n, _, p, _, _, _) <- fs]+ elab = \(n, n', p, t, doc, i) -> elabUpdate info n paramnames n' p t doc rsyn fc target cn args fieldNames i (optionalSetter n) in mapM_ elab fs -- | Decides whether a setter should be generated for a field or not.@@ -301,19 +314,20 @@ -- | Creates and elaborates a projection function. elabProjection :: ElabInfo- -> Name -- ^ Name of the argument in the constructor- -> Name -- ^ Projection Name- -> Plicity -- ^ Projection Plicity- -> PTerm -- ^ Projection Type+ -> Name -- ^ Name of the argument in the constructor+ -> [Name] -- ^ Parameter names+ -> Name -- ^ Projection Name+ -> Plicity -- ^ Projection Plicity+ -> PTerm -- ^ Projection Type -> (Docstring (Either Err PTerm)) -- ^ Projection Documentation- -> SyntaxInfo -- ^ Projection SyntaxInfo- -> FC -> PTerm -- ^ Projection target type- -> Name -- ^ Data constructor tame- -> [PArg] -- ^ Placeholder Arguments to constructor- -> [Name] -- ^ All Field Names- -> Int -- ^ Argument Index+ -> SyntaxInfo -- ^ Projection SyntaxInfo+ -> FC -> PTerm -- ^ Projection target type+ -> Name -- ^ Data constructor tame+ -> [PArg] -- ^ Placeholder Arguments to constructor+ -> [Name] -- ^ All Field Names+ -> Int -- ^ Argument Index -> Idris ()-elabProjection info cname pname plicity projTy pdoc psyn fc targetTy cn phArgs fnames index+elabProjection info cname paramnames pname plicity projTy pdoc psyn fc targetTy cn phArgs fnames index = do logElab 1 $ "Generating Projection for " ++ show pname let ty = generateTy@@ -332,8 +346,12 @@ -- | The type of the projection function. generateTy :: PDecl generateTy = PTy pdoc [] psyn fc [] pname NoFC $- PPi expl recName NoFC targetTy projTy+ bindParams paramnames $+ PPi expl recName NoFC targetTy projTy + bindParams [] t = t+ bindParams (n : ns) ty = PPi impl n NoFC Placeholder (bindParams ns ty)+ -- | The left hand side of the projection function. generateLhs :: PTerm generateLhs = let args = lhsArgs index phArgs@@ -358,20 +376,21 @@ -- | Creates and elaborates an update function. -- If 'optional' is true, we will not fail if we can't elaborate the update function. elabUpdate :: ElabInfo- -> Name -- ^ Name of the argument in the constructor- -> Name -- ^ Field Name- -> Plicity -- ^ Field Plicity- -> PTerm -- ^ Field Type+ -> Name -- ^ Name of the argument in the constructor+ -> [Name] -- ^ Parameter names+ -> Name -- ^ Field Name+ -> Plicity -- ^ Field Plicity+ -> PTerm -- ^ Field Type -> (Docstring (Either Err PTerm)) -- ^ Field Documentation- -> SyntaxInfo -- ^ Field SyntaxInfo- -> FC -> PTerm -- ^ Projection Source Type- -> Name -- ^ Data Constructor Name- -> [PArg] -- ^ Arguments to constructor- -> [Name] -- ^ All fields- -> Int -- ^ Argument Index- -> Bool -- ^ Optional+ -> SyntaxInfo -- ^ Field SyntaxInfo+ -> FC -> PTerm -- ^ Projection Source Type+ -> Name -- ^ Data Constructor Name+ -> [PArg] -- ^ Arguments to constructor+ -> [Name] -- ^ All fields+ -> Int -- ^ Argument Index+ -> Bool -- ^ Optional -> Idris ()-elabUpdate info cname pname plicity pty pdoc psyn fc sty cn args fnames i optional+elabUpdate info cname paramnames pname plicity pty pdoc psyn fc sty cn args fnames i optional = do logElab 1 $ "Generating Update for " ++ show pname let ty = generateTy@@ -395,9 +414,13 @@ -- | The type of the update function. generateTy :: PDecl generateTy = PTy pdoc [] psyn fc [] set_pname NoFC $- PPi expl (nsroot pname) NoFC pty $- PPi expl recName NoFC sty (substInput sty)+ bindParams paramnames $+ PPi expl (nsroot pname) NoFC pty $+ PPi expl recName NoFC sty (substInput sty) where substInput = substMatches [(cname, PRef fc [] (nsroot pname))]++ bindParams [] t = t+ bindParams (n : ns) ty = PPi impl n NoFC Placeholder (bindParams ns ty) -- | The "_set" name. set_pname :: Name
src/Idris/Elab/Rewrite.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.Rewrite+Description : Code to elaborate rewrite rules.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards, ViewPatterns #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Elab.Rewrite(elabRewrite, elabRewriteLemma) where@@ -17,7 +24,7 @@ import Debug.Trace -elabRewrite :: (PTerm -> ElabD ()) -> IState -> +elabRewrite :: (PTerm -> ElabD ()) -> IState -> FC -> Maybe Name -> PTerm -> PTerm -> Maybe PTerm -> ElabD () -- Old version, no rewrite rule given {-@@ -47,7 +54,7 @@ Nothing -> return sc_in Just t -> do letn <- getNameFrom (sMN 0 "rewrite_result")- return $ PLet fc letn fc t sc_in + return $ PLet fc letn fc t sc_in (PRef fc [] letn) tyn <- getNameFrom (sMN 0 "rty") claim tyn RType@@ -67,7 +74,7 @@ (P _ (UN q) _, [lt, rt, l, r]) | q == txt "=" -> do substfn <- findSubstFn substfn_in ist lt rt let pred_tt = mkP (P Bound rname rt) l r g- when (g == pred_tt) $ lift $ tfail (NoRewriting g)+ when (g == pred_tt) $ lift $ tfail (NoRewriting l r g) let pred = PLam fc rname fc Placeholder (delab ist pred_tt) let rewrite = stripImpls $@@ -75,7 +82,7 @@ [pexp pred, pexp rule, pexp sc]) -- trace ("LHS: " ++ show l ++ "\n" ++ -- "RHS: " ++ show r ++ "\n" ++--- "REWRITE: " ++ show rewrite ++ "\n" ++ +-- "REWRITE: " ++ show rewrite ++ "\n" ++ -- "GOAL: " ++ show (delab ist g)) $ elab rewrite solve@@ -84,7 +91,7 @@ mkP :: TT Name -> -- Left term, top level TT Name -> TT Name -> TT Name -> TT Name mkP lt l r ty | l == ty = lt- mkP lt l r (App s f a) + mkP lt l r (App s f a) = let f' = if (r /= f) then mkP lt l r f else f a' = if (r /= a) then mkP lt l r a else a in App s f' a'@@ -101,7 +108,7 @@ mkP lt l r x = x -- If we're rewriting a dependent type, the rewrite type the rewrite- -- may break the indices. + -- may break the indices. -- So, for any function argument which can be determined by looking -- at the indices (i.e. any constructor guarded elsewhere in the type) -- replace it with a _. e.g. (++) a n m xs ys becomes (++) _ _ _ xs ys@@ -116,7 +123,7 @@ where removeImp tm@(PImp{}) = tm { getTm = Placeholder } removeImp t = t phApps tm = tm- + findSubstFn :: Maybe Name -> IState -> Type -> Type -> ElabD Name findSubstFn Nothing ist lt rt | lt == rt = return (sUN "rewrite__impl")@@ -129,8 +136,8 @@ Just _ -> return (rewrite_name lcon) Nothing -> rewriteFail lt rt | otherwise = rewriteFail lt rt- where rewriteFail lt rt = lift . tfail . - Msg $ "Can't rewrite heterogeneous equality on types " ++ + where rewriteFail lt rt = lift . tfail .+ Msg $ "Can't rewrite heterogeneous equality on types " ++ show (delab ist lt) ++ " and " ++ show (delab ist rt) findSubstFn (Just substfn_in) ist lt rt@@ -142,8 +149,8 @@ rewrite_name :: Name -> Name rewrite_name n = sMN 0 (show n ++ "_rewrite_lemma") -data ParamInfo = Index - | Param +data ParamInfo = Index+ | Param | ImplicitIndex | ImplicitParam deriving Show@@ -163,9 +170,11 @@ isParam ImplicitIndex = False isParam ImplicitParam = True --- Make a rewriting lemma for the given type constructor.--- If it fails, fail silently (it may well fail for some very complex types.--- We can fix this later, for now this gives us a lot more working rewrites...)+-- | Make a rewriting lemma for the given type constructor.+--+-- If it fails, fail silently (it may well fail for some very complex+-- types. We can fix this later, for now this gives us a lot more+-- working rewrites...) elabRewriteLemma :: ElabInfo -> Name -> Type -> Idris () elabRewriteLemma info n cty_in = do ist <- getIState@@ -176,7 +185,7 @@ Just ti -> do let imps = case lookupCtxtExact n (idris_implicits ist) of Nothing -> repeat (pexp Placeholder)- Just is -> is + Just is -> is let pinfo = getParamInfo cty imps 0 (param_pos ti) if all isParam pinfo then return () -- no need for a lemma, = will be homogeneous@@ -189,7 +198,7 @@ let leftty = mkTy tcon ps (namesFrom "p" 0) (namesFrom "left" 0) rightty = mkTy tcon ps (namesFrom "p" 0) (namesFrom "right" 0) predty = bindIdxs ist ps ty (namesFrom "pred" 0) $- PPi expl (sMN 0 "rep") fc + PPi expl (sMN 0 "rep") fc (mkTy tcon ps (namesFrom "p" 0) (namesFrom "pred" 0)) (PType fc) let xarg = sMN 0 "x"@@ -215,8 +224,8 @@ let lemRHS = PRef fc [] prop -- Elaborate the type of the lemma- rec_elabDecl info EAll info - (PTy emptyDocstring [] defaultSyntax fc [] lemma fc lemTy) + rec_elabDecl info EAll info+ (PTy emptyDocstring [] defaultSyntax fc [] lemma fc lemTy) -- Elaborate the definition rec_elabDecl info EAll info (PClauses fc [] lemma [PClause fc lemma lemLHS [] lemRHS []])@@ -224,9 +233,9 @@ where fc = emptyFC - namesFrom x i = sMN i x : namesFrom x (i + 1) - - mkTy fn pinfo ps is + namesFrom x i = sMN i x : namesFrom x (i + 1)++ mkTy fn pinfo ps is = PApp fc (PRef fc [] fn) (mkArgs pinfo ps is) mkArgs [] ps is = []@@ -241,15 +250,13 @@ mkArgs _ _ _ = [] bindIdxs ist [] ty is tm = tm- bindIdxs ist (Param : pinfo) (Bind n (Pi _ ty _) sc) is tm + bindIdxs ist (Param : pinfo) (Bind n (Pi _ ty _) sc) is tm = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm- bindIdxs ist (Index : pinfo) (Bind n (Pi _ ty _) sc) (i : is) tm - = PPi forall_imp i fc (delab ist ty) + bindIdxs ist (Index : pinfo) (Bind n (Pi _ ty _) sc) (i : is) tm+ = PPi forall_imp i fc (delab ist ty) (bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm)- bindIdxs ist (ImplicitParam : pinfo) (Bind n (Pi _ ty _) sc) is tm + bindIdxs ist (ImplicitParam : pinfo) (Bind n (Pi _ ty _) sc) is tm = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm- bindIdxs ist (ImplicitIndex : pinfo) (Bind n (Pi _ ty _) sc) (i : is) tm + bindIdxs ist (ImplicitIndex : pinfo) (Bind n (Pi _ ty _) sc) (i : is) tm = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm bindIdxs _ _ _ _ tm = tm--
src/Idris/Elab/RunElab.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.RunElab+Description : Code to run the elaborator process.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Idris.Elab.RunElab (elabRunElab) where import Idris.Elab.Term@@ -33,9 +40,9 @@ ist <- getIState ctxt <- getContext (ElabResult tyT' defer is ctxt' newDecls highlights newGName, log) <-- tclift $ elaborate ctxt (idris_datatypes ist) (idris_name ist) (sMN 0 "toplLevelElab") elabScriptTy initEState+ tclift $ elaborate (constraintNS info) ctxt (idris_datatypes ist) (idris_name ist) (sMN 0 "toplLevelElab") elabScriptTy initEState (transformErr RunningElabScript- (erun fc (do tm <- runElabAction ist fc [] script ns+ (erun fc (do tm <- runElabAction info ist fc [] script ns EState is _ impls highlights _ _ <- getAux ctxt <- get_context let ds = [] -- todo
src/Idris/Elab/Term.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.Term+Description : Code to elaborate terms.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Elab.Term where@@ -42,33 +49,39 @@ deriving Eq -data ElabResult =- ElabResult { resultTerm :: Term -- ^ The term resulting from elaboration- , resultMetavars :: [(Name, (Int, Maybe Name, Type, [Name]))]- -- ^ Information about new metavariables- , resultCaseDecls :: [PDecl]- -- ^ Deferred declarations as the meaning of case blocks- , resultContext :: Context- -- ^ The potentially extended context from new definitions- , resultTyDecls :: [RDeclInstructions]- -- ^ Meta-info about the new type declarations- , resultHighlighting :: [(FC, OutputAnnotation)]- -- ^ Saved highlights from elaboration- , resultName :: Int- -- ^ The new global name counter- }+data ElabResult = ElabResult {+ -- | The term resulting from elaboration+ resultTerm :: Term+ -- | Information about new metavariables+ , resultMetavars :: [(Name, (Int, Maybe Name, Type, [Name]))]+ -- | Deferred declarations as the meaning of case blocks+ , resultCaseDecls :: [PDecl]+ -- | The potentially extended context from new definitions+ , resultContext :: Context+ -- | Meta-info about the new type declarations+ , resultTyDecls :: [RDeclInstructions]+ -- | Saved highlights from elaboration+ , resultHighlighting :: [(FC, OutputAnnotation)]+ -- | The new global name counter+ , resultName :: Int+ } --- Using the elaborator, convert a term in raw syntax to a fully++-- | Using the elaborator, convert a term in raw syntax to a fully -- elaborated, typechecked term. -- -- If building a pattern match, we convert undeclared variables from -- holes to pattern bindings.-+-- -- Also find deferred names in the term and their types--build :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->- ElabD ElabResult+build :: IState+ -> ElabInfo+ -> ElabMode+ -> FnOpts+ -> Name+ -> PTerm+ -> ElabD ElabResult build ist info emode opts fn tm = do elab ist info emode opts fn tm let tmIn = tm@@ -139,7 +152,8 @@ (h: hs) -> do patvar h; mkPat [] -> return () --- Build a term autogenerated as a typeclass method definition+-- | Build a term autogenerated as a typeclass method definition.+-- -- (Separate, so we don't go overboard resolving things that we don't -- know about yet on the LHS of a pattern def) @@ -177,9 +191,10 @@ else return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname) where pattern = emode == ELHS --- return whether arguments of the given constructor name can be--- matched on. If they're polymorphic, no, unless the type has beed made--- concrete by the time we get around to elaborating the argument.+-- | return whether arguments of the given constructor name can be+-- matched on. If they're polymorphic, no, unless the type has beed+-- made concrete by the time we get around to elaborating the+-- argument. getUnmatchable :: Context -> Name -> [Bool] getUnmatchable ctxt n | isDConName n ctxt && n /= inferCon = case lookupTyExact n ctxt of@@ -220,8 +235,13 @@ -- | Returns the set of declarations we need to add to complete the -- definition (most likely case blocks to elaborate) as well as -- declarations resulting from user tactic scripts (%runElab)-elab :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->- ElabD ()+elab :: IState+ -> ElabInfo+ -> ElabMode+ -> FnOpts+ -> Name+ -> PTerm+ -> ElabD () elab ist info emode opts fn tm = do let loglvl = opt_logLevel (idris_options ist) when (loglvl > 5) $ unifyLog True@@ -795,8 +815,8 @@ mkN n@(NS _ _) = n mkN n@(SN _) = n mkN n = case namespace info of- Just xs@(_:_) -> sNS n xs- _ -> n+ xs@(_:_) -> sNS n xs+ _ -> n elab' ina _ (PMatchApp fc fn) = do (fn', imps) <- case lookupCtxtName fn (idris_implicits ist) of@@ -1069,7 +1089,7 @@ -- mkCaseName (MN i x) = MN i (x ++ "_case") mkN n@(NS _ _) = n mkN n = case namespace info of- Just xs@(_:_) -> sNS n xs+ xs@(_:_) -> sNS n xs _ -> n getScrType [] = Nothing@@ -1137,7 +1157,7 @@ g_nextname <- get_global_nextname saveState updatePS (const .- newProof (sMN 0 "q") ctxt datatypes g_nextname $+ newProof (sMN 0 "q") (constraintNS info) ctxt datatypes g_nextname $ P Ref (reflm "TT") Erased) -- Re-add the unquotes, letting Idris infer the (fictional)@@ -1188,7 +1208,7 @@ _ -> False case quoted of Just q -> do ctxt <- get_context- (q', _, _) <- lift $ recheck ctxt [(uq, Lam Erased) | uq <- unquoteNames] (forget q) q+ (q', _, _) <- lift $ recheck (constraintNS info) ctxt [(uq, Lam Erased) | uq <- unquoteNames] (forget q) q if pattern then if isRaw then reflectRawQuotePattern unquoteNames (forget q')@@ -1240,9 +1260,11 @@ -- Delay dotted things to the end, then when we elaborate them -- we can check the result against what was inferred movelast h- delayElab 10 $ do focus h- dotterm- elab' ina fc t+ delayElab 10 $ do hs <- get_holes+ when (h `elem` hs) $ do+ focus h+ dotterm+ elab' ina fc t elab' ina fc (PRunElab fc' tm ns) = do attack n <- getNameFrom (sMN 0 "tacticScript")@@ -1257,7 +1279,7 @@ fullyElaborated script solve -- eliminate the hole. Becuase there are no references, the script is only in the binding env <- get_env- runElabAction ist (maybe fc' id fc) env script ns+ runElabAction info ist (maybe fc' id fc) env script ns solve elab' ina fc (PConstSugar constFC tm) = -- Here we elaborate the contained term, then calculate@@ -1438,7 +1460,7 @@ return (mkPApp fc a ftm args) _ -> return tm expandToArity t = return t- + fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs)) fullApp x = x @@ -1550,11 +1572,11 @@ addAutoBind _ _ = return () testImplicitWarning :: FC -> Name -> Type -> ElabD ()- testImplicitWarning fc n goal + testImplicitWarning fc n goal | implicitable n && emode == ETyDecl = do env <- get_env est <- getAux- when (n `elem` auto_binds est) $ + when (n `elem` auto_binds est) $ tryUnify env (lookupTyName n (tt_ctxt ist)) | otherwise = return () where@@ -1564,7 +1586,7 @@ hs <- get_holes case unify (tt_ctxt ist) env (ty, Nothing) (goal, Nothing) inj hs [] [] of- OK _ -> + OK _ -> updateAux (\est -> est { implicit_warnings = (fc, nm) : implicit_warnings est }) _ -> tryUnify env ts@@ -1645,14 +1667,14 @@ = -- trace ("Trying " ++ show f' ++ " for " ++ show n) $ case lookupTyExact f' ctxt of Just ty -> case unApply (getRetTy ty) of- (P _ ctyn _, _) | isTConName ctyn ctxt && not (ctyn == f) + (P _ ctyn _, _) | isTConName ctyn ctxt && not (ctyn == f) -> False _ -> let ty' = normalise ctxt [] ty in -- trace ("Trying " ++ show (getRetTy ty') ++ " for " ++ show goalty) $ case unApply (getRetTy ty') of (V _, _) -> isPlausible ist var env n ty- _ -> matching (getRetTy ty') goalty + _ -> matching (getRetTy ty') goalty || isCoercion (getRetTy ty') goalty -- May be useful to keep for debugging purposes for a bit: -- let res = matching (getRetTy ty') goalty in@@ -1661,12 +1683,12 @@ _ -> False -- If the goal is a constructor, it must match the suggested function type- matching (P _ ctyn _) (P _ n' _) + matching (P _ ctyn _) (P _ n' _) | isTConName n' ctxt = ctyn == n' | otherwise = True -- Variables match anything- matching (V _) _ = True - matching _ (V _) = True + matching (V _) _ = True+ matching _ (V _) = True matching _ (P _ n _) = not (isTConName n ctxt) matching (P _ n _) _ = not (isTConName n ctxt) -- Binders are a plausible match, so keep them@@ -1686,7 +1708,7 @@ isCoercion rty gty | (P _ r _, _) <- unApply rty = not (null (getCoercionsBetween r gty)) isCoercion _ _ = False- + getCoercionsBetween :: Name -> Type -> [Name] getCoercionsBetween r goal = let cs = getCoercionsTo ist goal in@@ -1699,7 +1721,7 @@ _ -> [] in ps ++ findCoercions t ns - useR ty = + useR ty = case unApply (getRetTy ty) of (P _ t _, _) -> t == r _ -> False@@ -1840,14 +1862,14 @@ when autoSolve solveAll -- | Compute the appropriate name for a top-level metavariable-metavarName :: Maybe [String] -> Name -> Name-metavarName _ n@(NS _ _) = n-metavarName (Just (ns@(_:_))) n = sNS n ns-metavarName _ n = n+metavarName :: [String] -> Name -> Name+metavarName _ n@(NS _ _) = n+metavarName (ns@(_:_)) n = sNS n ns+metavarName _ n = n -runElabAction :: IState -> FC -> Env -> Term -> [String] -> ElabD Term-runElabAction ist fc env tm ns = do tm' <- eval tm- runTacTm tm'+runElabAction :: ElabInfo -> IState -> FC -> Env -> Term -> [String] -> ElabD Term+runElabAction info ist fc env tm ns = do tm' <- eval tm+ runTacTm tm' where eval tm = do ctxt <- get_context@@ -1877,7 +1899,7 @@ _ -> P Ref n Erased fakeTT (RBind n b body) = Bind n (fmap fakeTT b) (fakeTT body) fakeTT (RApp f a) = App Complete (fakeTT f) (fakeTT a)- fakeTT RType = TType (UVar (-1))+ fakeTT RType = TType (UVar [] (-1)) fakeTT (RUType u) = UType u fakeTT (RConstant c) = Constant c @@ -2286,10 +2308,10 @@ (ctxt', ES (p, aux') _ _) <- do (ES (current_p, _) _ _) <- get lift $ runElab aux- (do runElabAction ist fc [] script ns+ (do runElabAction info ist fc [] script ns ctxt' <- get_context return ctxt')- ((newProof recH ctxt datatypes g_next goalTT)+ ((newProof recH (constraintNS info) ctxt datatypes g_next goalTT) { nextname = nextname current_p }) set_context ctxt' @@ -2300,7 +2322,7 @@ } put (ES (p', aux') s e) env' <- get_env- (tm, ty, _) <- lift $ recheck ctxt' env (forget tm_out) tm_out+ (tm, ty, _) <- lift $ recheck (constraintNS info) ctxt' env (forget tm_out) tm_out let (tm', ty') = (reflect tm, reflect ty) fmap fst . checkClosed $ rawPair (Var $ reflm "TT", Var $ reflm "TT")@@ -2311,7 +2333,7 @@ ptm <- get_term -- See documentation above in the elab case for PMetavar let unique_used = getUniqueUsed ctxt ptm- let mvn = metavarName (Just ns) n'+ let mvn = metavarName ns n' attack defer unique_used mvn solve@@ -2677,7 +2699,7 @@ updateIState $ \i -> i { idris_implicits = addDef n impls (idris_implicits i) } addIBC (IBCImp n)- ds <- checkDef fc (\_ e -> e) True [(n, (-1, Nothing, ty, []))]+ ds <- checkDef info fc (\_ e -> e) True [(n, (-1, Nothing, ty, []))] addIBC (IBCDef n) ctxt <- getContext case lookupDef n ctxt of@@ -2700,7 +2722,8 @@ cty (_, _, t) = t addIBC (IBCDef tyn) mapM_ (addIBC . IBCDef . cn) ctors- let params = findParams tyn (map cty ctors)+ ctxt <- getContext+ let params = findParams tyn (normalise ctxt [] tyconTy) (map cty ctors) let typeInfo = TI (map cn ctors) False [] params [] -- implicit precondition to IBCData is that idris_datatypes on the IState is populated. -- otherwise writing the IBC just fails silently!@@ -2794,7 +2817,7 @@ let lhs = addImplPat ist lhs_in let fc = fileFC "elab_reflected_totality" let tcgen = False -- TODO: later we may support dictionary generation- case elaborate ctxt (idris_datatypes ist) (idris_name ist) (sMN 0 "refPatLHS") infP initEState+ case elaborate (constraintNS info) ctxt (idris_datatypes ist) (idris_name ist) (sMN 0 "refPatLHS") infP initEState (erun fc (buildTC ist info ELHS [] fname (allNamesIn lhs_in) (infTerm lhs))) of OK (ElabResult lhs' _ _ _ _ _ name', _) ->@@ -2802,7 +2825,7 @@ -- want to run infinitely many times let lhs_tm = orderPats (getInferTerm lhs') updateIState $ \i -> i { idris_name = name' }- case recheck ctxt [] (forget lhs_tm) lhs_tm of+ case recheck (constraintNS info) ctxt [] (forget lhs_tm) lhs_tm of OK _ -> return True err -> return False -- if it's a recoverable error, the case may become possible
src/Idris/Elab/Transform.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.Transform+Description : Transformations for elaborate terms.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module Idris.Elab.Transform where @@ -55,7 +62,7 @@ let lhs = addImplPat i lhs_in logElab 5 ("Transform LHS input: " ++ showTmImpls lhs) (ElabResult lhs' dlhs [] ctxt' newDecls highlights newGName, _) <-- tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "transLHS") infP initEState+ tclift $ elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) (sMN 0 "transLHS") infP initEState (erun fc (buildTC i info ETransLHS [] (sUN "transform") (allNamesIn lhs_in) (infTerm lhs))) setContext ctxt'@@ -66,7 +73,7 @@ let lhs_ty = getInferType lhs' let newargs = pvars i lhs_tm - (clhs_tm_in, clhs_ty) <- recheckC_borrowing False False [] fc id [] lhs_tm+ (clhs_tm_in, clhs_ty) <- recheckC_borrowing False False [] (constraintNS info) fc id [] lhs_tm let clhs_tm = renamepats pnames clhs_tm_in logElab 3 ("Transform LHS " ++ show clhs_tm) logElab 3 ("Transform type " ++ show clhs_ty)@@ -75,7 +82,7 @@ logElab 5 ("Transform RHS input: " ++ showTmImpls rhs) ((rhs', defer, ctxt', newDecls, newGName), _) <-- tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "transRHS") clhs_ty initEState+ tclift $ elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) (sMN 0 "transRHS") clhs_ty initEState (do pbinds i lhs_tm setNextName (ElabResult _ _ _ ctxt' newDecls highlights newGName) <- erun fc (build i info ERHS [] (sUN "transform") rhs)@@ -90,7 +97,7 @@ sendHighlighting highlights updateIState $ \i -> i { idris_name = newGName } - (crhs_tm_in, crhs_ty) <- recheckC_borrowing False False [] fc id [] rhs'+ (crhs_tm_in, crhs_ty) <- recheckC_borrowing False False [] (constraintNS info) fc id [] rhs' let crhs_tm = renamepats pnames crhs_tm_in logElab 3 ("Transform RHS " ++ show crhs_tm)
src/Idris/Elab/Type.hs view
@@ -1,6 +1,15 @@+{-|+Module : Idris.Elab.Type+Description : Code to elaborate types.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-}-module Idris.Elab.Type (buildType, elabType, elabType',- elabPostulate, elabExtern) where+module Idris.Elab.Type (+ buildType, elabType, elabType'+ , elabPostulate, elabExtern+ ) where import Idris.AbsSyntax import Idris.ASTUtils@@ -52,8 +61,13 @@ import Util.Pretty(pretty, text) -buildType :: ElabInfo -> SyntaxInfo -> FC -> FnOpts -> Name -> PTerm ->- Idris (Type, Type, PTerm, [(Int, Name)])+buildType :: ElabInfo+ -> SyntaxInfo+ -> FC+ -> FnOpts+ -> Name+ -> PTerm+ -> Idris (Type, Type, PTerm, [(Int, Name)]) buildType info syn fc opts n ty' = do ctxt <- getContext i <- getIState@@ -68,21 +82,21 @@ logElab 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty ((ElabResult tyT' defer is ctxt' newDecls highlights newGName, est), log) <-- tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) n (TType (UVal 0)) initEState- (errAt "type of " n Nothing + tclift $ elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) n (TType (UVal 0)) initEState+ (errAt "type of " n Nothing (erunAux fc (build i info ETyDecl [] n ty))) displayWarnings est setContext ctxt' processTacticDecls info newDecls- sendHighlighting highlights + sendHighlighting highlights updateIState $ \i -> i { idris_name = newGName } let tyT = patToImp tyT' logElab 3 $ show ty ++ "\nElaborated: " ++ show tyT' - ds <- checkAddDef True False fc iderr True defer+ ds <- checkAddDef True False info fc iderr True defer -- if the type is not complete, note that we'll need to infer -- things later (for solving metavariables) when (length ds > length is) -- more deferred than case blocks@@ -90,10 +104,10 @@ mapM_ (elabCaseBlock info opts) is ctxt <- getContext- logElab 5 $ "Rechecking"- logElab 6 $ show tyT+ logElab 5 "Rechecking"+ logElab 6 (show tyT) logElab 10 $ "Elaborated to " ++ showEnvDbg [] tyT- (cty, ckind) <- recheckC fc id [] tyT+ (cty, ckind) <- recheckC (constraintNS info) fc id [] tyT -- record the implicit and inaccessible arguments i <- getIState@@ -108,7 +122,7 @@ -- Add the names referenced to the call graph, and check we're not -- referring to anything less visible- -- In particular, a public/export type can not refer to anything + -- In particular, a public/export type can not refer to anything -- private, but can refer to any public/export let refs = freeNames cty nvis <- getFromHideList n@@ -126,7 +140,7 @@ return (cty, ckind, ty, inacc) where- patToImp (Bind n (PVar t) sc) = Bind n (Pi Nothing t (TType (UVar 0))) (patToImp sc)+ patToImp (Bind n (PVar t) sc) = Bind n (Pi Nothing t (TType (UVar [] 0))) (patToImp sc) patToImp (Bind n b sc) = Bind n b (patToImp sc) patToImp t = t @@ -136,17 +150,29 @@ param_pos i ns t = [] -- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".-elabType :: ElabInfo -> SyntaxInfo- -> Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))]- -> FC -> FnOpts- -> Name -> FC -- ^ The precise location of the name- -> PTerm -> Idris Type+elabType :: ElabInfo+ -> SyntaxInfo+ -> Docstring (Either Err PTerm)+ -> [(Name, Docstring (Either Err PTerm))]+ -> FC+ -> FnOpts+ -> Name+ -> FC -- ^ The precise location of the name+ -> PTerm+ -> Idris Type elabType = elabType' False -elabType' :: Bool -> -- normalise it- ElabInfo -> SyntaxInfo ->- Docstring (Either Err PTerm) -> [(Name, Docstring (Either Err PTerm))] ->- FC -> FnOpts -> Name -> FC -> PTerm -> Idris Type+elabType' :: Bool -- normalise it+ -> ElabInfo+ -> SyntaxInfo+ -> Docstring (Either Err PTerm)+ -> [(Name, Docstring (Either Err PTerm))]+ -> FC+ -> FnOpts+ -> Name+ -> FC+ -> PTerm+ -> Idris Type elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (params info) ty_in n = liftname info n_in in -} do checkUndefined fc n@@ -177,7 +203,7 @@ -- Productivity checking now via checking for guarded 'Delay' let opts' = opts -- if corec then (Coinductive : opts) else opts let usety = if norm then nty' else nty- ds <- checkDef fc iderr True [(n, (-1, Nothing, usety, []))]+ ds <- checkDef info fc iderr True [(n, (-1, Nothing, usety, []))] addIBC (IBCDef n) addDefinedName n let ds' = map (\(n, (i, top, fam, ns)) -> (n, (i, top, fam, ns, True, True))) ds@@ -198,7 +224,7 @@ case fam of P _ tyn _ -> do addAutoHint tyn n addIBC (IBCAutoHint tyn n)- t -> ifail $ "Hints must return a data or record type"+ t -> ifail "Hints must return a data or record type" -- If the function is declared as an error handler and the language -- extension is enabled, then add it to the list of error handlers.
src/Idris/Elab/Utils.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Elab.Utils+Description : Elaborator utilities.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module Idris.Elab.Utils where @@ -28,17 +35,21 @@ recheckC = recheckC_borrowing False True [] -recheckC_borrowing uniq_check addConstrs bs fc mkerr env t+recheckC_borrowing uniq_check addConstrs bs tcns fc mkerr env t = do -- t' <- applyOpts (forget t) (doesn't work, or speed things up...)+ ctxt <- getContext t' <- case safeForget t of Just ft -> return ft Nothing -> tclift $ tfail $ mkerr (At fc (IncompleteTerm t))- (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs ctxt env t' t of+ (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs tcns ctxt env t' t of Error e -> tfail (At fc (mkerr e)) OK x -> return x logElab 6 $ "CONSTRAINTS ADDED: " ++ show (tm, ty, cs)- when addConstrs $ addConstraints fc cs+ tit <- typeInType+ when (not tit && addConstrs) $ + do addConstraints fc cs+ mapM_ (\c -> addIBC (IBCConstraint fc c)) (snd cs) mapM_ (checkDeprecated fc) (allTTNames tm) mapM_ (checkDeprecated fc) (allTTNames ty) mapM_ (checkFragile fc) (allTTNames tm)@@ -73,23 +84,23 @@ iderr :: Name -> Err -> Err iderr _ e = e -checkDef :: FC -> (Name -> Err -> Err) -> Bool ->+checkDef :: ElabInfo -> FC -> (Name -> Err -> Err) -> Bool -> [(Name, (Int, Maybe Name, Type, [Name]))] -> Idris [(Name, (Int, Maybe Name, Type, [Name]))]-checkDef fc mkerr definable ns- = checkAddDef False True fc mkerr definable ns+checkDef info fc mkerr definable ns+ = checkAddDef False True info fc mkerr definable ns -checkAddDef :: Bool -> Bool -> FC -> (Name -> Err -> Err) -> Bool+checkAddDef :: Bool -> Bool -> ElabInfo -> FC -> (Name -> Err -> Err) -> Bool -> [(Name, (Int, Maybe Name, Type, [Name]))] -> Idris [(Name, (Int, Maybe Name, Type, [Name]))]-checkAddDef add toplvl fc mkerr def [] = return []-checkAddDef add toplvl fc mkerr definable ((n, (i, top, t, psns)) : ns)+checkAddDef add toplvl info fc mkerr def [] = return []+checkAddDef add toplvl info fc mkerr definable ((n, (i, top, t, psns)) : ns) = do ctxt <- getContext logElab 5 $ "Rechecking deferred name " ++ show (n, t, definable)- (t', _) <- recheckC fc (mkerr n) [] t+ (t', _) <- recheckC (constraintNS info) fc (mkerr n) [] t when add $ do addDeferred [(n, (i, top, t, psns, toplvl, definable))] addIBC (IBCDef n)- ns' <- checkAddDef add toplvl fc mkerr definable ns+ ns' <- checkAddDef add toplvl info fc mkerr definable ns return ((n, (i, top, t', psns)) : ns') -- | Get the list of (index, name) of inaccessible arguments from an elaborated@@ -353,15 +364,18 @@ else return () --- | Find the type constructor arguments that are parameters, given a list of constructor types.--- Parameters are names which are unchanged across the structure,--- which appear exactly once in the return type of a constructor--- First, find all applications of the constructor, then check over--- them for repeated arguments-findParams :: Name -- ^ the name of the family that we are finding parameters for+-- | Find the type constructor arguments that are parameters, given a+-- list of constructor types.+--+-- Parameters are names which are unchanged across the structure.+-- They appear at least once in every constructor type, always appear+-- in the same argument position(s), and nothing else ever appears in those+-- argument positions.+findParams :: Name -- ^ the name of the family that we are finding parameters for+ -> Type -- ^ the type of the type constructor (normalised already) -> [Type] -- ^ the declared constructor types -> [Int]-findParams tyn ts =+findParams tyn famty ts = let allapps = map getDataApp ts -- do each constructor separately, then merge the results (names -- may change between constructors)@@ -376,9 +390,11 @@ paramPos [] = [] paramPos (args : rest) = dropNothing $ keepSame (zip [0..] args) rest+ dropNothing [] = [] dropNothing ((x, Nothing) : ts) = dropNothing ts dropNothing ((x, _) : ts) = x : dropNothing ts+ keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] -> [(Int, Maybe Name)] keepSame as [] = as@@ -389,6 +405,7 @@ update ((n, Just x) : as) (Just x' : args) | x == x' = (n, Just x) : update as args update ((n, _) : as) (_ : args) = (n, Nothing) : update as args+ getDataApp :: Type -> [[Maybe Name]] getDataApp f@(App _ _ _) | (P _ d _, args) <- unApply f@@ -396,16 +413,24 @@ getDataApp (Bind n (Pi _ t _) sc) = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc) getDataApp _ = []- -- keep the arguments which are single names, which don't appear- -- elsewhere++ -- keep the arguments which are single names, which appear+ -- in the return type, counting only the first time they appear in+ -- the return type as the parameter position mParam args [] = [] mParam args (P Bound n _ : rest)- | count n args == 1- = Just n : mParam args rest- where count n [] = 0- count n (t : ts)- | n `elem` freeNames t = 1 + count n ts- | otherwise = count n ts+ | paramIn False n args = Just n : mParam (filter (noN n) args) rest+ where paramIn ok n [] = ok+ paramIn ok n (P _ t _ : ts)+ = paramIn (ok || n == t) n ts+ paramIn ok n (t : ts)+ | n `elem` freeNames t = False -- not a single name+ | otherwise = paramIn ok n ts++ -- If the name appears again later, don't count that appearance+ -- as a parameter position+ noN n (P _ t _) = n /= t+ noN n _ = False mParam args (_ : rest) = Nothing : mParam args rest -- | Mark a name as detaggable in the global state (should be called@@ -448,5 +473,76 @@ isImplicit (PImp _ _ _ x _ : is) n | x == n = True isImplicit (_ : is) n = isImplicit is n propagateParams i ps t bound x = x++-- | Gather up all the outer 'PVar's and 'Hole's in an expression and reintroduce+-- them in a canonical order+orderPats :: Term -> Term+orderPats tm = op [] tm+ where+ op [] (App s f a) = App s f (op [] a) -- for Infer terms++ op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc+ op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc+ op ps (Bind n (Pi i t k) sc) = op ((n, Pi i t k) : ps) sc+ op ps sc = bindAll (sortP ps) sc++ -- Keep explicit Pi in the same order, insert others as necessary,+ -- Pi as early as possible, Hole as late as possible+ sortP ps = let (exps, imps) = partition isExp ps in+ pick (reverse exps) imps++ isExp (_, Pi Nothing _ _) = True+ isExp (_, Pi (Just i) _ _) = toplevel_imp i && not (machine_gen i)+ isExp _ = False++ pick acc [] = acc+ pick acc ((n, t) : ps) = pick (insert n t acc) ps++ insert n t [] = [(n, t)]+ -- if 't' uses any of the names which appear later, insert it later+ insert n t rest@((n', t') : ps)+ | any (\x -> x `elem` refsIn (binderTy t)) (n' : map fst ps)+ = (n', t') : insert n t ps+ -- otherwise it's fine where it is (preserve ordering)+ | otherwise = (n, t) : rest++-- Make sure all the pattern bindings are as far out as possible+liftPats :: Term -> Term+liftPats tm = let (tm', ps) = runState (getPats tm) [] in+ orderPats $ bindPats (reverse ps) tm'+ where+ bindPats [] tm = tm+ bindPats ((n, t):ps) tm+ | n `notElem` map fst ps = Bind n (PVar t) (bindPats ps tm)+ | otherwise = bindPats ps tm++ getPats :: Term -> State [(Name, Type)] Term+ getPats (Bind n (PVar t) sc) = do ps <- get+ put ((n, t) : ps)+ getPats sc+ getPats (Bind n (Guess t v) sc) = do t' <- getPats t+ v' <- getPats v+ sc' <- getPats sc+ return (Bind n (Guess t' v') sc')+ getPats (Bind n (Let t v) sc) = do t' <- getPats t+ v' <- getPats v+ sc' <- getPats sc+ return (Bind n (Let t' v') sc')+ getPats (Bind n (Pi i t k) sc) = do t' <- getPats t+ k' <- getPats k+ sc' <- getPats sc+ return (Bind n (Pi i t' k') sc')+ getPats (Bind n (Lam t) sc) = do t' <- getPats t+ sc' <- getPats sc+ return (Bind n (Lam t') sc')+ getPats (Bind n (Hole t) sc) = do t' <- getPats t+ sc' <- getPats sc+ return (Bind n (Hole t') sc')+++ getPats (App s f a) = do f' <- getPats f+ a' <- getPats a+ return (App s f' a')+ getPats t = return t
src/Idris/Elab/Value.hs view
@@ -1,7 +1,16 @@+{-|+Module : Idris.Elab.Value+Description : Code to elaborate values.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}-module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms,- elabExec, elabREPL) where+module Idris.Elab.Value(+ elabVal, elabValBind, elabDocTerms+ , elabExec, elabREPL+ ) where import Idris.AbsSyntax import Idris.ASTUtils@@ -65,7 +74,7 @@ -- * elaboration as a function a -> b (ElabResult tm' defer is ctxt' newDecls highlights newGName, _) <-- tclift (elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "val") infP initEState+ tclift (elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) (sMN 0 "val") infP initEState (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm))) -- Extend the context with new definitions created@@ -76,13 +85,13 @@ let vtm = orderPats (getInferTerm tm') - def' <- checkDef (fileFC "(input)") iderr True defer+ def' <- checkDef info (fileFC "(input)") iderr True defer let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, True, True))) def' addDeferred def'' mapM_ (elabCaseBlock info []) is logElab 3 ("Value: " ++ show vtm)- (vtm_in, vty) <- recheckC (fileFC "(input)") id [] vtm+ (vtm_in, vty) <- recheckC (constraintNS info) (fileFC "(input)") id [] vtm let vtm = if norm then normalise (tt_ctxt i) [] vtm_in else vtm_in
src/Idris/ElabDecls.hs view
@@ -1,3 +1,11 @@+{-|+Module : Idris.ElabDecls+Description : Code to elaborate declarations.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, PatternGuards #-} @@ -62,13 +70,13 @@ import Util.Pretty(pretty, text) --- Top level elaborator info, supporting recursive elaboration-recinfo :: ElabInfo-recinfo = EInfo [] emptyContext id Nothing Nothing id elabDecl'+-- | Top level elaborator info, supporting recursive elaboration+recinfo :: FC -> ElabInfo+recinfo fc = EInfo [] emptyContext id [] (Just fc) (fc_fname fc) 0 id elabDecl' -- | Return the elaborated term which calls 'main' elabMain :: Idris Term-elabMain = do (m, _) <- elabVal recinfo ERHS+elabMain = do (m, _) <- elabVal (recinfo fc) ERHS (PApp fc (PRef fc [] (sUN "run__IO")) [pexp $ PRef fc [] (sNS (sUN "main") ["Main"])]) return m@@ -76,13 +84,18 @@ -- | Elaborate primitives elabPrims :: Idris ()-elabPrims = do mapM_ (elabDecl' EAll recinfo)- (map (\(opt, decl, docs, argdocs) -> PData docs argdocs defaultSyntax (fileFC "builtin") opt decl)- (zip4- [inferOpts, eqOpts]- [inferDecl, eqDecl]- [emptyDocstring, eqDoc]- [[], eqParamDoc]))+elabPrims = do i <- getIState+ let cs_in = idris_constraints i+ let mkdec opt decl docs argdocs =+ PData docs argdocs defaultSyntax (fileFC "builtin") + opt decl+ elabDecl' EAll (recinfo primfc) (mkdec inferOpts inferDecl emptyDocstring [])+ -- We don't want the constraints generated by 'Infer' since+ -- it's only scaffolding for the elaborator+ i <- getIState+ putIState $ i { idris_constraints = cs_in }+ elabDecl' EAll (recinfo primfc) (mkdec eqOpts eqDecl eqDoc eqParamDoc)+ addNameHint eqTy (sUN "prf") mapM_ elabPrim primitives -- Special case prim__believe_me because it doesn't work on just constants@@ -96,6 +109,8 @@ i <- getIState putIState i { idris_scprims = (n, sc) : idris_scprims i } + primfc = fileFC "primitive"+ valuePrim :: ([Const] -> Maybe Const) -> [Value] -> Maybe Value valuePrim prim vals = fmap VConstant (mapM getConst vals >>= prim) @@ -105,13 +120,13 @@ p_believeMe [_,_,x] = Just x p_believeMe _ = Nothing- believeTy = Bind (sUN "a") (Pi Nothing (TType (UVar (-2))) (TType (UVar (-1))))- (Bind (sUN "b") (Pi Nothing (TType (UVar (-2))) (TType (UVar (-1))))- (Bind (sUN "x") (Pi Nothing (V 1) (TType (UVar (-1)))) (V 1)))+ believeTy = Bind (sUN "a") (Pi Nothing (TType (UVar [] (-2))) (TType (UVar [] (-1))))+ (Bind (sUN "b") (Pi Nothing (TType (UVar [] (-2))) (TType (UVar [] (-1))))+ (Bind (sUN "x") (Pi Nothing (V 1) (TType (UVar [] (-1)))) (V 1))) elabBelieveMe = do let prim__believe_me = sUN "prim__believe_me" updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)- -- The point is that it is believed to be total, even + -- The point is that it is believed to be total, even -- though it clearly isn't :) setTotality prim__believe_me (Total []) i <- getIState@@ -130,10 +145,10 @@ vnNothing = VP (DCon 0 1 False) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased vnRefl = VP (DCon 0 2 False) eqCon VErased - synEqTy = Bind (sUN "a") (Pi Nothing (TType (UVar (-3))) (TType (UVar (-2))))- (Bind (sUN "b") (Pi Nothing (TType (UVar (-3))) (TType (UVar (-2))))- (Bind (sUN "x") (Pi Nothing (V 1) (TType (UVar (-2))))- (Bind (sUN "y") (Pi Nothing (V 1) (TType (UVar (-2))))+ synEqTy = Bind (sUN "a") (Pi Nothing (TType (UVar [] (-3))) (TType (UVar [] (-2))))+ (Bind (sUN "b") (Pi Nothing (TType (UVar [] (-3))) (TType (UVar [] (-2))))+ (Bind (sUN "x") (Pi Nothing (V 1) (TType (UVar [] (-2))))+ (Bind (sUN "y") (Pi Nothing (V 1) (TType (UVar [] (-2)))) (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased) [V 3, V 2, V 1, V 0]])))) elabSynEq@@ -204,13 +219,17 @@ (map snd (idris_totcheck i)) mapM_ buildSCG (idris_totcheck i) mapM_ checkDeclTotality (idris_totcheck i)+ -- We've only checked that things are total independently. Given+ -- the ordering, something we think is total might have called+ -- something we hadn't checked yet+ mapM_ verifyTotality (idris_totcheck i) clear_totcheck where isDataDecl (PData _ _ _ _ _ _) = True isDataDecl _ = False getDataDecls (PNamespace _ _ ds : decls) = getDataDecls ds ++ getDataDecls decls- getDataDecls (d : decls) + getDataDecls (d : decls) | isDataDecl d = d : getDataDecls decls | otherwise = getDataDecls decls getDataDecls [] = []@@ -249,8 +268,8 @@ let ns = reverse (map T.pack newNS) sendHighlighting [(nfc, AnnNamespace ns Nothing)] where- newNS = maybe [n] (n:) (namespace info)- ninfo = info { namespace = Just newNS }+ newNS = n : namespace info+ ninfo = info { namespace = newNS } elabDecl' what info (PClass doc s f cs n nfc ps pdocs fds ds cn cd) | what /= EDefns
src/Idris/Erasure.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Erasure+Description : Utilities to erase irrelevant stuff.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module Idris.Erasure (performUsageAnalysis, mkFieldName) where@@ -32,7 +39,8 @@ import Data.Text (pack) import qualified Data.Text as T --- UseMap maps names to the set of used (reachable) argument positions.+-- | UseMap maps names to the set of used (reachable) argument+-- positions. type UseMap = Map Name (IntMap (Set Reason)) data Arg = Arg Int | Result deriving (Eq, Ord)@@ -45,26 +53,26 @@ type Deps = Map Cond DepSet type Reason = (Name, Int) -- function name, argument index --- Nodes along with sets of reasons for every one.+-- | Nodes along with sets of reasons for every one. type DepSet = Map Node (Set Reason) --- "Condition" is the conjunction--- of elementary assumptions along the path from the root.--- Elementary assumption (f, i) means that "function f uses the argument i".+-- | "Condition" is the conjunction of elementary assumptions along+-- the path from the root. Elementary assumption (f, i) means that+-- "function f uses the argument i". type Cond = Set Node --- Variables carry certain information with them.+-- | Variables carry certain information with them. data VarInfo = VI- { viDeps :: DepSet -- dependencies drawn in by the variable- , viFunArg :: Maybe Int -- which function argument this variable came from (defined only for patvars)- , viMethod :: Maybe Name -- name of the metamethod represented by the var, if any+ { viDeps :: DepSet -- ^ dependencies drawn in by the variable+ , viFunArg :: Maybe Int -- ^ which function argument this variable came from (defined only for patvars)+ , viMethod :: Maybe Name -- ^ name of the metamethod represented by the var, if any } deriving Show type Vars = Map Name VarInfo --- Perform usage analysis, write the relevant information in the internal--- structures, returning the list of reachable names.+-- | Perform usage analysis, write the relevant information in the+-- internal structures, returning the list of reachable names. performUsageAnalysis :: [Name] -> Idris [Name] performUsageAnalysis startNames = do ctx <- tt_ctxt <$> getIState@@ -137,7 +145,7 @@ fmt n rs = show n ++ " from " ++ intercalate ", " [show rn ++ " arg# " ++ show ri | (rn,ri) <- rs] warn = logErasure 0 --- Find the minimal consistent usage by forward chaining.+-- | Find the minimal consistent usage by forward chaining. minimalUsage :: Deps -> (Deps, (Set Name, UseMap)) minimalUsage = second gather . forwardChain where@@ -160,8 +168,8 @@ remove :: DepSet -> Deps -> Deps remove ds = M.mapKeysWith (M.unionWith S.union) (S.\\ M.keysSet ds) --- Build the dependency graph,--- starting the depth-first search from a list of Names.+-- | Build the dependency graph, starting the depth-first search from+-- a list of Names. buildDepMap :: Ctxt ClassInfo -> [(Name, Int)] -> [(Name, Int)] -> Context -> [Name] -> Deps buildDepMap ci used externs ctx startNames@@ -508,6 +516,6 @@ unionMap :: (a -> Deps) -> [a] -> Deps unionMap f = M.unionsWith (M.unionWith S.union) . map f --- Make a field name out of a data constructor name and field number.+-- | Make a field name out of a data constructor name and field number. mkFieldName :: Name -> Int -> Name mkFieldName ctorName fieldNo = SN (WhereN fieldNo ctorName $ sMN fieldNo "field")
src/Idris/ErrReverse.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.ErrReverse+Description : Utility to make errors readable using transformations.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module Idris.ErrReverse(errReverse) where@@ -9,9 +16,8 @@ import Data.List import Debug.Trace --- For display purposes, apply any 'error reversal' transformations so that--- errors will be more readable-+-- | For display purposes, apply any 'error reversal' transformations+-- so that errors will be more readable errReverse :: IState -> Term -> Term errReverse ist t = rewrite 5 t -- (elideLambdas t) where@@ -28,7 +34,7 @@ -- the rule as invalid and return t) applyNames ns t (Bind n (PVar ty) scl) (Bind n' (PVar ty') scr)- | n == n' = applyNames (n : ns) t (instantiate (P Ref n ty) scl) + | n == n' = applyNames (n : ns) t (instantiate (P Ref n ty) scl) (instantiate (P Ref n' ty') scr) | otherwise = t applyNames ns t l r = matchTerm ns l r t@@ -38,7 +44,7 @@ matchTerm ns l r (App s f a) = let f' = matchTerm ns l r f a' = matchTerm ns l r a in App s f' a'- matchTerm ns l r (Bind n b sc) = let b' = fmap (matchTerm ns l r) b + matchTerm ns l r (Bind n b sc) = let b' = fmap (matchTerm ns l r) b sc' = matchTerm ns l r sc in Bind n b' sc' matchTerm ns l r t = t@@ -48,7 +54,7 @@ -- If any duplicate mappings, it's a failure combine [] = Just []- combine ((x, t) : xs) + combine ((x, t) : xs) | Just _ <- lookup x xs = Nothing | otherwise = do xs' <- combine xs Just ((x, t) : xs')@@ -64,9 +70,8 @@ -- it as it won't be very enlightening. elideLambdas (App s f a) = App s (elideLambdas f) (elideLambdas a)- elideLambdas (Bind n (Lam t) sc) + elideLambdas (Bind n (Lam t) sc) | size sc > 200 = P Ref (sUN "...") Erased elideLambdas (Bind n b sc) = Bind n (fmap elideLambdas b) (elideLambdas sc) elideLambdas t = t-
src/Idris/Error.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Error+Description : Utilities to deal with error reporting.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} @@ -21,6 +28,7 @@ import Data.Char import Data.List (intercalate, isPrefixOf) import qualified Data.Text as T+import qualified Data.Set as S import Data.Typeable import qualified Data.Traversable as Traversable import qualified Data.Foldable as Foldable@@ -29,7 +37,7 @@ iucheck = do tit <- typeInType ist <- getIState let cs = idris_constraints ist- logLvl 7 $ "ALL CONSTRAINTS: " ++ show cs+ logLvl 7 $ "ALL CONSTRAINTS: " ++ show (length (S.toList cs)) when (not tit) $ (tclift $ ucheck (idris_constraints ist)) `idrisCatch` (\e -> do let fc = getErrSpan e
src/Idris/Help.hs view
@@ -1,21 +1,29 @@+{-|+Module : Idris.Help+Description : Utilities to aid with the REPL's HELP system.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+ module Idris.Help (CmdArg(..), extraHelp) where -data CmdArg = ExprArg -- ^ The command takes an expression- | NameArg -- ^ The command takes a name- | FileArg -- ^ The command takes a file- | ModuleArg -- ^ The command takes a module name- | PkgArgs -- ^ The command takes a list of package names- | NumberArg -- ^ The command takes a number- | NamespaceArg -- ^ The command takes a namespace name- | OptionArg -- ^ The command takes an option- | MetaVarArg -- ^ The command takes a metavariable- | ColourArg -- ^ The command is the colour-setting command- | NoArg -- ^ No completion (yet!?)- | SpecialHeaderArg -- ^ do not use- | ConsoleWidthArg -- ^ The width of the console- | DeclArg -- ^ An Idris declaration, as might be contained in a file- | ManyArgs CmdArg -- ^ Zero or more of one kind of argument- | OptionalArg CmdArg -- ^ Zero or one of one kind of argument+data CmdArg = ExprArg -- ^ The command takes an expression+ | NameArg -- ^ The command takes a name+ | FileArg -- ^ The command takes a file+ | ModuleArg -- ^ The command takes a module name+ | PkgArgs -- ^ The command takes a list of package names+ | NumberArg -- ^ The command takes a number+ | NamespaceArg -- ^ The command takes a namespace name+ | OptionArg -- ^ The command takes an option+ | MetaVarArg -- ^ The command takes a metavariable+ | ColourArg -- ^ The command is the colour-setting command+ | NoArg -- ^ No completion (yet!?)+ | SpecialHeaderArg -- ^ do not use+ | ConsoleWidthArg -- ^ The width of the console+ | DeclArg -- ^ An Idris declaration, as might be contained in a file+ | ManyArgs CmdArg -- ^ Zero or more of one kind of argument+ | OptionalArg CmdArg -- ^ Zero or one of one kind of argument | SeqArgs CmdArg CmdArg -- ^ One kind of argument followed by another instance Show CmdArg where
src/Idris/IBC.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.IBC+Description : Core representations and code to generate IBC files.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} @@ -39,73 +46,76 @@ import System.Directory import Codec.Archive.Zip +import Debug.Trace+ ibcVersion :: Word16-ibcVersion = 143+ibcVersion = 144 --- When IBC is being loaded - we'll load different things (and omit different--- structures/definitions) depending on which phase we're in-data IBCPhase = IBC_Building -- ^ when building the module tree- | IBC_REPL Bool -- ^ when loading modules for the REPL- -- Bool = True for top level module+-- | When IBC is being loaded - we'll load different things (and omit+-- different structures/definitions) depending on which phase we're in.+data IBCPhase = IBC_Building -- ^ when building the module tree+ | IBC_REPL Bool -- ^ when loading modules for the REPL Bool = True for top level module deriving (Show, Eq) -data IBCFile = IBCFile { ver :: Word16,- sourcefile :: FilePath,- ibc_reachablenames :: ![Name],- ibc_imports :: ![(Bool, FilePath)],- ibc_importdirs :: ![FilePath],- ibc_implicits :: ![(Name, [PArg])],- ibc_fixes :: ![FixDecl],- ibc_statics :: ![(Name, [Bool])],- ibc_classes :: ![(Name, ClassInfo)],- ibc_records :: ![(Name, RecordInfo)],- ibc_instances :: ![(Bool, Bool, Name, Name)],- ibc_dsls :: ![(Name, DSL)],- ibc_datatypes :: ![(Name, TypeInfo)],- ibc_optimise :: ![(Name, OptInfo)],- ibc_syntax :: ![Syntax],- ibc_keywords :: ![String],- ibc_objs :: ![(Codegen, FilePath)],- ibc_libs :: ![(Codegen, String)],- ibc_cgflags :: ![(Codegen, String)],- ibc_dynamic_libs :: ![String],- ibc_hdrs :: ![(Codegen, String)],- ibc_totcheckfail :: ![(FC, String)],- ibc_flags :: ![(Name, [FnOpt])],- ibc_fninfo :: ![(Name, FnInfo)],- ibc_cg :: ![(Name, CGInfo)],- ibc_docstrings :: ![(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))],- ibc_moduledocs :: ![(Name, Docstring D.DocTerm)],- ibc_transforms :: ![(Name, (Term, Term))],- ibc_errRev :: ![(Term, Term)],- ibc_coercions :: ![Name],- ibc_lineapps :: ![(FilePath, Int, PTerm)],- ibc_namehints :: ![(Name, Name)],- ibc_metainformation :: ![(Name, MetaInformation)],- ibc_errorhandlers :: ![Name],- ibc_function_errorhandlers :: ![(Name, Name, Name)], -- fn, arg, handler- ibc_metavars :: ![(Name, (Maybe Name, Int, [Name], Bool, Bool))],- ibc_patdefs :: ![(Name, ([([(Name, Term)], Term, Term)], [PTerm]))],- ibc_postulates :: ![Name],- ibc_externs :: ![(Name, Int)],- ibc_parsedSpan :: !(Maybe FC),- ibc_usage :: ![(Name, Int)],- ibc_exports :: ![Name],- ibc_autohints :: ![(Name, Name)],- ibc_deprecated :: ![(Name, String)],- ibc_defs :: ![(Name, Def)],- ibc_total :: ![(Name, Totality)],- ibc_injective :: ![(Name, Injectivity)],- ibc_access :: ![(Name, Accessibility)],- ibc_fragile :: ![(Name, String)]- }- deriving Show+data IBCFile = IBCFile {+ ver :: Word16+ , sourcefile :: FilePath+ , ibc_reachablenames :: ![Name]+ , ibc_imports :: ![(Bool, FilePath)]+ , ibc_importdirs :: ![FilePath]+ , ibc_implicits :: ![(Name, [PArg])]+ , ibc_fixes :: ![FixDecl]+ , ibc_statics :: ![(Name, [Bool])]+ , ibc_classes :: ![(Name, ClassInfo)]+ , ibc_records :: ![(Name, RecordInfo)]+ , ibc_instances :: ![(Bool, Bool, Name, Name)]+ , ibc_dsls :: ![(Name, DSL)]+ , ibc_datatypes :: ![(Name, TypeInfo)]+ , ibc_optimise :: ![(Name, OptInfo)]+ , ibc_syntax :: ![Syntax]+ , ibc_keywords :: ![String]+ , ibc_objs :: ![(Codegen, FilePath)]+ , ibc_libs :: ![(Codegen, String)]+ , ibc_cgflags :: ![(Codegen, String)]+ , ibc_dynamic_libs :: ![String]+ , ibc_hdrs :: ![(Codegen, String)]+ , ibc_totcheckfail :: ![(FC, String)]+ , ibc_flags :: ![(Name, [FnOpt])]+ , ibc_fninfo :: ![(Name, FnInfo)]+ , ibc_cg :: ![(Name, CGInfo)]+ , ibc_docstrings :: ![(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))]+ , ibc_moduledocs :: ![(Name, Docstring D.DocTerm)]+ , ibc_transforms :: ![(Name, (Term, Term))]+ , ibc_errRev :: ![(Term, Term)]+ , ibc_coercions :: ![Name]+ , ibc_lineapps :: ![(FilePath, Int, PTerm)]+ , ibc_namehints :: ![(Name, Name)]+ , ibc_metainformation :: ![(Name, MetaInformation)]+ , ibc_errorhandlers :: ![Name]+ , ibc_function_errorhandlers :: ![(Name, Name, Name)] -- fn, arg, handler+ , ibc_metavars :: ![(Name, (Maybe Name, Int, [Name], Bool, Bool))]+ , ibc_patdefs :: ![(Name, ([([(Name, Term)], Term, Term)], [PTerm]))]+ , ibc_postulates :: ![Name]+ , ibc_externs :: ![(Name, Int)]+ , ibc_parsedSpan :: !(Maybe FC)+ , ibc_usage :: ![(Name, Int)]+ , ibc_exports :: ![Name]+ , ibc_autohints :: ![(Name, Name)]+ , ibc_deprecated :: ![(Name, String)]+ , ibc_defs :: ![(Name, Def)]+ , ibc_total :: ![(Name, Totality)]+ , ibc_injective :: ![(Name, Injectivity)]+ , ibc_access :: ![(Name, Accessibility)]+ , ibc_fragile :: ![(Name, String)]+ , ibc_constraints :: ![(FC, UConstraint)]+ }+ deriving Show {-! deriving instance Binary IBCFile !-} initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] [] [] [] [] [] []+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] [] [] [] [] [] [] [] hasValidIBCVersion :: FilePath -> Idris Bool hasValidIBCVersion fp = do@@ -140,7 +150,7 @@ -- | Load an entire package from its index file loadPkgIndex :: String -> Idris ()-loadPkgIndex pkg = do ddir <- runIO $ getIdrisLibDir+loadPkgIndex pkg = do ddir <- runIO getIdrisLibDir addImportDir (ddir </> pkg) fp <- findPkgIndex pkg loadIBC True IBC_Building fp@@ -201,6 +211,8 @@ makeEntry "ibc_injective" (ibc_injective i), makeEntry "ibc_access" (ibc_access i), makeEntry "ibc_fragile" (ibc_fragile i)]+-- TODO: Put this back in shortly after minimising/pruning constraints+-- makeEntry "ibc_constraints" (ibc_constraints i)] writeArchive :: FilePath -> IBCFile -> Idris () writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArchive (entries i)@@ -221,8 +233,9 @@ (\c -> do logIBC 1 $ "Failed " ++ pshow i c) return () --- Write a package index containing all the imports in the current IState--- Used for ':search' of an entire package, to ensure everything is loaded.+-- | Write a package index containing all the imports in the current+-- IState Used for ':search' of an entire package, to ensure+-- everything is loaded. writePkgIndex :: FilePath -> Idris () writePkgIndex f = do i <- getIState@@ -329,6 +342,7 @@ ibc i (IBCAutoHint n h) f = return f { ibc_autohints = (n, h) : ibc_autohints f } ibc i (IBCDeprecate n r) f = return f { ibc_deprecated = (n, r) : ibc_deprecated f } ibc i (IBCFragile n r) f = return f { ibc_fragile = (n,r) : ibc_fragile f }+ibc i (IBCConstraint fc u) f = return f { ibc_constraints = (fc, u) : ibc_constraints f } getEntry :: (Binary b, NFData b) => b -> FilePath -> Archive -> Idris b getEntry alt f a = case findEntryByPath f a of@@ -400,6 +414,7 @@ processInjective archive processAccess reexp phase archive processFragile archive+ processConstraints archive timestampOlder :: FilePath -> FilePath -> Idris () timestampOlder src ibc = do@@ -453,6 +468,11 @@ processFragile ar = do ns <- getEntry [] "ibc_fragile" ar mapM_ (\(n,reason) -> addFragile n reason) ns++processConstraints :: Archive -> Idris ()+processConstraints ar = do+ cs <- getEntry [] "ibc_constraints" ar+ mapM_ (\ (fc, c) -> addConstraints fc (0, [c])) cs processImportDirs :: Archive -> Idris () processImportDirs ar = do
src/Idris/IdeMode.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.IdeMode+Description : Idris' IDE Mode+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-# LANGUAGE FlexibleInstances, IncoherentInstances, PatternGuards #-}@@ -251,18 +258,18 @@ | GetIdrisVersion sexpToCommand :: SExp -> Maybe IdeModeCommand-sexpToCommand (SexpList (x:[])) = sexpToCommand x-sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd)-sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix)-sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename, IntegerAtom line]) = Just (LoadFile filename (Just (fromInteger line)))-sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename]) = Just (LoadFile filename Nothing)-sexpToCommand (SexpList [SymbolAtom "type-of", StringAtom name]) = Just (TypeOf name)-sexpToCommand (SexpList [SymbolAtom "case-split", IntegerAtom line, StringAtom name]) = Just (CaseSplit (fromInteger line) name)-sexpToCommand (SexpList [SymbolAtom "add-clause", IntegerAtom line, StringAtom name]) = Just (AddClause (fromInteger line) name)-sexpToCommand (SexpList [SymbolAtom "add-proof-clause", IntegerAtom line, StringAtom name]) = Just (AddProofClause (fromInteger line) name)-sexpToCommand (SexpList [SymbolAtom "add-missing", IntegerAtom line, StringAtom name]) = Just (AddMissing (fromInteger line) name)-sexpToCommand (SexpList [SymbolAtom "make-with", IntegerAtom line, StringAtom name]) = Just (MakeWithBlock (fromInteger line) name)-sexpToCommand (SexpList [SymbolAtom "make-case", IntegerAtom line, StringAtom name]) = Just (MakeCaseBlock (fromInteger line) name)+sexpToCommand (SexpList ([x])) = sexpToCommand x+sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd)+sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix)+sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename, IntegerAtom line]) = Just (LoadFile filename (Just (fromInteger line)))+sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename]) = Just (LoadFile filename Nothing)+sexpToCommand (SexpList [SymbolAtom "type-of", StringAtom name]) = Just (TypeOf name)+sexpToCommand (SexpList [SymbolAtom "case-split", IntegerAtom line, StringAtom name]) = Just (CaseSplit (fromInteger line) name)+sexpToCommand (SexpList [SymbolAtom "add-clause", IntegerAtom line, StringAtom name]) = Just (AddClause (fromInteger line) name)+sexpToCommand (SexpList [SymbolAtom "add-proof-clause", IntegerAtom line, StringAtom name]) = Just (AddProofClause (fromInteger line) name)+sexpToCommand (SexpList [SymbolAtom "add-missing", IntegerAtom line, StringAtom name]) = Just (AddMissing (fromInteger line) name)+sexpToCommand (SexpList [SymbolAtom "make-with", IntegerAtom line, StringAtom name]) = Just (MakeWithBlock (fromInteger line) name)+sexpToCommand (SexpList [SymbolAtom "make-case", IntegerAtom line, StringAtom name]) = Just (MakeCaseBlock (fromInteger line) name) -- The Boolean in ProofSearch means "search recursively" -- If it's False, that means "refine", i.e. apply the name and fill in any -- arguments which can be done by unification.
src/Idris/IdrisDoc.hs view
@@ -1,8 +1,13 @@+{-|+Module : Idris.IdrisDoc+Description : Generation of HTML documentation for Idris code+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}---- | Generation of HTML documentation for Idris code module Idris.IdrisDoc (generateDocs) where import Idris.Core.TT (Name (..), sUN, SpecialName (..), OutputAnnotation (..),@@ -175,7 +180,6 @@ -- | Whether a Name names something which should be documented filterName :: Name -- ^ Name to check -> Bool -- ^ Predicate result-filterName (UN n) | '@':'@':_ <- str n = False filterName (UN _) = True filterName (NS n _) = filterName n filterName _ = False@@ -419,7 +423,7 @@ createIndex nss out = do (path, h) <- openTempFile out "index.html" BS2.hPut h $ renderHtml $ wrapper Nothing $ do- H.h1 $ "Namespaces"+ H.h1 "Namespaces" H.ul ! class_ "names" $ do let path ns = "docs" ++ "/" ++ genRelNsPath ns "html" item ns = do let n = toHtml $ nsName2Str ns@@ -519,7 +523,7 @@ docExtractor (_, _, _, Nothing) = Nothing docExtractor (n, _, _, Just d) = Just (n, doc2Str d) -- TODO: Remove <p> tags more robustly- doc2Str d = let dirty = renderMarkup $ contents $ Docstrings.renderHtml $ d+ doc2Str d = let dirty = renderMarkup $ contents $ Docstrings.renderHtml d in take (length dirty - 8) $ drop 3 dirty name (NS n ns) = show (NS (sUN $ name n) ns)
src/Idris/Imports.hs view
@@ -1,5 +1,14 @@-module Idris.Imports(IFileType(..), findImport, findInPath, findPkgIndex,- ibcPathNoFallback, installedPackages, pkgIndex) where+{-|+Module : Idris.Imports+Description : Code to handle import declarations.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+module Idris.Imports(+ IFileType(..), findImport, findInPath, findPkgIndex+ , ibcPathNoFallback, installedPackages, pkgIndex+ ) where import Control.Applicative ((<$>)) import Data.List (isSuffixOf)@@ -103,11 +112,11 @@ goodDir idir d = any (".ibc" `isSuffixOf`) <$> allFilesInDir idir d --- Case sensitive file existence check for Mac OS X.+-- | Case sensitive file existence check for Mac OS X. doesFileExist' :: FilePath -> IO Bool doesFileExist' = caseSensitive doesFileExist --- Case sensitive directory existence check for Mac OS X.+-- | Case sensitive directory existence check for Mac OS X. doesDirectoryExist' :: FilePath -> IO Bool doesDirectoryExist' = caseSensitive doesDirectoryExist
src/Idris/Inliner.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Inliner+Description : Idris' Inliner.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module Idris.Inliner(inlineDef, inlineTerm) where@@ -8,8 +15,8 @@ inlineDef :: IState -> [([Name], Term, Term)] -> [([Name], Term, Term)] inlineDef ist ds = map (\ (ns, lhs, rhs) -> (ns, lhs, inlineTerm ist rhs)) ds --- Inlining is either top level (i.e. not in a function arg) or argument level-+-- | Inlining is either top level (i.e. not in a function arg) or argument level+-- -- For each application in a term: -- * Check if the function is inlinable -- (Dictionaries are inlinable in an argument, not otherwise)@@ -17,7 +24,6 @@ -- + If successful, then continue on the result (top level) -- + If not, reduce the arguments (argument level) and try again -- - If not, inline all the arguments (top level)- inlineTerm :: IState -> Term -> Term inlineTerm ist tm = inl tm where inl orig@(P _ n _) = inlApp n [] orig@@ -28,4 +34,3 @@ inl tm = tm inlApp fn args orig = orig-
src/Idris/Interactive.hs view
@@ -1,11 +1,18 @@-{-# LANGUAGE PatternGuards #-}+{-|+Module : Idris.Interactive+Description : Bits and pieces for editing source files interactively, called from the REPL+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} -module Idris.Interactive(caseSplitAt, addClauseFrom, addProofClauseFrom,- addMissing, makeWith, makeCase, doProofSearch,- makeLemma) where+{-# LANGUAGE PatternGuards #-} -{- Bits and pieces for editing source files interactively, called from- the REPL -}+module Idris.Interactive(+ caseSplitAt, addClauseFrom, addProofClauseFrom+ , addMissing, makeWith, makeCase, doProofSearch+ , makeLemma+ ) where import Idris.Core.TT import Idris.Core.Evaluate@@ -13,6 +20,7 @@ import Idris.AbsSyntax import Idris.ElabDecls import Idris.Error+import Idris.ErrReverse import Idris.Delaborate import Idris.Output import Idris.IdeMode hiding (IdeModeCommand(..))@@ -239,8 +247,8 @@ (ProofSearch rec False depth t psnames hints)] let def = PClause fc mn (PRef fc [] mn) [] (body top) [] newmv_pre <- idrisCatch- (do elabDecl' EAll recinfo (PClauses fc [] mn [def])- (tm, ty) <- elabVal recinfo ERHS (PRef fc [] mn)+ (do elabDecl' EAll (recinfo (fileFC "proofsearch")) (PClauses fc [] mn [def])+ (tm, ty) <- elabVal (recinfo (fileFC "proofsearch")) ERHS (PRef fc [] mn) ctxt <- getContext i <- getIState return . flip displayS "" . renderPretty 1.0 80 $@@ -326,11 +334,14 @@ let isProv = checkProv tyline (show n) ctxt <- getContext- (fname, mty) <- case lookupTyName n ctxt of- [t] -> return t- [] -> ierror (NoSuchVariable n)- ns -> ierror (CantResolveAlts (map fst ns))+ (fname, mty_full) <- case lookupTyName n ctxt of+ [t] -> return t+ [] -> ierror (NoSuchVariable n)+ ns -> ierror (CantResolveAlts (map fst ns))+ i <- getIState+ let mty = errReverse i mty_full+ margs <- case lookup fname (idris_metavars i) of Just (_, arity, _, _, _) -> return arity _ -> return (-1)@@ -369,7 +380,7 @@ runIO $ writeSource fb (addProv before tyline lem_app later) runIO $ copyFile fb fn else case idris_outputmode i of- RawOutput _ -> iPrintResult $ lem_app+ RawOutput _ -> iPrintResult lem_app IdeMode n h -> let good = SexpList [SymbolAtom "ok", SexpList [SymbolAtom "provisional-definition-lemma",@@ -484,7 +495,7 @@ addLem before tyline lem lem_app later = let (bef_end, blankline : bef_start) = case span (not . blank) (reverse before) of- (bef, []) -> (bef, "" : [])+ (bef, []) -> (bef, [""]) x -> x mvline = updateMeta tyline (show n) lem_app in unlines $ reverse bef_start ++@@ -494,7 +505,7 @@ addProv before tyline lem_app later = let (later_bef, blankline : later_end) = case span (not . blank) later of- (bef, []) -> (bef, "" : [])+ (bef, []) -> (bef, [""]) x -> x in unlines $ before ++ tyline : (later_bef ++ [blankline, lem_app, blankline] ++
src/Idris/Output.hs view
@@ -1,3 +1,11 @@+{-|+Module : Idris.Output+Description : Utilities to display Idris' internals and other informtation to the user.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+ {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Output where@@ -99,7 +107,7 @@ let output = vsep (map (uncurry (ppOverload ppo infixes)) overloads) iRenderResult output where fullName ppo n | length overloads > 1 = prettyName True True bnd n- | otherwise = prettyName True (ppopt_impl ppo) bnd n + | otherwise = prettyName True (ppopt_impl ppo) bnd n ppOverload ppo infixes n tm = fullName ppo n <+> colon <+> align tm
src/Idris/Parser.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Parser+Description : Idris' parser.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-} {-# OPTIONS_GHC -O0 #-} module Idris.Parser(module Idris.Parser,@@ -89,7 +96,7 @@ {- * Main grammar -} -{- | Parses module definition+{-| Parses module definition @ ModuleHeader ::= DocComment_t? 'module' Identifier_t ';'?;@@ -122,7 +129,7 @@ , import_modname_location :: FC } -{- | Parses an import statement+{-| Parses an import statement @ Import ::= 'import' Identifier_t ';'?;@@ -144,7 +151,7 @@ where ns = Spl.splitOn "." toPath = foldl1' (</>) . ns -{- | Parses program source+{-| Parses program source @ Prog ::= Decl* EOF;@@ -238,7 +245,7 @@ continue False (PClauses _ _ _ _) = True continue c _ = c -{- | Parses a top-level declaration with possible syntax sugar+{-| Parses a top-level declaration with possible syntax sugar @ Decl' ::=@@ -387,7 +394,7 @@ highlightP fc AnnKeyword return Nothing -{- | Parses a syntax extension declaration (and adds the rule to parser state)+{-| Parses a syntax extension declaration (and adds the rule to parser state) @ SyntaxDecl ::= SyntaxRule;@@ -418,7 +425,7 @@ ns = syntax_keywords i ks = map show (syntaxNames s) -{- | Parses a syntax extension declaration+{-| Parses a syntax extension declaration @ SyntaxRuleOpts ::= 'term' | 'pattern';@@ -545,7 +552,7 @@ put ist { idris_name = idx + 1 } return $ sMN idx (show n) -{- | Parses a syntax symbol (either binding variable, keyword or expression)+{-| Parses a syntax symbol (either binding variable, keyword or expression) @ SyntaxSym ::= '[' Name_t ']'@@ -566,7 +573,7 @@ return (Symbol sym) <?> "syntax symbol" -{- | Parses a function declaration with possible syntax sugar+{-| Parses a function declaration with possible syntax sugar @ FunDecl ::= FunDecl';@@ -695,7 +702,9 @@ <|> do try (lchar '%' *> reserved "inline"); return Inlinable <|> do try (lchar '%' *> reserved "assert_total");- return AssertTotal+ fc <- getFC+ parserWarning fc Nothing (Msg "%assert_total is deprecated. Use the 'assert_total' function instead.")+ return AssertTotal <|> do try (lchar '%' *> reserved "error_handler"); return ErrorHandler <|> do try (lchar '%' *> reserved "error_reverse");@@ -715,7 +724,7 @@ return (Just (fromInteger reds))) return (n, t) -{- | Parses a postulate+{-| Parses a postulate @ Postulate ::=@@ -742,8 +751,9 @@ <?> "postulate" where ppostDecl = do fc <- reservedHL "postulate"; return False <|> do lchar '%'; reserved "extern"; return True-{- | Parses a using declaration +{-| Parses a using declaration+ @ Using ::= 'using' '(' UsingDeclList ')' OpenBlock Decl* CloseBlock@@ -761,14 +771,14 @@ return (concat ds) <?> "using declaration" -{- | Parses a parameters declaration+{-| Parses a parameters declaration @ Params ::= 'parameters' '(' TypeDeclList ')' OpenBlock Decl* CloseBlock ; @- -}+-} params :: SyntaxInfo -> IdrisParser [PDecl] params syn = do reservedHL "parameters"; lchar '('; ns <- typeDeclList syn; lchar ')'@@ -781,10 +791,7 @@ return [PParams fc ns' (concat ds)] <?> "parameters declaration" -{- | Parses an open block---}-+-- | Parses an open block openInterface :: SyntaxInfo -> IdrisParser [PDecl] openInterface syn = do reservedHL "using"@@ -801,8 +808,9 @@ -{- | Parses a mutual declaration (for mutually recursive functions) +{-| Parses a mutual declaration (for mutually recursive functions)+ @ Mutual ::= 'mutual' OpenBlock Decl* CloseBlock@@ -838,7 +846,7 @@ return [PNamespace n nfc (concat ds)] <?> "namespace declaration" -{- | Parses a methods block (for instances)+{-| Parses a methods block (for instances) @ InstanceBlock ::= 'where' OpenBlock FnDecl* CloseBlock@@ -852,7 +860,7 @@ return (concat ds) <?> "implementation block" -{- | Parses a methods and instances block (for type classes)+{-| Parses a methods and instances block (for type classes) @ MethodOrInstance ::=@@ -941,7 +949,7 @@ fc <- getFC return (i, ifc, PType fc) -{- | Parses a type class instance declaration+{-| Parses a type class instance declaration @ Instance ::=@@ -1003,7 +1011,7 @@ return (doc', argDocs') -{- | Parses a using declaration list+{-| Parses a using declaration list @ UsingDeclList ::=@@ -1035,7 +1043,7 @@ return (map (\x -> UImplicit x t) ns) <?> "using declaration list" -{- |Parses a using declaration+{-| Parses a using declaration @ UsingDecl ::=@@ -1054,7 +1062,7 @@ return (UConstraint c xs) <?> "using declaration" -{- | Parse a clause with patterns+{-| Parse a clause with patterns @ Pattern ::= Clause;@@ -1066,7 +1074,7 @@ return (PClauses fc [] (sMN 2 "_") [clause]) -- collect together later <?> "pattern" -{- | Parse a constant applicative form declaration+{-| Parse a constant applicative form declaration @ CAF ::= 'let' FnName '=' Expr Terminator;@@ -1083,7 +1091,7 @@ return (PCAF fc n t) <?> "constant applicative form declaration" -{- | Parse an argument expression+{-| Parse an argument expression @ ArgExpr ::= HSimpleExpr | {- In Pattern External (User-defined) Expression -};@@ -1094,7 +1102,7 @@ try (hsimpleExpr syn') <|> simpleExternalExpr syn' <?> "argument expression" -{- | Parse a right hand side of a function+{-| Parse a right hand side of a function @ RHS ::= '=' Expr@@ -1130,7 +1138,7 @@ where addLetC (l, r) = (l, addLet fc nm r) addLet fc nm r = (PLet fc (sUN "value") NoFC Placeholder r (PMetavar NoFC nm)) -{- |Parses a function clause+{-|Parses a function clause @ RHSOrWithBlock ::= RHS WhereOrTerminator@@ -1296,7 +1304,7 @@ expr' (syn { inPattern = True }) <?> "with pattern" -{- | Parses a where block+{-| Parses a where block @ WhereBlock ::= 'where' OpenBlock Decl+ CloseBlock;@@ -1310,7 +1318,7 @@ return (concat ds, map (\x -> (x, decoration syn x)) dns) <?> "where block" -{- |Parses a code generation target language name+{-|Parses a code generation target language name @ Codegen ::= 'C'@@ -1328,7 +1336,7 @@ <|> do reserved "Bytecode"; return Bytecode <?> "code generation language" -{- |Parses a compiler directive+{-|Parses a compiler directive @ StringList ::= String@@ -1347,6 +1355,7 @@ | 'include' CodeGen String_t | 'hide' Name | 'freeze' Name+ | 'thaw' Name | 'access' Accessibility | 'default' Totality | 'logging' Natural@@ -1379,10 +1388,16 @@ return [PDirective (DHide n)] <|> do try (lchar '%' *> reserved "freeze"); n <- fst <$> iName [] return [PDirective (DFreeze n)]+ <|> do try (lchar '%' *> reserved "thaw"); n <- fst <$> iName []+ return [PDirective (DThaw n)] -- injectivity assertins are intended for debugging purposes -- only, and won't be documented/could be removed at any point <|> do try (lchar '%' *> reserved "assert_injective"); n <- fst <$> fnName return [PDirective (DInjective n)]+ -- Assert totality of something after definition. This is+ -- here as a debugging aid, so commented out...+-- <|> do try (lchar '%' *> reserved "assert_set_total"); n <- fst <$> fnName+-- return [PDirective (DSetTotal n)] <|> do try (lchar '%' *> reserved "access") acc <- accessibility ist <- get@@ -1433,7 +1448,7 @@ pLangExt = (reserved "TypeProviders" >> return TypeProviders) <|> (reserved "ErrorReflection" >> return ErrorReflection) -{- | Parses a totality+{-| Parses a totality @ Totality ::= 'partial' | 'total' | 'covering'@@ -1446,7 +1461,7 @@ <|> do reservedHL "partial"; return DefaultCheckingPartial <|> do reservedHL "covering"; return DefaultCheckingCovering -{- | Parses a type provider+{-| Parses a type provider @ Provider ::= DocComment_t? '%' 'provide' Provider_What? '(' FnName TypeSig ')' 'with' Expr;@@ -1476,7 +1491,7 @@ e <- expr syn <?> "provider expression" return [PProvider doc syn fc nfc (ProvPostulate e) n] -{- | Parses a transform+{-| Parses a transform @ Transform ::= '%' 'transform' Expr '==>' Expr@@ -1495,7 +1510,7 @@ return [PTransform fc False l r] <?> "transform" -{- | Parses a top-level reflected elaborator script+{-| Parses a top-level reflected elaborator script @ RunElabDecl ::= '%' 'runElab' Expr@@ -1513,19 +1528,19 @@ <?> "top-level elaborator script" {- * Loading and parsing -}-{- | Parses an expression from input -}+{-| Parses an expression from input -} parseExpr :: IState -> String -> Result PTerm parseExpr st = runparser (fullExpr defaultSyntax) st "(input)" -{- | Parses a constant form input -}+{-| Parses a constant form input -} parseConst :: IState -> String -> Result Const parseConst st = runparser (fmap fst constant) st "(input)" -{- | Parses a tactic from input -}+{-| Parses a tactic from input -} parseTactic :: IState -> String -> Result PTactic parseTactic st = runparser (fullTactic defaultSyntax) st "(input)" -{- | Parses a do-step from input (used in the elab shell) -}+{-| Parses a do-step from input (used in the elab shell) -} parseElabShellStep :: IState -> String -> Result (Either ElabShellCmd PDo) parseElabShellStep ist = runparser (fmap Right (do_ defaultSyntax) <|> fmap Left elabShellCmd) ist "(input)" where elabShellCmd = char ':' >>@@ -1639,7 +1654,7 @@ i' <- get return (ds, i') -{- | Load idris module and show error if something wrong happens -}+{-| Load idris module and show error if something wrong happens -} loadModule :: FilePath -> IBCPhase -> Idris (Maybe String) loadModule f phase = idrisCatch (loadModule' f phase)@@ -1648,7 +1663,7 @@ iWarn (getErrSpan e) $ pprintErr ist e return Nothing) -{- | Load idris module -}+{-| Load idris module -} loadModule' :: FilePath -> IBCPhase -> Idris (Maybe String) loadModule' f phase = do i <- getIState@@ -1671,7 +1686,7 @@ LIDR sfn -> loadSource True sfn Nothing) return $ Just file -{- | Load idris code from file -}+{-| Load idris code from file -} loadFromIFile :: Bool -> IBCPhase -> IFileType -> Maybe Int -> Idris () loadFromIFile reexp phase i@(IBC fn src) maxline = do logParser 1 $ "Skipping " ++ getSrcFile i@@ -1695,7 +1710,7 @@ At f e' -> iWarn f (pprintErr ist e') _ -> iWarn (getErrSpan e) (pprintErr ist e)) -{- | Load Idris source code-}+{-| Load Idris source code-} loadSource :: Bool -> FilePath -> Maybe Int -> Idris () loadSource lidr f toline = do logParser 1 ("Reading " ++ f)@@ -1791,7 +1806,7 @@ -- we totality check after every Mutual block, so if -- anything is a single definition, wrap it in a -- mutual block on its own- elabDecls toplevel (map toMutual ds)+ elabDecls (toplevelWith f) (map toMutual ds) i <- getIState -- simplify every definition do give the totality checker -- a better chance@@ -1806,6 +1821,7 @@ i <- getIState mapM_ buildSCG (idris_totcheck i) mapM_ checkDeclTotality (idris_totcheck i)+ mapM_ verifyTotality (idris_totcheck i) -- Redo totality check for deferred names let deftots = idris_defertotcheck i@@ -1870,7 +1886,7 @@ addModDoc :: SyntaxInfo -> [String] -> Docstring () -> Idris () addModDoc syn mname docs = do ist <- getIState- docs' <- elabDocTerms recinfo (parsedDocs ist)+ docs' <- elabDocTerms (toplevelWith f) (parsedDocs ist) let modDocs' = addDef docName docs' (idris_moduledocs ist) putIState ist { idris_moduledocs = modDocs' } addIBC (IBCModDocs docName)@@ -1878,7 +1894,7 @@ docName = NS modDocName (map T.pack (reverse mname)) parsedDocs ist = annotCode (tryFullExpr syn ist) docs -{- | Adds names to hide list -}+{-| Adds names to hide list -} addHides :: Ctxt Accessibility -> Idris () addHides xs = do i <- getIState let defh = default_access i
src/Idris/Parser/Data.hs view
@@ -1,12 +1,21 @@+{-|+Module : Idris.Parser.Data+Description : Parse Data declarations.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-} module Idris.Parser.Data where import Prelude hiding (pi) import Text.Trifecta.Delta-import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace, Err)-import Text.Parser.LookAhead-import Text.Parser.Expression+import Text.Trifecta hiding ( span, stringLiteral, charLiteral, natural+ , symbol, char, string, whiteSpace, Err)++import Text.Parser.LookAhead+import Text.Parser.Expression import qualified Text.Parser.Token as Tok import qualified Text.Parser.Char as Chr import qualified Text.Parser.Token.Highlight as Hi@@ -26,18 +35,18 @@ import Control.Monad import Control.Monad.State.Strict -import Data.Maybe+import Data.Maybe import qualified Data.List.Split as Spl-import Data.List-import Data.Monoid-import Data.Char+import Data.List+import Data.Monoid+import Data.Char import qualified Data.HashSet as HS import qualified Data.Text as T import qualified Data.ByteString.UTF8 as UTF8 import Debug.Trace -{- |Parses a record type declaration+{- | Parses a record type declaration Record ::= DocComment Accessibility? 'record' FnName TypeSig 'where' OpenBlock Constructor KeepTerminator CloseBlock; -}@@ -223,7 +232,7 @@ let kw = (if DefaultEliminator `elem` dataOpts then "%elim" else "") ++ (if Codata `elem` dataOpts then "co" else "") ++ "data " let n = show tyn_in ++ " " let s = kw ++ n- let as = concat (intersperse " " $ map show args) ++ " "+ let as = unwords (map show args) ++ " " let ns = concat (intersperse " -> " $ map ((\x -> "(" ++ x ++ " : Type)") . show) args) let ss = concat (intersperse " -> " $ map (const "Type") args) let fix1 = s ++ as ++ " = ..."
src/Idris/Parser/Expr.hs view
@@ -1,4 +1,12 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, TupleSections #-}+{-|+Module : Idris.Parser.Expr+Description : Parse Expressions.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds #-}+{-# LANGUAGE PatternGuards, TupleSections #-} module Idris.Parser.Expr where import Prelude hiding (pi)@@ -80,7 +88,7 @@ -} opExpr :: SyntaxInfo -> IdrisParser PTerm opExpr syn = do i <- get- buildExpressionParser (table (idris_infixes i)) + buildExpressionParser (table (idris_infixes i)) (expr' syn) {- | Parses either an internally defined expression or@@ -491,7 +499,7 @@ {-| Parses the rest of a dependent pair after '(' or '(Expr **' -} dependentPair :: PunInfo -> [(PTerm, Maybe (FC, PTerm), FC)] -> FC -> SyntaxInfo -> IdrisParser PTerm dependentPair pun prev openFC syn =- if prev == [] then+ if null prev then nametypePart <|> namePart else case pun of@@ -955,8 +963,8 @@ fc <- getFC prf <- expr syn giving <- optional (do symbol "==>"; expr' syn)- using <- optional (do reserved "using" - (n, _) <- name + using <- optional (do reserved "using"+ (n, _) <- name return n) kw' <- reservedFC "in"; sc <- expr syn highlightP kw AnnKeyword@@ -1095,10 +1103,10 @@ sc <- expr syn let (im,cl) = if implicitAllowed syn- then (Imp opts st False (Just (Impl False True)) True,+ then (Imp opts st False (Just (Impl False True False)) True, constraint)- else (Imp opts st False (Just (Impl False False)) True,- Imp opts st False (Just (Impl True False)) True)+ else (Imp opts st False (Just (Impl False False False)) True,+ Imp opts st False (Just (Impl True False False)) True) return (bindList (PPi im) xt (bindList (PPi cl) cs sc)) @@ -1107,7 +1115,7 @@ sc <- expr syn if implicitAllowed syn then return (bindList (PPi constraint) cs sc)- else return (bindList (PPi (Imp opts st False (Just (Impl True False)) True))+ else return (bindList (PPi (Imp opts st False (Just (Impl True False False)) True)) cs sc) implicitPi opts st syn =@@ -1122,15 +1130,26 @@ return (PPi binder (sUN "__pi_arg") NoFC x sc)) <|> return x +-- This is used when we need to disambiguate from a constraint list+unboundPiNoConstraint opts st syn = do+ x <- opExpr syn+ (do binder <- bindsymbol opts st syn+ sc <- expr syn+ notFollowedBy $ reservedOp "=>"+ return (PPi binder (sUN "__pi_arg") NoFC x sc))+ <|> do notFollowedBy $ reservedOp "=>"+ return x++ pi :: SyntaxInfo -> IdrisParser PTerm pi syn = do opts <- piOpts syn st <- static explicitPi opts st syn <|> try (do lchar '{'; implicitPi opts st syn)- <|> if constraintAllowed syn - then try (constraintPi opts st syn)- <|> unboundPi opts st syn+ <|> if constraintAllowed syn+ then try (unboundPiNoConstraint opts st syn)+ <|> constraintPi opts st syn else unboundPi opts st syn <?> "dependent type signature"
src/Idris/Parser/Helpers.hs view
@@ -1,4 +1,12 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, StandaloneDeriving #-}+{-|+Module : Idris.Parser.Helpers+Description : Utilities for Idris' parser.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ConstraintKinds #-}+{-# LANGUAGE PatternGuards, StandaloneDeriving #-} #if !(MIN_VERSION_base(4,8,0)) {-# LANGUAGE OverlappingInstances #-} #endif
src/Idris/Parser/Ops.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Parser.Ops+Description : Parser for operators and fixity declarations.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-} module Idris.Parser.Ops where
src/Idris/PartialEval.hs view
@@ -1,8 +1,17 @@+{-|+Module : Idris.PartialEval+Description : Implementation of a partial evaluator.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} -module Idris.PartialEval(partial_eval, getSpecApps, specType,- mkPE_TyDecl, mkPE_TermDecl, PEArgType(..),- pe_app, pe_def, pe_clauses, pe_simple) where+module Idris.PartialEval(+ partial_eval, getSpecApps, specType+ , mkPE_TyDecl, mkPE_TermDecl, PEArgType(..)+ , pe_app, pe_def, pe_clauses, pe_simple+ ) where import Idris.AbsSyntax import Idris.Delaborate@@ -27,11 +36,12 @@ -- | A partially evaluated function. pe_app captures the lhs of the -- new definition, pe_def captures the rhs, and pe_clauses is the -- specialised implementation.--- pe_simple is set if the result is always reducible, because in such a--- case we'll also need to reduce the static argument+--+-- pe_simple is set if the result is always reducible, because in such+-- a case we'll also need to reduce the static argument data PEDecl = PEDecl { pe_app :: PTerm, -- new application pe_def :: PTerm, -- old application- pe_clauses :: [(PTerm, PTerm)], -- clauses of new application + pe_clauses :: [(PTerm, PTerm)], -- clauses of new application pe_simple :: Bool -- if just one reducible clause } @@ -42,14 +52,14 @@ -- must have reduced at least once. -- If we don't do this, we might end up making an infinite function after -- applying the transformation.-partial_eval :: Context -> - [(Name, Maybe Int)] ->- [Either Term (Term, Term)] ->- Maybe [Either Term (Term, Term)]+partial_eval :: Context+ -> [(Name, Maybe Int)]+ -> [Either Term (Term, Term)]+ -> Maybe [Either Term (Term, Term)] partial_eval ctxt ns_in tms = mapM peClause tms where ns = squash ns_in- squash ((n, Just x) : ns) - | Just (Just y) <- lookup n ns + squash ((n, Just x) : ns)+ | Just (Just y) <- lookup n ns = squash ((n, Just (x + y)) : drop n ns) | otherwise = (n, Just x) : squash ns squash (n : ns) = n : squash ns@@ -58,7 +68,7 @@ drop n ((m, _) : ns) | n == m = ns drop n (x : ns) = x : drop n ns drop n [] = []- + -- If the term is not a clause, it is simply kept as is peClause (Left t) = Just $ Left t -- If the term is a clause, specialise the right hand side@@ -68,7 +78,7 @@ return (Right (lhs, rhs')) -- TMP HACK until I do PE by WHNF rather than using main evaluator- toLimit (n, Nothing) | isTCDict n ctxt = (n, 2) + toLimit (n, Nothing) | isTCDict n ctxt = (n, 2) toLimit (n, Nothing) = (n, 65536) -- somewhat arbitrary reduction limit toLimit (n, Just l) = (n, l) @@ -103,7 +113,7 @@ unifyEq (imp@(ImplicitD, v) : xs) (Bind n (Pi i t k) sc) = do amap <- get case lookup imp amap of- Just n' -> + Just n' -> do put (amap ++ [((UnifiedD, Erased), n)]) sc' <- unifyEq xs (subst n (P Bound n' Erased) sc) return (Bind n (Pi i t k) sc') -- erase later@@ -119,12 +129,12 @@ put (args ++ (zip xs (repeat (sUN "_")))) return t --- | Creates an Idris type declaration given current state and a +-- | Creates an Idris type declaration given current state and a -- specialised TT function application type. -- Can be used in combination with the output of 'specType'. -- -- This should: specialise any static argument position, then generalise--- over any function applications in the result. +-- over any function applications in the result. mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm mkPE_TyDecl ist args ty = mkty args ty where@@ -132,7 +142,7 @@ = PPi expl n NoFC (delab ist (generaliseIn t)) (mkty xs sc) mkty ((ImplicitD, v) : xs) (Bind n (Pi _ t k) sc) | concreteClass ist t = mkty xs sc- | classConstraint ist t + | classConstraint ist t = PPi constraint n NoFC (delab ist (generaliseIn t)) (mkty xs sc) | otherwise = PPi impl n NoFC (delab ist (generaliseIn t)) (mkty xs sc) @@ -141,7 +151,7 @@ mkty [] t = delab ist t generaliseIn tm = evalState (gen tm) 0- + gen tm | (P _ fn _, args) <- unApply tm, isFnName fn (tt_ctxt ist) = do nm <- get@@ -166,26 +176,26 @@ | (P _ c _, args) <- unApply v = all concrete args | otherwise = False where concrete (Constant _) = True- concrete tm | (P _ n _, args) <- unApply tm + concrete tm | (P _ n _, args) <- unApply tm = case lookupTy n (tt_ctxt ist) of [_] -> all concrete args _ -> False | otherwise = False -mkNewPats :: IState ->- [(Term, Term)] -> -- definition to specialise- [(PEArgType, Term)] -> -- arguments to specialise with- Name -> -- New name- Name -> -- Specialised function name- PTerm -> -- Default lhs- PTerm -> -- Default rhs- PEDecl+mkNewPats :: IState+ -> [(Term, Term)] -- ^ definition to specialise+ -> [(PEArgType, Term)] -- ^ arguments to specialise with+ -> Name -- ^ New name+ -> Name -- ^ Specialised function name+ -> PTerm -- ^ Default lhs+ -> PTerm -- ^ Default rhs+ -> PEDecl -- If all of the dynamic positions on the lhs are variables (rather than -- patterns or constants) then we can just make a simple definition -- directly applying the specialised function, since we know the -- definition isn't going to block on any of the dynamic arguments -- in this case-mkNewPats ist d ns newname sname lhs rhs | all dynVar (map fst d) +mkNewPats ist d ns newname sname lhs rhs | all dynVar (map fst d) = PEDecl lhs rhs [(lhs, rhs)] True where dynVar ap = case unApply ap of (_, args) -> dynArgs ns args@@ -197,32 +207,32 @@ -- do some more work dynArgs (_ : ns) (V _ : as) = dynArgs ns as dynArgs (_ : ns) (P _ _ _ : as) = dynArgs ns as- dynArgs _ _ = False -- and now we'll get stuck + dynArgs _ _ = False -- and now we'll get stuck mkNewPats ist d ns newname sname lhs rhs = PEDecl lhs rhs (map mkClause d) False- where + where mkClause :: (Term, Term) -> (PTerm, PTerm) mkClause (oldlhs, oldrhs)- = let (_, as) = unApply oldlhs + = let (_, as) = unApply oldlhs lhsargs = mkLHSargs [] ns as lhs = PApp emptyFC (PRef emptyFC [] newname) lhsargs- rhs = PApp emptyFC (PRef emptyFC [] sname) + rhs = PApp emptyFC (PRef emptyFC [] sname) (mkRHSargs ns lhsargs) in (lhs, rhs) mkLHSargs _ [] _ = [] -- dynamics don't appear if they're implicit- mkLHSargs sub ((ExplicitD, t) : ns) (a : as) + mkLHSargs sub ((ExplicitD, t) : ns) (a : as) = pexp (delab ist (substNames sub a)) : mkLHSargs sub ns as- mkLHSargs sub ((ImplicitD, _) : ns) (a : as) + mkLHSargs sub ((ImplicitD, _) : ns) (a : as) = mkLHSargs sub ns as- mkLHSargs sub ((UnifiedD, _) : ns) (a : as) + mkLHSargs sub ((UnifiedD, _) : ns) (a : as) = mkLHSargs sub ns as -- statics get dropped in any case- mkLHSargs sub ((ImplicitS, t) : ns) (a : as) + mkLHSargs sub ((ImplicitS, t) : ns) (a : as) = mkLHSargs (extend a t sub) ns as- mkLHSargs sub ((ExplicitS, t) : ns) (a : as) + mkLHSargs sub ((ExplicitS, t) : ns) (a : as) = mkLHSargs (extend a t sub) ns as mkLHSargs sub _ [] = [] -- no more LHS @@ -237,20 +247,23 @@ mkSubst :: (Term, Term) -> Maybe (Name, Term) mkSubst (P _ n _, t) = Just (n, t) mkSubst _ = Nothing- + -- | Creates a new declaration for a specialised function application. -- Simple version at the moment: just create a version which is a direct -- application of the function to be specialised. -- More complex version to do: specialise the definition clause by clause-mkPE_TermDecl :: IState -> Name -> Name ->- [(PEArgType, Term)] -> PEDecl-mkPE_TermDecl ist newname sname ns - = let lhs = PApp emptyFC (PRef emptyFC [] newname) (map pexp (mkp ns)) - rhs = eraseImps $ delab ist (mkApp (P Ref sname Erased) (map snd ns)) +mkPE_TermDecl :: IState+ -> Name+ -> Name+ -> [(PEArgType, Term)]+ -> PEDecl+mkPE_TermDecl ist newname sname ns+ = let lhs = PApp emptyFC (PRef emptyFC [] newname) (map pexp (mkp ns))+ rhs = eraseImps $ delab ist (mkApp (P Ref sname Erased) (map snd ns)) patdef = lookupCtxtExact sname (idris_patdefs ist) newpats = case patdef of Nothing -> PEDecl lhs rhs [(lhs, rhs)] True- Just d -> mkNewPats ist (getPats d) ns + Just d -> mkNewPats ist (getPats d) ns newname sname lhs rhs in newpats where @@ -269,8 +282,10 @@ deImpArg a = a -- | Get specialised applications for a given function-getSpecApps :: IState -> [Name] -> Term -> - [(Name, [(PEArgType, Term)])]+getSpecApps :: IState+ -> [Name]+ -> Term+ -> [(Name, [(PEArgType, Term)])] getSpecApps ist env tm = ga env (explicitNames tm) where -- staticArg env True _ tm@(P _ n _) _ | n `elem` env = Just (True, tm)@@ -326,7 +341,7 @@ -- There's an overlap if the case tree has a default case along with -- some other cases. It's fine if there's a default case on its own.- noOverlapAlts (ConCase _ _ _ sc : rest) + noOverlapAlts (ConCase _ _ _ sc : rest) = noOverlapAlts rest && noOverlap sc noOverlapAlts (FnCase _ _ sc : rest) = noOverlapAlts rest noOverlapAlts (ConstCase _ sc : rest)@@ -335,4 +350,3 @@ = noOverlapAlts rest && noOverlap sc noOverlapAlts (DefaultCase _ : _) = False noOverlapAlts _ = True-
src/Idris/Primitives.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Primitives+Description : Provision of primitive data types.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE RankNTypes, ScopedTypeVariables, PatternGuards #-} module Idris.Primitives(primitives, Prim(..)) where@@ -27,7 +34,7 @@ ty :: [Const] -> Const -> Type ty [] x = Constant x-ty (t:ts) x = Bind (sMN 0 "T") (Pi Nothing (Constant t) (TType (UVar (-3)))) (ty ts x)+ty (t:ts) x = Bind (sMN 0 "T") (Pi Nothing (Constant t) (TType (UVar [] (-3)))) (ty ts x) total, partial, iopartial :: Totality total = Total []
src/Idris/ProofSearch.hs view
@@ -1,6 +1,19 @@+{-|+Module : Idris.ProofSearch+Description : Searches current context for proofs'+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+ {-# LANGUAGE PatternGuards #-} -module Idris.ProofSearch(trivial, trivialHoles, proofSearch, resolveTC) where+module Idris.ProofSearch(+ trivial+ , trivialHoles+ , proofSearch+ , resolveTC+ ) where import Idris.Core.Elaborate hiding (Tactic(..)) import Idris.Core.TT@@ -113,17 +126,18 @@ lift $ tfail $ CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env) -proofSearch :: Bool -> -- recursive search (False for 'refine')- Bool -> -- invoked from a tactic proof. If so, making- -- new metavariables is meaningless, and there shoudl- -- be an error reported instead.- Bool -> -- ambiguity ok- Bool -> -- defer on failure- Int -> -- maximum depth- (PTerm -> ElabD ()) -> Maybe Name -> Name ->- [Name] ->- [Name] ->- IState -> ElabD ()+proofSearch :: Bool -- ^ recursive search (False for 'refine')+ -> Bool -- ^ invoked from a tactic proof. If so, making new metavariables is meaningless, and there should be an error reported instead.+ -> Bool -- ^ ambiguity ok+ -> Bool -- ^ defer on failure+ -> Int -- ^ maximum depth+ -> (PTerm -> ElabD ())+ -> Maybe Name+ -> Name+ -> [Name]+ -> [Name]+ -> IState+ -> ElabD () proofSearch False fromProver ambigok deferonfail depth elab _ nroot psnames [fn] ist = do -- get all possible versions of the name, take the first one that -- works@@ -336,20 +350,21 @@ (Bind _ (Pi _ _ _) _) -> [TextPart "In particular, function types are not supported."] _ -> [] --- | Resolve interfaces. This will only pick up 'normal' implementations, never--- named implementations (which is enforced by 'findInstances').-resolveTC :: Bool -- ^ using default Int- -> Bool -- ^ allow open implementations- -> Int -- ^ depth- -> Term -- ^ top level goal, for error messages- -> Name -- ^ top level function name, to prevent loops+-- | Resolve interfaces. This will only pick up 'normal'+-- implementations, never named implementations (which is enforced by+-- 'findInstances').+resolveTC :: Bool -- ^ using default Int+ -> Bool -- ^ allow open implementations+ -> Int -- ^ depth+ -> Term -- ^ top level goal, for error messages+ -> Name -- ^ top level function name, to prevent loops -> (PTerm -> ElabD ()) -- ^ top level elaborator -> IState -> ElabD () resolveTC def openOK depth top fn elab ist = do hs <- get_holes resTC' [] def openOK hs depth top fn elab ist -resTC' tcs def openOK topholes 0 topg fn elab ist = fail $ "Can't resolve interface"+resTC' tcs def openOK topholes 0 topg fn elab ist = fail "Can't resolve interface" resTC' tcs def openOK topholes 1 topg fn elab ist = try' (trivial elab ist) (resolveTC def False 0 topg fn elab ist) True resTC' tcs defaultOn openOK topholes depth topg fn elab ist = do compute@@ -392,7 +407,7 @@ try' (trivialTCs okholes elab ist) (do addDefault t tc ttypes let stk = map fst (filter snd $ elab_stack ist)- let insts = idris_openimpls ist ++ findInstances ist t + let insts = idris_openimpls ist ++ findInstances ist t blunderbuss t depth stk (stk ++ insts)) True -- returns Just hs if okay, where hs are holes which are okay in the@@ -436,14 +451,6 @@ | Constant _ <- c = not (n `elem` hs) notHole _ _ = True - -- HACK! Rather than giving a special name, better to have some kind- -- of flag in ClassInfo structure- chaser (UN nm)- | ('@':'@':_) <- str nm = True -- old way- chaser (SN (ParentN _ _)) = True- chaser (NS n _) = chaser n- chaser _ = False- numclass = sNS (sUN "Num") ["Interfaces","Prelude"] addDefault t num@(P _ nc _) [P Bound a _] | nc == numclass && defaultOn@@ -477,7 +484,7 @@ solven n = replicateM_ n solve resolve n depth- | depth == 0 = fail $ "Can't resolve interface"+ | depth == 0 = fail "Can't resolve interface" | otherwise = do lams <- introImps t <- goal
src/Idris/Prover.hs view
@@ -1,4 +1,10 @@-+{-|+Module : Idris.Prover+Description : Idris' theorem prover.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards #-} module Idris.Prover (prover, showProof, showRunElab) where @@ -45,13 +51,13 @@ import Debug.Trace -- | Launch the proof shell-prover :: Bool -> Bool -> Name -> Idris ()-prover mode lit x =+prover :: ElabInfo -> Bool -> Bool -> Name -> Idris ()+prover info mode lit x = do ctxt <- getContext i <- getIState case lookupTy x ctxt of [t] -> if elem x (map fst (idris_metavars i))- then prove mode (idris_optimisation i) ctxt lit x t+ then prove mode info (idris_optimisation i) ctxt lit x t else ifail $ show x ++ " is not a hole" _ -> fail "No such hole" @@ -83,13 +89,13 @@ names ((MN _ _, _) : bs) = names bs names ((n, _) : bs) = show n : names bs -prove :: Bool -> Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()-prove mode opt ctxt lit n ty- = do ps <- fmap (\ist -> initElaborator n ctxt (idris_datatypes ist) (idris_name ist) ty) getIState+prove :: Bool -> ElabInfo -> Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()+prove mode info opt ctxt lit n ty+ = do ps <- fmap (\ist -> initElaborator n (constraintNS info) ctxt (idris_datatypes ist) (idris_name ist) ty) getIState idemodePutSExp "start-proof-mode" n (tm, prf) <- if mode- then elabloop n True ("-" ++ show n) [] (ES (ps, initEState) "" Nothing) [] Nothing []+ then elabloop info n True ("-" ++ show n) [] (ES (ps, initEState) "" Nothing) [] Nothing [] else do iputStrLn $ "Warning: this interactive prover is deprecated and will be removed " ++ "in a future release. Please see :elab for a similar feature that "++ "will replace it."@@ -106,7 +112,7 @@ putIState (i { proof_list = (n, (mode, prf)) : proofs }) let tree = simpleCase False (STerm Erased) False CompileTime (fileFC "proof") [] [] [([], P Ref n ty, tm)] logLvl 3 (show tree)- (ptm, pty) <- recheckC (fileFC "proof") id [] tm+ (ptm, pty) <- recheckC (constraintNS info) (fileFC "proof") id [] tm logLvl 5 ("Proof type: " ++ show pty ++ "\n" ++ "Expected type:" ++ show ty) case converts ctxt [] ty pty of@@ -271,6 +277,8 @@ undoElab prf env st (h:hs) = do (prf', env', st') <- undoStep prf env st h return (prf', env', st', hs) +proverfc = fileFC "prover"+ runWithInterrupt :: ElabState EState -> Idris a -- ^ run with SIGINT handler@@ -287,8 +295,8 @@ if success then mSuccess else mFailure IdeMode _ _ -> mTry >> mSuccess -elabloop :: Name -> Bool -> String -> [String] -> ElabState EState -> [ElabShellHistory] -> Maybe History -> [(Name, Type, Term)] -> Idris (Term, [String])-elabloop fn d prompt prf e prev h env+elabloop :: ElabInfo -> Name -> Bool -> String -> [String] -> ElabState EState -> [ElabShellHistory] -> Maybe History -> [(Name, Type, Term)] -> Idris (Term, [String])+elabloop info fn d prompt prf e prev h env = do ist <- getIState when d $ dumpState ist True env (proof e) (x, h') <-@@ -349,13 +357,13 @@ DoLetP {} -> ifail "Pattern-matching let not supported here" DoBindP {} -> ifail "Pattern-matching <- not supported here" DoLet fc i ifc Placeholder expr ->- do (tm, ty) <- elabVal recinfo ERHS (inLets ist env expr)+ do (tm, ty) <- elabVal (recinfo proverfc) ERHS (inLets ist env expr) ctxt <- getContext let tm' = normaliseAll ctxt [] tm ty' = normaliseAll ctxt [] ty return (True, LetStep:prev, e, False, prf ++ [step], (i, ty', tm' ) : env, Right (iPrintResult "")) DoLet fc i ifc ty expr ->- do (tm, ty) <- elabVal recinfo ERHS+ do (tm, ty) <- elabVal (recinfo proverfc) ERHS (PApp NoFC (PRef NoFC [] (sUN "the")) [ pexp (inLets ist env ty) , pexp (inLets ist env expr)@@ -365,34 +373,34 @@ ty' = normaliseAll ctxt [] ty return (True, LetStep:prev, e, False, prf ++ [step], (i, ty', tm' ) : env, Right (iPrintResult "")) DoBind fc i ifc expr ->- do (tm, ty) <- elabVal recinfo ERHS (inLets ist env expr)+ do (tm, ty) <- elabVal (recinfo proverfc) ERHS (inLets ist env expr) (_, e') <- elabStep e saveState -- enable :undo (res, e'') <- elabStep e' $- runElabAction ist NoFC [] tm ["Shell"]+ runElabAction info ist NoFC [] tm ["Shell"] ctxt <- getContext (v, vty) <- tclift $ check ctxt [] (forget res) let v' = normaliseAll ctxt [] v vty' = normaliseAll ctxt [] vty return (True, BothStep:prev, e'', False, prf ++ [step], (i, vty', v') : env, Right (iPrintResult "")) DoExp fc expr ->- do (tm, ty) <- elabVal recinfo ERHS (inLets ist env expr)+ do (tm, ty) <- elabVal (recinfo proverfc) ERHS (inLets ist env expr) -- TODO: call elaborator with Elab () as goal here (_, e') <- elabStep e saveState -- enable :undo (_, e'') <- elabStep e' $- runElabAction ist NoFC [] tm ["Shell"]+ runElabAction info ist NoFC [] tm ["Shell"] return (True, ElabStep:prev, e'', False, prf ++ [step], env, Right (iPrintResult ""))) (\err -> return (False, prev, e, False, prf, env, Left err)) idemodePutSExp "write-proof-state" (prf', length prf') case res of Left err -> do ist <- getIState iRenderError $ pprintErr ist err- elabloop fn d prompt prf' st prev' h' env'+ elabloop info fn d prompt prf' st prev' h' env' Right ok -> if done then do (tm, _) <- elabStep st get_term return (tm, prf') else runWithInterrupt e ok- (elabloop fn d prompt prf' st prev' h' env')- (elabloop fn d prompt prf e prev h' env)+ (elabloop info fn d prompt prf' st prev' h' env')+ (elabloop info fn d prompt prf e prev h' env) where -- A bit of a hack: wrap the value up in a let binding, which will@@ -496,7 +504,7 @@ let OK env = envAtFocus (proof e) ctxt' = envCtxt env ctxt putIState ist { tt_ctxt = ctxt' }- (tm, ty) <- elabVal recinfo ERHS t+ (tm, ty) <- elabVal (recinfo proverfc) ERHS t let ppo = ppOptionIst ist ty' = normaliseC ctxt [] ty infixes = idris_infixes ist@@ -522,7 +530,7 @@ ist' = ist { tt_ctxt = ctxt' } bnd = map (\x -> (fst x, False)) env putIState ist'- (tm, ty) <- elabVal recinfo ERHS t+ (tm, ty) <- elabVal (recinfo proverfc) ERHS t let tm' = force (normaliseAll ctxt' env tm) ty' = force (normaliseAll ctxt' env ty) ppo = ppOption (idris_options ist')
src/Idris/Providers.hs view
@@ -1,5 +1,16 @@+{-|+Module : Idris.Providers+Description : Idris' 'Type Provider' implementation.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE PatternGuards, DeriveFunctor #-}-module Idris.Providers (providerTy, getProvided, Provided(..)) where+module Idris.Providers (+ providerTy+ , getProvided+ , Provided(..)+ ) where import Idris.Core.TT import Idris.Core.Evaluate@@ -39,4 +50,3 @@ | otherwise = ifail $ "Internal type provider error: result was not " ++ "IO (Provider a), or perhaps missing normalisation." ++ "Term: " ++ take 1000 (show tm)-
src/Idris/REPL.hs view
@@ -1,10 +1,19 @@+{-|+Module : Idris.REPL+Description : Entry Point for the Idris REPL and CLI.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, PatternGuards, CPP #-} -module Idris.REPL(getClient, getPkg, getPkgCheck, getPkgClean, getPkgMkDoc,- getPkgREPL, getPkgTest, getPort, getIBCSubDir,- idris, idrisMain, loadInputs,- opt, runClient, runMain, ver) where+module Idris.REPL(+ getClient, getPkg, getPkgCheck, getPkgClean, getPkgMkDoc+ , getPkgREPL, getPkgTest, getPort, getIBCSubDir+ , idris, idrisMain, loadInputs+ , opt, runClient, runMain, ver+ ) where import Idris.AbsSyntax import Idris.ASTUtils@@ -773,7 +782,7 @@ edit "" orig = iputStrLn "Nothing to edit" edit f orig = do i <- getIState- env <- runIO $ getEnvironment+ env <- runIO getEnvironment let editor = getEditor env let line = case errSpan i of Just l -> ['+' : show (fst (fc_start l))]@@ -827,7 +836,7 @@ = withErrorReflection $ do logParser 5 $ show t getIState >>= flip warnDisamb t- (tm, ty) <- elabREPL recinfo ERHS t+ (tm, ty) <- elabREPL (recinfo (fileFC "toplevel")) ERHS t ctxt <- getContext let tm' = perhapsForce $ normaliseBlocking ctxt [] [sUN "foreign",@@ -862,12 +871,12 @@ getClauseName (PWith fc name whole with rhs pn whereBlock) = name defineName :: [PDecl] -> Idris () defineName (tyDecl@(PTy docs argdocs syn fc opts name _ ty) : decls) = do- elabDecl EAll recinfo tyDecl- elabClauses recinfo fc opts name (concatMap getClauses decls)+ elabDecl EAll info tyDecl+ elabClauses info fc opts name (concatMap getClauses decls) setReplDefined (Just name) defineName [PClauses fc opts _ [clause]] = do let pterm = getRHS clause- (tm,ty) <- elabVal recinfo ERHS pterm+ (tm,ty) <- elabVal info ERHS pterm ctxt <- getContext let tm' = force (normaliseAll ctxt [] tm) let ty' = force (normaliseAll ctxt [] ty)@@ -882,7 +891,7 @@ i <- get put (addReplSyntax i syntax) defineName decls = do- elabDecls toplevel (map fixClauses decls)+ elabDecls (toplevelWith fn) (map fixClauses decls) setReplDefined (getName (head decls)) getClauses (PClauses fc opts name clauses) = clauses getClauses _ = []@@ -907,6 +916,8 @@ PInstance doc argDocs syn fc constraints pnames acc opts cls nfc parms pextra ty instName (map fixClauses decls) fixClauses decl = decl + info = recinfo (fileFC "toplevel")+ process fn (Undefine names) = undefine names where undefine :: [Name] -> Idris ()@@ -945,7 +956,7 @@ process fn (ExecVal t) = do ctxt <- getContext ist <- getIState- (tm, ty) <- elabVal recinfo ERHS t+ (tm, ty) <- elabVal (recinfo (fileFC "toplevel")) ERHS t -- let tm' = normaliseAll ctxt [] tm let ty' = normaliseAll ctxt [] ty res <- execute tm@@ -992,7 +1003,7 @@ process fn (Check t)- = do (tm, ty) <- elabREPL recinfo ERHS t+ = do (tm, ty) <- elabREPL (recinfo (fileFC "toplevel")) ERHS t ctxt <- getContext ist <- getIState let ppo = ppOptionIst ist@@ -1006,7 +1017,7 @@ (pprintDelab ist ty') process fn (Core t)- = do (tm, ty) <- elabREPL recinfo ERHS t+ = do (tm, ty) <- elabREPL (recinfo (fileFC "toplevel")) ERHS t iPrintTermWithType (pprintTT [] tm) (pprintTT [] ty) process fn (DocStr (Left n) w)@@ -1036,7 +1047,7 @@ let cs = idris_constraints i let cslist = S.toAscList cs -- iputStrLn $ showSep "\n" (map show cs)- iputStrLn $ show (map uconstraint cslist)+ iputStrLn $ showSep "\n" (map show cslist) let n = length cslist iputStrLn $ "(" ++ show n ++ " constraints)" case ucheck cs of@@ -1074,8 +1085,8 @@ ts process fn (DebugUnify l r)- = do (ltm, _) <- elabVal recinfo ERHS l- (rtm, _) <- elabVal recinfo ERHS r+ = do (ltm, _) <- elabVal (recinfo (fileFC "toplevel")) ERHS l+ (rtm, _) <- elabVal (recinfo (fileFC "toplevel")) ERHS r ctxt <- getContext case unify ctxt [] (ltm, Nothing) (rtm, Nothing) [] [] [] [] of OK ans -> iputStrLn (show ans)@@ -1120,7 +1131,7 @@ process fn (DoProofSearch updatefile rec l n hints) = doProofSearch fn updatefile rec l n hints Nothing process fn (Spec t)- = do (tm, ty) <- elabVal recinfo ERHS t+ = do (tm, ty) <- elabVal (recinfo (fileFC "toplevel")) ERHS t ctxt <- getContext ist <- getIState let tm' = simplify ctxt [] {- (idris_statics ist) -} tm@@ -1194,25 +1205,24 @@ n <- case metavars of [] -> ierror (Msg $ "Cannot find metavariable " ++ show n') [(n, (_,_,_,False,_))] -> return n- [(_, (_,_,_,_,False))] -> ierror (Msg $ "Can't prove this hole as it depends on other holes")- [(_, (_,_,_,True,_))] -> ierror (Msg $ "Declarations not solvable using prover")+ [(_, (_,_,_,_,False))] -> ierror (Msg "Can't prove this hole as it depends on other holes")+ [(_, (_,_,_,True,_))] -> ierror (Msg "Declarations not solvable using prover") ns -> ierror (CantResolveAlts (map fst ns))- prover mode (lit fn) n+ prover (toplevelWith fn) mode (lit fn) n -- recheck totality i <- getIState totcheck (fileFC "(input)", n) mapM_ (\ (f,n) -> setTotality n Unchecked) (idris_totcheck i) mapM_ checkDeclTotality (idris_totcheck i) warnTotality- process fn (WHNF t)- = do (tm, ty) <- elabVal recinfo ERHS t+ = do (tm, ty) <- elabVal (recinfo (fileFC "toplevel")) ERHS t ctxt <- getContext ist <- getIState let tm' = whnf ctxt tm iPrintResult (show (delab ist tm')) process fn (TestInline t)- = do (tm, ty) <- elabVal recinfo ERHS t+ = do (tm, ty) <- elabVal (recinfo (fileFC "toplevel")) ERHS t ctxt <- getContext ist <- getIState let tm' = inlineTerm ist tm@@ -1221,7 +1231,7 @@ process fn (Execute tm) = idrisCatch (do ist <- getIState- (m, _) <- elabVal recinfo ERHS (elabExec fc tm)+ (m, _) <- elabVal (recinfo (fileFC "toplevel")) ERHS (elabExec fc tm) (tmpn, tmph) <- runIO $ tempfile "" runIO $ hClose tmph t <- codegen@@ -1244,7 +1254,7 @@ let mainname = sNS (sUN "main") ["Main"] m <- if iface then return Nothing else- do (m', _) <- elabVal recinfo ERHS+ do (m', _) <- elabVal (recinfo (fileFC "compiler")) ERHS (PApp fc (PRef fc [] (sUN "run__IO")) [pexp $ PRef fc [] mainname]) return (Just m')@@ -1256,7 +1266,7 @@ process fn (LogCategory cs) = setLogCats cs -- Elaborate as if LHS of a pattern (debug command) process fn (Pattelab t)- = do (tm, ty) <- elabVal recinfo ELHS t+ = do (tm, ty) <- elabVal (recinfo (fileFC "toplevel")) ELHS t iPrintResult $ show tm ++ "\n\n : " ++ show ty process fn (Missing n)@@ -1270,7 +1280,7 @@ [] (idris_infixes i)) tms))- _ -> iPrintError $ "Ambiguous name"+ _ -> iPrintError "Ambiguous name" process fn (DynamicLink l) = do i <- getIState let importdirs = opt_importdirs (idris_options i)@@ -1394,7 +1404,7 @@ parse n | Success x <- runparser (fmap fst name) istate fn n = Right x parse n = Left n (bad, nss) = partitionEithers $ map parse names- cd <- runIO $ getCurrentDirectory+ cd <- runIO getCurrentDirectory let outputDir = cd </> "doc" result <- if null bad then runIO $ generateDocs istate nss outputDir else return . Left $ "Illegal name: " ++ head bad@@ -1433,7 +1443,7 @@ process fn (PPrint fmt width t)- = do (tm, ty) <- elabVal recinfo ERHS t+ = do (tm, ty) <- elabVal (recinfo (fileFC "toplevel")) ERHS t ctxt <- getContext ist <- getIState let ppo = ppOptionIst ist@@ -1454,9 +1464,13 @@ showTotal t i = text (show t) showTotalN :: IState -> Name -> Doc OutputAnnotation-showTotalN i n = case lookupTotal n (tt_ctxt i) of- [t] -> showTotal t i+showTotalN ist n = case lookupTotal n (tt_ctxt ist) of+ [t] -> showN n <> text ", which is" <+> showTotal t ist _ -> empty+ where+ ppo = ppOptionIst ist+ showN n = annotate (AnnName n Nothing Nothing Nothing) . text $+ showName (Just ist) [] ppo False n displayHelp = let vstr = showVersion version in "\nIdris version " ++ vstr ++ "\n" ++@@ -1574,7 +1588,7 @@ case errSpan inew of Nothing -> do putIState $!! ist { idris_tyinfodata = tidata }- ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles)))+ ibcfiles <- mapM findNewIBC (nub (concatMap snd ifiles)) -- logLvl 0 $ "Loading from " ++ show ibcfiles tryLoad True (IBC_REPL True) (mapMaybe id ibcfiles) _ -> return ()@@ -1703,7 +1717,7 @@ when (DefaultTotal `elem` opts) $ do i <- getIState putIState (i { default_total = DefaultCheckingTotal })- tty <- runIO $ isATTY+ tty <- runIO isATTY setColourise $ not quiet && last (tty : opt getColour opts) @@ -1777,7 +1791,7 @@ runIO $ exitWith (ExitFailure 1) Success e -> process "" (Eval e)) exprs- runIO $ exitWith ExitSuccess+ runIO exitSuccess case script of@@ -1815,7 +1829,7 @@ makeOption _ = return () addPkgDir :: String -> Idris ()- addPkgDir p = do ddir <- runIO $ getIdrisLibDir+ addPkgDir p = do ddir <- runIO getIdrisLibDir addImportDir (ddir </> p) addIBC (IBCImportDir (ddir </> p)) @@ -1832,9 +1846,9 @@ Failure err -> do iputStrLn $ show (fixColour c err) runIO $ exitWith (ExitFailure 1) Success term -> do ctxt <- getContext- (tm, _) <- elabVal recinfo ERHS term+ (tm, _) <- elabVal (recinfo (fileFC "toplevel")) ERHS term res <- execute tm- runIO $ exitWith ExitSuccess+ runIO $ exitSuccess -- | Get the platform-specific, user-specific Idris dir getIdrisUserDataDir :: Idris FilePath
src/Idris/REPL/Browse.hs view
@@ -1,3 +1,11 @@+{-|+Module : Idris.REPL.Browse+Description : Browse the current namespace.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+ {-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-unused-imports #-} module Idris.REPL.Browse (namespacesInNS, namesInNS) where
src/Idris/REPL/Parser.hs view
@@ -1,5 +1,16 @@--module Idris.REPL.Parser (parseCmd, help, allHelp, setOptions) where+{-|+Module : Idris.REPL.Parser+Description : Parser for the REPL commands.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+module Idris.REPL.Parser (+ parseCmd+ , help+ , allHelp+ , setOptions+ ) where import System.FilePath ((</>)) import System.Console.ANSI (Color(..))
src/Idris/Reflection.hs view
@@ -1,6 +1,11 @@-{-| Code related to Idris's reflection system. This module contains-quoters and unquoters along with some supporting datatypes.+{-|+Module : Idris.Reflection+Description : Code related to Idris's reflection system. This module contains quoters and unquoters along with some supporting datatypes.+Copyright :+License : BSD3+Maintainer : The Idris Community. -}+ {-# LANGUAGE PatternGuards, CPP #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-unused-imports #-} module Idris.Reflection where@@ -168,9 +173,9 @@ reifyTT t@(App _ _ _) | (P _ f _, args) <- unApply t = reifyTTApp f args reifyTT t@(P _ n _)- | n == reflm "Erased" = return $ Erased+ | n == reflm "Erased" = return Erased reifyTT t@(P _ n _)- | n == reflm "Impossible" = return $ Impossible+ | n == reflm "Impossible" = return Impossible reifyTT t = fail ("Unknown reflection term: " ++ show t) reifyTTApp :: Name -> [Term] -> ElabD Term@@ -212,7 +217,7 @@ reifyRaw t@(App _ _ _) | (P _ f _, args) <- unApply t = reifyRawApp f args reifyRaw t@(P _ n _)- | n == reflm "RType" = return $ RType+ | n == reflm "RType" = return RType reifyRaw t = fail ("Unknown reflection raw term in reifyRaw: " ++ show t) reifyRawApp :: Name -> [Term] -> ElabD Raw@@ -327,9 +332,9 @@ reifyTTBinderApp _ f args = fail ("Unknown reflection binder: " ++ show (f, args)) reifyTTConst :: Term -> ElabD Const-reifyTTConst (P _ n _) | n == reflm "StrType" = return $ StrType-reifyTTConst (P _ n _) | n == reflm "VoidType" = return $ VoidType-reifyTTConst (P _ n _) | n == reflm "Forgot" = return $ Forgot+reifyTTConst (P _ n _) | n == reflm "StrType" = return StrType+reifyTTConst (P _ n _) | n == reflm "VoidType" = return VoidType+reifyTTConst (P _ n _) | n == reflm "Forgot" = return Forgot reifyTTConst t@(App _ _ _) | (P _ f _, [arg]) <- unApply t = reifyTTConstApp f arg reifyTTConst t = fail ("Unknown reflection constant: " ++ show t)@@ -338,23 +343,23 @@ reifyTTConstApp f aty | f == reflm "AType" = fmap AType (reifyArithTy aty) reifyTTConstApp f (Constant c@(I _))- | f == reflm "I" = return $ c+ | f == reflm "I" = return c reifyTTConstApp f (Constant c@(BI _))- | f == reflm "BI" = return $ c+ | f == reflm "BI" = return c reifyTTConstApp f (Constant c@(Fl _))- | f == reflm "Fl" = return $ c+ | f == reflm "Fl" = return c reifyTTConstApp f (Constant c@(Ch _))- | f == reflm "Ch" = return $ c+ | f == reflm "Ch" = return c reifyTTConstApp f (Constant c@(Str _))- | f == reflm "Str" = return $ c+ | f == reflm "Str" = return c reifyTTConstApp f (Constant c@(B8 _))- | f == reflm "B8" = return $ c+ | f == reflm "B8" = return c reifyTTConstApp f (Constant c@(B16 _))- | f == reflm "B16" = return $ c+ | f == reflm "B16" = return c reifyTTConstApp f (Constant c@(B32 _))- | f == reflm "B32" = return $ c+ | f == reflm "B32" = return c reifyTTConstApp f (Constant c@(B64 _))- | f == reflm "B64" = return $ c+ | f == reflm "B64" = return c reifyTTConstApp f v@(P _ _ _) = lift . tfail . Msg $ "Can't reify the variable " ++@@ -384,8 +389,10 @@ reifyTTUExp :: Term -> ElabD UExp reifyTTUExp t@(App _ _ _) = case unApply t of- (P _ f _, [Constant (I i)]) | f == reflm "UVar" -> return $ UVar i- (P _ f _, [Constant (I i)]) | f == reflm "UVal" -> return $ UVal i+ (P _ f _, [Constant (Str str), Constant (I i)])+ | f == reflm "UVar" -> return $ UVar str i+ (P _ f _, [Constant (I i)])+ | f == reflm "UVal" -> return $ UVal i _ -> fail ("Unknown reflection type universe expression: " ++ show t) reifyTTUExp t = fail ("Unknown reflection type universe expression: " ++ show t) @@ -480,7 +487,7 @@ reflectTTQuotePattern unq Erased = do erased <- claimTy (sMN 0 "erased") (Var (reflm "TT")) movelast erased- fill $ (Var erased)+ fill (Var erased) reflectTTQuotePattern unq Impossible = lift . tfail . InternalMsg $ "Phase error! The Impossible constructor is for optimization only and should not have been reflected during elaboration."@@ -787,7 +794,7 @@ reflectConstant TheWorld = Var (reflm "TheWorld") reflectUExp :: UExp -> Raw-reflectUExp (UVar i) = reflCall "UVar" [RConstant (I i)]+reflectUExp (UVar ns i) = reflCall "UVar" [RConstant (Str ns), RConstant (I i)] reflectUExp (UVal i) = reflCall "UVal" [RConstant (I i)] -- | Reflect the environment of a proof into a List (TTName, Binder TT)@@ -900,7 +907,7 @@ , reflect t2 , reflect t3 ]-reflectErr (CantResolve _ t more) +reflectErr (CantResolve _ t more) = raw_apply (Var $ reflErrName "CantResolve") [reflect t, reflectErr more] reflectErr (InvalidTCArg n t) = raw_apply (Var $ reflErrName "InvalidTCArg") [reflectName n, reflect t] reflectErr (CantResolveAlts ss) =@@ -919,7 +926,7 @@ reflectErr (NonCollapsiblePostulate n) = raw_apply (Var $ reflErrName "NonCollabsiblePostulate") [reflectName n] reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n] reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e]-reflectErr (NoRewriting tm) = raw_apply (Var $ reflErrName "NoRewriting") [reflect tm]+reflectErr (NoRewriting l r tm) = raw_apply (Var $ reflErrName "NoRewriting") [reflect l, reflect r, reflect tm] reflectErr (ProviderError str) = raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)] reflectErr (LoadingFailed str err) =@@ -967,7 +974,7 @@ Right (TextPart msg) reifyReportPart (App _ (P (DCon _ _ _) n _) ttn) | n == reflm "NamePart" =- case runElab initEState (reifyTTName ttn) (initElaborator (sMN 0 "hole") initContext emptyContext 0 Erased) of+ case runElab initEState (reifyTTName ttn) (initElaborator (sMN 0 "hole") internalNS initContext emptyContext 0 Erased) of Error e -> Left . InternalMsg $ "could not reify name term " ++ show ttn ++@@ -975,7 +982,7 @@ OK (n', _)-> Right $ NamePart n' reifyReportPart (App _ (P (DCon _ _ _) n _) tm) | n == reflm "TermPart" =- case runElab initEState (reifyTT tm) (initElaborator (sMN 0 "hole") initContext emptyContext 0 Erased) of+ case runElab initEState (reifyTT tm) (initElaborator (sMN 0 "hole") internalNS initContext emptyContext 0 Erased) of Error e -> Left . InternalMsg $ "could not reify reflected term " ++ show tm ++@@ -983,7 +990,7 @@ OK (tm', _) -> Right $ TermPart tm' reifyReportPart (App _ (P (DCon _ _ _) n _) tm) | n == reflm "RawPart" =- case runElab initEState (reifyRaw tm) (initElaborator (sMN 0 "hole") initContext emptyContext 0 Erased) of+ case runElab initEState (reifyRaw tm) (initElaborator (sMN 0 "hole") internalNS initContext emptyContext 0 Erased) of Error e -> Left . InternalMsg $ "could not reify reflected raw term " ++ show tm ++@@ -1183,14 +1190,17 @@ , rawList (Var $ tacN "TyConArg") (map reflectConArg tyConArgs) , reflectRaw tyConRes , rawList (rawTripleTy (Var $ reflm "TTName")- (RApp (Var (sNS (sUN "List") ["List", "Prelude"])) (Var $ tacN "CtorArg"))- (Var $ reflm "Raw"))- [ rawTriple ((Var $ reflm "TTName"),- (RApp (Var (sNS (sUN "List") ["List", "Prelude"])) (Var $ tacN "CtorArg")),+ (RApp (Var (sNS (sUN "List") ["List", "Prelude"]))+ (Var $ tacN "CtorArg")) (Var $ reflm "Raw"))- (reflectName cn,- rawList (Var $ tacN "CtorArg") (map reflectCtorArg cargs),- reflectRaw cty)+ [ rawTriple ((Var $ reflm "TTName")+ ,(RApp (Var (sNS (sUN "List") ["List", "Prelude"]))+ (Var $ tacN "CtorArg"))+ ,(Var $ reflm "Raw"))+ (reflectName cn+ ,rawList (Var $ tacN "CtorArg")+ (map reflectCtorArg cargs)+ ,reflectRaw cty) | (cn, cargs, cty) <- constrs ] ]@@ -1200,11 +1210,17 @@ RApp (Var $ tacN "TyConIndex") (reflectArg a) reflectFunClause :: RFunClause Term -> Raw-reflectFunClause (RMkFunClause lhs rhs) = raw_apply (Var $ tacN "MkFunClause") $ (Var $ reflm "TT") : map reflect [ lhs, rhs ]-reflectFunClause (RMkImpossibleClause lhs) = raw_apply (Var $ tacN "MkImpossibleClause") $ [ Var $ reflm "TT", reflect lhs ]+reflectFunClause (RMkFunClause lhs rhs) = raw_apply (Var $ tacN "MkFunClause")+ $ (Var $ reflm "TT") : map reflect [ lhs, rhs ] +reflectFunClause (RMkImpossibleClause lhs) = raw_apply (Var $ tacN "MkImpossibleClause")+ [ Var $ reflm "TT", reflect lhs ]+ reflectFunDefn :: RFunDefn Term -> Raw-reflectFunDefn (RDefineFun name clauses) = raw_apply (Var $ tacN "DefineFun") [ Var $ reflm "TT"- , reflectName name- , rawList (RApp (Var $ tacN "FunClause") (Var $ reflm "TT")) (map reflectFunClause clauses)- ]+reflectFunDefn (RDefineFun name clauses) = raw_apply (Var $ tacN "DefineFun")+ [ Var $ reflm "TT"+ , reflectName name+ , rawList (RApp (Var $ tacN "FunClause")+ (Var $ reflm "TT"))+ (map reflectFunClause clauses)+ ]
src/Idris/Transforms.hs view
@@ -1,9 +1,19 @@+{-|+Module : Idris.Transforms+Description : A collection of transformations.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-}+ {-# LANGUAGE PatternGuards #-} -module Idris.Transforms(transformPats, - transformPatsWith,- applyTransRulesWith,- applyTransRules) where+module Idris.Transforms(+ transformPats+ , transformPatsWith+ , applyTransRulesWith+ , applyTransRules+ ) where import Idris.AbsSyntax import Idris.Core.CaseTree@@ -27,23 +37,23 @@ = let rhs' = applyTransRulesWith rs rhs in Right (lhs, rhs') --- Work on explicitly named terms, so we don't have to manipulate--- de Bruijn indices+-- | Work on explicitly named terms, so we don't have to manipulate de+-- Bruijn indices applyTransRules :: IState -> Term -> Term applyTransRules ist tm = finalise $ applyAll [] (idris_transforms ist) (vToP tm) --- Work on explicitly named terms, so we don't have to manipulate--- de Bruijn indices+-- | Work on explicitly named terms, so we don't have to manipulate de+-- Bruijn indices applyTransRulesWith :: [(Term, Term)] -> Term -> Term-applyTransRulesWith rules tm +applyTransRulesWith rules tm = finalise $ applyAll rules emptyContext (vToP tm) applyAll :: [(Term, Term)] -> Ctxt [(Term, Term)] -> Term -> Term-applyAll extra ts ap@(App s f a) +applyAll extra ts ap@(App s f a) | (P _ fn ty, args) <- unApply ap = let rules = case lookupCtxtExact fn ts of Just r -> extra ++ r- Nothing -> extra + Nothing -> extra ap' = App s (applyAll extra ts f) (applyAll extra ts a) in case rules of [] -> ap'@@ -52,9 +62,9 @@ App s (applyAll extra ts f') (applyAll extra ts a') Just tm' -> tm'- _ -> App s (applyAll extra ts f) + _ -> App s (applyAll extra ts f) (applyAll extra ts a)-applyAll extra ts (Bind n b sc) = Bind n (fmap (applyAll extra ts) b) +applyAll extra ts (Bind n b sc) = Bind n (fmap (applyAll extra ts) b) (applyAll extra ts sc) applyAll extra ts t = t @@ -64,11 +74,11 @@ | otherwise = applyFnRules rs tm applyRule :: (Term, Term) -> Term -> Maybe Term-applyRule (lhs, rhs) tm - | Just ms <- matchTerm lhs tm +applyRule (lhs, rhs) tm+ | Just ms <- matchTerm lhs tm -- = trace ("SUCCESS " ++ show ms ++ "\n FROM\n" ++ show lhs ++--- "\n" ++ show rhs --- ++ "\n" ++ show tm ++ " GIVES\n" ++ show (depat ms rhs)) $ +-- "\n" ++ show rhs+-- ++ "\n" ++ show tm ++ " GIVES\n" ++ show (depat ms rhs)) $ = Just $ depat ms rhs | otherwise = Nothing -- ASSUMPTION: The names in the transformation rule bindings cannot occur@@ -76,7 +86,7 @@ -- (In general, this would not be true, but when we elaborate transformation -- rules we mangle the names so that it is true. While this feels a bit -- hacky, it's much easier to think about than mangling de Bruijn indices).- where depat ms (Bind n (PVar t) sc) + where depat ms (Bind n (PVar t) sc) = case lookup n ms of Just tm -> depat ms (subst n tm sc) _ -> depat ms sc -- no occurrence? Shouldn't happen@@ -85,9 +95,9 @@ matchTerm :: Term -> Term -> Maybe [(Name, Term)] matchTerm lhs tm = matchVars [] lhs tm where- matchVars acc (Bind n (PVar t) sc) tm + matchVars acc (Bind n (PVar t) sc) tm = matchVars (n : acc) (instantiate (P Bound n t) sc) tm- matchVars acc sc tm + matchVars acc sc tm = -- trace (show acc ++ ": " ++ show (sc, tm)) $ doMatch acc sc tm @@ -100,5 +110,3 @@ return (fm ++ am) doMatch ns x y | vToP x == vToP y = return [] | otherwise = Nothing--
src/Idris/TypeSearch.hs view
@@ -1,36 +1,45 @@+{-|+Module : Idris.TypeSearch+Description : A Hoogle for Idris.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE ScopedTypeVariables #-} module Idris.TypeSearch (- searchByType, searchPred, defaultScoreFunction-) where+ searchByType+ , searchPred+ , defaultScoreFunction+ ) where import Control.Applicative (Applicative (..), (<$>), (<*>), (<|>))-import Control.Arrow (first, second, (&&&), (***))-import Control.Monad (when, guard)+import Control.Arrow (first, second, (&&&), (***))+import Control.Monad (when, guard) -import Data.List (find, partition, (\\))-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe (catMaybes, fromMaybe, isJust, maybeToList, mapMaybe)-import Data.Monoid (Monoid (mempty, mappend))-import Data.Ord (comparing)+import Data.List (find, partition, (\\))+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (catMaybes, fromMaybe, isJust, maybeToList, mapMaybe)+import Data.Monoid (Monoid (mempty, mappend))+import Data.Ord (comparing) import qualified Data.PriorityQueue.FingerTree as Q-import Data.Set (Set)-import qualified Data.Set as S-import qualified Data.Text as T (pack, isPrefixOf)-import Data.Traversable (traverse)+import Data.Set (Set)+import qualified Data.Set as S+import qualified Data.Text as T (pack, isPrefixOf)+import Data.Traversable (traverse) -import Idris.AbsSyntax (addUsingConstraints, addImpl, getIState, putIState, implicit, logLvl)-import Idris.AbsSyntaxTree (class_instances, ClassInfo, defaultSyntax, eqTy, Idris,- IState (idris_classes, idris_docstrings, tt_ctxt, idris_outputmode),- implicitAllowed, OutputMode(..), PTerm, toplevel)+import Idris.AbsSyntax (addUsingConstraints, addImpl, getIState, putIState, implicit, logLvl)+import Idris.AbsSyntaxTree (class_instances, ClassInfo, defaultSyntax, eqTy, Idris+ , IState (idris_classes, idris_docstrings, tt_ctxt, idris_outputmode),+ implicitAllowed, OutputMode(..), PTerm, toplevel) import Idris.Core.Evaluate (Context (definitions), Def (Function, TyDecl, CaseOp), normaliseC)-import Idris.Core.TT hiding (score)-import Idris.Core.Unify (match_unify)-import Idris.Delaborate (delabTy)-import Idris.Docstrings (noDocs, overview)-import Idris.Elab.Type (elabType)-import Idris.Output (iputStrLn, iRenderOutput, iPrintResult, iRenderError, iRenderResult, prettyDocumentedIst)+import Idris.Core.TT hiding (score)+import Idris.Core.Unify (match_unify)+import Idris.Delaborate (delabTy)+import Idris.Docstrings (noDocs, overview)+import Idris.Elab.Type (elabType)+import Idris.Output (iputStrLn, iRenderOutput, iPrintResult, iRenderError, iRenderResult, prettyDocumentedIst) import Idris.IBC import Prelude hiding (pred)@@ -40,9 +49,9 @@ searchByType :: [String] -> PTerm -> Idris () searchByType pkgs pterm = do i <- getIState -- save original- when (not (null pkgs)) $ + when (not (null pkgs)) $ iputStrLn $ "Searching packages: " ++ showSep ", " pkgs- + mapM_ loadPkgIndex pkgs pterm' <- addUsingConstraints syn emptyFC pterm pterm'' <- implicit toplevel syn name pterm'@@ -67,9 +76,9 @@ name = sMN 0 "searchType" -- name -- | Conduct a type-directed search using a given match predicate-searchUsing :: (IState -> Type -> [(Name, Type)] -> [(Name, a)]) +searchUsing :: (IState -> Type -> [(Name, Type)] -> [(Name, a)]) -> IState -> Type -> [(Name, a)]-searchUsing pred istate ty = pred istate nty . concat . M.elems $ +searchUsing pred istate ty = pred istate nty . concat . M.elems $ M.mapWithKey (\key -> M.toAscList . M.mapMaybe (f key)) (definitions ctxt) where nty = normaliseC ctxt [] ty@@ -81,7 +90,7 @@ special :: Name -> Bool special (NS n _) = special n special (SN _) = True- special (UN n) = T.pack "default#" `T.isPrefixOf` n + special (UN n) = T.pack "default#" `T.isPrefixOf` n || n `elem` map T.pack ["believe_me", "really_believe_me"] special _ = False @@ -117,10 +126,10 @@ -- run vToP first! -- | Compute a directed acyclic graph corresponding to the--- arguments of a function. +-- arguments of a function. -- returns [(the name and type of the bound variable -- the names in the type of the bound variable)]-computeDagP :: Ord n +computeDagP :: Ord n => (TT n -> Bool) -- ^ filter to remove some arguments -> TT n -> ([((n, TT n), Set n)], [(n, TT n)], TT n)@@ -196,7 +205,7 @@ Sided True False -> annotated LT "<" -- found type is more general than searched type Sided False True -> annotated GT ">" -- searched type is more general than found type Sided False False -> text "_"- where + where annotated ordr = annotate (AnnSearchResult ordr) . text noMods (Mods app tcApp tcIntro) = app + tcApp + tcIntro == 0 @@ -208,19 +217,19 @@ ( sided (&&) (both ((> 0) . argApp) amods) || sided (+) (both argApp amods) > 4 || sided (||) (both (\(Mods _ tcApp tcIntro) -> tcApp > 3 || tcIntro > 3) amods)- ) + ) -- | Convert a 'Score' to an 'Int' to provide an order for search results. -- Lower scores are better. defaultScoreFunction :: Score -> Int-defaultScoreFunction (Score trans eqFlip amods) = +defaultScoreFunction (Score trans eqFlip amods) = trans + eqFlip + linearPenalty + upAndDowncastPenalty where -- prefer finding a more general type to a less general type- linearPenalty = (\(Sided l r) -> 3 * l + r) + linearPenalty = (\(Sided l r) -> 3 * l + r) (both (\(Mods app tcApp tcIntro) -> 3 * app + 4 * tcApp + 2 * tcIntro) amods) -- it's very bad to have *both* upcasting and downcasting- upAndDowncastPenalty = 100 * + upAndDowncastPenalty = 100 * sided (*) (both (\(Mods app tcApp tcIntro) -> 2 * app + tcApp + tcIntro) amods) instance Ord Score where@@ -237,7 +246,7 @@ instance Monoid Score where mempty = Score 0 0 mempty- (Score t e mods) `mappend` (Score t' e' mods') = Score (t + t') (e + e') (mods `mappend` mods') + (Score t e mods) `mappend` (Score t' e' mods') = Score (t + t') (e + e') (mods `mappend` mods') -- | A directed acyclic graph representing the arguments to a function -- The 'Int' represents the position of the argument (1st argument, 2nd, etc.)@@ -311,7 +320,7 @@ [(0, eq1), (1, app (app (app (app eq tyR) tyL) valR) valL)] Bind n binder sc -> (\bind' (j, sc') -> (fst (binderTy bind') + j, Bind n (fmap snd bind') sc')) <$> traverse flipEqualities binder <*> flipEqualities sc- App _ f x -> (\(i, f') (j, x') -> (i + j, app f' x')) + App _ f x -> (\(i, f') (j, x') -> (i + j, app f' x')) <$> flipEqualities f <*> flipEqualities x t' -> [(0, t')] where app = App Complete@@ -329,13 +338,13 @@ where ty2s = (\(i, dag) (j, retTy) -> (i + j, dag, retTy)) <$> flipEqualitiesDag dag2 <*> flipEqualities retTy2- flipEqualitiesDag dag = case dag of + flipEqualitiesDag dag = case dag of [] -> [(0, [])]- ((n, ty), (pos, deps)) : xs -> + ((n, ty), (pos, deps)) : xs -> (\(i, ty') (j, xs') -> (i + j , ((n, ty'), (pos, deps)) : xs')) <$> flipEqualities ty <*> flipEqualitiesDag xs startStates (numEqFlips, sndDag, sndRetTy) = do- state <- unifyQueue (State startingHoles + state <- unifyQueue (State startingHoles (Sided (dag1, typeClassArgs1) (sndDag, typeClassArgs2)) (mempty { equalityFlips = numEqFlips }) usedns) [(retTy1, sndRetTy)] return (score state, state)@@ -346,7 +355,7 @@ usedns = map fst startingHoles startingHoles = argNames1 ++ argNames2 - startingTypes = [(retTy1, retTy2)] + startingTypes = [(retTy1, retTy2)] startQueueOfQueues :: Q.PQueue Score (info, Q.PQueue Score State)@@ -372,14 +381,14 @@ (dag1, typeClassArgs1, retTy1) = makeDag type1 argNames1 = map fst dag1 makeDag :: Type -> (ArgsDAG, Classes, Type)- makeDag = first3 (zipWith (\i (ty, deps) -> (ty, (i, deps))) [0..] . reverseDag) . + makeDag = first3 (zipWith (\i (ty, deps) -> (ty, (i, deps))) [0..] . reverseDag) . computeDagP (isTypeClassArg classInfo) . vToP . unLazy first3 f (a,b,c) = (f a, b, c)- + -- update our state with the unification resolutions resolveUnis :: [(Name, Type)] -> State -> Maybe (State, [(Type, Type)]) resolveUnis [] state = Just (state, [])- resolveUnis ((name, term@(P Bound name2 _)) : xs) + resolveUnis ((name, term@(P Bound name2 _)) : xs) state | isJust findArgs = do ((ty1, ix1), (ty2, ix2)) <- findArgs @@ -408,7 +417,7 @@ -- due to injectivity matchedVarMap = usedVars term bothT f (x, y) = (f x, f y)- (injUsedVars, notInjUsedVars) = bothT M.keys . M.partition id . M.filterWithKey (\k _-> k `elem` map fst hs) $ M.map snd matchedVarMap + (injUsedVars, notInjUsedVars) = bothT M.keys . M.partition id . M.filterWithKey (\k _-> k `elem` map fst hs) $ M.map snd matchedVarMap varsInTy = injUsedVars ++ notInjUsedVars toDelete = name : varsInTy deleteMany = foldr (.) id (map deleteName toDelete)@@ -417,7 +426,7 @@ addScore additions theState = theState { score = let s = score theState in s { asymMods = asymMods s `mappend` additions } }- state' = state { holes = filter (not . (`elem` toDelete) . fst) hs + state' = state { holes = filter (not . (`elem` toDelete) . fst) hs , argsAndClasses = both (modifyTypes (subst name term) . deleteMany) (argsAndClasses state) } nextStep = resolveUnis xs state' @@ -427,8 +436,8 @@ unifyQueue state [] = return state unifyQueue state ((ty1, ty2) : queue) = do --trace ("go: \n" ++ show state) True `seq` return ()- res <- tcToMaybe $ match_unify ctxt [ (n, Pi Nothing ty (TType (UVar 0))) | (n, ty) <- holes state] - (ty1, Nothing) + res <- tcToMaybe $ match_unify ctxt [ (n, Pi Nothing ty (TType (UVar [] 0))) | (n, ty) <- holes state]+ (ty1, Nothing) (ty2, Nothing) [] (map fst $ holes state) [] (state', queueAdditions) <- resolveUnis res state guard $ scoreCriterion (score state')@@ -453,7 +462,7 @@ nextStepsQueue :: Q.PQueue Score State -> Maybe (Either (Q.PQueue Score State) Score) nextStepsQueue queue = do ((nextScore, next), rest) <- Q.minViewWithKey queue- Just $ if isFinal next + Just $ if isFinal next then Right nextScore else let additions = if scoreCriterion nextScore then Q.fromList [ (score state, state) | state <- nextSteps next ]@@ -469,19 +478,19 @@ nextSteps :: State -> [State] -- Stage 3 - match typeclasses- nextSteps (State [] unresolved@(Sided ([], c1) ([], c2)) scoreAcc usedns) = + nextSteps (State [] unresolved@(Sided ([], c1) ([], c2)) scoreAcc usedns) = if null results3 then results4 else results3 where -- try to match a typeclass argument from the left with a typeclass argument from the right results3 =- catMaybes [ unifyQueue (State [] + catMaybes [ unifyQueue (State [] (Sided ([], deleteFromArgList n1 c1) ([], map (second subst2for1) (deleteFromArgList n2 c2)))- scoreAcc usedns) [(ty1, ty2)] + scoreAcc usedns) [(ty1, ty2)] | (n1, ty1) <- c1, (n2, ty2) <- c2, let subst2for1 = psubst n2 (P Bound n1 ty1)] -- try to hunt match a typeclass constraint by replacing it with an instance- results4 = [ State [] (both (\(cs, _, _) -> ([], cs)) sds) + results4 = [ State [] (both (\(cs, _, _) -> ([], cs)) sds) (scoreAcc `mappend` Score 0 0 (both (\(_, amods, _) -> amods) sds)) (usedns ++ sided (++) (both (\(_, _, hs) -> hs) sds)) | sds <- allMods ]@@ -512,10 +521,10 @@ canBeFirst = map fst . filter (S.null . snd . snd) -- try to match an argument from the left with an argument from the right- results1 = catMaybes [ unifyQueue (State (filter (not . (`elem` [n1,n2]) . fst) hs) - (Sided (deleteFromDag n1 dagL, c1) + results1 = catMaybes [ unifyQueue (State (filter (not . (`elem` [n1,n2]) . fst) hs)+ (Sided (deleteFromDag n1 dagL, c1) (inArgTys subst2for1 $ deleteFromDag n2 dagR, map (second subst2for1) c2))- scoreAcc usedns) [(ty1, ty2)] + scoreAcc usedns) [(ty1, ty2)] | (n1, ty1) <- canBeFirst dagL, (n2, ty2) <- canBeFirst dagR , let subst2for1 = psubst n2 (P Bound n1 ty1)] @@ -523,7 +532,7 @@ -- Stage 2 - simply introduce a subset of the typeclasses -- we've finished, so take some classes- takeSomeClasses (State [] unresolved@(Sided ([], _) ([], _)) scoreAcc usedns) = + takeSomeClasses (State [] unresolved@(Sided ([], _) ([], _)) scoreAcc usedns) = map statesFromMods . prod $ both (classMods . snd) unresolved where swap (Sided l r) = Sided r l@@ -532,7 +541,7 @@ mods = swap (both snd sides) in State [] classes (scoreAcc `mappend` (mempty { asymMods = mods })) usedns classMods :: Classes -> [(Classes, AsymMods)]- classMods cs = let lcs = length cs in + classMods cs = let lcs = length cs in [ (cs', mempty { typeClassIntro = lcs - length cs' }) | cs' <- subsets cs ] prod :: Sided [a] -> [Sided a] prod (Sided ls rs) = [Sided l r | l <- ls, r <- rs]
src/Idris/Unlit.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.Unlit+Description : Turn literate programs into normal programs.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Idris.Unlit(unlit) where import Idris.Core.TT
src/Idris/WhoCalls.hs view
@@ -1,3 +1,10 @@+{-|+Module : Idris.WhoCalls+Description : Find function callers and callees.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Idris.WhoCalls (whoCalls, callsWho) where import Idris.AbsSyntax@@ -77,7 +84,7 @@ findOccurs n = do ctxt <- getContext -- A definition calls a function if the function is in the type or RHS of the definition let defs = (map fst . filter (\(n', def) -> n /= n' && occursDef n def) . ctxtAlist) ctxt- -- A datatype calls its + -- A datatype calls its return defs whoCalls :: Name -> Idris [(Name, [Name])]
src/Pkg/PParser.hs view
@@ -1,3 +1,10 @@+{-|+Module : Pkg.PParser+Description : `iPKG` file parser and package description information.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE CPP, ConstraintKinds #-} #if !(MIN_VERSION_base(4,8,0)) {-# LANGUAGE OverlappingInstances #-}@@ -22,18 +29,33 @@ type PParser = StateT PkgDesc IdrisInnerParser data PkgDesc = PkgDesc {- pkgname :: String- , libdeps :: [String]- , objs :: [String]- , makefile :: Maybe String- , idris_opts :: [Opt]- , sourcedir :: String- , modules :: [Name]- , idris_main :: Name- , execout :: Maybe String- , idris_tests :: [Name]+ pkgname :: String -- ^ Name associated with a package.+ , pkgbrief :: Maybe String -- ^ Brief description of the package.+ , pkgversion :: Maybe String -- ^ Version string to associate with the package.+ , pkgreadme :: Maybe String -- ^ Location of the README file.+ , pkglicense :: Maybe String -- ^ Description of the licensing information.+ , pkgauthor :: Maybe String -- ^ Author information.+ , pkgmaintainer :: Maybe String -- ^ Maintainer information.+ , pkghomepage :: Maybe String -- ^ Website associated with the package.+ , pkgsourceloc :: Maybe String -- ^ Location of the source files.+ , pkgbugtracker :: Maybe String -- ^ Location of the project's bug tracker.+ , libdeps :: [String] -- ^ External dependencies.+ , objs :: [String] -- ^ Object files required by the package.+ , makefile :: Maybe String -- ^ Makefile used to build external code. Used as part of the FFI process.+ , idris_opts :: [Opt] -- ^ List of options to give the compiler.+ , sourcedir :: String -- ^ Source directory for Idris files.+ , modules :: [Name] -- ^ Modules provided by the package.+ , idris_main :: Name -- ^ If an executable in which module can the Main namespace and function be found.+ , execout :: Maybe String -- ^ What to call the executable.+ , idris_tests :: [Name] -- ^ Lists of tests to execute against the package. } deriving (Show) +-- | Default settings for package descriptions.+defaultPkg :: PkgDesc+defaultPkg = PkgDesc "" Nothing Nothing Nothing Nothing+ Nothing Nothing Nothing Nothing+ Nothing [] [] Nothing [] "" [] (sUN "") Nothing []+ instance HasLastTokenSpan PParser where getLastTokenSpan = return Nothing @@ -44,8 +66,6 @@ #endif someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure () -defaultPkg :: PkgDesc-defaultPkg = PkgDesc "" [] [] Nothing [] "" [] (sUN "") Nothing [] parseDesc :: FilePath -> IO PkgDesc parseDesc fp = do@@ -56,7 +76,8 @@ pPkg :: PParser PkgDesc pPkg = do- reserved "package"; p <- fst <$> identifier+ reserved "package"+ p <- filename st <- get put (st { pkgname = p }) some pClause@@ -113,41 +134,118 @@ exec <- filename st <- get put (st { execout = Just exec })+ <|> do reserved "main"; lchar '='; main <- fst <$> iName [] st <- get put (st { idris_main = main })+ <|> do reserved "sourcedir"; lchar '='; src <- fst <$> identifier st <- get put (st { sourcedir = src })+ <|> do reserved "opts"; lchar '='; opts <- stringLiteral st <- get let args = pureArgParser (words opts) put (st { idris_opts = args ++ idris_opts st })+ <|> do reserved "pkgs"; lchar '='; ps <- sepBy1 (fst <$> identifier) (lchar ',') st <- get let pkgs = pureArgParser $ concatMap (\x -> ["-p", x]) ps put (st {idris_opts = pkgs ++ idris_opts st})+ <|> do reserved "modules"; lchar '='; ms <- sepBy1 (fst <$> iName []) (lchar ',') st <- get put (st { modules = modules st ++ ms })+ <|> do reserved "libs"; lchar '='; ls <- sepBy1 (fst <$> identifier) (lchar ',') st <- get put (st { libdeps = libdeps st ++ ls })+ <|> do reserved "objs"; lchar '='; ls <- sepBy1 (fst <$> identifier) (lchar ',') st <- get put (st { objs = libdeps st ++ ls })+ <|> do reserved "makefile"; lchar '='; mk <- fst <$> iName [] st <- get put (st { makefile = Just (show mk) })+ <|> do reserved "tests"; lchar '='; ts <- sepBy1 (fst <$> iName []) (lchar ',') st <- get put st { idris_tests = idris_tests st ++ ts }++ <|> do reserved "version"+ lchar '='+ vStr <- many (satisfy (not . isEol))+ eol+ someSpace+ st <- get+ put st {pkgversion = Just vStr}++ <|> do reserved "readme"+ lchar '='+ rme <- many (satisfy (not . isEol))+ eol+ someSpace+ st <- get+ put (st { pkgreadme = Just rme })++ <|> do reserved "license"+ lchar '='+ lStr <- many (satisfy (not . isEol))+ eol+ st <- get+ put st {pkglicense = Just lStr}++ <|> do reserved "homepage"+ lchar '='+ www <- many (satisfy (not . isEol))+ eol+ someSpace+ st <- get+ put st {pkghomepage = Just www}++ <|> do reserved "sourceloc"+ lchar '='+ srcpage <- many (satisfy (not . isEol))+ eol+ someSpace+ st <- get+ put st {pkgsourceloc = Just srcpage}++ <|> do reserved "bugtracker"+ lchar '='+ src <- many (satisfy (not . isEol))+ eol+ someSpace+ st <- get+ put st {pkgbugtracker = Just src}++ <|> do reserved "brief"+ lchar '='+ brief <- stringLiteral+ st <- get+ someSpace+ put st {pkgbrief = Just brief}++ <|> do reserved "author"; lchar '=';+ author <- many (satisfy (not . isEol))+ eol+ someSpace+ st <- get+ put st {pkgauthor = Just author}++ <|> do reserved "maintainer"; lchar '=';+ maintainer <- many (satisfy (not . isEol))+ eol+ someSpace+ st <- get+ put st {pkgmaintainer = Just maintainer}
src/Pkg/Package.hs view
@@ -1,3 +1,10 @@+{-|+Module : Pkg.Package+Description : Functionality for working with Idris packages.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE CPP #-} module Pkg.Package where @@ -132,7 +139,7 @@ let mod = idris_main pkgdesc let f = toPath (showCG mod) putIState orig- dir <- runIO $ getCurrentDirectory+ dir <- runIO getCurrentDirectory runIO $ setCurrentDirectory $ dir </> sourcedir pkgdesc if (f /= "")
src/Util/DynamicLinker.hs view
@@ -1,7 +1,16 @@--- | Platform-specific dynamic linking support. Add new platforms to this file--- through conditional compilation.+{-|+Module : Util.DynamicLinker+Description : Platform-specific dynamic linking support. Add new platforms to this file through conditional compilation.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE ExistentialQuantification, CPP #-}-module Util.DynamicLinker (ForeignFun(..), DynamicLib(..), tryLoadLib, tryLoadFn) where+module Util.DynamicLinker ( ForeignFun(..)+ , DynamicLib(..)+ , tryLoadLib+ , tryLoadFn+ ) where #ifdef IDRIS_FFI import Foreign.LibFFI@@ -110,5 +119,3 @@ tryLoadFn fn lib = do putStrLn $ "WARNING: Cannot load '" ++ fn ++ "' at compile time because Idris was compiled without libffi support." return Nothing #endif--
src/Util/Net.hs view
@@ -1,3 +1,10 @@+{-|+Module : Util.Net+Description : Utilities for Network IO.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Util.Net (listenOnLocalhost, listenOnLocalhostAnyPort) where import Network hiding (socketPort)
src/Util/Pretty.hs view
@@ -1,8 +1,16 @@+{-|+Module : Util.Pretty+Description : Utilities for Pretty Printing.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Util.Pretty (- module Text.PrettyPrint.Annotated.Leijen,- Sized(..), nestingSize,- Pretty(..)-) where+ module Text.PrettyPrint.Annotated.Leijen+ , Sized(..)+ , nestingSize+ , Pretty(..)+ ) where --import Text.PrettyPrint.HughesPJ import Text.PrettyPrint.Annotated.Leijen@@ -22,5 +30,3 @@ class Pretty a ty where pretty :: a -> Doc ty--
src/Util/ScreenSize.hs view
@@ -1,3 +1,10 @@+{-|+Module : Util.ScreenSize+Description : Utilities for getting screen width.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} module Util.ScreenSize(getScreenWidth) where import System.Console.Terminal.Size (size, width)
src/Util/System.hs view
@@ -1,8 +1,22 @@+{-|+Module : Util.System+Description : Utilities for interacting with the system.+Copyright :+License : BSD3+Maintainer : The Idris Community.+-} {-# LANGUAGE CPP, ForeignFunctionInterface #-}-module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows,- writeSource, writeSourceText, readSource,- setupBundledCC, isATTY) where--- System helper functions.+module Util.System( tempfile+ , withTempdir+ , rmFile+ , catchIO+ , isWindows+ , writeSource+ , writeSourceText+ , readSource+ , setupBundledCC+ , isATTY+ ) where import Control.Exception as CE import Control.Monad (when)
test/basic010/expected view
@@ -1,3 +1,3 @@-*oink* -10000 -Axiom 10000 +*oink*+10000+Axiom 10000
test/error001/expected view
@@ -1,8 +1,8 @@ test002.idr:1:6:Universe inconsistency.- Working on: z+ Working on: ./test002.idr.z Old domain: (6,6) New domain: (6,5) Involved constraints: - ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}- ConstraintFC {uconstraint = y < z, ufc = test002.idr:1:6}- ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}+ ConstraintFC {uconstraint = ./test002.idr.z <= ./test002.idr.a1, ufc = test002.idr:1:6}+ ConstraintFC {uconstraint = ./test002.idr.y < ./test002.idr.z, ufc = test002.idr:1:6}+ ConstraintFC {uconstraint = ./test002.idr.z <= ./test002.idr.a1, ufc = test002.idr:1:6}
− test/error004/idx.idr
@@ -1,4 +0,0 @@-idx : (n : Nat) -> (l : List a) -> {auto ok : n < length l = True} -> a-idx Z (x::xs) {ok=p} = x-idx (S n) (x::xs) {ok=p} = idx n xs {ok=rewrite p in Refl}-idx _ [] {ok=Refl} impossible -- = ?foo
test/interactive010/expected view
@@ -4,9 +4,9 @@ Usage is :doc <functionname> Usage is :wc <functionname> Usage is :printdef <functionname>-pat {ty504} : Type u. pat {__class505} : Prelude.Interfaces.Fractional {ty504}. Prelude.Interfaces./ {ty504} {__class505}+pat {ty504} : Type toplevel.u. pat {__class505} : Prelude.Interfaces.Fractional {ty504}. Prelude.Interfaces./ {ty504} {__class505} - : pty {ty504} : Type u. pty {__class505} : Prelude.Interfaces.Fractional {ty504}. {ty504} -> {ty504} -> {ty504}+ : pty {ty504} : Type toplevel.u. pty {__class505} : Prelude.Interfaces.Fractional {ty504}. {ty504} -> {ty504} -> {ty504} (input):1:1: error: expected: ":", dependent type signature, end of input
test/interactive012/expected view
@@ -25,9 +25,9 @@ append_rhs_1 : Vect m a a : Type x : a- k : Nat- xs : Vect k a m : Nat ys : Vect m a+ k : Nat+ xs : Vect k a -------------------------------------- append_rhs_2 : Vect (S (plus k m)) a
test/io003/test018.idr view
@@ -10,11 +10,11 @@ pong = do (sender, x) <- recvMsg putStrLn x putStrLn "Received"- sendToThread sender "Hello to you too!"+ sendToThread sender 0 "Hello to you too!" return () ping : Ptr -> IO ()-ping thread = do sendToThread thread (prim__vm, "Hello!")+ping thread = do sendToThread thread 0 (prim__vm, "Hello!") return () pingpong : IO ()
test/pkg001/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-${IDRIS:-idris} $@ --build test.ipkg+${IDRIS:-idris} $@ --build test-pkg.ipkg rm -f *.ibc-${IDRIS:-idris} $@ --build test.ipkg --quiet-${IDRIS:-idris} $@ --build test.ipkg --logging-categories "elab" --log 1+${IDRIS:-idris} $@ --build test-pkg.ipkg --quiet+${IDRIS:-idris} $@ --build test-pkg.ipkg --logging-categories "elab" --log 1
+ test/pkg001/test-pkg.ipkg view
@@ -0,0 +1,17 @@+package "test-pkg"++pkgs = effects++opts = "--warnpartial --warnreach --nocolour --quiet --consolewidth 80"++modules = Main++author = Anne Author+maintainer = Anne Maintainer+license = BSD3 but see LICENSE for more information+brief = "This is a test package."+readme = README.md+version = 1234+homepage = http://www.idris-lang.org+sourceloc = http://ww.github.com/idris-lang/Idris-Dev+bugtracker = http://ww.github.com/idris-lang/Idris-Dev/issues
− test/pkg001/test.ipkg
@@ -1,7 +0,0 @@-package test--pkgs = effects--opts = "--warnpartial --warnreach --nocolour --quiet --consolewidth 80"--modules = Main
test/primitives006/Data/Bytes.idr view
@@ -61,11 +61,11 @@ BA.copy (arr, ofs) (arr', ofs') bytesUsed return $ B arr' ofs' (ofs' + bytesUsed) -%assert_total export snoc : Bytes -> Byte -> Bytes snoc bs@(B arr ofs end) byte- = if end >= BA.size arr+ = assert_total $+ if end >= BA.size arr then unsafePerformIO $ do -- need more space grown <- grow 2 bs return $ snoc grown byte@@ -114,11 +114,10 @@ return $ ConsView.Cons first (B arr (ofs+1) end) infixr 7 ++-%assert_total export (++) : Bytes -> Bytes -> Bytes (++) bsL@(B arrL ofsL endL) bsR@(B arrR ofsR endR)- = let countR = endR - ofsR in+ = assert_total $ let countR = endR - ofsR in if endL + countR > BA.size arrL then unsafePerformIO $ do -- need more space grown <- grow 2 bsL
test/proof002/Reflect.idr view
@@ -176,7 +176,7 @@ rewrite sym xprf; rewrite sym yprf; rewrite prf;- rewrite sym (appendAssociative xs1 xs2 ys1);+ rewrite sym (appendAssociative xs2 xs3 ys1); trivial; }
test/proof003/expected view
@@ -6,9 +6,9 @@ This style of tactic proof is deprecated. See %runElab for the replacement. test015.idr:97:16-21: This style of tactic proof is deprecated. See %runElab for the replacement.-test015.idr:108:20-25:+test015.idr:107:20-25: This style of tactic proof is deprecated. See %runElab for the replacement.-test015.idr:136:20-25:+test015.idr:142:20-25: This style of tactic proof is deprecated. See %runElab for the replacement. 00101010 01011001
test/proof003/test015.idr view
@@ -104,9 +104,14 @@ } -- There is almost certainly an easier proof. I don't care, for now :)- Main.adc_lemma_2 = proof {- intro v,w,num0,v1,num1,x,bx,x1,bx1,bit0,b0,bit1,b1,c,bc+ intros; -- v,w,num0,v1,num1,x,bx,x1,bx1,bit0,b0,bit1,b1,c,bc+ -- I'm bored of rewriting this when elaboration changes, and this+ -- style of proof is deprecated anyway, and this doesn't really test+ -- anything new, so I'm just going to add a 'believe_me'.+ -- TODO: When Franck's solver is ready, use it here!+ exact believe_me value;+{- rewrite sym (plusZeroRightNeutral x); rewrite sym (plusZeroRightNeutral v1); rewrite sym (plusZeroRightNeutral (plus (plus x v) v1));@@ -131,6 +136,7 @@ rewrite sym (plusAssociative (plus x v) v1 (plus x v)); rewrite (plusAssociative (plus (plus x v) v1) (plus x v) v1); trivial;+ -} } Main.adc_lemma_1 = proof {
test/proof011/expected view
@@ -2,11 +2,13 @@ When checking right hand side of vassoc' with expected type (x :: xs) ++ ys ++ zs = ((x :: xs) ++ ys) ++ zs -rewrite did not change type x :: xs ++ ys ++ zs =- x :: (xs ++ ys) ++ zs+rewriting xs ++ ys ++ xs to (xs ++ ys) +++ xs did not change type x :: xs ++ ys ++ zs =+ x :: (xs ++ ys) ++ zs proof011a.idr:13:9: When checking right hand side of vassoc' with expected type (x :: xs) ++ ys ++ zs = ((x :: xs) ++ ys) ++ zs -rewrite did not change type x :: xs ++ ys ++ zs =- x :: (xs ++ ys) ++ zs+rewriting xs ++ ys ++ xs to (xs ++ ys) +++ xs did not change type x :: xs ++ ys ++ zs =+ x :: (xs ++ ys) ++ zs
test/proofsearch002/Process.idr view
@@ -248,15 +248,15 @@ readMsg : IO (Maybe (Ptr, Message iface hs)) readMsg {iface} {hs} = do if !checkMsgs- then do msg <- getMsgWithSender {a = Message iface hs}- pure (Just msg)+ then do (p, _, msg) <- getMsgWithSender {a = Message iface hs}+ pure (Just (p, msg)) else pure Nothing readMsgTimeout : Int -> IO (Maybe (Ptr, Message iface hs)) readMsgTimeout {iface} {hs} i = do if !(checkMsgsTimeout i)- then do msg <- getMsgWithSender {a = Message iface hs}- pure (Just msg)+ then do (pid, _, msg) <- getMsgWithSender {a = Message iface hs}+ pure (Just (pid, msg)) else pure Nothing data RespEnv : List (ReqHandle, Type) -> Type where@@ -383,7 +383,7 @@ eval (record { clients = clients st + 1 } st) cont k eval {hs} (MkEvalState q reqs c nh) (Request (MkPID pid) x) k- = do sendToThread pid (MsgQuery {hs} (RequestMsg nh x))+ = do sendToThread pid 0 (MsgQuery {hs} (RequestMsg nh x)) k (MkReqH nh) (MkEvalState q (Nothing :: reqs) c (S nh)) eval {p} st (GetReply {pending} h) k @@ -407,7 +407,7 @@ (\ r, st''' => case r of (resp, val) => do- sendToThread pid (MsgReply {iface} {hs} (ReplyMsg rq resp))+ sendToThread pid 0 (MsgReply {iface} {hs} (ReplyMsg rq resp)) k val st''') eval {iface} {hs} st (Respond f) k @@ -416,19 +416,19 @@ Nothing => eval {iface} st' (Respond f) k Just (pid, (_ ** (rq, req)), st'') => do eval st'' (f req) (\ (resp, val), st''' => do- sendToThread pid (MsgReply {iface} {hs} (ReplyMsg rq resp))+ sendToThread pid 0 (MsgReply {iface} {hs} (ReplyMsg rq resp)) k val st''') eval {hs} st (Connect {serveri} (MkPID pid)) k = if pid == prim__vm then k False st else do- v <- sendToThread pid (MsgQuery {iface=serveri} {hs}- ConnectMsg)+ v <- sendToThread pid 0 (MsgQuery {iface=serveri} {hs}+ ConnectMsg) -- TODO: Wait for ACK k (v == 1) st eval {hs} st (Disconnect {serveri} (MkPID pid)) k - = do v <- sendToThread pid (MsgQuery {iface=serveri} {hs} - CloseMsg)+ = do v <- sendToThread pid 0 (MsgQuery {iface=serveri} {hs} + CloseMsg) k () st eval st CountClients k @@ -440,4 +440,3 @@ run : Program a iface -> IO a run p = eval (MkEvalState [] [] 0 0) p (\res, t => pure res)-
test/pruviloj001/pruviloj001.idr view
@@ -68,4 +68,3 @@ -- Local Variables: -- idris-load-packages: ("pruviloj") -- End:-
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 (-1))) (TType (UVar (-1)))) (Bind (UN "x") (Pi (V 0) (TType (UVar (-1)))) (Bind (UN "xs") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 8 0) (UN "Unit") (TType (UVar (-1))))) (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 (-1))) (TType (UVar (-1)))) (Bind (UN "x") (Pi (V 0) (TType (UVar (-1)))) (Bind (UN "xs") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 8 0) (UN "Unit") (TType (UVar (-1))))) (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 (-1))) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 0)))) (P (TCon 8 0) (UN "Unit") (TType (UVar (-1))))))+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 (-1))) (TType (UVar (-1)))) (Bind (UN "x") (Pi (V 0) (TType (UVar (-1)))) (Bind (UN "xs") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 24))) (TType (UVar 25))) (App (App (App (P (DCon 1 3) (NS (UN "::") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "x") (Pi (V 0) (TType (UVar (-1)))) (Bind (UN "xs") (Pi (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 1)) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 26))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "B") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "a") (Pi (V 1) (TType (UVar (-1)))) (Bind (UN "b") (Pi (V 1) (TType (UVar (-1)))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (P (TCon 8 0) (NS (UN "Nat") ["Nat", "Prelude"]) (TType (UVar (-1))))) (P (TCon 8 0) (NS (UN "Nat") ["Nat", "Prelude"]) (TType (UVar (-1)))))) (App (P (DCon 0 1) (NS (UN "Nil") ["List", "Prelude"]) (Bind (UN "elem") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (App (P (TCon 0 0) (NS (UN "List") ["List", "Prelude"]) Erased) (V 0)))) (TType (UVar 27))))+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 (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "B") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "a") (Pi (V 1) (TType (UVar (-1)))) (Bind (UN "b") (Pi (V 1) (TType (UVar (-1)))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "B") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "a") (Pi (V 1) (TType (UVar (-1)))) (Bind (UN "b") (Pi (V 1) (TType (UVar (-1)))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (TType (UVar 24))) (TType (UVar 24)))) (App (App (App (App (P (DCon 0 4) (NS (UN "MkPair") ["Builtins"]) (Bind (UN "A") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "B") (Pi (TType (UVar (-1))) (TType (UVar (-1)))) (Bind (UN "a") (Pi (V 1) (TType (UVar (-1)))) (Bind (UN "b") (Pi (V 1) (TType (UVar (-1)))) (App (App (P (TCon 0 0) (NS (UN "Pair") ["Builtins"]) Erased) (V 3)) (V 2))))))) (TType (UVar 22))) (TType (UVar 23))) (TType (UVar 24))) (TType (UVar 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))) (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)))
− test/reg001/expected
− test/reg001/reg001.idr
@@ -1,209 +0,0 @@--- Everything here should type check but at some point in the past has--- not.--import Data.So-import Data.Vect-import Data.HVect-import Data.Fin-import Control.Isomorphism--interface Functor f => VerifiedFunctor (f : Type -> Type) where- identity : (fa : f a) -> map Basics.id fa = fa--data Imp : Type where- MkImp : {any : Type} -> any -> Imp--testVal : Imp-testVal = MkImp (apply id Z)--zfin : Fin 1-zfin = 0--data Infer = MkInf a--foo : Infer-foo = MkInf (the (Fin 1) 0)--isAnyBy : (alpha -> Bool) -> (n : Nat ** Vect n alpha) -> Bool-isAnyBy _ (_ ** Nil) = False-isAnyBy p (_ ** (a :: as)) = p a || isAnyBy p (_ ** as)--filterTagP : (p : alpha -> Bool) ->- (as : Vect n alpha) ->- So (isAnyBy p (n ** as)) ->- (m : Nat ** (Vect m (a : alpha ** So (p a)), So (m > Z)))-filterTagP {n = S m} p (a :: as) q with (p a)- | True = (_- **- ((a ** believe_me Oh)- ::- (fst (snd (filterTagP p as (believe_me Oh)))),- Oh- )- )- | False = filterTagP p as (believe_me Oh)--vfoldl : (P : Nat -> Type) ->- ((x : Nat) -> P x -> a -> P (S x)) -> P Z- -> Vect m a -> P m-vfoldl P cons nil (x :: xs)- = vfoldl (\k => P (S k)) (\ n => cons (S n)) (cons Z nil x) xs---total soElim : (C : (b : Bool) -> So b -> Type) ->- C True Oh ->- (b : Bool) -> (s : So b) -> (C b s)-soElim C coh True Oh = coh--soFalseElim : So False -> a-soFalseElim x = void (soElim C () False x)- where- C : (b : Bool) -> So b -> Type- C True s = ()- C False s = Void--soTrue : So b -> b = True-soTrue {b = False} x = soFalseElim x-soTrue {b = True} x = Refl--interface Eq alpha => ReflEqEq alpha where- reflexive_eqeq : (a : alpha) -> So (a == a)--modifyFun : (Eq alpha) =>- (alpha -> beta) ->- (alpha, beta) ->- (alpha -> beta)-modifyFun f (a, b) a' = if a' == a then b else f a'--modifyFunLemma : (ReflEqEq alpha) =>- (f : alpha -> beta) ->- (ab : (alpha, beta)) ->- modifyFun f ab (fst ab) = snd ab-modifyFunLemma f (a,b) =- rewrite soTrue (reflexive_eqeq a) in Refl---Matrix : Type -> Nat -> Nat -> Type-Matrix a n m = Vect n (Vect m a)--mytranspose : Matrix a (S n) (S m) -> Matrix a (S m) (S n)-mytranspose ((x:: []) :: []) = [[x]]-mytranspose [x :: y :: xs] = [x] :: (mytranspose [y :: xs])-mytranspose (x :: y :: xs)- = let tx = mytranspose [x] in- let ux = mytranspose (y :: xs) in zipWith (++) tx ux--using (A : Type, B : A->Type, C : Type)- foo2 : ((x:A) -> B x -> C) -> ((x:A ** B x) -> C)- foo2 f p = f (fst p) (snd p)---m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) ->- Maybe (Either Bool Int)-m_add x y = do x' <- x -- Extract value from x- y' <- y -- Extract value from y- case x' of- Left _ => Nothing- Right _ => Nothing--data Ty = TyBool--data Id a = I a--interpTy : Ty -> Type-interpTy TyBool = Id Bool--data Term : Ty -> Type where- TLit : Bool -> Term TyBool- TNot : Term TyBool -> Term TyBool--map : (a -> b) -> Id a -> Id b-map f (I x) = I (f x)--interp : Term t -> interpTy t-interp (TLit x) = I x-interp (TNot x) = map not (interp x)--data Result str a = Success str a | Failure String--implementation Functor (Result str) where- map f (Success s x) = Success s (f x)- map f (Failure e ) = Failure e--ParserT : (Type -> Type) -> Type -> Type -> Type-ParserT m str a = str -> m (Result str a)--ap : Monad m => ParserT m str (a -> b) -> ParserT m str a ->- ParserT m str b-ap f x = \s => do f' <- f s- case f' of- Failure e => (pure (Failure e))- Success s' g => x s' >>= pure . map g--X : Nat -> Type-X t = (c : Nat ** So (c < 5))--column : X t -> Nat-column = fst--data Action = Left | Ahead | Right--admissible : X t -> Action -> Bool-admissible {t} x Ahead = column {t} x == 0 || column {t} x == 4-admissible {t} x Left = column {t} x <= 2-admissible {t} x Right = column {t} x >= 2---interface Set univ where- member : univ -> univ -> Type--isSubsetOf : Set univ => univ -> univ -> Type-isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)--interface Set univ => HasPower univ where- Powerset : (a : univ) ->- DPair univ (\Pa => (c : univ) ->- (isSubsetOf c a) -> member c Pa)--powerset : HasPower univ => univ -> univ-powerset {univ} a = fst (Powerset a)--mapFilter : (alpha -> beta) ->- (alpha -> Bool) ->- Vect n alpha ->- (n : Nat ** Vect n beta)-mapFilter f p Nil = (_ ** Nil)-mapFilter f p (a :: as) with (p a)- | True = (_ ** (f a) :: (snd (mapFilter f p as)))- | False = mapFilter f p as--hVectEx1 : HVect [String, List Nat, Nat, (Nat, Nat)]-hVectEx1 = ["Hello",[1,2,3],42,(0,10)]--vecfoo : HVect [String, List Nat, Nat, (Nat, Nat)]-vecfoo = put (S (S Z)) hVectEx1--foom : Monad m => Int -> m Int-foom = pure--bar : IO ()-bar = case foom 5 of- Nothing => print 42- Just n => print n--Max : (Nat -> Type) -> Type-Max p = (Nat , (k : Nat) -> p k -> Nat)--maxEquiv : Max p -> (n1 : Nat) -> p n1 -> Nat-maxEquiv a n1 pr1 = snd a n1 pr1--data Rho = R--rho : Rho -> Rho-rho r = case r of R => r--data Kappa : (r : Rho) -> Type where K : Kappa r--kappa : Kappa (rho r) -> Kappa (rho r)-kappa {r} k = k' where -- k' : Kappa (rho r)- k' = k
− test/reg001/run
@@ -1,4 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} reg001.idr --check-rm -rf reg001.ibc-
test/reg035/reg035a.lidr view
@@ -15,13 +15,12 @@ > hasNoDuplicates : (Eq alpha) => List alpha -> Bool > hasNoDuplicates as = as == nub as -> %assert_total > setEq : (Eq alpha) => List alpha -> List alpha -> Bool > setEq Nil Nil = True > setEq Nil (y :: ys) = False > setEq (x :: xs) Nil = False > setEq {alpha} (x :: xs) (y :: ys) =-> (x == y && setEq xs ys) +> assert_total $ (x == y && setEq xs ys) > || > (elem x ys && elem y xs && > setEq (filter (/= y) xs) (filter (/= x) ys)
− test/reg036/expected
− test/reg036/reg036.idr
@@ -1,12 +0,0 @@-import Data.HVect- -using (m : Nat, ts : Vect m Type)- - data HV : Vect n Type -> Type where- MkHV : HVect ts -> HV ts-- showHV : Shows m ts => HV ts -> String- showHV (MkHV v) = show v-- implementation Shows m ts => Show (HV ts) where- show = showHV
− test/reg036/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} --check reg036.idr-rm -f reg036 *.ibc
− test/reg037/expected
− test/reg037/reg037.idr
@@ -1,9 +0,0 @@----- Parser regression for (=) as a function name (fnName)--interface Foo (t : a -> b -> Type) where- foo : (x : _) -> (y : _) -> t x y -> t x y--implementation Foo ((=) {A=a} {B=b}) where- foo x y prf = prf-
− test/reg037/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} --check reg037.idr-rm -f reg037 *.ibc
− test/reg038/expected
− test/reg038/reg038.idr
@@ -1,17 +0,0 @@-interface C t (f : t -> t) (r : t -> t -> Type) where- g : (a : t) -> r (f a) (f a) -> r (f a) (f a)--data Foo : {t : Type} -> t -> t -> Type where- MkFoo : {t : Type} -> {x : t} -> {y : t} -> Foo x y--implementation C t f (Foo {t = t}) where- g x = id--data Bar : {t1 : Type} -> {t2 : Type} -> t1 -> t2 -> Type where- MkBar : {x : t1} -> Bar x x--implementation C s f (Bar {t1 = s} {t2 = s}) where- g x = id--implementation C s f ((=) {A = s} {B = s}) where- g x = id
− test/reg038/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} --check reg038.idr-rm -f *.ibc
test/reg041/ott.idr view
@@ -23,18 +23,17 @@ syntax "<|" [s] "|>" = El s syntax [x] "==" [y] "in" [s] = EQ s x s y -%assert_total EQ : (s : U) -> <| s |> -> (t : U) -> <| t |> -> U EQ MkU MkU MkU MkU = One EQ MkU Zero MkU Zero = One EQ MkU One MkU One = One EQ MkU Two MkU Two = One-EQ MkU (Pi s t) MkU (Pi s' t') = Pi s $ \x => Pi s' $ \y => EQ s x s' y ~> EQ MkU (t x) MkU (t' y)+EQ MkU (Pi s t) MkU (Pi s' t') = assert_total $ Pi s $ \x => Pi s' $ \y => EQ s x s' y ~> EQ MkU (t x) MkU (t' y) EQ Zero x Zero y = One EQ One x One y = One EQ Two True Two True = One EQ Two False Two False = One-EQ (Pi s t) f (Pi s' t') g = Pi s $ \x => Pi s' $ \y => EQ s x s' y ~> EQ (t x) (f x) (t' y) (g y)+EQ (Pi s t) f (Pi s' t') g = assert_total $ Pi s $ \x => Pi s' $ \y => EQ s x s' y ~> EQ (t x) (f x) (t' y) (g y) EQ _ _ _ _ = Zero example : <| (Basics.id == Basics.id in (OTT.Two ~> OTT.Two)) |>
− test/reg046/expected
− test/reg046/reg046.idr
@@ -1,19 +0,0 @@-module test--data MyList : (A : Type) -> Type where- MyNil : (A : Type) -> MyList A- MyCons : (A : Type) -> A -> MyList A -> MyList A--elimList : (A : Type) ->- (m : MyList A -> Type) ->- (f1 : m (MyNil A)) ->- (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)--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)- b)
− test/reg046/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ reg046.idr --check-rm -f reg046 *.ibc
− test/reg047/expected
− test/reg047/reg047.idr
@@ -1,18 +0,0 @@-module test--data TTSigma : (A : Type) -> (B : A -> Type) -> Type where- Sigma : (A : Type) -> (B : A -> Type) -> (a : A) -> B a -> TTSigma A B--data Nat = Zero | Succ Nat--Id : (A : Type) -> A -> A -> Type-Id A = (=) {A = A} {B = A}--IdRefl : (A : Type) -> (a : A) -> Id A a a-IdRefl A a = Refl {x = a}--zzz : Id Nat Zero Zero-zzz = IdRefl Nat Zero--eep : TTSigma Nat (\ a => Id Nat a Zero)-eep = Sigma Nat (\ a => Id Nat a Zero) Zero zzz
− test/reg047/reg047a.idr
@@ -1,24 +0,0 @@-module test--data TTSigma : (A : Type) -> (B : A -> Type) -> Type where- Sigma : (A : Type) -> (B : A -> Type) -> (a : A) -> B a -> TTSigma A B--data MNat = Zero | Succ MNat--Id : (A : Type) -> A -> A -> Type-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}--zzzz : Id MNat Zero Zero-zzzz = IdRefl MNat Zero--eep : TTSigma MNat (\ c => Id MNat c Zero)-eep = (Sigma MNat (\b => Id MNat b Zero) Zero zzzz)--eep2 : TTSigma MNat (\ c => Id MNat c Zero)-eep2 = (Sigma MNat (\b => Id MNat b Zero) Zero (IdRefl MNat Zero))---
− test/reg047/run
@@ -1,4 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ reg047.idr --check --nobuiltins-${IDRIS:-idris} $@ reg047a.idr --check-rm -f *.ibc
− test/reg053/expected
− test/reg053/four.idr
@@ -1,9 +0,0 @@-module FourFunctor--data FourFunctor y = Four y y y y--traverseFourFunctor : Applicative f -> - (x -> f b) -> FourFunctor x -> f (FourFunctor b)-traverseFourFunctor constr f (Four w x y z) - = pure Four <*> (f w) <*> (f x) <*> (f y) <*> (f z)-
− test/reg053/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ --check four.idr -rm -f *.ibc
test/reg056/reg056.idr view
@@ -12,4 +12,3 @@ false : Void false = nonk (k Nat Z Z trap Refl) -
− test/reg057/expected
− test/reg057/reg057.idr
@@ -1,8 +0,0 @@-module Foo--data CrappySet : (a : Type) -> Ord a -> Type where- Empty : (inst : Ord a) => CrappySet a inst- Item : (inst : Ord a) => a -> CrappySet a inst -> CrappySet a inst--empty : (inst : Ord a) => CrappySet a inst-
− test/reg057/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ reg057.idr --check-rm -f *.ibc
− test/reg058/expected
− test/reg058/implicits.idr
@@ -1,14 +0,0 @@-%default total--InterpBool : () -> Type-InterpBool () = {x : Type} -> x -> Nat--interface IdrisBug (u : ()) where- idrisBug : InterpBool u--implementation IdrisBug () where- idrisBug _ = Z--f : Nat-f = idrisBug {u = ()} 'a'-
− test/reg058/implicits2.idr
@@ -1,19 +0,0 @@-import Data.Vect--impTy : Bool -> Type-impTy True = Int-impTy False = {n : Nat} -> Vect n Int -> Vect n Int--wibble : impTy False-wibble [] = [] -wibble (x :: xs) = x * 2 :: wibble xs--wobble : (b : Bool) -> impTy b-wobble True = 42-wobble False = wibble--foo : Vect 4 Int-foo = wobble False [1,2,3,4]--bar : Int-bar = wobble True
− test/reg058/run
@@ -1,5 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ implicits.idr --check-${IDRIS:-idris} $@ implicits2.idr --check--rm -f *.ibc
− test/reg059/expected
− test/reg059/reg059.idr
@@ -1,8 +0,0 @@-interface Monad m => ContainerMonad (m : Type -> Type) where- Elem : a -> m a -> Type- tagElem : (mx : m a) -> m (x : a ** Elem x mx)--interface Monad m => ContainerMonad2 a (m : Type -> Type) where- Elem2 : a -> m a -> Type- tagElem2 : (mx : m a) -> m (x : a ** Elem2 x mx)-
− test/reg059/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ reg059.idr --check-rm -f *.ibc
− test/reg060/expected
− test/reg060/reg060.idr
@@ -1,12 +0,0 @@--interface MyFunctor (f : Type -> Type) where- mymap : (m : a -> b) -> f a -> f b--data Foo x y = Bar y--implementation MyFunctor (Foo m) where- mymap m x = ?wibble--implementation [foo] Functor m => MyFunctor m where- mymap m x = map m x-
− test/reg060/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ reg060.idr --check-rm -f *.ibc
− test/reg061/Capture.idr
@@ -1,9 +0,0 @@-module Capture---- Test for variable capture in syntax--syntax delay [x] = \z => case z of { () => x }-syntax delay' [z] = delay z--capture : a -> () -> a-capture x = delay' x
− test/reg061/expected
− test/reg061/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ Capture.idr --check-rm -f *.ibc
− test/reg062/expected
− test/reg062/reg062.idr
@@ -1,13 +0,0 @@-module MinCrash---- Test that #2130 stays fixed. It's important that the first argument--- to revInduction be called `pred` here, because the bug was--- triggered by looking up a bound variable in the global context and--- getting an ambiguous result in a context where fully-qualified--- names were expected.--revInduction : (P : List a -> Type) -> P [] -> ((xs : List a) -> (x : a) -> P xs -> P (xs ++ [x]))- -> (ys : List a) -> P ys-revInduction pred base ind ys with (reverse ys)- revInduction pred base ind _ | revys =- ?revInduction_rhs
− test/reg062/run
@@ -1,4 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ reg062.idr --check --nocolour-${IDRIS:-idris} $@ reg062.lidr --check --nocolour-rm -f *.ibc
− test/reg063/Cmp.idr
@@ -1,19 +0,0 @@-||| Test that explicit proof objects on the with rule work-module Cmp---data MyCmp : Nat -> Nat -> Type where- IsLT : (d : Nat) -> MyCmp n (S d + n)- IsEQ : MyCmp n n- IsGT : (d : Nat) -> MyCmp (S d + n) n--myCmp : (j, k : Nat) -> MyCmp j k-myCmp Z Z = IsEQ-myCmp Z (S k) = rewrite sym $ plusZeroRightNeutral k in IsLT k-myCmp (S j) Z = rewrite sym $ plusZeroRightNeutral j in IsGT j-myCmp (S j) (S k) with (myCmp j k) proof p- myCmp (S j) (S (S (plus d j))) | (IsLT d) = rewrite plusSuccRightSucc d j- in let useless = id p in IsLT d- myCmp (S j) (S j) | IsEQ = IsEQ- myCmp (S (S (plus d k))) (S k) | (IsGT d) = rewrite plusSuccRightSucc d k- in IsGT d
− test/reg063/expected
− test/reg063/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ Cmp.idr --check --nocolour --quiet-rm *.ibc
− test/reg064/expected
− test/reg064/reg064.idr
@@ -1,8 +0,0 @@-sigmaEq2 : {A : Type} ->- {P : A -> Type} ->- {s1: DPair A P} ->- {s2: DPair A P} ->- fst s1 = fst s2 ->- snd s1 = snd s2 ->- s1 = s2-sigmaEq2 {A} {P} {s1 = (x ** prf)} {s2 = (x ** prf)} Refl Refl = Refl
− test/reg064/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ reg064.idr --check-rm -f *.ibc
− test/reg065/expected
− test/reg065/reg065.idr
@@ -1,26 +0,0 @@-||| Test that dependent type interface definitions work.-|||-||| Fixes a regression where previous methods used in a later method's-||| type would lead to "can't find interface" errors-module TypeClassDep--import Data.Vect---interface Foo a where- getLen : Nat- item : a -> Vect getLen a--implementation Foo () where- getLen = 3- item () = [(), (), ()]--implementation Foo String where- getLen = 1- item str = [str]--check1 : item () = with Vect [(),(),()]-check1 = Refl--check2 : item "halløjsa" = with Vect ["halløjsa"]-check2 = Refl
− test/reg065/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ reg065.idr --check-rm -f *.ibc
− test/reg066/expected
− test/reg066/reg066.idr
@@ -1,7 +0,0 @@-foo : Reflection.Raw -> Bool-foo `(~_ -> ~_) = True-foo _ = False--foo' : TT -> Bool-foo' `(~_ -> ~_) = True-foo' _ = False
− test/reg066/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ reg066.idr --check --nocolor-rm -f *.ibc
− test/reg071/expected
− test/reg071/reg071.idr
@@ -1,19 +0,0 @@-mutual- data Odd : Type where- MkOdd : Even -> Odd-- data Even : Type where- MkEven : Odd -> Even - EvenZ : Even--mutual- total- countEven : Even -> Nat- countEven (MkEven x) = countOdd x- countEven EvenZ = Z-- total- countOdd : Odd -> Nat- countOdd (MkOdd x) = S (countEven x)- -
− test/reg071/run
@@ -1,3 +0,0 @@-#!/usr/bin/env bash-${IDRIS:-idris} $@ reg071.idr --check-rm -f *.ibc
+ test/reg075/expected view
@@ -0,0 +1,6 @@+data Foo : Bar m BMODEL -> Model ty -> FTy -> Type where+ FElem : (name : String) -> Foo p (MElem name) FELEM+ FLink : Foo p x FELEM ->+ (c : Common) ->+ (f : Bar g BELEM) ->+ {auto prf : isValid f p = Yes prf'} -> Foo p (MLink c x g) FLINK
+ test/reg075/input view
@@ -0,0 +1,1 @@+:printdef Foo
+ test/reg075/reg075.idr view
@@ -0,0 +1,33 @@+module PDefs++%access public export++data Common = MkCommon++data MTy = MMODEL | MELEM | MLINK+data Model : MTy -> Type where+ MkModel : Model MMODEL+ MLink : Common -> Model MELEM -> Model MELEM -> Model MLINK+ MElem : String -> Model MELEM++data BTy = BELEM | BMODEL+data Bar : Model ty -> BTy -> Type where+ BElem : (name : String) -> Bar (MElem name) BELEM+ BModel : Bar (MkModel) BMODEL++data Pred : Bar g BELEM -> Bar m BMODEL -> Type where++isValid : (f : Bar g BELEM) -> (p : Bar m BMODEL) -> Dec (Pred f p)+isValid p = ?as++data FTy = FELEM | FLINK++data Foo : Bar m BMODEL -> Model ty -> FTy -> Type where+ FElem : (name : String) -> Foo p (MElem name) FELEM++ FLink : (a : Foo p x FELEM)+ -> (c : Common)+ -> (f : Bar g BELEM)+ -> {auto prf : isValid f p = Yes prf'}+ -> Foo p (MLink c x g) FLINK+
+ test/reg075/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} --quiet reg075.idr < input+rm -f *.ibc
+ test/regression001/expected view
+ test/regression001/reg001.idr view
@@ -0,0 +1,209 @@+-- Everything here should type check but at some point in the past has+-- not.++import Data.So+import Data.Vect+import Data.HVect+import Data.Fin+import Control.Isomorphism++interface Functor f => VerifiedFunctor (f : Type -> Type) where+ identity : (fa : f a) -> map Basics.id fa = fa++data Imp : Type where+ MkImp : {any : Type} -> any -> Imp++testVal : Imp+testVal = MkImp (apply id Z)++zfin : Fin 1+zfin = 0++data Infer = MkInf a++foo : Infer+foo = MkInf (the (Fin 1) 0)++isAnyBy : (alpha -> Bool) -> (n : Nat ** Vect n alpha) -> Bool+isAnyBy _ (_ ** Nil) = False+isAnyBy p (_ ** (a :: as)) = p a || isAnyBy p (_ ** as)++filterTagP : (p : alpha -> Bool) ->+ (as : Vect n alpha) ->+ So (isAnyBy p (n ** as)) ->+ (m : Nat ** (Vect m (a : alpha ** So (p a)), So (m > Z)))+filterTagP {n = S m} p (a :: as) q with (p a)+ | True = (_+ **+ ((a ** believe_me Oh)+ ::+ (fst (snd (filterTagP p as (believe_me Oh)))),+ Oh+ )+ )+ | False = filterTagP p as (believe_me Oh)++vfoldl : (P : Nat -> Type) ->+ ((x : Nat) -> P x -> a -> P (S x)) -> P Z+ -> Vect m a -> P m+vfoldl P cons nil (x :: xs)+ = vfoldl (\k => P (S k)) (\ n => cons (S n)) (cons Z nil x) xs+++total soElim : (C : (b : Bool) -> So b -> Type) ->+ C True Oh ->+ (b : Bool) -> (s : So b) -> (C b s)+soElim C coh True Oh = coh++soFalseElim : So False -> a+soFalseElim x = void (soElim C () False x)+ where+ C : (b : Bool) -> So b -> Type+ C True s = ()+ C False s = Void++soTrue : So b -> b = True+soTrue {b = False} x = soFalseElim x+soTrue {b = True} x = Refl++interface Eq alpha => ReflEqEq alpha where+ reflexive_eqeq : (a : alpha) -> So (a == a)++modifyFun : (Eq alpha) =>+ (alpha -> beta) ->+ (alpha, beta) ->+ (alpha -> beta)+modifyFun f (a, b) a' = if a' == a then b else f a'++modifyFunLemma : (ReflEqEq alpha) =>+ (f : alpha -> beta) ->+ (ab : (alpha, beta)) ->+ modifyFun f ab (fst ab) = snd ab+modifyFunLemma f (a,b) =+ rewrite soTrue (reflexive_eqeq a) in Refl+++Matrix : Type -> Nat -> Nat -> Type+Matrix a n m = Vect n (Vect m a)++mytranspose : Matrix a (S n) (S m) -> Matrix a (S m) (S n)+mytranspose ((x:: []) :: []) = [[x]]+mytranspose [x :: y :: xs] = [x] :: (mytranspose [y :: xs])+mytranspose (x :: y :: xs)+ = let tx = mytranspose [x] in+ let ux = mytranspose (y :: xs) in zipWith (++) tx ux++using (A : Type, B : A->Type, C : Type)+ foo2 : ((x:A) -> B x -> C) -> ((x:A ** B x) -> C)+ foo2 f p = f (fst p) (snd p)+++m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) ->+ Maybe (Either Bool Int)+m_add x y = do x' <- x -- Extract value from x+ y' <- y -- Extract value from y+ case x' of+ Left _ => Nothing+ Right _ => Nothing++data Ty = TyBool++data Id a = I a++interpTy : Ty -> Type+interpTy TyBool = Id Bool++data Term : Ty -> Type where+ TLit : Bool -> Term TyBool+ TNot : Term TyBool -> Term TyBool++map : (a -> b) -> Id a -> Id b+map f (I x) = I (f x)++interp : Term t -> interpTy t+interp (TLit x) = I x+interp (TNot x) = map not (interp x)++data Result str a = Success str a | Failure String++implementation Functor (Result str) where+ map f (Success s x) = Success s (f x)+ map f (Failure e ) = Failure e++ParserT : (Type -> Type) -> Type -> Type -> Type+ParserT m str a = str -> m (Result str a)++ap : Monad m => ParserT m str (a -> b) -> ParserT m str a ->+ ParserT m str b+ap f x = \s => do f' <- f s+ case f' of+ Failure e => (pure (Failure e))+ Success s' g => x s' >>= pure . map g++X : Nat -> Type+X t = (c : Nat ** So (c < 5))++column : X t -> Nat+column = fst++data Action = Left | Ahead | Right++admissible : X t -> Action -> Bool+admissible {t} x Ahead = column {t} x == 0 || column {t} x == 4+admissible {t} x Left = column {t} x <= 2+admissible {t} x Right = column {t} x >= 2+++interface Set univ where+ member : univ -> univ -> Type++isSubsetOf : Set univ => univ -> univ -> Type+isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)++interface Set univ => HasPower univ where+ Powerset : (a : univ) ->+ DPair univ (\Pa => (c : univ) ->+ (isSubsetOf c a) -> member c Pa)++powerset : HasPower univ => univ -> univ+powerset {univ} a = fst (Powerset a)++mapFilter : (alpha -> beta) ->+ (alpha -> Bool) ->+ Vect n alpha ->+ (n : Nat ** Vect n beta)+mapFilter f p Nil = (_ ** Nil)+mapFilter f p (a :: as) with (p a)+ | True = (_ ** (f a) :: (snd (mapFilter f p as)))+ | False = mapFilter f p as++hVectEx1 : HVect [String, List Nat, Nat, (Nat, Nat)]+hVectEx1 = ["Hello",[1,2,3],42,(0,10)]++vecfoo : HVect [String, List Nat, Nat, (Nat, Nat)]+vecfoo = put (S (S Z)) hVectEx1++foom : Monad m => Int -> m Int+foom = pure++bar : IO ()+bar = case foom 5 of+ Nothing => print 42+ Just n => print n++Max : (Nat -> Type) -> Type+Max p = (Nat , (k : Nat) -> p k -> Nat)++maxEquiv : Max p -> (n1 : Nat) -> p n1 -> Nat+maxEquiv a n1 pr1 = snd a n1 pr1++data Rho = R++rho : Rho -> Rho+rho r = case r of R => r++data Kappa : (r : Rho) -> Type where K : Kappa r++kappa : Kappa (rho r) -> Kappa (rho r)+kappa {r} k = k' where -- k' : Kappa (rho r)+ k' = k
+ test/regression001/reg036.idr view
@@ -0,0 +1,12 @@+import Data.HVect+ +using (m : Nat, ts : Vect m Type)+ + data HV : Vect n Type -> Type where+ MkHV : HVect ts -> HV ts++ showHV : Shows m ts => HV ts -> String+ showHV (MkHV v) = show v++ implementation Shows m ts => Show (HV ts) where+ show = showHV
+ test/regression001/reg037.idr view
@@ -0,0 +1,9 @@++--- Parser regression for (=) as a function name (fnName)++interface Foo (t : a -> b -> Type) where+ foo : (x : _) -> (y : _) -> t x y -> t x y++implementation Foo ((=) {A=a} {B=b}) where+ foo x y prf = prf+
+ test/regression001/reg038.idr view
@@ -0,0 +1,17 @@+interface C t (f : t -> t) (r : t -> t -> Type) where+ g : (a : t) -> r (f a) (f a) -> r (f a) (f a)++data Foo : {t : Type} -> t -> t -> Type where+ MkFoo : {t : Type} -> {x : t} -> {y : t} -> Foo x y++implementation C t f (Foo {t = t}) where+ g x = id++data Bar : {t1 : Type} -> {t2 : Type} -> t1 -> t2 -> Type where+ MkBar : {x : t1} -> Bar x x++implementation C s f (Bar {t1 = s} {t2 = s}) where+ g x = id++implementation C s f ((=) {A = s} {B = s}) where+ g x = id
+ test/regression001/reg046.idr view
@@ -0,0 +1,19 @@+module test++data MyList : (A : Type) -> Type where+ MyNil : (A : Type) -> MyList A+ MyCons : (A : Type) -> A -> MyList A -> MyList A++elimList : (A : Type) ->+ (m : MyList A -> Type) ->+ (f1 : m (MyNil A)) ->+ (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)++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)+ b)
+ test/regression001/reg047.idr view
@@ -0,0 +1,18 @@+module test++data TTSigma : (A : Type) -> (B : A -> Type) -> Type where+ Sigma : (A : Type) -> (B : A -> Type) -> (a : A) -> B a -> TTSigma A B++data Nat = Zero | Succ Nat++Id : (A : Type) -> A -> A -> Type+Id A = (=) {A = A} {B = A}++IdRefl : (A : Type) -> (a : A) -> Id A a a+IdRefl A a = Refl {x = a}++zzz : Id Nat Zero Zero+zzz = IdRefl Nat Zero++eep : TTSigma Nat (\ a => Id Nat a Zero)+eep = Sigma Nat (\ a => Id Nat a Zero) Zero zzz
+ test/regression001/reg047a.idr view
@@ -0,0 +1,24 @@+module test++data TTSigma : (A : Type) -> (B : A -> Type) -> Type where+ Sigma : (A : Type) -> (B : A -> Type) -> (a : A) -> B a -> TTSigma A B++data MNat = Zero | Succ MNat++Id : (A : Type) -> A -> A -> Type+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}++zzzz : Id MNat Zero Zero+zzzz = IdRefl MNat Zero++eep : TTSigma MNat (\ c => Id MNat c Zero)+eep = (Sigma MNat (\b => Id MNat b Zero) Zero zzzz)++eep2 : TTSigma MNat (\ c => Id MNat c Zero)+eep2 = (Sigma MNat (\b => Id MNat b Zero) Zero (IdRefl MNat Zero))+++
+ test/regression001/reg053.idr view
@@ -0,0 +1,9 @@+module FourFunctor++data FourFunctor y = Four y y y y++traverseFourFunctor : Applicative f -> + (x -> f b) -> FourFunctor x -> f (FourFunctor b)+traverseFourFunctor constr f (Four w x y z) + = pure Four <*> (f w) <*> (f x) <*> (f y) <*> (f z)+
+ test/regression001/reg057.idr view
@@ -0,0 +1,8 @@+module Foo++data CrappySet : (a : Type) -> Ord a -> Type where+ Empty : (inst : Ord a) => CrappySet a inst+ Item : (inst : Ord a) => a -> CrappySet a inst -> CrappySet a inst++empty : (inst : Ord a) => CrappySet a inst+
+ test/regression001/reg058.idr view
@@ -0,0 +1,14 @@+%default total++InterpBool : () -> Type+InterpBool () = {x : Type} -> x -> Nat++interface IdrisBug (u : ()) where+ idrisBug : InterpBool u++implementation IdrisBug () where+ idrisBug _ = Z++f : Nat+f = idrisBug {u = ()} 'a'+
+ test/regression001/reg058a.idr view
@@ -0,0 +1,19 @@+import Data.Vect++impTy : Bool -> Type+impTy True = Int+impTy False = {n : Nat} -> Vect n Int -> Vect n Int++wibble : impTy False+wibble [] = [] +wibble (x :: xs) = x * 2 :: wibble xs++wobble : (b : Bool) -> impTy b+wobble True = 42+wobble False = wibble++foo : Vect 4 Int+foo = wobble False [1,2,3,4]++bar : Int+bar = wobble True
+ test/regression001/reg059.idr view
@@ -0,0 +1,8 @@+interface Monad m => ContainerMonad (m : Type -> Type) where+ Elem : a -> m a -> Type+ tagElem : (mx : m a) -> m (x : a ** Elem x mx)++interface Monad m => ContainerMonad2 a (m : Type -> Type) where+ Elem2 : a -> m a -> Type+ tagElem2 : (mx : m a) -> m (x : a ** Elem2 x mx)+
+ test/regression001/reg060.idr view
@@ -0,0 +1,12 @@++interface MyFunctor (f : Type -> Type) where+ mymap : (m : a -> b) -> f a -> f b++data Foo x y = Bar y++implementation MyFunctor (Foo m) where+ mymap m x = ?wibble++implementation [foo] Functor m => MyFunctor m where+ mymap m x = map m x+
+ test/regression001/reg061.idr view
@@ -0,0 +1,9 @@+module Capture++-- Test for variable capture in syntax++syntax delay [x] = \z => case z of { () => x }+syntax delay' [z] = delay z++capture : a -> () -> a+capture x = delay' x
+ test/regression001/reg062.idr view
@@ -0,0 +1,13 @@+module MinCrash++-- Test that #2130 stays fixed. It's important that the first argument+-- to revInduction be called `pred` here, because the bug was+-- triggered by looking up a bound variable in the global context and+-- getting an ambiguous result in a context where fully-qualified+-- names were expected.++revInduction : (P : List a -> Type) -> P [] -> ((xs : List a) -> (x : a) -> P xs -> P (xs ++ [x]))+ -> (ys : List a) -> P ys+revInduction pred base ind ys with (reverse ys)+ revInduction pred base ind _ | revys =+ ?revInduction_rhs
+ test/regression001/reg062.lidr view
@@ -0,0 +1,41 @@++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/reg063.idr view
@@ -0,0 +1,19 @@+||| Test that explicit proof objects on the with rule work+module Cmp+++data MyCmp : Nat -> Nat -> Type where+ IsLT : (d : Nat) -> MyCmp n (S d + n)+ IsEQ : MyCmp n n+ IsGT : (d : Nat) -> MyCmp (S d + n) n++myCmp : (j, k : Nat) -> MyCmp j k+myCmp Z Z = IsEQ+myCmp Z (S k) = rewrite sym $ plusZeroRightNeutral k in IsLT k+myCmp (S j) Z = rewrite sym $ plusZeroRightNeutral j in IsGT j+myCmp (S j) (S k) with (myCmp j k) proof p+ myCmp (S j) (S (S (plus d j))) | (IsLT d) = rewrite plusSuccRightSucc d j+ in let useless = id p in IsLT d+ myCmp (S j) (S j) | IsEQ = IsEQ+ myCmp (S (S (plus d k))) (S k) | (IsGT d) = rewrite plusSuccRightSucc d k+ in IsGT d
+ test/regression001/reg064.idr view
@@ -0,0 +1,8 @@+sigmaEq2 : {A : Type} ->+ {P : A -> Type} ->+ {s1: DPair A P} ->+ {s2: DPair A P} ->+ fst s1 = fst s2 ->+ snd s1 = snd s2 ->+ s1 = s2+sigmaEq2 {A} {P} {s1 = (x ** prf)} {s2 = (x ** prf)} Refl Refl = Refl
+ test/regression001/reg065.idr view
@@ -0,0 +1,26 @@+||| Test that dependent type interface definitions work.+|||+||| Fixes a regression where previous methods used in a later method's+||| type would lead to "can't find interface" errors+module TypeClassDep++import Data.Vect+++interface Foo a where+ getLen : Nat+ item : a -> Vect getLen a++implementation Foo () where+ getLen = 3+ item () = [(), (), ()]++implementation Foo String where+ getLen = 1+ item str = [str]++check1 : item () = with Vect [(),(),()]+check1 = Refl++check2 : item "halløjsa" = with Vect ["halløjsa"]+check2 = Refl
+ test/regression001/reg066.idr view
@@ -0,0 +1,7 @@+foo : Reflection.Raw -> Bool+foo `(~_ -> ~_) = True+foo _ = False++foo' : TT -> Bool+foo' `(~_ -> ~_) = True+foo' _ = False
+ test/regression001/reg071.idr view
@@ -0,0 +1,19 @@+mutual+ data Odd : Type where+ MkOdd : Even -> Odd++ data Even : Type where+ MkEven : Odd -> Even + EvenZ : Even++mutual+ total+ countEven : Even -> Nat+ countEven (MkEven x) = countOdd x+ countEven EvenZ = Z++ total+ countOdd : Odd -> Nat+ countOdd (MkOdd x) = S (countEven x)+ +
+ test/regression001/reg073.lidr view
@@ -0,0 +1,24 @@+> %default total+> %auto_implicits off++> postulate decLT : (m : Nat) -> (n : Nat) -> Dec (LT m n)+> postulate last : Nat++> LTB : Nat -> Type+> LTB b = DPair Nat (\ n => LT n b)++> Foo : (t : Nat) -> Type+> Foo t = LTB (S last)++> Bar : {t : Nat} -> (n : Nat) -> Foo t -> Type+> Bar Z _ = Unit+> Bar (S n) x with (decLT (fst x) last)+> | (Yes _) = Unit+> | (No _) = Void++> lemma : {t : Nat} -> {m : Nat} -> {x : Foo t} -> +> (fst x) `LT` last -> Bar (S m) x = Unit+> lemma {m} {x} prf with (decLT (fst x) last)+> | (Yes _) = Refl+> | (No contra) = void (contra prf)+
+ test/regression001/reg074.idr view
@@ -0,0 +1,21 @@+%default total++binary_relation : (a : Type) -> Type+binary_relation a = (x, y : a) -> Type++reflexive : (a : Type) -> (r : binary_relation a) -> Type+reflexive a r = (x : a) -> r x x++symmetric : (a : Type) -> (r : binary_relation a) -> Type+symmetric a r = (x, y : a) -> r x y -> r y x++data Equal : (a : Type) -> binary_relation a where+ Same : (a : Type) -> (x : a) -> Equal a x x++Equal_reflexive : (a : Type) -> reflexive a (Equal a)+Equal_reflexive a x = Same a x++Equal_symmetric : (a : Type) -> symmetric a (Equal a)+-- Equal_symmetric : (a : Type) -> (x, y : a) -> Equal a x y -> Equal a y x+Equal_symmetric a x x (Same a x) = Same a x+
+ test/regression001/run view
@@ -0,0 +1,13 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ --check \+ reg001.idr reg036.idr reg037.idr reg038.idr reg046.idr \+ reg047a.idr reg053.idr reg057.idr reg058.idr reg058a.idr \+ reg059.idr reg060.idr reg061.idr reg062.idr reg063.idr \+ reg064.idr reg065.idr reg066.idr reg071.idr reg074.idr++${IDRIS:-idris} $@ --check --nobuiltins reg047.idr++${IDRIS:-idris} $@ --check --nocolour \+ reg062.lidr reg073.lidr++rm -f *.ibc
test/totality012/totality012.idr view
@@ -17,9 +17,9 @@ echo1 = do PutStr "$ " x <- GetStr PutStr (x ++ "\n")- case (x == "quit") of- True => PutStr "Bye!\n"- False => echo1+ if (x == "quit") + then PutStr "Bye!\n"+ else echo1 echo2 : String -> InfIO () echo2 x = case (x == "quit") of
test/totality012/totality012a.idr view
@@ -6,8 +6,7 @@ (>>=) : InfIO a -> (a -> Inf (InfIO b)) -> InfIO b echo2 : String -> InfIO ()-echo2 x = case (x == "quit") of- True => PutStr "Bye!\n"- False => echo2 x+echo2 x = if (x == "quit") then PutStr "Bye!\n"+ else echo2 x
+ test/totality014/expected view
@@ -0,0 +1,8 @@+totality014.idr:1:6:Universe inconsistency.+ Working on: ./totality014.idr.w+ Old domain: (5,5)+ New domain: (5,4)+ Involved constraints: + ConstraintFC {uconstraint = ./totality014.idr.w < ./totality014.idr.u, ufc = totality014.idr:1:6}+ ConstraintFC {uconstraint = ./totality014.idr.w < ./totality014.idr.u, ufc = totality014.idr:1:6}+ ConstraintFC {uconstraint = ./totality014.idr.u <= ./totality014.idr.w, ufc = totality014.idr:6:9}
+ test/totality014/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ totality014.idr --check+rm -f *.ibc
+ test/totality014/totality014.idr view
@@ -0,0 +1,7 @@+data Con2 : Type where+ MkCon2 : (a : Type) -> Con2 = a -> (a -> Void) -> Con2+ +total+runCon2 : Con2 -> (Con2 -> Void)+runCon2 (MkCon2 _ Refl f) = f+
+ test/totality015/expected view
@@ -0,0 +1,6 @@+totality015a.idr:52:3:+Main.quiz is possibly not total due to recursive path Main.quiz --> Main.quiz+totality015a.idr:42:3:+Main.correct is possibly not total due to: Main.quiz+totality015a.idr:47:3:+Main.wrong is possibly not total due to: Main.quiz
+ test/totality015/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ totality015.idr --check+${IDRIS:-idris} $@ totality015a.idr --check+rm -f *.ibc
+ test/totality015/totality015.idr view
@@ -0,0 +1,70 @@+import Data.Primitives.Views+import System++%default total++data Command : Type -> Type where+ PutStr : String -> Command ()+ GetLine : Command String++data ConsoleIO : Type -> Type where+ Quit : a -> ConsoleIO a+ Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b++(>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b+(>>=) = Do++data Fuel = Dry | More (Lazy Fuel)++runCommand : Command a -> IO a+runCommand (PutStr x) = putStr x+runCommand GetLine = getLine++run : Fuel -> ConsoleIO a -> IO (Maybe a)+run fuel (Quit val) = do pure (Just val)+run (More fuel) (Do c f) = do res <- runCommand c+ run fuel (f res)+run Dry p = pure Nothing++randoms : Int -> Stream Int+randoms seed = let seed' = 1664525 * seed + 1013904223 in+ (seed' `shiftR` 2) :: randoms seed'++arithInputs : Int -> Stream Int+arithInputs seed = map bound (randoms seed)+ where+ bound : Int -> Int+ bound x with (divides x 12)+ bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1++mutual+ correct : Stream Int -> (score : Nat) -> ConsoleIO Nat+ correct nums score+ = do PutStr "Correct!\n"+ quiz nums (score + 1)++ wrong : Stream Int -> Int -> (score : Nat) -> ConsoleIO Nat+ wrong nums ans score+ = do PutStr ("Wrong, the answer is " ++ show ans ++ "\n")+ quiz nums score++ quiz : Stream Int -> (score : Nat) -> ConsoleIO Nat+ quiz (num1 :: num2 :: nums) score+ = do PutStr ("Score so far: " ++ show score ++ "\n")+ PutStr (show num1 ++ " * " ++ show num2 ++ "? ")+ answer <- GetLine+ if toLower answer == "quit" then Quit score else+ if (cast answer == num1 * num2)+ then correct nums score+ else wrong nums (num1 * num2) score++partial+forever : Fuel+forever = More forever++partial+main : IO ()+main = do seed <- time+ Just score <- run forever (quiz (arithInputs (fromInteger seed)) 0)+ | Nothing => putStrLn "Ran out of fuel"+ putStrLn ("Final score: " ++ show score)
+ test/totality015/totality015a.idr view
@@ -0,0 +1,63 @@+import Data.Primitives.Views+import System++%default total++data Command : Type -> Type where+ PutStr : String -> Command ()+ GetLine : Command String++data ConsoleIO : Type -> Type where+ Quit : a -> ConsoleIO a+ Do : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b++(>>=) : Command a -> (a -> Inf (ConsoleIO b)) -> ConsoleIO b+(>>=) = Do++data Fuel = Dry | More (Lazy Fuel)++runCommand : Command a -> IO a+runCommand (PutStr x) = putStr x+runCommand GetLine = getLine++run : Fuel -> ConsoleIO a -> IO (Maybe a)+run fuel (Quit val) = do pure (Just val)+run (More fuel) (Do c f) = do res <- runCommand c+ run fuel (f res)+run Dry p = pure Nothing++randoms : Int -> Stream Int+randoms seed = let seed' = 1664525 * seed + 1013904223 in+ (seed' `shiftR` 2) :: randoms seed'++arithInputs : Int -> Stream Int+arithInputs seed = map bound (randoms seed)+ where+ bound : Int -> Int+ bound x with (divides x 12)+ bound ((12 * div) + rem) | (DivBy prf) = abs rem + 1++mutual+ correct : Stream Int -> (score : Nat) -> ConsoleIO Nat+ correct nums score+ = do PutStr "Correct!\n"+ quiz nums (score + 1)++ wrong : Stream Int -> Int -> (score : Nat) -> ConsoleIO Nat+ wrong nums ans score+ = do PutStr ("Wrong, the answer is " ++ show ans ++ "\n")+ quiz nums score++ quiz : Stream Int -> (score : Nat) -> ConsoleIO Nat+ quiz (num1 :: num2 :: nums) score = quiz nums score++partial+forever : Fuel+forever = More forever++partial+main : IO ()+main = do seed <- time+ Just score <- run forever (quiz (arithInputs (fromInteger seed)) 0)+ | Nothing => putStrLn "Ran out of fuel"+ putStrLn ("Final score: " ++ show score)
+ test/universes001/expected view
@@ -0,0 +1,9 @@+universes001.idr:7:5:Universe inconsistency.+ Working on: ./universes001.idr.x+ Old domain: (5,5)+ New domain: (5,4)+ Involved constraints: + ConstraintFC {uconstraint = ./universes001.idr.x <= ./universes001.idr.z, ufc = universes001.idr:7:5}+ ConstraintFC {uconstraint = ./universes001.idr.x < ./universes001.idr.y, ufc = universes001.idr:1:6}+ ConstraintFC {uconstraint = ./universes001.idr.z < ./universes001.idr.x, ufc = universes001.idr:1:6}+ ConstraintFC {uconstraint = ./universes001.idr.x <= ./universes001.idr.z, ufc = universes001.idr:7:5}
+ test/universes001/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ universes001.idr --check+rm -f *.ibc
+ test/universes001/universes001.idr view
@@ -0,0 +1,8 @@+data Exp : Type -> Type where+ Const : {t : Type} -> t -> Exp t+ Pair : {t1,t2:Type} -> Exp t1 -> Exp t2 -> Exp (t1, t2)+ Eq : {t:Type} -> Exp t -> Exp t -> Exp Bool++foo : Exp (Exp Integer)+foo = Const (Const 0)+
+ test/universes002/expected view
@@ -0,0 +1,9 @@+universes002.idr:45:9:Universe inconsistency.+ Working on: ./universes002.idr.b1+ Old domain: (5,5)+ New domain: (5,4)+ Involved constraints: + ConstraintFC {uconstraint = ./universes002.idr.b1 <= ./universes002.idr.e7, ufc = universes002.idr:45:9}+ ConstraintFC {uconstraint = ./universes002.idr.b1 < ./universes002.idr.c1, ufc = universes002.idr:3:6}+ ConstraintFC {uconstraint = ./universes002.idr.b1 <= ./universes002.idr.e7, ufc = universes002.idr:45:9}+ ConstraintFC {uconstraint = ./universes002.idr.d1 <= ./universes002.idr.b1, ufc = universes002.idr:3:6}
+ test/universes002/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ universes002.idr --check+rm -f *.ibc
+ test/universes002/universes002.idr view
@@ -0,0 +1,45 @@+module TypeInType++data MPair : (a : Type) -> (P : a -> Type) -> Type where+ MkMPair : .{P : a -> Type} -> (x : a) -> (pf : P x) -> MPair a P++data EQt : a -> b -> Type where+ REFL : EQt x x++msym : EQt x y -> EQt y x+msym REFL = REFL++mreplace : {a,x,y:_} -> {P : a -> Type} -> EQt x y -> P x -> P y+mreplace REFL p = p++data Tree : Type where+ Sup : (a : Type) -> (f : a -> Tree) -> Tree++A : Tree -> Type+A (Sup a _) = a++F : (t : Tree) -> A t -> Tree+F (Sup a f) = f++normal : Tree -> Type+normal t = (MPair (A t) (\y => EQt (F t y) (Sup (A t) (F t)))) -> Void++NT : Type+NT = MPair Tree (\t => normal t)++p : NT -> Tree+p (MkMPair x _) = x++R : Tree+R = Sup NT p++lemma : normal R+lemma (MkMPair (MkMPair y1 y2) z)+ = y2 + (mreplace {P = (\ y3 => (MPair (A y3) + (\y => EQt (F y3 y) (Sup (A y3) (F y3)))))} + (msym z) (MkMPair (MkMPair y1 y2) z))++total+russell : Void+russell = lemma (MkMPair (MkMPair R lemma) REFL)