packages feed

idris 0.10 → 0.10.1

raw patch · 445 files changed

+7235/−5766 lines, 445 filesdep ~asyncdep ~basedep ~containerssetup-changedbinary-added

Dependency ranges changed: async, base, containers, directory, filepath, haskeline, process, time, transformers

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

CHANGELOG view
@@ -1,3 +1,69 @@+New in 0.11:+============++Updated export rules+--------------------++* The export rules are:+  - 'private' means that the definition is not exported at all+  - 'export' means that the top level type is exported, but not the+    definition. In the case of 'data', this means the type constructor is+    exported but not the data constructors.+  - 'public export' means that the entire definition is exported.+* By default, names are 'private'. This can be altered with an %access+  directive as before.+* Exported types can only refer to other exported names+* Publicly exported definitions can only refer to publicly exported names++Improved C FFI+--------------++* Idris functions can now be passed as callbacks to C functions or wrapped+in a C function pointer.+* C function pointers can be called.+* Idris can access pointers to C globals.++Minor language changes+----------------------++* The '[static]' annotation is changed to '%static' to be consistent with the+  other annotations.+* Added '%auto_implicits' directive. The default is '%auto_implicits on'.+  Placing '%auto_implicits off' in a source file means that after that+  point, any implicit arguments must be bound, e.g.:+    append : {n,m,a:_} -> Vect n a -> Vect m a -> Vect (n + m) a++  Only names which are used explicitly in the type need to be bound, e.g.:+    Here  : {x, xs : _} -> Elem x (x :: xs)++  In 'Here', there is no need to bind any of the variables in the type of+  'xs' (it could be e.g. List a or Vect n a; 'a' and 'n' will still be+  implicitly bound).++  You can still implicitly bind with 'using':++    using (xs : Vect _ _)+      data Elem  : {a, n : _} -> a -> Vect n a -> Type where+           Here  : {x : _} -> Elem x (x :: xs)+           There : {x, y : _} -> Elem x xs -> Elem x (y :: xs)++  However, note that *only* names which appear in *both* the using block+  *and* the type being defined will be implicitly bound. The following will+  therefore fail because 'n' isn't implicitly bound:++    using (xs : Vect n a)+      bad : Elem x xs -> Elem x (y :: xs)+* `Sigma` has been renamed  to `DPair`.+* Accessor functions for dependent pairs have been renamed to bring them into+  line with standard accessor functions for pairs. The function `getWitness`+  is now `fst`, and `getProof` is `snd`.+* File Modes expanded: Append, ReadWriteTruncate, and ReadAppend added,+  Write is deprecated and renamed to WriteTruncate.+* C11 Extended Mode variations added to File Modes.+* More flexible holes.+  Holes can now depend on other holes in a term (such as implicit arguments+  which may be inferred from the definition of the hole).+ New in 0.10: ============
CONTRIBUTORS view
@@ -32,6 +32,7 @@ Tom Prince raichoo Philip Rasmussen+Aistis Raulinaitis Reynir Reynisson Adam Sandberg Eriksson Seo Sanghyeon
Makefile view
@@ -20,24 +20,13 @@ test: doc test_c  test_c:-	$(MAKE) -C test IDRIS=../dist/build/idris--test_java:-	$(MAKE) -C test IDRIS=../dist/build/idris test_java--test_llvm:-	$(MAKE) -C test IDRIS=../dist/build/idris test_llvm+	$(MAKE) -C test IDRIS=../dist/build/idris/idris test  test_js:-	$(MAKE) -C test IDRIS=../dist/build/idris test_js--test_all:-	$(MAKE) test-	$(MAKE) test_llvm-	$(MAKE) test_java+	$(MAKE) -C test IDRIS=../dist/build/idris/idris test_js  test_timed:-	$(MAKE) -C test IDRIS=../dist/build/idris time+	$(MAKE) -C test IDRIS=../dist/build/idris/idris time  lib_clean: 	$(MAKE) -C libs IDRIS=../../dist/build/idris/idris RTS=../../dist/build/rts/libidris_rts clean
Setup.hs view
@@ -10,6 +10,7 @@ import qualified Distribution.Simple.Setup as S import qualified Distribution.Simple.Program as P import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFile)+import Distribution.Compiler import Distribution.PackageDescription import Distribution.Text @@ -45,6 +46,9 @@ make verbosity =    P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake +#ifdef mingw32_HOST_OS+windres verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "windres"+#endif -- ----------------------------------------------------------------------------- -- Flags @@ -198,6 +202,20 @@       let buildinfo = (emptyBuildInfo { cppOptions = ["-DVERSION="++hash] }) :: BuildInfo       return (Just buildinfo, []) +++idrisPreBuild args flags = do+#ifdef mingw32_HOST_OS+        createDirectoryIfMissingVerbose verbosity True dir+        windres verbosity ["icons/idris_icon.rc","-o", dir++"idris_icon.o"]+        return (Nothing, [("idris", emptyBuildInfo { ldOptions = [dir ++ "idris_icon.o"] })])+     where+        verbosity = S.fromFlag $ S.buildVerbosity flags+        dir = S.fromFlagOrDefault "dist" $ S.buildDistPref flags+#else+        return (Nothing, [])+#endif+ idrisBuild _ flags _ local = unless (execOnly (configFlags local)) $ do       buildStdLib       buildRTS@@ -247,6 +265,7 @@ main = defaultMainWithHooks $ simpleUserHooks    { postClean = idrisClean    , postConf  = idrisConfigure+   , preBuild = idrisPreBuild    , postBuild = idrisBuild    , postCopy = \_ flags pkg local ->                   idrisInstall (S.fromFlag $ S.copyVerbosity flags)
benchmarks/quasigroups/Parser.idr view
@@ -5,6 +5,8 @@  import Solver +%access public export+ ParseErr : Type ParseErr = String
benchmarks/quasigroups/Solver.idr view
@@ -6,6 +6,7 @@ import Data.Vect.Quantifiers  %default total+%access public export  Cell : Nat -> Type Cell n = Maybe (Fin n)@@ -32,7 +33,7 @@     addLine : List Char -> List Char -> List Char     addLine w s = w ++ ('\n' :: s) -instance Show (Board n) where+Show (Board n) where   show (MkBoard rs) = unlines (map showRow rs)  updateAt : Fin n -> Vect n a -> (a -> a) -> Vect n a
+ icons/idris.ico view

binary file changed (absent → 19427 bytes)

+ icons/idris_icon.rc view
@@ -0,0 +1,1 @@+0 ICON "idris.ico"
idris-tutorial.pdf view

binary file changed (287080 → 326385 bytes)

idris.cabal view
@@ -1,5 +1,5 @@ Name:           idris-Version:        0.10+Version:        0.10.1 License:        BSD3 License-file:   LICENSE Author:         Edwin Brady@@ -150,7 +150,7 @@                        libs/pruviloj/Pruviloj/Internals/*.idr                         test/Makefile-                       test/runtest.pl+                       test/runtest.hs                        test/reg001/run                        test/reg001/*.idr                        test/reg001/expected@@ -163,6 +163,9 @@                        test/reg004/run                        test/reg004/*.idr                        test/reg004/expected+                       test/reg005/run+                       test/reg005/*.idr+                       test/reg005/expected                        test/reg006/run                        test/reg006/*.idr                        test/reg006/expected@@ -311,6 +314,15 @@                        test/reg067/run                        test/reg067/*.idr                        test/reg067/expected+                       test/reg068/run+                       test/reg068/*.idr+                       test/reg068/expected+                       test/reg069/run+                       test/reg069/*.idr+                       test/reg069/expected+                       test/reg070/run+                       test/reg070/*.idr+                       test/reg070/expected                         test/basic001/run                        test/basic001/*.idr@@ -361,6 +373,9 @@                        test/basic016/run                        test/basic016/*.idr                        test/basic016/expected+                       test/basic017/run+                       test/basic017/*.idr+                       test/basic017/expected                         test/bignum001/run                        test/bignum001/*.idr@@ -462,6 +477,11 @@                        test/ffi006/*.c                        test/ffi006/run                        test/ffi006/expected+                       test/ffi007/*.idr+                       test/ffi007/*.c+                       test/ffi007/*.h+                       test/ffi007/run+                       test/ffi007/expected                         test/folding001/*.idr                        test/folding001/run@@ -585,6 +605,9 @@                        test/primitives003/run                        test/primitives003/*.idr                        test/primitives003/expected+                       test/primitives005/run+                       test/primitives005/*.idr+                       test/primitives005/expected                         test/pkg001/run                        test/pkg001/test.ipkg@@ -728,6 +751,9 @@                        test/totality010/run                        test/totality010/*.idr                        test/totality010/expected+                       test/totality011/run+                       test/totality011/*.lidr+                       test/totality011/expected                         test/tutorial001/run                        test/tutorial001/*.idr@@ -788,6 +814,9 @@                        benchmarks/trivial/sortvec.idr                        benchmarks/trivial/sortvec.ipkg +                       icons/idris_icon.rc+                       icons/idris.ico+ source-repository head   type:     git   location: git://github.com/idris-lang/Idris-dev.git@@ -859,6 +888,7 @@                 , Idris.Elab.Transform                 , Idris.Elab.Value                 , Idris.Elab.Term+                , Idris.Elab.Quasiquote                  , Idris.REPL.Browse @@ -879,7 +909,6 @@                 , Idris.Docs                 , Idris.Docstrings                 , Idris.ElabDecls-                , Idris.ElabQuasiquote                 , Idris.Erasure                 , Idris.Error                 , Idris.ErrReverse@@ -892,10 +921,10 @@                 , Idris.Interactive                 , Idris.Output                 , Idris.Parser-                , Idris.ParseHelpers-                , Idris.ParseOps-                , Idris.ParseExpr-                , Idris.ParseData+                , Idris.Parser.Helpers+                , Idris.Parser.Ops+                , Idris.Parser.Expr+                , Idris.Parser.Data                 , Idris.PartialEval                 , Idris.Primitives                 , Idris.ProofSearch@@ -903,7 +932,7 @@                 , Idris.Providers                 , Idris.Reflection                 , Idris.REPL-                , Idris.REPLParser+                , Idris.REPL.Parser                 , Idris.Transforms                 , Idris.TypeSearch                 , Idris.Unlit@@ -978,7 +1007,8 @@                 , zip-archive > 0.2.3.5 && < 0.2.4                 , safe                 , fsnotify < 2.2-                , async < 2.1+                , async < 2.2+   -- zlib >= 0.6.1 is broken with GHC < 7.10.3   if impl(ghc < 7.10.3)      build-depends: zlib < 0.6.1@@ -992,7 +1022,6 @@                 , TemplateHaskell    ghc-prof-options: -auto-all -caf-all-  ghc-options:      -threaded -rtsopts    if os(linux)      cpp-options:   -DLINUX@@ -1035,6 +1064,24 @@                 , directory                 , haskeline >= 0.7                 , transformers++  ghc-prof-options: -auto-all -caf-all+  ghc-options:      -threaded -rtsopts -funbox-strict-fields++Test-suite regression-and-sanity-tests+  Type:           exitcode-stdio-1.0+  Main-is:        runtest.hs+  hs-source-dirs: test++  Build-depends: idris+               , base+               , containers+               , process+               , time+               , filepath+               , directory+               , haskeline >= 0.7+               , transformers    ghc-prof-options: -auto-all -caf-all   ghc-options:      -threaded -rtsopts -funbox-strict-fields
libs/base/Control/Arrow.idr view
@@ -3,7 +3,7 @@ import Data.Morphisms import Control.Category -%access public+%access public export  infixr 5 <++> infixr 3 ***
libs/base/Control/Catchable.idr view
@@ -2,6 +2,8 @@  import Control.IOExcept +%access public export+ interface Catchable (m : Type -> Type) t where     throw : t -> m a     catch : m a -> (t -> m a) -> m a
libs/base/Control/Category.idr view
@@ -2,7 +2,7 @@  import Data.Morphisms -%access public+%access public export  interface Category (cat : Type -> Type -> Type) where   id  : cat a a
libs/base/Control/IOExcept.idr view
@@ -1,5 +1,7 @@ module Control.IOExcept +%access public export+ -- An IO monad with exception handling  record IOExcept' (f:FFI) err a where
libs/base/Control/Isomorphism.idr view
@@ -4,6 +4,7 @@ import Data.Fin  %default total+%access public export  ||| An isomorphism between two types data Iso : Type -> Type -> Type where
libs/base/Control/Monad/Identity.idr view
@@ -1,6 +1,8 @@ module Control.Monad.Identity -public record Identity (a : Type) where+%access public export++public export record Identity (a : Type) where   constructor Id   runIdentity : a
libs/base/Control/Monad/RWS.idr view
@@ -5,7 +5,7 @@ import Control.Monad.Writer import Control.Monad.Reader -%access public+%access public export  ||| A combination of the Reader, Writer, and State monads interface (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m) => MonadRWS r w s (m : Type -> Type) where {}
libs/base/Control/Monad/Reader.idr view
@@ -4,7 +4,7 @@ import Control.Monad.Identity import Control.Monad.Trans -%access public+%access public export  ||| A monad representing a computation that runs in an immutable context interface Monad m => MonadReader r (m : Type -> Type) where
libs/base/Control/Monad/State.idr view
@@ -3,7 +3,7 @@ import public Control.Monad.Identity import public Control.Monad.Trans -%access public+%access public export  ||| A computation which runs in a context and produces an output interface Monad m => MonadState s (m : Type -> Type) | m where
libs/base/Control/Monad/Trans.idr view
@@ -1,4 +1,6 @@ module Control.Monad.Trans +%access public export+ interface MonadTrans (t : (Type -> Type) -> Type -> Type) where     lift : Monad m => m a -> t m a
libs/base/Control/Monad/Writer.idr view
@@ -4,7 +4,7 @@ import Control.Monad.Identity import Control.Monad.Trans -%access public+%access public export  ||| A monad representing a computation that produces a stream of output interface (Monoid w, Monad m) => MonadWriter w (m : Type -> Type) where
libs/base/Data/Bits.idr view
@@ -4,7 +4,7 @@  %default total -public+public export nextPow2 : Nat -> Nat nextPow2 Z = Z nextPow2 (S x) = if (S x) == (2 `power` l2x)@@ -13,11 +13,11 @@     where       l2x = log2NZ (S x) SIsNotZ -public+public export nextBytes : Nat -> Nat nextBytes bits = (nextPow2 (divCeilNZ bits 8 SIsNotZ)) -public+public export machineTy : Nat -> Type machineTy Z = Bits8 machineTy (S Z) = Bits16@@ -47,7 +47,7 @@ getPad : Nat -> machineTy n getPad n = natToBits (minus (bitsUsed (nextBytes n)) n) -public+public export data Bits : Nat -> Type where     MkBits : machineTy (nextBytes n) -> Bits n @@ -92,6 +92,10 @@     where       pad = getPad {n=3} n +-- TODO: This (and all the other functions along these lings) is public export+-- because it is used by public export things. Do they really need to be+-- public export, or is export good enough?+public export shiftLeft' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) shiftLeft' {n=n} x c with (nextBytes n)     | Z = pad8' n prim__shlB8 x c@@ -99,10 +103,11 @@     | S (S Z) = pad32' n prim__shlB32 x c     | S (S (S _)) = pad64' n prim__shlB64 x c -public+public export shiftLeft : Bits n -> Bits n -> Bits n shiftLeft (MkBits x) (MkBits y) = MkBits (shiftLeft' x y) +public export shiftRightLogical' : machineTy n -> machineTy n -> machineTy n shiftRightLogical' {n=n} x c with (n)     | Z = prim__lshrB8 x c@@ -110,11 +115,12 @@     | S (S Z) = prim__lshrB32 x c     | S (S (S _)) = prim__lshrB64 x c -public+public export shiftRightLogical : Bits n -> Bits n -> Bits n shiftRightLogical {n} (MkBits x) (MkBits y)     = MkBits {n} (shiftRightLogical' {n=nextBytes n} x y) +public export shiftRightArithmetic' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) shiftRightArithmetic' {n=n} x c with (nextBytes n)     | Z = pad8' n prim__ashrB8 x c@@ -122,10 +128,11 @@     | S (S Z) = pad32' n prim__ashrB32 x c     | S (S (S _)) = pad64' n prim__ashrB64 x c -public+public export shiftRightArithmetic : Bits n -> Bits n -> Bits n shiftRightArithmetic (MkBits x) (MkBits y) = MkBits (shiftRightArithmetic' x y) +public export and' : machineTy n -> machineTy n -> machineTy n and' {n=n} x y with (n)     | Z = prim__andB8 x y@@ -133,10 +140,11 @@     | S (S Z) = prim__andB32 x y     | S (S (S _)) = prim__andB64 x y -public+public export and : Bits n -> Bits n -> Bits n and {n} (MkBits x) (MkBits y) = MkBits (and' {n=nextBytes n} x y) +public export or' : machineTy n -> machineTy n -> machineTy n or' {n=n} x y with (n)     | Z = prim__orB8 x y@@ -144,10 +152,11 @@     | S (S Z) = prim__orB32 x y     | S (S (S _)) = prim__orB64 x y -public+public export or : Bits n -> Bits n -> Bits n or {n} (MkBits x) (MkBits y) = MkBits (or' {n=nextBytes n} x y) +public export xor' : machineTy n -> machineTy n -> machineTy n xor' {n=n} x y with (n)     | Z = prim__xorB8 x y@@ -155,10 +164,11 @@     | S (S Z) = prim__xorB32 x y     | S (S (S _)) = prim__xorB64 x y -public+public export xor : Bits n -> Bits n -> Bits n xor {n} (MkBits x) (MkBits y) = MkBits {n} (xor' {n=nextBytes n} x y) +public export plus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) plus' {n=n} x y with (nextBytes n)     | Z = pad8 n prim__addB8 x y@@ -166,10 +176,11 @@     | S (S Z) = pad32 n prim__addB32 x y     | S (S (S _)) = pad64 n prim__addB64 x y -public+public export plus : Bits n -> Bits n -> Bits n plus (MkBits x) (MkBits y) = MkBits (plus' x y) +public export minus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) minus' {n=n} x y with (nextBytes n)     | Z = pad8 n prim__subB8 x y@@ -177,10 +188,11 @@     | S (S Z) = pad32 n prim__subB32 x y     | S (S (S _)) = pad64 n prim__subB64 x y -public+public export minus : Bits n -> Bits n -> Bits n minus (MkBits x) (MkBits y) = MkBits (minus' x y) +public export times' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) times' {n=n} x y with (nextBytes n)     | Z = pad8 n prim__mulB8 x y@@ -188,11 +200,12 @@     | S (S Z) = pad32 n prim__mulB32 x y     | S (S (S _)) = pad64 n prim__mulB64 x y -public+public export times : Bits n -> Bits n -> Bits n times (MkBits x) (MkBits y) = MkBits (times' x y)  partial+public export sdiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) sdiv' {n=n} x y with (nextBytes n)     | Z = prim__sdivB8 x y@@ -200,11 +213,12 @@     | S (S Z) = prim__sdivB32 x y     | S (S (S _)) = prim__sdivB64 x y -public partial+public export partial sdiv : Bits n -> Bits n -> Bits n sdiv (MkBits x) (MkBits y) = MkBits (sdiv' x y)  partial+public export udiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) udiv' {n=n} x y with (nextBytes n)     | Z = prim__udivB8 x y@@ -212,11 +226,11 @@     | S (S Z) = prim__udivB32 x y     | S (S (S _)) = prim__udivB64 x y -public partial+public export partial udiv : Bits n -> Bits n -> Bits n udiv (MkBits x) (MkBits y) = MkBits (udiv' x y) -partial+public export partial srem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) srem' {n=n} x y with (nextBytes n)     | Z = prim__sremB8 x y@@ -224,11 +238,11 @@     | S (S Z) = prim__sremB32 x y     | S (S (S _)) = prim__sremB64 x y -public partial+public export partial srem : Bits n -> Bits n -> Bits n srem (MkBits x) (MkBits y) = MkBits (srem' x y) -partial+public export partial urem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) urem' {n=n} x y with (nextBytes n)     | Z = prim__uremB8 x y@@ -236,7 +250,7 @@     | S (S Z) = prim__uremB32 x y     | S (S (S _)) = prim__uremB64 x y -public partial+public export partial urem : Bits n -> Bits n -> Bits n urem (MkBits x) (MkBits y) = MkBits (urem' x y) @@ -276,9 +290,11 @@     | S (S Z) = prim__gtB32 x y     | S (S (S _)) = prim__gtB64 x y +public export implementation Eq (Bits n) where     (MkBits x) == (MkBits y) = boolOp eq x y +public export implementation Ord (Bits n) where     (MkBits x) < (MkBits y) = boolOp lt x y     (MkBits x) <= (MkBits y) = boolOp lte x y@@ -291,6 +307,7 @@              then EQ              else GT +public export complement' : machineTy (nextBytes n) -> machineTy (nextBytes n) complement' {n=n} x with (nextBytes n)     | Z = let pad = getPad {n=0} n in@@ -302,12 +319,12 @@     | S (S (S _)) = let pad = getPad {n=3} n in                     prim__complB64 (x `prim__shlB64` pad) `prim__lshrB64` pad -public+public export complement : Bits n -> Bits n complement (MkBits x) = MkBits (complement' x)  -- TODO: Prove-%assert_total -- can't verify coverage of with block+public export %assert_total -- can't verify coverage of with block zext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))     | (Z, Z) = believe_me x@@ -321,11 +338,11 @@     | (S (S Z), S (S (S _))) = believe_me (prim__zextB32_B64 (believe_me x))     | (S (S (S _)), S (S (S _))) = believe_me x -public+public export zeroExtend : Bits n -> Bits (n+m) zeroExtend (MkBits x) = MkBits (zext' x) -%assert_total+public export %assert_total intToBits' : Integer -> machineTy (nextBytes n) intToBits' {n=n} x with (nextBytes n)     | Z = let pad = getPad {n=0} n in@@ -337,13 +354,14 @@     | S (S (S _)) = let pad = getPad {n=3} n in                     prim__lshrB64 (prim__shlB64 (prim__truncBigInt_B64 x) pad) pad -public+public export intToBits : Integer -> Bits n intToBits n = MkBits (intToBits' n)  implementation Cast Integer (Bits n) where     cast = intToBits +public export bitsToInt' : machineTy (nextBytes n) -> Integer bitsToInt' {n=n} x with (nextBytes n)     | Z = prim__zextB8_BigInt x@@ -351,11 +369,12 @@     | S (S Z) = prim__zextB32_BigInt x     | S (S (S _)) = prim__zextB64_BigInt x -public+public export bitsToInt : Bits n -> Integer bitsToInt (MkBits x) = bitsToInt' x  -- Zero out the high bits of a truncated bitstring+public export zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n) zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0) @@ -393,12 +412,12 @@     | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in                                    believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad) ---public+--public export --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+public export %assert_total -- can't verify coverage of with block trunc' : machineTy (nextBytes (m+n)) -> machineTy (nextBytes n) trunc' {m=m} {n=n} x with (nextBytes n, nextBytes (m+n))     | (Z, Z) = believe_me x@@ -412,23 +431,23 @@     | (S (S Z), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x))     | (S (S (S _)), S (S (S _))) = believe_me x -public+public export truncate : Bits (m+n) -> Bits n truncate (MkBits x) = MkBits (zeroUnused (trunc' x)) -public+public export bitAt : Fin n -> Bits n bitAt n = intToBits 1 `shiftLeft` intToBits (cast n) -public+public export getBit : Fin n -> Bits n -> Bool getBit n x = (x `and` (bitAt n)) /= intToBits 0 -public+public export setBit : Fin n -> Bits n -> Bits n setBit n x = x `or` (bitAt n) -public+public export unsetBit : Fin n -> Bits n -> Bits n unsetBit n x = x `and` complement (bitAt n)
libs/base/Data/Complex.idr view
@@ -5,6 +5,8 @@  module Data.Complex +%access public export+ ------------------------------ Rectangular form  infix 6 :+
libs/base/Data/Erased.idr view
@@ -1,6 +1,6 @@ module Data.Erased -%access public+%access public export %default total  ||| The erasure monad.
libs/base/Data/Fin.idr view
@@ -1,7 +1,7 @@ module Data.Fin  %default total-%access public+%access public export  ||| Numbers strictly less than some bound.  The name comes from "finite sets". |||@@ -149,7 +149,7 @@          , TermPart `(Fin ~(getNat finSize))          , SubReport subErr          ]-total+total export finFromIntegerErrors : Err -> Maybe (List ErrorReportPart) finFromIntegerErrors (CantUnify x tm `(IsJust (integerToFin ~(TConst c) ~m)) err xs y)   = mkFinIntegerErr (TConst c) m
libs/base/Data/HVect.idr view
@@ -2,7 +2,7 @@  import public Data.Vect -%access public+%access public export %default total  ||| Heterogeneous vectors where the type index gives, element-wise,
libs/base/Data/List.idr view
@@ -1,6 +1,6 @@ module Data.List -%access public+%access public export  ||| A proof that some element is found in a list. |||@@ -13,7 +13,7 @@      ||| A proof that the element is after the front of the list      |||      ||| Example: `the (Elem "b" ["a", "b"]) (There Here)`-     There : Elem x xs -> Elem x (y :: xs)+     There : (later : Elem x xs) -> Elem x (y :: xs)  implementation Uninhabited (Elem {a} x []) where      uninhabited Here impossible
libs/base/Data/List/Quantifiers.idr view
@@ -2,6 +2,8 @@  import Data.List +%access public export+ ||| A proof that some element of a list satisfies some property ||| ||| @ P the property to be satsified
libs/base/Data/Mod2.idr view
@@ -5,26 +5,27 @@ %default total  ||| Integers modulo 2^n-public+public export data Mod2 : Nat -> Type where     MkMod2 : {n : Nat} -> Bits n -> Mod2 n +public export modBin : (Bits n -> Bits n -> Bits n) -> Mod2 n -> Mod2 n -> Mod2 n modBin f (MkMod2 x) (MkMod2 y) = MkMod2 (f x y)  modComp : (Bits n -> Bits n -> a) -> Mod2 n -> Mod2 n -> a modComp f (MkMod2 x) (MkMod2 y) = f x y -public partial+public export partial div : Mod2 n -> Mod2 n -> Mod2 n div = modBin udiv -public partial+public export partial rem : Mod2 n -> Mod2 n -> Mod2 n rem = modBin urem  %assert_total-public+public export intToMod : {n : Nat} -> Integer -> Mod2 n intToMod {n=n} x = MkMod2 (intToBits x)
libs/base/Data/Morphisms.idr view
@@ -1,6 +1,6 @@ module Data.Morphisms -%access public+%access public export  data Morphism : Type -> Type -> Type where   Mor : (a -> b) -> Morphism a b
libs/base/Data/So.idr view
@@ -1,6 +1,7 @@ module Data.So  %default total+%access public export  ||| Ensure that some run-time Boolean test has been performed. |||
libs/base/Data/String.idr view
@@ -1,5 +1,5 @@ module Data.String-%access public+%access public export  private parseNumWithoutSign : List Char -> Integer -> Maybe Integer
libs/base/Data/Vect.idr view
@@ -3,7 +3,7 @@ import public Data.Fin import Language.Reflection -%access public+%access public export %default total  infixr 7 ::@@ -198,8 +198,12 @@ -- Zips and unzips -------------------------------------------------------------------------------- -||| Combine two equal-length vectors pairwise with some function-zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c+||| Combine two equal-length vectors pairwise with some function.+|||+||| @ f the function to combine elements with+||| @ xs the first vector of elements+||| @ ys the second vector of elements+zipWith : (f : a -> b -> c) -> (xs : Vect n a) -> (ys : Vect n b) -> Vect n c zipWith f []      []      = [] zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys @@ -573,11 +577,14 @@ ||| A proof that some element is found in a vector data Elem : a -> Vect k a -> Type where      Here : Elem x (x::xs)-     There : Elem x xs -> Elem x (y::xs)+     There : (later : Elem x xs) -> Elem x (y::xs)  ||| Nothing can be in an empty Vect noEmptyElem : {x : a} -> Elem x [] -> Void noEmptyElem Here impossible++Uninhabited (Elem x []) where+  uninhabited = noEmptyElem   ||| An item not in the head and not in the tail is not in the Vect at all neitherHereNorThere : {x, y : a} -> {xs : Vect n a} -> Not (x = y) -> Not (Elem x xs) -> Not (Elem x (y :: xs))
libs/base/Data/Vect/Quantifiers.idr view
@@ -2,6 +2,8 @@  import Data.Vect +%access public export+ ||| A proof that some element of a vector satisfies some property ||| ||| @ P the property to be satsified
libs/base/Debug/Error.idr view
@@ -7,7 +7,7 @@ ||| ||| @ loc     The source location to display for the error ||| @ message The error to print-partial+partial export error : {default (%runElab sourceLocation) loc : SourceLocation} ->         (message : String) ->         a
libs/base/Debug/Trace.idr view
@@ -3,6 +3,7 @@ ||| Print a message for debugging purposes as a side effect ||| @ msg what to print ||| @ result the final result+export trace : (msg : String) -> (result : a) -> a trace x val = unsafePerformIO {ffi=FFI_C} (do putStrLn x; return val)
libs/base/Language/Reflection/Utils.idr view
@@ -4,6 +4,8 @@ import Language.Reflection.Elab import Language.Reflection.Errors +%access public export+ -------------------------------------------------------- -- Tactic construction conveniences --------------------------------------------------------@@ -145,6 +147,8 @@   showPrec d StrType    = "StrType"   showPrec d VoidType   = "VoidType"   showPrec d Forgot     = "Forgot"+  showPrec d WorldType  = "WorldType"+  showPrec d TheWorld   = "TheWorld"  implementation Eq NativeTy where   IT8  == IT8  = True@@ -299,7 +303,7 @@   showPrec d (CantMatch tm) = showCon d "CantMatch" $ showArg tm   showPrec d (NoTypeDecl n) = showCon d "NoTypeDecl" $ showArg n   showPrec d (NotInjective tm tm' x) = showCon d "NotInjective" $ showArg tm ++ showArg tm'-  showPrec d (CantResolve tm) = showCon d "CantResolve" $ showArg tm+  showPrec d (CantResolve tm e) = showCon d "CantResolve" $ showArg tm ++ showArg e   showPrec d (InvalidTCArg n tm) = showCon d "InvalidTCName" $ showArg n ++ showArg tm   showPrec d (CantResolveAlts xs) = showCon d "CantResolveAlts" $ showArg xs   showPrec d (NoValidAlts xs) = showCon d "NoValidAlts" $ showArg xs
libs/base/Syntax/PreorderReasoning.idr view
@@ -1,5 +1,7 @@ module Syntax.PreorderReasoning +%access public export+ -- QED is first to get the precedence to work out. It's just Refl with an explicit argument. syntax [expr] "QED" = qed expr -- foo ={ prf }= bar ={ prf' }= fnord QED
libs/base/System.idr view
@@ -2,7 +2,7 @@  %include C "unistd.h" %default partial-%access public+%access public export  ||| Retrieves a value from the environment if the given key is present, ||| otherwise it returns Nothing.
libs/base/System/Concurrency/Raw.idr view
@@ -6,6 +6,8 @@  import System +%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
libs/base/System/Info.idr view
@@ -1,13 +1,16 @@ module System.Info  ||| The Idris backend in use+export backend : String backend = prim__systemInfo 0  ||| The operating system in use.+export os : String os = prim__systemInfo 1  ||| The triple this program was targeted for+export targetTriple : String targetTriple = prim__systemInfo 2
libs/contrib/Classes/Verified.idr view
@@ -4,6 +4,8 @@ import Control.Algebra.Lattice import Control.Algebra.VectorSpace +%access public export+ -- Due to these being basically unused and difficult to implement, -- they're in contrib for a bit. Once a design is found that lets them -- be implemented for a number of implementations, and we get those@@ -92,6 +94,11 @@   total meetSemilatticeMeetIsCommutative : (l, r : a)    -> meet l r = meet r l   total meetSemilatticeMeetIsIdempotent  : (e : a)       -> meet e e = e +{- FIXME: Some maintenance required here.+   Algebra.top and Algebra.bottom don't exist!+-}+{-+ interface (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where   total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e Algebra.bottom = e @@ -112,3 +119,5 @@ --  total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v)  --interface (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}++-}
libs/contrib/Control/Algebra.idr view
@@ -3,6 +3,7 @@ infixl 6 <-> infixl 7 <.> +%access public export  ||| Sets equipped with a single binary operation that is associative, along with ||| a neutral element for that binary operation and inverses for all elements.
libs/contrib/Control/Algebra/Lattice.idr view
@@ -3,6 +3,7 @@ import Control.Algebra import Data.Heap +%access public export  ||| Sets equipped with a binary operation that is commutative, associative and ||| idempotent.  Must satisfy the following laws:
libs/contrib/Control/Algebra/NumericInstances.idr view
@@ -7,6 +7,7 @@ import Data.Complex import Data.ZZ +%access public export  Semigroup Integer where   (<+>) = (+)
libs/contrib/Control/Algebra/VectorSpace.idr view
@@ -2,6 +2,8 @@  import Control.Algebra +%access public export+ infixl 5 <#> infixr 2 <||>
libs/contrib/Control/Isomorphism/Primitives.idr view
@@ -4,7 +4,7 @@ import Data.ZZ  %default total-%access public+%access public export  -- This module contains isomorphisms between convenient inductive types and -- Idris primitives.  Because primitives lack a convenient structure, these
libs/contrib/Control/Partial.idr view
@@ -7,7 +7,7 @@ ||| @ p the predicate to wait for ||| @ f the function to repeatedly apply ||| @ v the starting value-partial+partial export until : (p : a -> Bool) -> (f : a -> a) -> (v : a) -> a until p f v with (p v)   | False = until p f (f v)
libs/contrib/Control/WellFounded.idr view
@@ -6,7 +6,7 @@ module Control.WellFounded  %default total-+%access public export  ||| Accessibility: some element `x` is accessible if all `y` such that ||| `rel y x` are themselves accessible.
libs/contrib/Data/BoundedList.idr view
@@ -2,7 +2,7 @@  import Data.Fin -%access public+%access public export %default total  ||| A list with an upper bound on its length.
libs/contrib/Data/CoList.idr view
@@ -1,6 +1,6 @@ module Data.CoList -%access public+%access public export %default total  ||| Idris will know that it always can produce a new element in finite time
libs/contrib/Data/Fun.idr view
@@ -3,6 +3,7 @@ import public Data.Vect  %default total+%access public export  ||| Build an n-ary function type from a Vect of Types and a result type Fun : Vect n Type -> Type -> Type
libs/contrib/Data/Hash.idr view
@@ -2,7 +2,7 @@  import Data.Vect -%access public+%access public export %default total  {- A general purpose Hashing library (not cryptographic)
libs/contrib/Data/Heap.idr view
@@ -7,9 +7,9 @@   %default total-%access public+%access export -abstract data MaxiphobicHeap : Type -> Type where+export data MaxiphobicHeap : Type -> Type where   Empty : MaxiphobicHeap a   Node  : Nat -> MaxiphobicHeap a -> a -> MaxiphobicHeap a -> MaxiphobicHeap a
libs/contrib/Data/Matrix.idr view
@@ -5,6 +5,7 @@ import public Data.Vect  %default total+%access public export  ||| Matrix with n rows and m columns Matrix : Nat -> Nat -> Type -> Type
libs/contrib/Data/Matrix/Algebraic.idr view
@@ -9,7 +9,7 @@  import public Data.Matrix -+%access public export %default total  infixr 2 <:>  -- vector inner product
libs/contrib/Data/Matrix/Numeric.idr view
@@ -5,6 +5,7 @@ import public Data.Matrix  %default total+%access public export  infixr 2 <:>  -- vector inner product infixr 2 ><   -- vector outer product
libs/contrib/Data/Nat/DivMod.idr view
@@ -2,6 +2,7 @@ module Data.Nat.DivMod  %default total+%access public export  ||| The result of euclidean division of natural numbers |||
libs/contrib/Data/Nat/DivMod/IteratedSubtraction.idr view
@@ -8,7 +8,7 @@ import Control.WellFounded  %default total-%access public+%access public export  ||| A strict less-than relation on `Nat`. |||
libs/contrib/Data/Rel.idr view
@@ -2,6 +2,7 @@  import Data.Fun +%access public export  ||| Build an n-ary relation type from a Vect of Types Rel : Vect n Type -> Type
libs/contrib/Data/Sign.idr view
@@ -1,5 +1,7 @@ module Data.Sign +%access public export+ ||| A representation of signs for signed datatypes such as `ZZ` data Sign = Plus | Zero | Minus
libs/contrib/Data/SortedMap.idr view
@@ -192,21 +192,21 @@     treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1     treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1 -abstract+export data SortedMap : Type -> Type -> Type where   Empty : Ord k => SortedMap k v   M : (o : Ord k) => (n:Nat) -> Tree n k v o -> SortedMap k v -public+export empty : Ord k => SortedMap k v empty = Empty -public+export lookup : k -> SortedMap k v -> Maybe v lookup _ Empty = Nothing lookup k (M _ t) = treeLookup k t -public+export insert : k -> v -> SortedMap k v -> SortedMap k v insert k v Empty = M Z (Leaf k v) insert k v (M _ t) =@@ -214,7 +214,7 @@     Left t' => (M _ t')     Right t' => (M _ t') -public+export delete : k -> SortedMap k v -> SortedMap k v delete _ Empty = Empty delete k (M Z t) =@@ -226,16 +226,15 @@     Left t' => (M _ t')     Right t' => (M _ t') -public+export fromList : Ord k => List (k, v) -> SortedMap k v fromList l = foldl (flip (uncurry insert)) empty l -public+export toList : SortedMap k v -> List (k, v) toList Empty = [] toList (M _ t) = treeToList t -public treeMap : (a -> b) -> Tree n k a o -> Tree n k b o treeMap f (Leaf k v) = Leaf k (f v) treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)
libs/contrib/Data/SortedSet.idr view
@@ -4,30 +4,30 @@  -- TODO: add intersection, union, difference -abstract+export data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ()) -public+export empty : Ord k => SortedSet k empty = SetWrapper Data.SortedMap.empty -public+export insert : k -> SortedSet k -> SortedSet k insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m) -public+export delete : k -> SortedSet k -> SortedSet k delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m) -public+export contains : k -> SortedSet k -> Bool contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m) -public+export fromList : Ord k => List k -> SortedSet k fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l)) -public+export toList : SortedSet k -> List k toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)
+ libs/contrib/Data/Storable.idr view
@@ -0,0 +1,41 @@+module Data.Storable++%access public export++interface Storable a where+    sizeOf : a -> Int+    alignOf : a -> Int+    peek : Ptr -> Int -> IO a+    poke : Ptr -> Int -> a -> IO ()++Storable Bits8 where+    sizeOf _ = 1+    alignOf _ = 1+    peek p offset = prim_peek8 p offset+    poke p offset val = do+        _ <- prim_poke8 p offset val+        return ()++Storable Bits16 where+    sizeOf _ = 2+    alignOf _ = 2+    peek p offset = prim_peek16 p offset+    poke p offset val = do+        _ <- prim_poke16 p offset val+        return ()++Storable Bits32 where+    sizeOf _ = 4+    alignOf _ = 4+    peek p offset = prim_peek32 p offset+    poke p offset val = do+        _ <- prim_poke32 p offset val+        return ()++Storable Bits64 where+    sizeOf _ = 8+    alignOf _ = 8+    peek p offset = prim_peek64 p offset+    poke p offset val = do+        _ <- prim_poke64 p offset val+        return ()
libs/contrib/Data/ZZ.idr view
@@ -4,7 +4,7 @@ import Data.Sign  %default total-%access public+%access public export   ||| An integer is either a positive `Nat` or the negated successor of a `Nat`.
libs/contrib/Decidable/Decidable.idr view
@@ -3,7 +3,7 @@ import Data.Rel import Data.Fun -%access public+%access public export  -------------------------------------------------------------------------------- -- Interface for decidable n-ary Relations
libs/contrib/Decidable/Order.idr view
@@ -6,7 +6,7 @@ import Data.Fun import Data.Rel -%access public+%access public export  -------------------------------------------------------------------------------- -- Utility Lemmas
libs/contrib/Network/Cgi.idr view
@@ -4,7 +4,7 @@  %default total -public+public export Vars : Type Vars = List (String, String) @@ -23,7 +23,7 @@ add_Output : String -> CGIInfo -> CGIInfo add_Output str st = record { Output = Output st ++ str } st -abstract+export data CGI : Type -> Type where     MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a @@ -51,32 +51,32 @@ getInfo : CGI CGIInfo getInfo = MkCGI (\s => return (s, s)) -abstract+export lift : IO a -> CGI a lift op = MkCGI (\st => do { x <- op                              return (x, st) } ) -abstract+export output : String -> CGI () output s = do i <- getInfo               setInfo (add_Output s i) -abstract+export queryVars : CGI Vars queryVars = do i <- getInfo                return (GET i) -abstract+export postVars : CGI Vars postVars = do i <- getInfo               return (POST i) -abstract+export cookieVars : CGI Vars cookieVars = do i <- getInfo                 return (Cookies i) -abstract+export queryVar : String -> CGI (Maybe String) queryVar x = do vs <- queryVars                 return (lookup x vs)@@ -89,12 +89,12 @@ getHeaders = do i <- getInfo                 return (Headers i) -abstract+export flushHeaders : CGI () flushHeaders = do o <- getHeaders                   lift (putStrLn o) -abstract+export flush : CGI () flush = do o <- getOutput            lift (putStr o)@@ -119,7 +119,7 @@   val <- getEnv key   return $ maybe "" id val -abstract+export runCGI : CGI a -> IO a runCGI prog = do     clen_in <- getCgiEnv "CONTENT_LENGTH"
libs/contrib/Network/Socket.idr view
@@ -8,9 +8,7 @@ %include C "sys/socket.h" %include C "netdb.h" -%access public--ByteLength : Type+public export ByteLength : Type ByteLength = Int  interface ToCode a where@@ -67,9 +65,10 @@  data RecvStructPtr = RSPtr Ptr data RecvfromStructPtr = RFPtr Ptr-data BufPtr = BPtr Ptr-data SockaddrPtr = SAPtr Ptr +export data BufPtr = BPtr Ptr+export data SockaddrPtr = SAPtr Ptr+ ||| Protocol Number. ||| ||| Generally good enough to just set it to 0.@@ -120,18 +119,18 @@   remote_port : Port  ||| Frees a given pointer-public+export sock_free : BufPtr -> IO () sock_free (BPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr -public+export sockaddr_free : SockaddrPtr -> IO () sockaddr_free (SAPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr  ||| Allocates an amount of memory given by the ByteLength parameter. ||| ||| Used to allocate a mutable pointer to be given to the Recv functions.-public+export sock_alloc : ByteLength -> IO BufPtr sock_alloc bl = map BPtr $ foreign FFI_C "idrnet_malloc" (Int -> IO Ptr) bl
libs/contrib/System/Concurrency/Process.idr view
@@ -4,9 +4,9 @@  import System.Concurrency.Raw -%access public+%access public export -abstract+export data ProcID msg = MkPID Ptr  ||| Type safe message passing programs. Parameterised over the type of@@ -30,24 +30,29 @@ run (Lift prog) = prog  ||| Get current process ID+export myID : Process msg (ProcID msg) myID = Lift (return (MkPID prim__vm))  ||| Send a message to another process ||| 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))  ||| Return whether a message is waiting in the queue+export msgWaiting : Process msg Bool msgWaiting = Lift checkMsgs  ||| 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)  ||| Receive a message - blocks if there is no message waiting+export recv : Process msg msg recv {msg} = do (senderid, m) <- Lift get                 return m@@ -55,6 +60,7 @@         get = getMsg  ||| Receive a message from specific sender - blocks if there is no message waiting+export recvFrom : ProcID msg -> Process msg msg recvFrom (MkPID p) {msg} = do (senderid, m) <- Lift get                               return m@@ -62,6 +68,7 @@         get = getMsgFrom p  ||| receive a message, and return with the sender's process ID.+export recvWithSender : Process msg (ProcID msg, msg) recvWithSender {msg}      = do (senderid, m) <- Lift get@@ -69,6 +76,7 @@   where get : IO (Ptr, msg)         get = getMsg +export create : Process msg () -> Process msg (ProcID msg) create (Lift p) = do ptr <- Lift (fork p)                      return (MkPID ptr)
libs/contrib/contrib.ipkg view
@@ -7,7 +7,9 @@           Control.Isomorphism.Primitives,           Control.Partial,           Control.WellFounded,+           Classes.Verified,+           Data.Fun, Data.Rel,           Data.Hash,           Data.Matrix, Data.Matrix.Algebraic, Data.Matrix.Numeric,@@ -16,7 +18,7 @@           Data.BoundedList,           Data.Heap,           Data.SortedMap, Data.SortedSet,-          Data.CoList,+          Data.CoList, Data.Storable,            Decidable.Decidable, Decidable.Order,
libs/effects/Effect/Default.idr view
@@ -2,6 +2,8 @@  import Data.Vect +%access public export+ interface Default a where     default : a
libs/effects/Effect/Exception.idr view
@@ -4,6 +4,8 @@ import System import Control.IOExcept +%access public export+ data Exception : Type -> Effect where      Raise : a -> sig (Exception a) b
libs/effects/Effect/File.idr view
@@ -4,6 +4,7 @@ import Effects import Control.IOExcept +%access public export  ||| A Dependent type to describe File Handles. File handles are ||| parameterised with the current state of the file: Closed; Open for@@ -63,7 +64,7 @@   ||| Write a string to a file.   |||   ||| Only file that are open for writing can be written to.-  WriteString : String -> sig FileIO () (OpenFile Write)+  WriteString : String -> sig FileIO () (OpenFile WriteTruncate)    ||| End of file?   |||@@ -137,11 +138,11 @@ readLine = call $ ReadLine  ||| Write a string to a file.-writeString : String -> Eff () [FILE_IO (OpenFile Write)]+writeString : String -> Eff () [FILE_IO (OpenFile WriteTruncate)] writeString str = call $ WriteString str  ||| Write a line to a file.-writeLine : String -> Eff () [FILE_IO (OpenFile Write)]+writeLine : String -> Eff () [FILE_IO (OpenFile WriteTruncate)] writeLine str = call $ WriteString (str ++ "\n")  ||| End of file?@@ -175,7 +176,7 @@          -> (content : String)          -> Eff (Either e ()) [FILE_IO ()] writeFile errFunc fname content = do-    case !(open fname Write) of+    case !(open fname WriteTruncate) of       True => do         writeString content         close
libs/effects/Effect/Logging/Category.idr view
@@ -14,7 +14,7 @@ import Effects import public Effect.Logging.Level -%access public+%access public export  -- -------------------------------------------------------- [ Logging Resource ] @@ -147,7 +147,7 @@                       -> (cs : List a)                       -> (m : String)                       -> Eff () [LOG a]-logN l cs msg = call $ Log (getProof lvl) cs msg+logN l cs msg = call $ Log (snd lvl) cs msg   where     lvl : (n ** LogLevel n)     lvl = case cast {to=String} (cast {to=Int} l) of
libs/effects/Effect/Logging/Default.idr view
@@ -15,7 +15,7 @@ import Effects import public Effect.Logging.Level -%access public+%access public export  -- ------------------------------------------------------------ [ The Resource ] @@ -84,7 +84,7 @@ ||| @l The level to log. ||| @m The message to log. logN : (l : Nat) -> {auto prf : LTE l 70} -> (m : String) -> Eff () [LOG]-logN l msg = call $ Log (getProof lvl) msg+logN l msg = call $ Log (snd lvl) msg   where     lvl : (n ** LogLevel n)     lvl = case cast {to=String} (cast {to=Int} l) of
libs/effects/Effect/Logging/Level.idr view
@@ -14,7 +14,7 @@ ||| loggers. module Effect.Logging.Level -%access public+%access public export %default total  -- ---------------------------------------------------- [ Log Level Definition ]
libs/effects/Effect/Memory.idr view
@@ -5,13 +5,13 @@ import Data.Vect import public Data.So -%access public+%access public export -abstract+export data MemoryChunk : Nat -> Nat -> Type where      CH : Ptr -> MemoryChunk size initialized -abstract+export data RawMemory : Effect where      Allocate   : (n : Nat) ->                   RawMemory () () (\v => MemoryChunk n 0)@@ -102,10 +102,12 @@ RAW_MEMORY : Type -> EFFECT RAW_MEMORY t = MkEff t RawMemory +export allocate : (n : Nat) ->            Eff () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)]) allocate size = call $ Allocate size +export initialize : {i : Nat} ->              {n : Nat} ->              Bits8 ->@@ -115,9 +117,11 @@                        (\v => [RAW_MEMORY (MemoryChunk n (i + size))]) initialize c size prf = call $ Initialize c size prf +export free : Eff () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()]) free = call Free +export peek : {i : Nat} ->        (offset : Nat) ->        (size : Nat) ->@@ -125,6 +129,7 @@        { [RAW_MEMORY (MemoryChunk n i)] } Eff (Vect size Bits8) peek offset size prf = call $ Peek offset size prf +export poke : {n : Nat} ->        {i : Nat} ->        (offset : Nat) ->@@ -155,6 +160,7 @@  data MoveDescriptor = Dst | Src +export move : {dst_size : Nat} ->        {dst_init : Nat} ->        {src_size : Nat} ->
libs/effects/Effect/Monad.idr view
@@ -2,6 +2,8 @@  import Effects +%access public export+ data MonadEffT : List EFFECT -> (Type -> Type) -> Type -> Type where      MkMonadEffT : EffM m a xs (\v => xs) -> MonadEffT xs m a
libs/effects/Effect/Perf.idr view
@@ -12,7 +12,7 @@ import Effects import Effect.Default -%access public+%access public export  -- ---------------------------------------------------- [ Timer Data Structure ]
libs/effects/Effect/Random.idr view
@@ -3,6 +3,8 @@ import Effects import Data.Vect +%access public export+ data Random : Effect where       GetRandom : sig Random Integer Integer      SetSeed   : Integer -> sig Random () Integer
libs/effects/Effect/Select.idr view
@@ -2,6 +2,8 @@  import Effects +%access public export+ data Selection : Effect where      Select : List a -> sig Selection a ()
libs/effects/Effect/State.idr view
@@ -2,7 +2,7 @@  import Effects -%access public+%access public export  data State : Effect where   Get :      sig State a  a
libs/effects/Effect/StdIO.idr view
@@ -3,6 +3,8 @@ import Effects import Control.IOExcept +%access public export+ ------------------------------------------------------------- -- IO effects internals -------------------------------------------------------------
libs/effects/Effect/System.idr view
@@ -7,6 +7,8 @@ import System import Control.IOExcept +%access public export+ data System : Effect where      Args : sig System (List String)      Time : sig System Integer
libs/effects/Effect/Trans.idr view
@@ -2,7 +2,7 @@  import Effects -%access public+%access public export  data Trans : (Type -> Type) -> Effect where   Lift : m a -> sig (Trans m) a
libs/effects/Effects.idr view
@@ -7,7 +7,7 @@ --- Effectful computations are described as algebraic data types that --- explain how an effect is interpreted in some underlying context. -%access public+%access export -- ----------------------------------------------------------------- [ Effects ] ||| The Effect type describes effectful computations. |||@@ -15,11 +15,13 @@ ||| + The return type of the computation. ||| + The input resource. ||| + The computation to run on the resource given the return value.+public export Effect : Type Effect = (x : Type) -> Type -> (x -> Type) -> Type  ||| The `EFFECT` Data type describes how to promote the Effect ||| description into a concrete effect.+public export %error_reverse data EFFECT : Type where      MkEff : Type -> Effect -> EFFECT@@ -30,24 +32,29 @@ -- or a dependent change. These are easily disambiguated by type.  namespace NoResourceEffect+  public export   sig : Effect -> Type -> Type   sig e r = e r () (\v => ())  namespace NoUpdateEffect+  public export   sig : Effect -> (ret : Type) -> (resource : Type) -> Type   sig e r e_in = e r e_in (\v => e_in)  namespace UpdateEffect+  public export   sig : Effect -> (ret : Type) -> (res_in : Type) -> (res_out : Type) -> Type   sig e r e_in e_out = e r e_in (\v => e_out)  namespace DepUpdateEffect+  public export   sig : Effect ->         (ret : Type) -> (res_in : Type) -> (res_out : ret -> Type) -> Type   sig e r e_in e_out = e r e_in e_out  ||| Handler interfaces describe how an effect `e` is translated to the ||| underlying computation context `m` for execution.+public export interface Handler (e : Effect) (m : Type -> Type) where   ||| How to handle the effect.   |||@@ -77,6 +84,7 @@ syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)  -- --------------------------------------- [ Properties and Proof Construction ]+public export data SubList : List a -> List a -> Type where      SubNil : SubList [] []      Keep   : SubList xs ys -> SubList (x :: xs) (x :: ys)@@ -88,21 +96,25 @@ subListId {xs = x :: xs} = Keep subListId  namespace Env+  public export   data Env  : (m : Type -> Type) -> List EFFECT -> Type where        Nil  : Env m Nil        (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs) +public export data EffElem : Effect -> Type ->                List EFFECT -> Type where      Here : EffElem x a (MkEff a x :: xs)      There : EffElem x a xs -> EffElem x a (y :: xs)  ||| make an environment corresponding to a sub-list+private dropEnv : Env m ys -> SubList xs ys -> Env m xs dropEnv [] SubNil = [] dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest dropEnv (v :: vs) (Drop rest) = dropEnv vs rest +public export updateWith : (ys' : List a) -> (xs : List a) ->              SubList ys xs -> List a updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest@@ -112,6 +124,7 @@ updateWith []        (x :: xs) (Keep rest) = []  ||| Put things back, replacing old with new in the sub-environment+private rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->              Env m xs -> Env m (updateWith ys' xs prf) rebuildEnv []        SubNil      env = env@@ -123,6 +136,7 @@  -- -------------------------------------------------- [ The Effect EDSL itself ] +public export updateResTy : (val : t) ->               (xs : List EFFECT) -> EffElem e a xs -> e t a b ->               List EFFECT@@ -131,9 +145,11 @@  infix 5 :::, :-, := +public export data LRes : lbl -> Type -> Type where      (:=) : (x : lbl) -> res -> LRes x res +public export (:::) : lbl -> EFFECT -> EFFECT (:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e @@ -156,6 +172,7 @@ ||| @ x The return type of the result. ||| @ es The list of allowed side-effects. ||| @ ce Function to compute a new list of allowed side-effects.+public export data EffM : (m : Type -> Type) -> (x : Type)             -> (es : List EFFECT)             -> (ce : x -> List EFFECT) -> Type where@@ -182,27 +199,33 @@  namespace SimpleEff   -- Simple effects, no updates+  public export   Eff : (x : Type) -> (es : List EFFECT) -> Type   Eff x es = {m : Type -> Type} -> EffM m x es (\v => es) +  public export   EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) -> Type   EffT m x es = EffM m x es (\v => es)  namespace TransEff   -- Dependent effects, updates not dependent on result+  public export   Eff : (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type   Eff x es ce = {m : Type -> Type} -> EffM m x es (\_ => ce) +  public export   EffT : (m : Type -> Type) ->          (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type   EffT m x es ce = EffM m x es (\_ => ce)  namespace DepEff   -- Dependent effects, updates dependent on result+  public export   Eff : (x : Type) -> (es : List EFFECT)         -> (ce : x -> List EFFECT) -> Type   Eff x es ce = {m : Type -> Type} -> EffM m x es ce +  public export   EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT)         -> (ce : x -> List EFFECT) -> Type   EffT m x es ce = EffM m x es ce@@ -271,6 +294,7 @@ -- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state -- updates can be propagated even through failing computations? +export eff : Env m xs -> EffM m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b eff env (Value x) k = k x env eff env (prog `EBind` c) k
libs/prelude/Builtins.idr view
@@ -1,6 +1,6 @@ %unqualified -%access public+%access public export %default total  ||| The canonical single-element type, also known as the trivially@@ -37,23 +37,31 @@   %used MkUPair a   %used MkUPair b -  ||| Dependent pairs+  ||| Dependent pairs aid in the construction of dependent types by+  ||| providing evidence that some value resides in the type.   |||-  ||| Dependent pairs represent existential quantification - they consist of a-  ||| witness for the existential claim and a proof that the property holds for-  ||| it. Another way to see dependent pairs is as just data - for instance, the-  ||| length of a vector paired with that vector.+  ||| Formally, speaking, dependent pairs represent existential+  ||| quantification - they consist of a witness for the existential+  ||| claim and a proof that the property holds for it.   |||-  |||  @ a the type of the witness-  |||  @ P the type of the proof-  data Sigma : (a : Type) -> (P : a -> Type) -> Type where-      MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P+  |||  @a the value to place in the type.+  |||  @P the dependent type that requires the value.+  data DPair : (a : Type) -> (P : a -> Type) -> Type where+      MkDPair : .{P : a -> Type} -> (x : a) -> (pf : P x) -> DPair a P +  Sigma : (a : Type) -> (P : a -> Type) -> Type+  Sigma wit prf = DPair wit prf+  %deprecate Sigma "This name is being deprecated in favour of `DPair`."++  MkSigma : .{P : a -> Type} -> (x : a) -> (prf : P x) -> DPair a P+  MkSigma wit prf = MkDPair wit prf+  %deprecate MkSigma "This constructor is being deprecated in favour of `MkDPair`."+ ||| The empty type, also known as the trivially false proposition. |||-||| Use `void` or `absurd` to prove anything if you have a variable of type `Void` in scope. -%elim data Void : Type where    -    +||| Use `void` or `absurd` to prove anything if you have a variable of type `Void` in scope.+%elim data Void : Type where+ ||| The eliminator for the `Void` type. void : Void -> a -- We can't define void yet. We can't define a function with no clauses without@@ -155,13 +163,13 @@  ||| 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!-abstract %assert_total -- need to pretend+export %assert_total -- need to pretend believe_me : a -> b believe_me x = 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 %assert_total+public export %assert_total really_believe_me : a -> b really_believe_me x = prim__believe_me _ _ x @@ -174,8 +182,8 @@ -- Pointers as external primitive; there's no literals for these, so no -- need for them to be part of the compiler. -abstract data Ptr : Type-abstract data ManagedPtr : Type+export data Ptr : Type+export data ManagedPtr : Type  %extern prim__readFile : prim__WorldType -> Ptr -> String %extern prim__writeFile : prim__WorldType -> Ptr -> String -> Int@@ -190,4 +198,18 @@ %extern prim__eqManagedPtr : ManagedPtr -> ManagedPtr -> Int %extern prim__registerPtr : Ptr -> Int -> ManagedPtr +-- primitives for accessing memory.+%extern prim__asPtr : ManagedPtr -> Ptr+%extern prim__sizeofPtr : Int+%extern prim__peek8 : prim__WorldType -> Ptr -> Int -> Bits8+%extern prim__peek16 : prim__WorldType -> Ptr -> Int -> Bits16+%extern prim__peek32 : prim__WorldType -> Ptr -> Int -> Bits32+%extern prim__peek64 : prim__WorldType -> Ptr -> Int -> Bits64 +%extern prim__poke8 : prim__WorldType -> Ptr -> Int -> Bits8 -> Int+%extern prim__poke16 : prim__WorldType -> Ptr -> Int -> Bits16 -> Int+%extern prim__poke32 : prim__WorldType -> Ptr -> Int -> Bits32 -> Int+%extern prim__poke64 : prim__WorldType -> Ptr -> Int -> Bits64 -> Int++%extern prim__peekPtr : prim__WorldType -> Ptr -> Int -> Ptr+%extern prim__pokePtr : prim__WorldType -> Ptr -> Int -> Ptr -> Int
libs/prelude/Decidable/Equality.idr view
@@ -3,12 +3,14 @@ import Builtins import Prelude.Basics import Prelude.Bool-import Prelude.Classes+import Prelude.Interfaces import Prelude.Either import Prelude.List import Prelude.Nat import Prelude.Maybe +%access public export+ -------------------------------------------------------------------------------- -- Utility lemmas --------------------------------------------------------------------------------@@ -141,7 +143,7 @@   decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil)   decEq (x :: xs) (y :: ys) with (decEq x y)     decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys)-      decEq (x :: xs) (x :: xs) | (Yes Refl) | (Yes Refl) = Yes Refl +      decEq (x :: xs) (x :: xs) | (Yes Refl) | (Yes Refl) = Yes Refl       decEq (x :: xs) (x :: ys) | (Yes Refl) | (No p) = No (\eq => lemma_x_eq_xs_neq Refl p eq)     decEq (x :: xs) (y :: ys) | No p with (decEq xs ys)       decEq (x :: xs) (y :: xs) | (No p) | (Yes Refl) = No (\eq => lemma_x_neq_xs_eq p Refl eq)@@ -211,6 +213,3 @@        where primitiveEq : x = y              primitiveEq = believe_me (Refl {x})              postulate primitiveNotEq : x = y -> Void---
libs/prelude/IO.idr view
@@ -3,25 +3,24 @@ import Builtins import Prelude.List -%access public+%access export  ||| Idris's primitive IO, for building abstractions on top of-abstract data PrimIO : Type -> Type where      Prim__IO : a -> PrimIO a  ||| A token representing the world, for use in `IO`-abstract data World = TheWorld prim__WorldType+data World = TheWorld prim__WorldType -private world : World -> prim__WorldType world (TheWorld w) = w -abstract WorldRes : Type -> Type+WorldRes : Type -> Type WorldRes x = x  ||| An FFI specifier, which describes how a particular compiler ||| backend handles foreign function calls.+public export record FFI where   constructor MkFFI   ||| A family describing which types are available in the FFI@@ -35,10 +34,10 @@  ||| The IO type, parameterised over the FFI that is available within ||| it.-abstract data IO' : (lang : FFI) -> Type -> Type where      MkIO : (World -> PrimIO (WorldRes a)) -> IO' lang a +public export data FTy : FFI -> List Type -> Type -> Type where      FRet : ffi_types f t -> FTy f xs (IO' f t)      FFun : ffi_types f s -> FTy f (s :: xs) t -> FTy f xs (s -> t)@@ -47,15 +46,16 @@   data FEnv : FFI -> List Type -> Type where        Nil : FEnv f []        (::) : (ffi_types f t, t) -> FEnv f xs -> FEnv f (t :: xs)-  + ForeignPrimType : (xs : List Type) -> FEnv ffi xs -> Type -> Type ForeignPrimType {ffi} [] [] t = World -> ffi_fn ffi -> ffi_types ffi t -> PrimIO t-ForeignPrimType {ffi} (x :: xs) ((a, _) :: env) t +ForeignPrimType {ffi} (x :: xs) ((a, _) :: env) t      = (ffi_types ffi x, x) -> ForeignPrimType xs env t  %inline-applyEnv : (env : FEnv ffi xs) -> -           ForeignPrimType xs env t -> +private+applyEnv : (env : FEnv ffi xs) ->+           ForeignPrimType xs env t ->            World -> ffi_fn ffi -> ffi_types ffi t -> PrimIO t applyEnv [] f = f applyEnv (x@(_, _) :: xs) f = applyEnv xs (f x)@@ -66,7 +66,8 @@ -- explicit here.  %inline-foreign_prim : (f : FFI) -> +private+foreign_prim : (f : FFI) ->                (fname : ffi_fn f) -> FTy f xs ty -> FEnv f xs -> ty foreign_prim f fname (FRet y) env         = MkIO (\w => applyEnv env mkForeignPrim w fname y)@@ -91,25 +92,21 @@           {auto fty : FTy f [] ty} -> ty foreign ffi fname ty {fty} = foreign_prim ffi fname fty [] -abstract prim_io_bind : PrimIO a -> (a -> PrimIO b) -> PrimIO b prim_io_bind (Prim__IO v) k = k v  unsafePerformPrimIO : PrimIO a -> a -- compiled as primitive -abstract prim_io_return : a -> PrimIO a prim_io_return x = Prim__IO x -abstract io_bind : IO' l a -> (a -> IO' l b) -> IO' l b io_bind (MkIO fn) k    = MkIO (\w => prim_io_bind (fn w)                     (\ b => case k b of                                  MkIO fkb => fkb w)) -abstract io_return : a -> IO' l a io_return x = MkIO (\w => prim_io_return x) @@ -131,27 +128,32 @@ prim_read = MkIO (\w => prim_io_return (prim__readString (world w)))  prim_write : String -> IO' l Int-prim_write s +prim_write s    = MkIO (\w => prim_io_return (prim__writeString (world w) s))  prim_fread : Ptr -> IO' l String prim_fread h = MkIO (\w => prim_io_return (prim__readFile (world w) h))  prim_fwrite : Ptr -> String -> IO' l Int-prim_fwrite h s +prim_fwrite h s    = MkIO (\w => prim_io_return (prim__writeFile (world w) h s))  --------- The C FFI namespace FFI_C+  public export   data Raw : Type -> Type where        -- code generated can assume it's compiled just as 't'        MkRaw : (x : t) -> Raw t -  -- Tell erasure analysis not to erase the argument-  %used MkRaw x+  public export+  data CFnPtr : Type -> Type where+    MkCFnPtr : (x : t) -> CFnPtr t -  ||| Supported C integer types-  data C_IntTypes : Type -> Type where++  mutual+    ||| Supported C integer types+    public export+    data C_IntTypes : Type -> Type where        C_IntChar   : C_IntTypes Char        C_IntNative : C_IntTypes Int        C_IntBits8  : C_IntTypes Bits8@@ -159,28 +161,43 @@        C_IntBits32 : C_IntTypes Bits32        C_IntBits64 : C_IntTypes Bits64 -  ||| Supported C foreign types-  data C_Types : Type -> Type where+    public export+    data C_FnTypes : Type -> Type where+       C_Fn : C_Types s -> C_FnTypes t -> C_FnTypes (s -> t)+       C_FnIO : C_Types t -> C_FnTypes (IO' FFI_C t)+       C_FnBase : C_Types t -> C_FnTypes t++    ||| Supported C foreign types+    public export+    data C_Types : Type -> Type where        C_Str   : C_Types String        C_Float : C_Types Double        C_Ptr   : C_Types Ptr        C_MPtr  : C_Types ManagedPtr        C_Unit  : C_Types ()        C_Any   : C_Types (Raw a)+       C_FnT   : C_FnTypes t -> C_Types (CFnPtr t)        C_IntT  : C_IntTypes i -> C_Types i -  ||| A descriptor for the C FFI. See the constructors of `C_Types`-  ||| and `C_IntTypes` for the concrete types that are available.+    ||| A descriptor for the C FFI. See the constructors of `C_Types`+    ||| and `C_IntTypes` for the concrete types that are available.   %error_reverse-  FFI_C : FFI-  FFI_C = MkFFI C_Types String String+  public export+    FFI_C : FFI+    FFI_C = MkFFI C_Types String String  ||| Interactive programs, describing I/O actions and returning a value.-||| @res The result type of the program +||| @res The result type of the program %error_reverse+public export+ IO : (res : Type) -> Type IO = IO' FFI_C + -- Tell erasure analysis not to erase the argument+%used MkRaw x+%used MkCFnPtr x+ -- Cannot be relaxed as is used by type providers and they expect IO a -- in the first argument. run__provider : IO a -> PrimIO a@@ -207,18 +224,22 @@  -- Supported JS foreign types mutual+  public export   data JsFn : Type -> Type where        MkJsFn : (x : t) -> JsFn t +  public export   data JS_IntTypes  : Type -> Type where        JS_IntChar   : JS_IntTypes Char        JS_IntNative : JS_IntTypes Int +  public export   data JS_FnTypes : Type -> Type where        JS_Fn     : JS_Types s -> JS_FnTypes t -> JS_FnTypes (s -> t)        JS_FnIO   : JS_Types t -> JS_FnTypes (IO' l t)        JS_FnBase : JS_Types t -> JS_FnTypes t +  public export   data JS_Types : Type -> Type where        JS_Str   : JS_Types String        JS_Float : JS_Types Double@@ -236,10 +257,12 @@ ||| JavaScript code snippets, into which the arguments are substituted ||| for the placeholders `%0`, `%1`, etc. %error_reverse+public export FFI_JS : FFI FFI_JS = MkFFI JS_Types String String  %error_reverse+public export JS_IO : Type -> Type JS_IO = IO' FFI_JS @@ -249,10 +272,12 @@ namespace FFI_Export -- It's just like Data.List.Elem, but we don't need all the other stuff -- that comes with it, just a proof that a data type is defined.+  public export   data DataDefined : Type -> List (Type, s) -> s -> Type where        DHere : DataDefined x ((x, t) :: xs) t        DThere : DataDefined x xs t -> DataDefined x (y :: xs) t +  public export   data FFI_Base : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where        FFI_ExpType : {n : ffi_data f} -> (def : DataDefined t xs n) -> FFI_Base f xs t        FFI_Prim : (prim : ffi_types f t) -> FFI_Base f xs t@@ -261,6 +286,7 @@   %used FFI_ExpType def   %used FFI_Prim prim +  public export   data FFI_Exportable : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where        FFI_IO : (b : FFI_Base f xs t) -> FFI_Exportable f xs (IO' f t)        FFI_Fun : (b : FFI_Base f xs s) -> (a : FFI_Exportable f xs t) -> FFI_Exportable f xs (s -> t)@@ -271,10 +297,11 @@   %used FFI_Fun a   %used FFI_Ret b +  public export   data FFI_Export : (f : FFI) -> String -> List (Type, ffi_data f) -> Type where-       Data : (x : Type) -> (n : ffi_data f) -> +       Data : (x : Type) -> (n : ffi_data f) ->               (es : FFI_Export f h ((x, n) :: xs)) -> FFI_Export f h xs-       Fun : (fn : t) -> (n : ffi_fn f) -> {auto prf : FFI_Exportable f xs t} -> +       Fun : (fn : t) -> (n : ffi_fn f) -> {auto prf : FFI_Exportable f xs t} ->              (es : FFI_Export f h xs) -> FFI_Export f h xs        End : FFI_Export f h xs @@ -286,3 +313,38 @@ %used Fun es %used Fun prf +-- Accessing memory+prim_peek8 : Ptr -> Int -> IO Bits8+prim_peek8 ptr offset = MkIO (\w => prim_io_return (prim__peek8 (world w) ptr offset))++prim_poke8 : Ptr -> Int -> Bits8 -> IO Int+prim_poke8 ptr offset val = MkIO (\w =>  prim_io_return (+    prim__poke8 (world w) ptr offset val))++prim_peek16 : Ptr -> Int -> IO Bits16+prim_peek16 ptr offset = MkIO (\w => prim_io_return (prim__peek16 (world w) ptr offset))++prim_poke16 : Ptr -> Int -> Bits16 -> IO Int+prim_poke16 ptr offset val = MkIO (\w =>  prim_io_return (+    prim__poke16 (world w) ptr offset val))++prim_peek32 : Ptr -> Int -> IO Bits32+prim_peek32 ptr offset = MkIO (\w => prim_io_return (prim__peek32 (world w) ptr offset))++prim_poke32 : Ptr -> Int -> Bits32 -> IO Int+prim_poke32 ptr offset val = MkIO (\w =>  prim_io_return (+    prim__poke32 (world w) ptr offset val))++prim_peek64 : Ptr -> Int -> IO Bits64+prim_peek64 ptr offset = MkIO (\w => prim_io_return (prim__peek64 (world w) ptr offset))++prim_poke64 : Ptr -> Int -> Bits64 -> IO Int+prim_poke64 ptr offset val = MkIO (\w =>  prim_io_return (+    prim__poke64 (world w) ptr offset val))++prim_peekPtr : Ptr -> Int -> IO Ptr+prim_peekPtr ptr offset = MkIO (\w => prim_io_return (prim__peekPtr (world w) ptr offset))++prim_pokePtr : Ptr -> Int -> Ptr -> IO Int+prim_pokePtr ptr offset val = MkIO (\w =>  prim_io_return (+    prim__pokePtr (world w) ptr offset val))
libs/prelude/Language/Reflection.idr view
@@ -9,7 +9,7 @@ import Prelude.Nat import Prelude.Traversable -%access public+%access public export  ||| A source location in an Idris file record SourceLocation where@@ -80,7 +80,7 @@            | WorldType | TheWorld %name Const c, c' -abstract interface ReflConst (a : Type) where+export interface ReflConst (a : Type) where    toConst : a -> Const  implementation ReflConst Int where@@ -110,7 +110,7 @@ implementation ReflConst Bits64 where    toConst = B64 -implicit+implicit export reflectConstant: (ReflConst a) => a -> Const reflectConstant = toConst
libs/prelude/Language/Reflection/Elab.idr view
@@ -16,6 +16,8 @@ import Prelude.Nat import Language.Reflection +%access public export+ data Fixity = Infixl Nat | Infixr Nat | Infix Nat | Prefix Nat  ||| Erasure annotations reflect Idris's idea of what is intended to be@@ -100,7 +102,7 @@   constructors : List (TTName, List CtorArg, Raw)  ||| A reflected elaboration script.-abstract+export data Elab : Type -> Type where   -- obligatory control stuff   Prim__PureElab : a -> Elab a@@ -164,7 +166,7 @@ ------------- -- Public API --------------%access public+%access public export namespace Tactics   implementation Functor Elab where     map f t = Prim__BindElab t (\x => Prim__PureElab (f x))@@ -186,31 +188,38 @@     x >>= f = Prim__BindElab x f    ||| Halt elaboration with an error+  export   fail : List ErrorReportPart -> Elab a   fail err = Prim__Fail err    ||| Look up the lexical binding at the focused hole. Fails if no holes are present.+  export   getEnv : Elab (List (TTName, Binder TT))   getEnv = Prim__Env    ||| Get the name and type of the focused hole. Fails if not holes are present.+  export   getGoal : Elab (TTName, TT)   getGoal = Prim__Goal    ||| Get the hole queue, in order.+  export   getHoles : Elab (List TTName)   getHoles = Prim__Holes    ||| If the current hole contains a guess, return it. Otherwise, fail.+  export   getGuess : Elab TT   getGuess = Prim__Guess    ||| Look up the types of every overloading of a name.+  export   lookupTy :  TTName -> Elab (List (TTName, NameType, TT))   lookupTy n = Prim__LookupTy n    ||| Get the type of a fully-qualified name. Fail if it doesn not   ||| resolve uniquely.+  export   lookupTyExact : TTName -> Elab (TTName, NameType, TT)   lookupTyExact n = case !(lookupTy n) of                       [res] => return res@@ -219,12 +228,14 @@    ||| Find the reflected representation of all datatypes whose names   ||| are overloadings of some name.+  export   lookupDatatype : TTName -> Elab (List Datatype)   lookupDatatype n = Prim__LookupDatatype n    ||| Find the reflected representation of a datatype, given its   ||| fully-qualified name. Fail if the name does not uniquely resolve   ||| to a datatype.+  export   lookupDatatypeExact : TTName -> Elab Datatype   lookupDatatypeExact n = case !(lookupDatatype n) of                             [res] => return res@@ -233,12 +244,14 @@    ||| Find the reflected function definition of all functions whose names   ||| are overloadings of some name.+  export   lookupFunDefn : TTName -> Elab (List (FunDefn TT))   lookupFunDefn n = Prim__LookupFunDefn n    ||| Find the reflected function definition of a function, given its   ||| fully-qualified name. Fail if the name does not uniquely resolve   ||| to a function.+  export   lookupFunDefnExact : TTName -> Elab (FunDefn TT)   lookupFunDefnExact n = case !(lookupFunDefn n) of                            [res] => return res@@ -246,11 +259,13 @@                            xs    => fail [TextPart "More than one function named", NamePart n]    ||| Get the argument specification for each overloading of a name.+  export   lookupArgs : TTName -> Elab (List (TTName, List FunArg, Raw))   lookupArgs n = Prim__LookupArgs n    ||| Get the argument specification for a name. Fail if the name does   ||| not uniquely resolve.+  export   lookupArgsExact : TTName -> Elab (TTName, List FunArg, Raw)   lookupArgsExact n = case !(lookupArgs n) of                         [res] => return res@@ -261,6 +276,7 @@   |||   ||| @ env the environment within which to check the type   ||| @ tm the term to check+  export   check : (env : List (TTName, Binder TT)) -> (tm : Raw) -> Elab (TT, TT)   check env tm = Prim__Check env tm @@ -269,15 +285,18 @@   |||   ||| **NB**: the generated name is unique _for this run of the   ||| elaborator_. Do not assume that they are globally unique.+  export   gensym : (hint : String) -> Elab TTName   gensym hint = Prim__Gensym hint    ||| Substitute a guess into a hole.+  export   solve : Elab ()   solve = Prim__Solve    ||| Place a term into a hole, unifying its type. Fails if the focus   ||| is not a hole.+  export   fill : Raw -> Elab ()   fill tm = Prim__Fill tm @@ -295,6 +314,7 @@   ||| @ argSpec instructions for finding the arguments to the term,   |||     where the Boolean states whether or not to attempt to solve   |||     the argument by unification.+  export   apply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)   apply tm argSpec = map snd <$> Prim__Apply tm argSpec @@ -313,6 +333,7 @@   |||     where the Boolean states whether or not to attempt to solve   |||     the argument by matching. +  export   matchApply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)   matchApply tm argSpec = map snd <$> Prim__Apply tm argSpec @@ -320,11 +341,13 @@   ||| exist.   |||   ||| @ hole the hole to focus on+  export   focus : (hole : TTName) -> Elab ()   focus hole = Prim__Focus hole    ||| Send the currently-focused hole to the end of the hole queue and   ||| focus on the next hole.+  export   unfocus : TTName -> Elab ()   unfocus hole = Prim__Unfocus hole @@ -336,6 +359,7 @@   ||| binding, or else the scopes of the generated terms won't make   ||| sense. This tactic creates a new hole of the proper form, and   ||| points the old hole at it.+  export   attack : Elab ()   attack = Prim__Attack @@ -344,6 +368,7 @@   ||| The new hole will be focused, and the previously-focused hole   ||| will be immediately after it in the hole queue. Because this   ||| tactic introduces a new binding, you may need to `attack` first.+  export   claim : TTName -> Raw -> Elab ()   claim n ty = Prim__Claim n ty @@ -352,6 +377,7 @@   ||| `attack`).   |||   ||| @ n the name to use for the argument+  export   intro : (n : TTName) -> Elab ()   intro n = Prim__Intro (Just n) @@ -361,6 +387,7 @@   |||   ||| Requires that the hole be immediately under its binder (use   ||| `attack` if it might not be).+  export   intro' : Elab ()   intro' = Prim__Intro Nothing @@ -369,10 +396,12 @@   |||   ||| Requires that the hole be immediately under its binder (use   ||| `attack` if it might not be).+  export   forall : TTName -> Raw -> Elab ()   forall n ty = Prim__Forall n ty    ||| Convert a hole into a pattern variable.+  export   patvar : TTName -> Elab ()   patvar n = Prim__PatVar n @@ -380,6 +409,7 @@   |||   ||| Requires that the hole be immediately under its binder (use   ||| `attack` if it might not be).+  export   patbind : TTName -> Elab ()   patbind n = Prim__PatBind n @@ -391,10 +421,12 @@   ||| @ n the name to let bind   ||| @ ty the type of the term to be let-bound   ||| @ tm the term to be bound+  export   letbind : (n : TTName) -> (ty, tm : Raw) -> Elab ()   letbind n ty tm = Prim__LetBind n ty tm    ||| Normalise the goal.+  export   compute : Elab ()   compute = Prim__Compute @@ -402,12 +434,14 @@   |||   ||| @ env the environment in which to compute (get one of these from `getEnv`)   ||| @ term the term to normalise+  export   normalise : (env : List (TTName, Binder TT)) -> (term : TT) -> Elab TT   normalise env term = Prim__Normalise env term    ||| Reduce a closed term to weak-head normal form   |||   ||| @ term the term to reduce+  export   whnf : (term : TT) -> Elab TT   whnf term = Prim__Whnf term @@ -417,6 +451,7 @@   ||| @ env a lexical environment to compare the terms in (see `getEnv`)   ||| @ term1 the first term to convert   ||| @ term2 the second term to convert+  export   convertsInEnv : (env : List (TTName, Binder TT)) -> (term1, term2 : TT) -> Elab ()   convertsInEnv env term1 term2 = Prim__Converts env term1 term2 @@ -424,14 +459,17 @@   |||   ||| @ term1 the first term to convert   ||| @ term2 the second term to convert+  export   converts : (term1, term2 : TT) -> Elab ()   converts term1 term2 = convertsInEnv !getEnv term1 term2    ||| Find the source context for the elaboration script+  export   getSourceLocation : Elab SourceLocation   getSourceLocation = Prim__SourceLocation    ||| Attempt to solve the current goal with the source code location+  export   sourceLocation : Elab ()   sourceLocation = do loc <- getSourceLocation                       fill (quote loc)@@ -442,6 +480,7 @@   |||   ||| The namespace is represented as a reverse-order list of strings,   ||| just as in the representation of names.+  export   currentNamespace : Elab (List String)   currentNamespace = Prim__Namespace @@ -455,16 +494,19 @@   ||| Because this tactic internally introduces a `let` binding, it   ||| requires that the hole be immediately under its binder (use   ||| `attack` if it might not be).+  export   rewriteWith : Raw -> Elab ()   rewriteWith rule = Prim__Rewrite rule    ||| Add a type declaration to the global context.+  export   declareType : TyDecl -> Elab ()   declareType decl = Prim__DeclareType decl    ||| Define a function in the global context. The function must have   ||| already been declared, either in ordinary Idris code or using   ||| `declareType`.+  export   defineFunction : FunDefn Raw -> Elab ()   defineFunction defun = Prim__DefineFunction defun @@ -472,12 +514,14 @@   |||   ||| @ ifaceName the name of the interface for which an implementation is being registered   ||| @ instName the name of the definition to use in implementation search+  export   addInstance : (ifaceName, instName : TTName) -> Elab ()   addInstance ifaceName instName = Prim__AddInstance ifaceName instName    ||| Determine whether a name denotes an interface.   |||   ||| @ name a name that might denote an interface.+  export   isTCName : (name : TTName) -> Elab Bool   isTCName name = Prim__IsTCName name @@ -485,10 +529,12 @@   |||   ||| @ fn the name of the definition being elaborated (to prevent Idris   ||| from looping)+  export   resolveTC : (fn : TTName) -> Elab ()   resolveTC fn = Prim__ResolveTC fn    ||| Use Idris's internal proof search.+  export   search : Elab ()   search = Prim__Search 100 [] @@ -496,6 +542,7 @@   |||   ||| @ depth the search depth   ||| @ hints additional names to try+  export   search' : (depth : Int) -> (hints : List TTName) -> Elab ()   search' depth hints = Prim__Search depth hints @@ -505,6 +552,7 @@   ||| if the string is not a valid operator.   |||   ||| @ operator the operator string to look up+  export   operatorFixity : (operator : String) -> Elab Fixity   operatorFixity operator = Prim__Fixity operator @@ -512,6 +560,7 @@   |||   ||| This is intended for elaboration script developers, not for   ||| end-users. Use `fail` for final scripts.+  export   debug : Elab a   debug = Prim__Debug [] @@ -522,18 +571,21 @@   ||| end-users. Use `fail` for final scripts.   |||   ||| @ msg the message to display+  export   debugMessage : (msg : List ErrorReportPart) -> Elab a   debugMessage msg = Prim__Debug msg    ||| Create a new top-level metavariable to solve the current hole.   |||   ||| @ name the name for the top-level variable+  export   metavar : (name : TTName) -> Elab ()   metavar name = Prim__Metavar name    ||| Recursively invoke the reflected elaborator with some goal.   |||   ||| The result is the final term and its type.+  export   runElab : Raw -> Elab () -> Elab (TT, TT)   runElab goal script = Prim__RecursiveElab goal script
libs/prelude/Language/Reflection/Errors.idr view
@@ -8,6 +8,8 @@ import Prelude.List import Prelude.Maybe +%access public export+ data Err = Msg String          | InternalMsg String          | CantUnify Bool TT TT Err (List (TTName, TT)) Int@@ -28,7 +30,7 @@          | CantMatch TT          | NoTypeDecl TTName          | NotInjective TT TT TT-         | CantResolve TT+         | CantResolve TT Err          | InvalidTCArg TTName TT          | CantResolveAlts (List TTName)          | NoValidAlts (List TTName)
libs/prelude/Prelude.idr view
@@ -6,7 +6,7 @@ import public Prelude.Algebra import public Prelude.Basics import public Prelude.Bool-import public Prelude.Classes+import public Prelude.Interfaces import public Prelude.Cast import public Prelude.Nat import public Prelude.List@@ -33,7 +33,7 @@ import public Language.Reflection.Elab import public Language.Reflection.Errors -%access public+%access public export %default total  -- Things that can't be elsewhere for import cycle reasons@@ -210,7 +210,7 @@ Enum Char where   toNat c   = toNat (ord c)   fromNat n = chr (fromNat n)-  +   pred c = fromNat (pred (toNat c))  syntax "[" [start] ".." [end] "]"@@ -264,15 +264,15 @@ ------- Some error rewriting  %language ErrorReflection-  + private cast_part : TT -> ErrorReportPart cast_part (P Bound n t) = TextPart "unknown type" cast_part x = TermPart x-  -%error_handler++%error_handler export cast_error : Err -> Maybe (List ErrorReportPart)-cast_error (CantResolve `(Cast ~x ~y))+cast_error (CantResolve `(Cast ~x ~y) _)      = Just [TextPart "Can't cast from",              cast_part x,              TextPart "to",@@ -280,8 +280,8 @@ cast_error _ = Nothing  %error_handler+export num_error : Err -> Maybe (List ErrorReportPart)-num_error (CantResolve `(Num ~x))+num_error (CantResolve `(Num ~x) _)      = Just [TermPart x, TextPart "is not a numeric type"] num_error _ = Nothing-
libs/prelude/Prelude/Algebra.idr view
@@ -4,7 +4,7 @@  infixl 6 <+> -%access public+%access public export  -------------------------------------------------------------------------------- -- A modest interface hierarchy
libs/prelude/Prelude/Applicative.idr view
@@ -4,9 +4,11 @@  import Prelude.Basics import Prelude.Bool-import Prelude.Classes+import Prelude.Interfaces import Prelude.Foldable import Prelude.Functor++%access public export  ---- Applicative functors/Idioms
libs/prelude/Prelude/Basics.idr view
@@ -1,7 +1,9 @@ module Prelude.Basics  import Builtins-       ++%access public export+ Not : Type -> Type Not a = a -> Void @@ -51,9 +53,9 @@    ||| The case where the property holds   ||| @ prf the proof-  Yes : {A : Type} -> (prf : A) -> Dec A+  Yes : (prf : prop) -> Dec prop    ||| The case where the property holding would be a contradiction-  ||| @ contra a demonstration that A would be a contradiction-  No  : {A : Type} -> (contra : A -> Void) -> Dec A+  ||| @ contra a demonstration that prop would be a contradiction+  No  : (contra : prop -> Void) -> Dec prop
libs/prelude/Prelude/Bits.idr view
@@ -6,13 +6,13 @@ import Prelude.Bool import Prelude.Cast import Prelude.Chars-import Prelude.Classes+import Prelude.Interfaces import Prelude.Foldable import Prelude.Nat import Prelude.List import Prelude.Strings -%access public+%access public export %default total  b8ToString : Bits8 -> String
libs/prelude/Prelude/Bool.idr view
@@ -4,6 +4,8 @@  import Prelude.Uninhabited +%access public export+ ||| Boolean Data Type %case data Bool = False | True
libs/prelude/Prelude/Cast.idr view
@@ -3,6 +3,8 @@ import Prelude.Bool import public Builtins +%access public export+ ||| Interface for transforming an instance of a data type to another type. interface Cast from to where     ||| Perform a cast operation.
libs/prelude/Prelude/Chars.idr view
@@ -2,11 +2,13 @@ -- Functions operating over Chars  import Prelude.Bool-import Prelude.Classes+import Prelude.Interfaces import Prelude.List import Prelude.Cast import Builtins +%access public export+ ||| Convert the number to its ASCII equivalent. chr : Int -> Char chr x = if (x >= 0 && x < 0x110000)@@ -74,5 +76,3 @@ ||| Returns true if the character is an octal digit. isOctDigit : Char -> Bool isOctDigit x = (x >= '0' && x <= '7')--
− libs/prelude/Prelude/Classes.idr 
@@ -1,404 +0,0 @@-module Prelude.Classes--import Builtins-import Prelude.Basics-import Prelude.Bool---- Numerical Operator Precedence-infixl 5 ==, /=-infixl 6 <, <=, >, >=-infixl 7 <<, >>-infixl 8 +,--infixl 9 *,/---- ------------------------------------------------------------- [ Boolean Ops ]-intToBool : Int -> Bool-intToBool 0 = False-intToBool x = True--boolOp : (a -> a -> Int) -> a -> a -> Bool-boolOp op x y = intToBool (op x y)---- ---------------------------------------------------------- [ Equality Interface ]-||| The Eq interface defines inequality and equality.-interface Eq ty where-    (==) : ty -> ty -> Bool-    (/=) : ty -> ty -> Bool--    x /= y = not (x == y)-    x == y = not (x /= y)--Eq () where-  () == () = True--Eq Int where-    (==) = boolOp prim__eqInt--Eq Integer where-    (==) = boolOp prim__eqBigInt--Eq Double where-    (==) = boolOp prim__eqFloat--Eq Char where-    (==) = boolOp prim__eqChar--Eq String where-    (==) = boolOp prim__eqString--Eq Ptr where-    (==) = boolOp prim__eqPtr--Eq ManagedPtr where-    (==) = boolOp prim__eqManagedPtr--Eq Bool where-    True  == True  = True-    True  == False = False-    False == True  = False-    False == False = True-    -(Eq a, Eq b) => Eq (a, b) where-  (==) (a, c) (b, d) = (a == b) && (c == d)----- ---------------------------------------------------------- [ Ordering Interface ]-%elim data Ordering = LT | EQ | GT--Eq Ordering where-    LT == LT = True-    EQ == EQ = True-    GT == GT = True-    _  == _  = False--||| Compose two comparisons into the lexicographic product-thenCompare : Ordering -> Lazy Ordering -> Ordering-thenCompare LT y = LT-thenCompare EQ y = y-thenCompare GT y = GT--||| The Ord interface defines comparison operations on ordered data types.-interface Eq ty => Ord ty where-    compare : ty -> ty -> Ordering--    (<) : ty -> ty -> Bool-    (<) x y with (compare x y)-        (<) x y | LT = True-        (<) x y | _  = False--    (>) : ty -> ty -> Bool-    (>) x y with (compare x y)-        (>) x y | GT = True-        (>) x y | _  = False--    (<=) : ty -> ty -> Bool-    (<=) x y = x < y || x == y--    (>=) : ty -> ty -> Bool-    (>=) x y = x > y || x == y--    max : ty -> ty -> ty-    max x y = if x > y then x else y--    min : ty -> ty -> ty-    min x y = if (x < y) then x else y--Ord () where-    compare () () = EQ--Ord Int where-    compare x y = if (x == y) then EQ else-                  if (boolOp prim__sltInt x y) then LT else-                  GT---Ord Integer where-    compare x y = if (x == y) then EQ else-                  if (boolOp prim__sltBigInt x y) then LT else-                  GT---Ord Double where-    compare x y = if (x == y) then EQ else-                  if (boolOp prim__sltFloat x y) then LT else-                  GT---Ord Char where-    compare x y = if (x == y) then EQ else-                  if (boolOp prim__sltChar x y) then LT else-                  GT---Ord String where-    compare x y = if (x == y) then EQ else-                  if (boolOp prim__ltString x y) then LT else-                  GT---Ord Bool where-    compare True True = EQ-    compare False False = EQ-    compare False True = LT-    compare True False = GT---(Ord a, Ord b) => Ord (a, b) where-  compare (xl, xr) (yl, yr) =-    if xl /= yl-      then compare xl yl-      else compare xr yr---- --------------------------------------------------------- [ Numerical Interface ]-||| The Num interface defines basic numerical arithmetic.-interface Num ty where-    (+) : ty -> ty -> ty-    (*) : ty -> ty -> ty-    ||| Conversion from Integer.-    fromInteger : Integer -> ty--Num Integer where-    (+) = prim__addBigInt-    (*) = prim__mulBigInt--    fromInteger = id--Num Int where-    (+) = prim__addInt-    (*) = prim__mulInt--    fromInteger = prim__truncBigInt_Int---Num Double where-    (+) = prim__addFloat-    (*) = prim__mulFloat--    fromInteger = prim__toFloatBigInt--Num Bits8 where-  (+) = prim__addB8-  (*) = prim__mulB8-  fromInteger = prim__truncBigInt_B8--Num Bits16 where-  (+) = prim__addB16-  (*) = prim__mulB16-  fromInteger = prim__truncBigInt_B16--Num Bits32 where-  (+) = prim__addB32-  (*) = prim__mulB32-  fromInteger = prim__truncBigInt_B32--Num Bits64 where-  (+) = prim__addB64-  (*) = prim__mulB64-  fromInteger = prim__truncBigInt_B64---- --------------------------------------------------------- [ Negatable Interface ]-||| The `Neg` interface defines operations on numbers which can be negative.-interface Num ty => Neg ty where-    ||| The underlying of unary minus. `-5` desugars to `negate (fromInteger 5)`.-    negate : ty -> ty-    (-) : ty -> ty -> ty-    ||| Absolute value-    abs : ty -> ty--Neg Integer where-    negate x = prim__subBigInt 0 x-    (-) = prim__subBigInt-    abs x = if x < 0 then -x else x--Neg Int where-    negate x = prim__subInt 0 x-    (-) = prim__subInt-    abs x = if x < (prim__truncBigInt_Int 0) then -x else x--Neg Double where-    negate x = prim__negFloat x-    (-) = prim__subFloat-    abs x = if x < (prim__toFloatBigInt 0) then -x else x---- -------------------------------------------------------------Eq Bits8 where-  x == y = intToBool (prim__eqB8 x y)--Eq Bits16 where-  x == y = intToBool (prim__eqB16 x y)--Eq Bits32 where-  x == y = intToBool (prim__eqB32 x y)--Eq Bits64 where-  x == y = intToBool (prim__eqB64 x y)--Ord Bits8 where-  (<) = boolOp prim__ltB8-  (>) = boolOp prim__gtB8-  (<=) = boolOp prim__lteB8-  (>=) = boolOp prim__gteB8-  compare l r = if l < r then LT-                else if l > r then GT-                     else EQ--Ord Bits16 where-  (<) = boolOp prim__ltB16-  (>) = boolOp prim__gtB16-  (<=) = boolOp prim__lteB16-  (>=) = boolOp prim__gteB16-  compare l r = if l < r then LT-                else if l > r then GT-                     else EQ--Ord Bits32 where-  (<) = boolOp prim__ltB32-  (>) = boolOp prim__gtB32-  (<=) = boolOp prim__lteB32-  (>=) = boolOp prim__gteB32-  compare l r = if l < r then LT-                else if l > r then GT-                     else EQ--Ord Bits64 where-  (<) = boolOp prim__ltB64-  (>) = boolOp prim__gtB64-  (<=) = boolOp prim__lteB64-  (>=) = boolOp prim__gteB64-  compare l r = if l < r then LT-                else if l > r then GT-                     else EQ---- ------------------------------------------------------------- [ Bounded ]--interface Ord b => MinBound b where-  ||| The lower bound for the type-  minBound : b--interface Ord b => MaxBound b where-  ||| The upper bound for the type-  maxBound : b--MinBound Bits8 where-  minBound = 0x0--MaxBound Bits8 where-  maxBound = 0xff--MinBound Bits16 where-  minBound = 0x0--MaxBound Bits16 where-  maxBound = 0xffff--MinBound Bits32 where-  minBound = 0x0--MaxBound Bits32 where-  maxBound = 0xffffffff--MinBound Bits64 where-  minBound = 0x0--MaxBound Bits64 where-  maxBound = 0xffffffffffffffff----- ------------------------------------------------------------- [ Fractionals ]--interface Num ty => Fractional ty where-  (/) : ty -> ty -> ty-  recip : ty -> ty--  recip x = 1 / x--Fractional Double where-  (/) = prim__divFloat---- --------------------------------------------------------------- [ Integrals ]-%default partial--interface Num ty => Integral ty where-   div : ty -> ty -> ty-   mod : ty -> ty -> ty---- ---------------------------------------------------------------- [ Integers ]-divBigInt : Integer -> Integer -> Integer-divBigInt x y = case y == 0 of-  False => prim__sdivBigInt x y--modBigInt : Integer -> Integer -> Integer-modBigInt x y = case y == 0 of-  False => prim__sremBigInt x y--Integral Integer where-  div = divBigInt-  mod = modBigInt---- --------------------------------------------------------------------- [ Int ]--divInt : Int -> Int -> Int-divInt x y = case y == 0 of-  False => prim__sdivInt x y--modInt : Int -> Int -> Int-modInt x y = case y == 0 of-  False => prim__sremInt x y--Integral Int where-  div = divInt-  mod = modInt---- ------------------------------------------------------------------- [ Bits8 ]-divB8 : Bits8 -> Bits8 -> Bits8-divB8 x y = case y == 0 of-  False => prim__sdivB8 x y--modB8 : Bits8 -> Bits8 -> Bits8-modB8 x y = case y == 0 of-  False => prim__sremB8 x y-  -Integral Bits8 where-  div = divB8-  mod = modB8---- ------------------------------------------------------------------ [ Bits16 ]-divB16 : Bits16 -> Bits16 -> Bits16-divB16 x y = case y == 0 of-  False => prim__sdivB16 x y--modB16 : Bits16 -> Bits16 -> Bits16-modB16 x y = case y == 0 of-  False => prim__sremB16 x y--Integral Bits16 where-  div = divB16 -  mod = modB16 ---- ------------------------------------------------------------------ [ Bits32 ]-divB32 : Bits32 -> Bits32 -> Bits32-divB32 x y = case y == 0 of-  False => prim__sdivB32 x y--modB32 : Bits32 -> Bits32 -> Bits32-modB32 x y = case y == 0 of-  False => prim__sremB32 x y--Integral Bits32 where-  div = divB32 -  mod = modB32 ---- ------------------------------------------------------------------ [ Bits64 ]-divB64 : Bits64 -> Bits64 -> Bits64-divB64 x y = case y == 0 of-  False => prim__sdivB64 x y--modB64 : Bits64 -> Bits64 -> Bits64-modB64 x y = case y == 0 of-  False => prim__sremB64 x y--Integral Bits64 where-  div = divB64 -  mod = modB64 --
libs/prelude/Prelude/Doubles.idr view
@@ -1,16 +1,16 @@-module Prelude.Doubles +module Prelude.Doubles  import Builtins-import Prelude.Classes+import Prelude.Interfaces -%access public+%access public export %default total  %include C "math.h" %lib C "m"  pi : Double-pi = 3.14159265358979323846 +pi = 3.14159265358979323846  euler : Double euler = 2.7182818284590452354@@ -59,5 +59,3 @@  ceiling : Double -> Double ceiling x = prim__floatCeil x--
libs/prelude/Prelude/Either.idr view
@@ -4,9 +4,11 @@  import Prelude.Basics import Prelude.Bool-import Prelude.Classes+import Prelude.Interfaces import Prelude.Maybe import Prelude.List++%access public export  ||| A sum type %elim data Either : (a, b : Type) -> Type where
libs/prelude/Prelude/File.idr view
@@ -9,15 +9,15 @@ import Prelude.Cast import Prelude.Bool import Prelude.Basics-import Prelude.Classes+import Prelude.Interfaces import Prelude.Either import Prelude.Show import IO -%access public+%access public export  ||| A file handle-abstract+export data File : Type where   FHandle : (p : Ptr) -> File @@ -39,35 +39,43 @@                   (foreign FFI_C "idris_showerror" (Int -> IO String) err)  getFileError : IO FileError-getFileError = do MkRaw err <- foreign FFI_C "idris_mkFileError" +getFileError = do MkRaw err <- foreign FFI_C "idris_mkFileError"                                     (Ptr -> IO (Raw FileError)) prim__vm                   return err  Show FileError where+  show FileReadError = "File Read Error"+  show FileWriteError = "File Write Error"   show FileNotFound = "File Not Found"   show PermissionDenied = "Permission Denied"   show (GenericFileError errno) = strError errno  ||| Standard input+export stdin : File stdin = FHandle prim__stdin  ||| Standard output+export stdout : File stdout = FHandle prim__stdout  ||| Standard output+export stderr : File stderr = FHandle prim__stderr +private do_ferror : Ptr -> IO Int do_ferror h = foreign FFI_C "fileError" (Ptr -> IO Int) h +export ferror : File -> IO Bool ferror (FHandle h) = do err <- do_ferror h                         return (not (err == 0))  ||| Call the RTS's file opening function+private do_fopen : String -> String -> IO Ptr do_fopen f m    = foreign FFI_C "fileOpen" (String -> String -> IO Ptr) f m@@ -75,6 +83,7 @@ ||| Open a file ||| @ f the filename ||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)+export fopen : (f : String) -> (m : String) -> IO (Either FileError File) fopen f m = do h <- do_fopen f m                if !(nullPtr h)@@ -83,60 +92,83 @@                   else return (Right (FHandle h))  ||| Check whether a file handle is actually a null pointer+export validFile : File -> IO Bool validFile (FHandle h) = do x <- nullPtr h                            return (not x)  ||| Modes for opening files-data Mode = Read | Write | ReadWrite+data Mode = Read | WriteTruncate | Append | ReadWrite | ReadWriteTruncate | ReadAppend +Write : Mode+Write = WriteTruncate+%deprecate Write "Please use WriteTruncate instead."++modeStr : Mode -> String+modeStr Read              = "r"+modeStr WriteTruncate     = "w"+modeStr Append            = "a"+modeStr ReadWrite         = "r+"+modeStr ReadWriteTruncate = "w+"+modeStr ReadAppend        = "a+"+ ||| Open a file ||| @ f the filename-||| @ m the mode; either Read, Write, or ReadWrite+||| @ m the mode; either Read, WriteTruncate, Append, ReadWrite, ReadWriteTruncate, or ReadAppend+export openFile : (f : String) -> (m : Mode) -> IO (Either FileError File)-openFile f m = fopen f (modeStr m) where-  modeStr Read  = "r"-  modeStr Write = "w"-  modeStr ReadWrite = "r+"+openFile f m = fopen f (modeStr m) +||| Open a file using C11 extended modes.+||| @ f the filename+||| @ m the mode; either Read, WriteTruncate, Append, ReadWrite, ReadWriteTruncate, or ReadAppend+export+openFileX : (f : String) -> (m : Mode) -> IO (Either FileError File)+openFileX f m = fopen f $ modeStr m ++ "x"++private do_fclose : Ptr -> IO () do_fclose h = foreign FFI_C "fileClose" (Ptr -> IO ()) h +export closeFile : File -> IO () closeFile (FHandle h) = do_fclose h +private do_fread : Ptr -> IO' l String do_fread h = prim_fread h +export fgetc : File -> IO (Either FileError Char) fgetc (FHandle h) = do let c = cast !(foreign FFI_C "fgetc" (Ptr -> IO Int) h)                        if !(ferror (FHandle h))                           then return (Left FileReadError)                           else return (Right c) +export fflush : File -> IO () fflush (FHandle h) = foreign FFI_C "fflush" (Ptr -> IO ()) h +private do_popen : String -> String -> IO Ptr do_popen f m = foreign FFI_C "do_popen" (String -> String -> IO Ptr) f m +export popen : String -> Mode -> IO (Either FileError File) popen f m = do ptr <- do_popen f (modeStr m)                if !(nullPtr ptr)                   then do err <- getFileError                           return (Left err)                   else return (Right (FHandle ptr))-  where-    modeStr Read  = "r"-    modeStr Write = "w"-    modeStr ReadWrite = "r+" +export pclose : File -> IO () pclose (FHandle h) = foreign FFI_C "pclose" (Ptr -> IO ()) h  -- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String)) --                        prim__vm h +export fread : File -> IO (Either FileError String) fread (FHandle h) = do str <- do_fread h                        if !(ferror (FHandle h))@@ -145,56 +177,65 @@  ||| Read a line from a file ||| @h a file handle which must be open for reading+export fGetLine : (h : File) -> IO (Either FileError String) fGetLine = fread  %deprecate fread "Use fGetLine instead" +private do_fwrite : Ptr -> String -> IO (Either FileError ()) do_fwrite h s = do res <- prim_fwrite h s                    if (res /= 0)                       then do errno <- getErrno-                              if errno == 0 +                              if errno == 0                                  then return (Left FileWriteError)                                  else do err <- getFileError                                          return (Left err)                       else return (Right ()) +export fwrite : File -> String -> IO (Either FileError ()) fwrite (FHandle h) s = do_fwrite h s  ||| Write a line to a file ||| @h a file handle which must be open for writing ||| @str the line to write to the file+export fPutStr : (h : File) -> (str : String) -> IO (Either FileError ()) fPutStr (FHandle h) s = do_fwrite h s +export fPutStrLn : File -> String -> IO (Either FileError ()) fPutStrLn (FHandle h) s = do_fwrite h (s ++ "\n")  %deprecate fwrite "Use fPutStr instead" +private do_feof : Ptr -> IO Int do_feof h = foreign FFI_C "fileEOF" (Ptr -> IO Int) h  ||| Check if a file handle has reached the end+export fEOF : File -> IO Bool fEOF (FHandle h) = do eof <- do_feof h                       return (not (eof == 0))  ||| Check if a file handle has reached the end+export feof : File -> IO Bool feof = fEOF  %deprecate feof "Use fEOF instead" +export fpoll : File -> IO Bool fpoll (FHandle h) = do p <- foreign FFI_C "fpoll" (Ptr -> IO Int) h                        return (p > 0)  ||| Read the contents of a file into a string-partial -- might be reading something infinitely long like /dev/null ... -covering+partial -- might be reading something infinitely long like /dev/null ...+covering export readFile : String -> IO (Either FileError String) readFile fn = do Right h <- openFile fn Read                     | Left err => return (Left err)@@ -212,10 +253,11 @@                    else return (Right contents)  ||| Write a string to a file-writeFile : (filepath : String) -> (contents : String) -> +export+writeFile : (filepath : String) -> (contents : String) ->             IO (Either FileError ()) writeFile fn contents = do-     Right h <- openFile fn Write | Left err => return (Left err)-     Right () <- fPutStr h contents | Left err => return (Left err)+     Right h  <- openFile fn WriteTruncate | Left err => return (Left err)+     Right () <- fPutStr h contents        | Left err => return (Left err)      closeFile h      return (Right ())
libs/prelude/Prelude/Foldable.idr view
@@ -3,15 +3,15 @@ import Builtins import Prelude.Bool import Prelude.Basics-import Prelude.Classes+import Prelude.Interfaces import Prelude.Algebra -%access public+%access public export %default total  interface Foldable (t : Type -> Type) where-  foldr : (elt -> acc -> acc) -> acc -> t elt -> acc-  foldl : (acc -> elt -> acc) -> acc -> t elt -> acc+  foldr : (elem -> acc -> acc) -> acc -> t elem -> acc+  foldl : (acc -> elem -> acc) -> acc -> t elem -> acc   foldl f z t = foldr (flip (.) . flip f) id t z  ||| Combine each element of a structure into a monoid@@ -54,4 +54,3 @@ ||| Multiply together all elements of a structure product : (Foldable t, Num a) => t a -> a product = foldr (*) 1-
libs/prelude/Prelude/Functor.idr view
@@ -2,21 +2,23 @@  import Prelude.Basics +%access public export+ ||| Functors allow a uniform action over a parameterised type. ||| @ f a parameterised type  interface Functor (f : Type -> Type) where     ||| Apply a function across everything of type 'a' in a      ||| parameterised type     ||| @ f the parameterised type-    ||| @ m the function to apply-    map : (m : a -> b) -> f a -> f b+    ||| @ func the function to apply+    map : (func : a -> b) -> f a -> f b  infixl 4 <$>  ||| An infix alias for `map`, applying a function across everything of ||| type 'a' in a parameterised type ||| @ f the parameterised type-||| @ m the function to apply-(<$>) : Functor f => (m : a -> b) -> f a -> f b-m <$> x = map m x+||| @ func the function to apply+(<$>) : Functor f => (func : a -> b) -> f a -> f b+func <$> x = map func x
libs/prelude/Prelude/Interactive.idr view
@@ -1,5 +1,5 @@ ||| Various helper functions for creating simple interactive systems.-||| +||| ||| These are mostly intended for helping with teaching, in that they will allow ||| the easy creation of interactive programs without needing to teach IO ||| or Effects first, but they also capture some common patterns of interactive@@ -10,7 +10,7 @@ import Prelude.List import Prelude.File import Prelude.Bool-import Prelude.Classes+import Prelude.Interfaces import Prelude.Strings import Prelude.Chars import Prelude.Show@@ -21,7 +21,7 @@ import Prelude.Monad import IO -%access public+%access public export  ---- some basic io @@ -115,19 +115,19 @@ ||| @ onEOF the function to run on reaching end of file, returning a String ||| to output partial-processHandle : File -> +processHandle : File ->                 (state : a) ->-                (onRead : a -> String -> (String, a)) -> -                (onEOF : a -> String) -> +                (onRead : a -> String -> (String, a)) ->+                (onEOF : a -> String) ->                 IO ()-processHandle h acc onRead onEOF +processHandle h acc onRead onEOF    = if !(fEOF h)         then putStr (onEOF acc)         else do Right x <- fGetLine h                     | Left err => putStr (onEOF acc)                 let (out, acc') = onRead acc x                 putStr out-                processHandle h acc' onRead onEOF    +                processHandle h acc' onRead onEOF  ||| Process input from the standard input stream, while maintaining a state. ||| @ state the input state@@ -136,34 +136,33 @@ ||| @ onEOI the function to run on reaching end of input, returning a String ||| to output partial-processStdin : (state : a) -> -               (onRead : a -> String -> (String, a)) -> +processStdin : (state : a) ->+               (onRead : a -> String -> (String, a)) ->                (onEOI : a -> String) -> IO () processStdin = processHandle stdin  ||| A basic read-eval-print loop, maintaining a state ||| @ state the input state-||| @ prompt the prompt to show +||| @ prompt the prompt to show ||| @ onInput the function to run on reading input, returning a String to ||| output and a new state. Returns Nothing if the repl should exit partial-replWith : (state : a) -> (prompt : String) -> +replWith : (state : a) -> (prompt : String) ->            (onInput : a -> String -> Maybe (String, a)) -> IO ()-replWith acc prompt fn +replWith acc prompt fn    = do putStr prompt         x <- getLine         case fn acc x of-             Just (out, acc') => do putStr out +             Just (out, acc') => do putStr out                                     replWith acc' prompt fn              Nothing => return ()  ||| A basic read-eval-print loop-||| @ prompt the prompt to show +||| @ prompt the prompt to show ||| @ onInput the function to run on reading input, returning a String to-||| output +||| output partial-repl : (prompt : String) -> +repl : (prompt : String) ->        (onInput : String -> String) -> IO ()-repl prompt fn +repl prompt fn    = replWith () prompt (\x, s => Just (fn s, ()))-
+ libs/prelude/Prelude/Interfaces.idr view
@@ -0,0 +1,404 @@+module Prelude.Interfaces++import Builtins+import Prelude.Basics+import Prelude.Bool++%access public export++-- Numerical Operator Precedence+infixl 5 ==, /=+infixl 6 <, <=, >, >=+infixl 7 <<, >>+infixl 8 +,-+infixl 9 *,/++-- ------------------------------------------------------------- [ Boolean Ops ]+intToBool : Int -> Bool+intToBool 0 = False+intToBool x = True++boolOp : (a -> a -> Int) -> a -> a -> Bool+boolOp op x y = intToBool (op x y)++-- ---------------------------------------------------------- [ Equality Interface ]+||| The Eq interface defines inequality and equality.+interface Eq ty where+    (==) : ty -> ty -> Bool+    (/=) : ty -> ty -> Bool++    x /= y = not (x == y)+    x == y = not (x /= y)++Eq () where+  () == () = True++Eq Int where+    (==) = boolOp prim__eqInt++Eq Integer where+    (==) = boolOp prim__eqBigInt++Eq Double where+    (==) = boolOp prim__eqFloat++Eq Char where+    (==) = boolOp prim__eqChar++Eq String where+    (==) = boolOp prim__eqString++Eq Ptr where+    (==) = boolOp prim__eqPtr++Eq ManagedPtr where+    (==) = boolOp prim__eqManagedPtr++Eq Bool where+    True  == True  = True+    True  == False = False+    False == True  = False+    False == False = True++(Eq a, Eq b) => Eq (a, b) where+  (==) (a, c) (b, d) = (a == b) && (c == d)+++-- ---------------------------------------------------------- [ Ordering Interface ]+%elim data Ordering = LT | EQ | GT++Eq Ordering where+    LT == LT = True+    EQ == EQ = True+    GT == GT = True+    _  == _  = False++||| Compose two comparisons into the lexicographic product+thenCompare : Ordering -> Lazy Ordering -> Ordering+thenCompare LT y = LT+thenCompare EQ y = y+thenCompare GT y = GT++||| The Ord interface defines comparison operations on ordered data types.+interface Eq ty => Ord ty where+    compare : ty -> ty -> Ordering++    (<) : ty -> ty -> Bool+    (<) x y with (compare x y)+        (<) x y | LT = True+        (<) x y | _  = False++    (>) : ty -> ty -> Bool+    (>) x y with (compare x y)+        (>) x y | GT = True+        (>) x y | _  = False++    (<=) : ty -> ty -> Bool+    (<=) x y = x < y || x == y++    (>=) : ty -> ty -> Bool+    (>=) x y = x > y || x == y++    max : ty -> ty -> ty+    max x y = if x > y then x else y++    min : ty -> ty -> ty+    min x y = if (x < y) then x else y++Ord () where+    compare () () = EQ++Ord Int where+    compare x y = if (x == y) then EQ else+                  if (boolOp prim__sltInt x y) then LT else+                  GT+++Ord Integer where+    compare x y = if (x == y) then EQ else+                  if (boolOp prim__sltBigInt x y) then LT else+                  GT+++Ord Double where+    compare x y = if (x == y) then EQ else+                  if (boolOp prim__sltFloat x y) then LT else+                  GT+++Ord Char where+    compare x y = if (x == y) then EQ else+                  if (boolOp prim__sltChar x y) then LT else+                  GT+++Ord String where+    compare x y = if (x == y) then EQ else+                  if (boolOp prim__ltString x y) then LT else+                  GT+++Ord Bool where+    compare True True = EQ+    compare False False = EQ+    compare False True = LT+    compare True False = GT+++(Ord a, Ord b) => Ord (a, b) where+  compare (xl, xr) (yl, yr) =+    if xl /= yl+      then compare xl yl+      else compare xr yr++-- --------------------------------------------------------- [ Numerical Interface ]+||| The Num interface defines basic numerical arithmetic.+interface Num ty where+    (+) : ty -> ty -> ty+    (*) : ty -> ty -> ty+    ||| Conversion from Integer.+    fromInteger : Integer -> ty++Num Integer where+    (+) = prim__addBigInt+    (*) = prim__mulBigInt++    fromInteger = id++Num Int where+    (+) = prim__addInt+    (*) = prim__mulInt++    fromInteger = prim__truncBigInt_Int+++Num Double where+    (+) = prim__addFloat+    (*) = prim__mulFloat++    fromInteger = prim__toFloatBigInt++Num Bits8 where+  (+) = prim__addB8+  (*) = prim__mulB8+  fromInteger = prim__truncBigInt_B8++Num Bits16 where+  (+) = prim__addB16+  (*) = prim__mulB16+  fromInteger = prim__truncBigInt_B16++Num Bits32 where+  (+) = prim__addB32+  (*) = prim__mulB32+  fromInteger = prim__truncBigInt_B32++Num Bits64 where+  (+) = prim__addB64+  (*) = prim__mulB64+  fromInteger = prim__truncBigInt_B64++-- --------------------------------------------------------- [ Negatable Interface ]+||| The `Neg` interface defines operations on numbers which can be negative.+interface Num ty => Neg ty where+    ||| The underlying of unary minus. `-5` desugars to `negate (fromInteger 5)`.+    negate : ty -> ty+    (-) : ty -> ty -> ty+    ||| Absolute value+    abs : ty -> ty++Neg Integer where+    negate x = prim__subBigInt 0 x+    (-) = prim__subBigInt+    abs x = if x < 0 then -x else x++Neg Int where+    negate x = prim__subInt 0 x+    (-) = prim__subInt+    abs x = if x < (prim__truncBigInt_Int 0) then -x else x++Neg Double where+    negate x = prim__negFloat x+    (-) = prim__subFloat+    abs x = if x < (prim__toFloatBigInt 0) then -x else x++-- ------------------------------------------------------------+Eq Bits8 where+  x == y = intToBool (prim__eqB8 x y)++Eq Bits16 where+  x == y = intToBool (prim__eqB16 x y)++Eq Bits32 where+  x == y = intToBool (prim__eqB32 x y)++Eq Bits64 where+  x == y = intToBool (prim__eqB64 x y)++Ord Bits8 where+  (<) = boolOp prim__ltB8+  (>) = boolOp prim__gtB8+  (<=) = boolOp prim__lteB8+  (>=) = boolOp prim__gteB8+  compare l r = if l < r then LT+                else if l > r then GT+                     else EQ++Ord Bits16 where+  (<) = boolOp prim__ltB16+  (>) = boolOp prim__gtB16+  (<=) = boolOp prim__lteB16+  (>=) = boolOp prim__gteB16+  compare l r = if l < r then LT+                else if l > r then GT+                     else EQ++Ord Bits32 where+  (<) = boolOp prim__ltB32+  (>) = boolOp prim__gtB32+  (<=) = boolOp prim__lteB32+  (>=) = boolOp prim__gteB32+  compare l r = if l < r then LT+                else if l > r then GT+                     else EQ++Ord Bits64 where+  (<) = boolOp prim__ltB64+  (>) = boolOp prim__gtB64+  (<=) = boolOp prim__lteB64+  (>=) = boolOp prim__gteB64+  compare l r = if l < r then LT+                else if l > r then GT+                     else EQ++-- ------------------------------------------------------------- [ Bounded ]++interface Ord b => MinBound b where+  ||| The lower bound for the type+  minBound : b++interface Ord b => MaxBound b where+  ||| The upper bound for the type+  maxBound : b++MinBound Bits8 where+  minBound = 0x0++MaxBound Bits8 where+  maxBound = 0xff++MinBound Bits16 where+  minBound = 0x0++MaxBound Bits16 where+  maxBound = 0xffff++MinBound Bits32 where+  minBound = 0x0++MaxBound Bits32 where+  maxBound = 0xffffffff++MinBound Bits64 where+  minBound = 0x0++MaxBound Bits64 where+  maxBound = 0xffffffffffffffff+++-- ------------------------------------------------------------- [ Fractionals ]++interface Num ty => Fractional ty where+  (/) : ty -> ty -> ty+  recip : ty -> ty++  recip x = 1 / x++Fractional Double where+  (/) = prim__divFloat++-- --------------------------------------------------------------- [ Integrals ]+%default partial++interface Num ty => Integral ty where+   div : ty -> ty -> ty+   mod : ty -> ty -> ty++-- ---------------------------------------------------------------- [ Integers ]+divBigInt : Integer -> Integer -> Integer+divBigInt x y = case y == 0 of+  False => prim__sdivBigInt x y++modBigInt : Integer -> Integer -> Integer+modBigInt x y = case y == 0 of+  False => prim__sremBigInt x y++Integral Integer where+  div = divBigInt+  mod = modBigInt++-- --------------------------------------------------------------------- [ Int ]++divInt : Int -> Int -> Int+divInt x y = case y == 0 of+  False => prim__sdivInt x y++modInt : Int -> Int -> Int+modInt x y = case y == 0 of+  False => prim__sremInt x y++Integral Int where+  div = divInt+  mod = modInt++-- ------------------------------------------------------------------- [ Bits8 ]+divB8 : Bits8 -> Bits8 -> Bits8+divB8 x y = case y == 0 of+  False => prim__sdivB8 x y++modB8 : Bits8 -> Bits8 -> Bits8+modB8 x y = case y == 0 of+  False => prim__sremB8 x y++Integral Bits8 where+  div = divB8+  mod = modB8++-- ------------------------------------------------------------------ [ Bits16 ]+divB16 : Bits16 -> Bits16 -> Bits16+divB16 x y = case y == 0 of+  False => prim__sdivB16 x y++modB16 : Bits16 -> Bits16 -> Bits16+modB16 x y = case y == 0 of+  False => prim__sremB16 x y++Integral Bits16 where+  div = divB16+  mod = modB16++-- ------------------------------------------------------------------ [ Bits32 ]+divB32 : Bits32 -> Bits32 -> Bits32+divB32 x y = case y == 0 of+  False => prim__sdivB32 x y++modB32 : Bits32 -> Bits32 -> Bits32+modB32 x y = case y == 0 of+  False => prim__sremB32 x y++Integral Bits32 where+  div = divB32+  mod = modB32++-- ------------------------------------------------------------------ [ Bits64 ]+divB64 : Bits64 -> Bits64 -> Bits64+divB64 x y = case y == 0 of+  False => prim__sdivB64 x y++modB64 : Bits64 -> Bits64 -> Bits64+modB64 x y = case y == 0 of+  False => prim__sremB64 x y++Integral Bits64 where+  div = divB64+  mod = modB64
libs/prelude/Prelude/List.idr view
@@ -5,14 +5,14 @@ import Prelude.Algebra import Prelude.Basics import Prelude.Bool-import Prelude.Classes+import Prelude.Interfaces import Prelude.Foldable import Prelude.Functor import Prelude.Maybe import Prelude.Uninhabited import Prelude.Nat -%access public+%access public export %default total  infix 5 \\@@ -174,7 +174,7 @@ init' (x::xs) =   case xs of     []    => Just []-    y::ys => +    y::ys =>       case init' $ y::ys of         Nothing => Nothing         Just j  => Just $ x :: j@@ -305,7 +305,7 @@ ||| @ z the third list zipWith3 : (f : a -> b -> c -> d) -> (x : List a) -> (y : List b) ->            (z : List c) -> List d-zipWith3 f _       []      (z::zs) = [] +zipWith3 f _       []      (z::zs) = [] zipWith3 f _       (y::ys) []      = [] zipWith3 f []      (y::ys) _       = [] zipWith3 f (x::xs) []      _       = []@@ -761,7 +761,7 @@ mergeBy order []      right   = right mergeBy order left    []      = left mergeBy order (x::xs) (y::ys) =-  if order x y == LT +  if order x y == LT      then x :: mergeBy order xs (y::ys)      else y :: mergeBy order (x::xs) ys @@ -888,4 +888,3 @@ foldlMatchesFoldr : (f : b -> a -> b) -> (q : b) -> (xs : List a) -> foldl f q xs = foldlAsFoldr f q xs foldlMatchesFoldr f q [] = Refl foldlMatchesFoldr f q (x :: xs) = foldlMatchesFoldr f (f q x) xs-
libs/prelude/Prelude/Maybe.idr view
@@ -5,10 +5,10 @@ import Prelude.Basics import Prelude.Bool import Prelude.Cast-import Prelude.Classes+import Prelude.Interfaces import Prelude.Foldable -%access public+%access public export %default total  ||| An optional value. This can be used to represent the possibility of
libs/prelude/Prelude/Monad.idr view
@@ -8,21 +8,29 @@ import Prelude.Basics import IO -%access public+%access public export  infixl 5 >>=  interface Applicative m => Monad (m : Type -> Type) where+    ||| Also called `bind`.     (>>=)  : m a -> ((result : a) -> m b) -> m b -||| Also called `join` or mu-flatten : Monad m => m (m a) -> m a-flatten a = a >>= id+    ||| Also called `flatten` or mu+    join : m (m a) -> m a +    -- default implementations+    (>>=) x f = join (f <$> x)+    join x = x >>= id+ ||| For compatibility with Haskell. Note that monads are **not** free to ||| define `return` and `pure` differently! return : Monad m => a -> m a return = pure++flatten : Monad m => m (m a) -> m a+flatten = join+%deprecate flatten "Please use `join`, which is the standard name."  -- Annoyingly, these need to be here, so that we can use them in other -- Prelude modules other than the top level.
libs/prelude/Prelude/Nat.idr view
@@ -6,10 +6,10 @@ import Prelude.Basics import Prelude.Bool import Prelude.Cast-import Prelude.Classes+import Prelude.Interfaces import Prelude.Uninhabited -%access public+%access public export %default total  ||| Natural numbers: unbounded, unsigned integers which can be pattern@@ -224,9 +224,9 @@  ||| A wrapper for Nat that specifies the semigroup and monad implementations that use (+) record Additive where-  constructor GetAdditive  +  constructor GetAdditive   _ : Nat-  + Semigroup Multiplicative where   (<+>) left right = GetMultiplicative $ left' * right'     where@@ -341,6 +341,7 @@ divCeil : Nat -> Nat -> Nat divCeil x (S y) = divCeilNZ x (S y) SIsNotZ +partial Integral Nat where   div = divNat   mod = modNat@@ -424,7 +425,7 @@ plusCommutative Z        right = rewrite plusZeroRightNeutral right in Refl plusCommutative (S left) right =   let inductiveHypothesis = plusCommutative left right in-    rewrite inductiveHypothesis in +    rewrite inductiveHypothesis in       rewrite plusSuccRightSucc right left in Refl  total plusAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->@@ -450,21 +451,21 @@ plusLeftCancel Z        right right' p = p plusLeftCancel (S left) right right' p =   let inductiveHypothesis = plusLeftCancel left right right' in-    inductiveHypothesis (succInjective _ _ p) +    inductiveHypothesis (succInjective _ _ p)  total plusRightCancel : (left : Nat) -> (left' : Nat) -> (right : Nat) ->   (p : left + right = left' + right) -> left = left' plusRightCancel left left' Z         p = rewrite sym (plusZeroRightNeutral left) in                                          rewrite sym (plusZeroRightNeutral left') in-                                                 p +                                                 p plusRightCancel left left' (S right) p =-  plusRightCancel left left' right -    (succInjective _ _ (rewrite plusSuccRightSucc left right in +  plusRightCancel left left' right+    (succInjective _ _ (rewrite plusSuccRightSucc left right in                         rewrite plusSuccRightSucc left' right in p))  total plusLeftLeftRightZero : (left : Nat) -> (right : Nat) ->   (p : left + right = left) -> right = Z-plusLeftLeftRightZero Z        right p = p +plusLeftLeftRightZero Z        right p = p plusLeftLeftRightZero (S left) right p =   plusLeftLeftRightZero left right (succInjective _ _ p) @@ -481,7 +482,7 @@ multRightSuccPlus Z        right = Refl multRightSuccPlus (S left) right =   let inductiveHypothesis = multRightSuccPlus left right in-    rewrite inductiveHypothesis in +    rewrite inductiveHypothesis in     rewrite plusAssociative left right (mult left right) in     rewrite plusAssociative right left (mult left right) in     rewrite plusCommutative right left in@@ -493,11 +494,11 @@  total multCommutative : (left : Nat) -> (right : Nat) ->   left * right = right * left-multCommutative Z right        = rewrite multZeroRightZero right in Refl +multCommutative Z right        = rewrite multZeroRightZero right in Refl multCommutative (S left) right =   let inductiveHypothesis = multCommutative left right in       rewrite inductiveHypothesis in-      rewrite multRightSuccPlus right left in +      rewrite multRightSuccPlus right left in               Refl  total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->@@ -505,7 +506,7 @@ multDistributesOverPlusRight Z        centre right = Refl multDistributesOverPlusRight (S left) centre right =   let inductiveHypothesis = multDistributesOverPlusRight left centre right in-    rewrite inductiveHypothesis in +    rewrite inductiveHypothesis in     rewrite plusAssociative (plus centre (mult left centre)) right (mult left right) in     rewrite sym (plusAssociative centre (mult left centre) right) in     rewrite plusCommutative (mult left centre) right in@@ -527,7 +528,7 @@ multAssociative Z        centre right = Refl multAssociative (S left) centre right =   let inductiveHypothesis = multAssociative left centre right in-    rewrite inductiveHypothesis in +    rewrite inductiveHypothesis in     rewrite multDistributesOverPlusLeft centre (mult left centre) right in             Refl @@ -619,7 +620,7 @@  total multPowerPowerPlus : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->   (power base exp) * (power base exp') = power base (exp + exp')-multPowerPowerPlus base Z       exp' = +multPowerPowerPlus base Z       exp' =     rewrite sym (plusZeroRightNeutral (power base exp')) in Refl multPowerPowerPlus base (S exp) exp' =   let inductiveHypothesis = multPowerPowerPlus base exp exp' in@@ -651,7 +652,7 @@ powerPowerMultPower base exp Z        = rewrite multZeroRightZero exp in Refl powerPowerMultPower base exp (S exp') =   let inductiveHypothesis = powerPowerMultPower base exp exp' in-    rewrite inductiveHypothesis in +    rewrite inductiveHypothesis in     rewrite multRightSuccPlus exp exp' in     rewrite sym (multPowerPowerPlus base exp (mult exp exp')) in             Refl@@ -664,7 +665,7 @@   minus left (S right) = pred (minus left right) minusSuccPred Z        right = Refl minusSuccPred (S left) Z =-    rewrite minusZeroRight left in Refl +    rewrite minusZeroRight left in Refl minusSuccPred (S left) (S right) =   let inductiveHypothesis = minusSuccPred left right in     rewrite inductiveHypothesis in Refl@@ -782,4 +783,3 @@ total sucMinR : (l : Nat) -> minimum l (S l) = l sucMinR Z = Refl sucMinR (S l) = cong (sucMinR l)-
libs/prelude/Prelude/Pairs.idr view
@@ -2,7 +2,7 @@  import Builtins -%access public+%access public export %default total  swap : (a, b) -> (b, a)@@ -14,7 +14,7 @@   data Exists : (P : a -> Type) -> Type where     Evidence : .(x : a) -> (pf : P x) -> Exists P -  ||| Dependent pair where the second field is erased. +  ||| Dependent pair where the second field is erased.   data Subset : (a : Type) -> (P : a -> Type) -> Type where     Element : (x : a) -> .(pf : P x) -> Subset a P @@ -34,12 +34,20 @@     getProof : (x : Subset a P) -> P (getWitness x)     getProof (Element x pf) = pf -  namespace Sigma-    getWitness : Sigma a P -> a-    getWitness (x ** pf) = x+  namespace DPair+    fst : DPair a P -> a+    fst (x ** pf) = x -    getProof : (x : Sigma a P) -> P (getWitness x)-    getProof (x ** pf) = pf+    snd : (x : DPair a P) -> P (fst x)+    snd (x ** pf) = pf++    getWitness : DPair a P -> a+    getWitness = fst+    %deprecate DPair.getWitness "This is being deprecated in favour of `fst`."++    getProof : (x : DPair a P) -> P (fst x)+    getProof = snd+    %deprecate DPair.getProof "This is being deprecated in favour of `snd`."    -- Polymorphic (class-based) projections have been removed   -- because type-directed name disambiguation works better.
libs/prelude/Prelude/Providers.idr view
@@ -1,11 +1,14 @@ module Prelude.Providers +import Prelude.Basics import Prelude.Functor import Prelude.Applicative import Prelude.Monad +%access public export+ ||| Type providers must build one of these in an IO computation.-public+public export data Provider : (a : Type) -> Type where   ||| Return a term to be spliced in   ||| @ x the term to be spliced (i.e. the proof)
libs/prelude/Prelude/Show.idr view
@@ -7,13 +7,15 @@ import Prelude.Bool import Prelude.Cast import Prelude.Chars-import Prelude.Classes+import Prelude.Interfaces import Prelude.List import Prelude.Maybe import Prelude.Either import Prelude.Nat import Prelude.Strings +%access public export+ %default total  ||| The precedence of an Idris operator or syntactic context.@@ -190,6 +192,5 @@   showPrec d (Left x)  = showCon d "Left" $ showArg x   showPrec d (Right x) = showCon d "Right" $ showArg x -(Show a, {y : a} -> Show (p y)) => Show (Sigma a p) where+(Show a, {y : a} -> Show (p y)) => Show (DPair a p) where     show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"-
libs/prelude/Prelude/Stream.idr view
@@ -9,7 +9,7 @@ import Prelude.Nat import Prelude.List -%access public+%access public export %default total  ||| An infinite stream@@ -62,8 +62,12 @@ index Z     (x::xs) = x index (S k) (x::xs) = index k xs -||| Combine two streams element-wise using a function-zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c+||| Combine two streams element-wise using a function.+|||+||| @ f the function to combine elements with+||| @ xs the first stream of elements+||| @ ys the second stream of elements+zipWith : (f : a -> b -> c) -> (xs : Stream a) -> (ys : Stream b) -> Stream c zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys  ||| Combine three streams by applying a function element-wise along them
libs/prelude/Prelude/Strings.idr view
@@ -8,7 +8,7 @@ import Prelude.Bool import Prelude.Chars import Prelude.Cast-import Prelude.Classes+import Prelude.Interfaces import Prelude.Either import Prelude.Foldable import Prelude.Functor@@ -17,6 +17,8 @@ import Prelude.Monad import Decidable.Equality +%access public export+ partial foldr1 : (a -> a -> a) -> List a -> a foldr1 _ [x] = x@@ -112,7 +114,7 @@ -- we need the 'believe_me' because the operations are primitives strM : (x : String) -> StrM x strM x with (decEq (not (x == "")) True)-  strM x | (Yes p) = really_believe_me $ +  strM x | (Yes p) = really_believe_me $                            StrCons (assert_total (strHead' x p))                                    (assert_total (strTail' x p))   strM x | (No p) = really_believe_me StrNil@@ -364,4 +366,3 @@ nullStr : String -> IO Bool nullStr p = do ok <- foreign FFI_C "isNull" (String -> IO Int) p                return (ok /= 0)-
libs/prelude/Prelude/Traversable.idr view
@@ -7,6 +7,8 @@ import Prelude.Foldable import Prelude.Functor +%access public export+ traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ f = foldr ((*>) . f) (pure ())
libs/prelude/Prelude/Uninhabited.idr view
@@ -5,6 +5,8 @@  import Builtins +%access public export+ ||| A canonical proof that some type is empty interface Uninhabited t where   ||| If I have a t, I've had a contradiction
libs/prelude/prelude.ipkg view
@@ -4,7 +4,7 @@ modules = Builtins, Prelude, IO,            Prelude.Algebra, Prelude.Basics, Prelude.Bool, Prelude.Cast,-          Prelude.Classes, Prelude.Nat, Prelude.List,+          Prelude.Interfaces, Prelude.Nat, Prelude.List,           Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either,           Prelude.Strings, Prelude.Chars, Prelude.Show, Prelude.Functor,           Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,@@ -14,4 +14,3 @@           Language.Reflection, Language.Reflection.Errors, Language.Reflection.Elab,            Decidable.Equality-
libs/pruviloj/Pruviloj/Core.idr view
@@ -5,6 +5,8 @@  import Language.Reflection.Utils +%access public export+ ||| Run something for effects, throwing away the return value ignore : Functor f => f a -> f () ignore x = map (const ()) x
libs/pruviloj/Pruviloj/Derive/DecEq.idr view
@@ -133,7 +133,7 @@ ||| equality. ||| ||| @ fn the name of the function whose type has been declared-abstract partial -- because of mkRhs+export partial -- because of mkRhs deriveDecEq : (fn : TTName) -> Elab () deriveDecEq fn =     do (_, Ref, sig') <- lookupTyExact fn
libs/pruviloj/Pruviloj/Derive/Eliminators.idr view
@@ -248,7 +248,7 @@   in traverse (\(i, con) => getElimClause info elimn methodCount con i)               (enumerate ctors) -abstract+export deriveElim : (tyn, elimn : TTName) -> Elab () deriveElim tyn elimn =   do -- Begin with some basic sanity checking: the type name uniquely
libs/pruviloj/Pruviloj/Disjoint.idr view
@@ -67,7 +67,7 @@  ||| Solve a goal of the form `(C1 x1 x2 ... xn = C2 x1 x2 ... xn) -> ||| Void` for disjoint constructors `C1` and `C2`.-public covering+public export covering disjoint : Elab () disjoint =   do compute
libs/pruviloj/Pruviloj/Induction.idr view
@@ -125,7 +125,7 @@  ||| Perform induction on some expression to solve the current ||| goal. Return a list of new holes to be solved.-public+public export induction : Raw -> Elab (List TTName) induction subj =     do g <- goalType
libs/pruviloj/Pruviloj/Injective.idr view
@@ -92,7 +92,7 @@ ||| ||| @ tm the equality to exploit injectivity on ||| @ n the name at which to bind the result-covering public+covering public export injective : (tm : Raw) -> (n : TTName) -> Elab () injective tm n =   do (_, ty) <- check !getEnv tm
libs/pruviloj/Pruviloj/Internals.idr view
@@ -7,6 +7,8 @@  import Data.Vect +%access public export+ ||| Get the name of a reflected type constructor argument. tyConArgName : TyConArg -> TTName tyConArgName (TyConParameter a) = name a
libs/pruviloj/Pruviloj/Internals/TyConInfo.idr view
@@ -6,7 +6,7 @@  import Language.Reflection.Utils -+%access public export  ||| A representation of a type constructor in which all argument names ||| are made unique and they are separated into params and then
libs/pruviloj/Pruviloj/Renamers.idr view
@@ -2,6 +2,8 @@  import Language.Reflection.Utils +%access public export+ ||| A renamer keeps track of names to be substituted Renamer : Type Renamer = TTName -> Maybe TTName
rts/idris_bitstring.c view
@@ -822,3 +822,38 @@     return cl; } +VAL idris_peekB8(VM* vm, VAL ptr, VAL offset) {+    return MKB8(vm, *(uint8_t*)(GETPTR(ptr) + GETINT(offset)));+}++VAL idris_pokeB8(VAL ptr, VAL offset, VAL data) {+    *(uint8_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS8(data);+    return MKINT(0);+}++VAL idris_peekB16(VM* vm, VAL ptr, VAL offset) {+    return MKB16(vm, *(uint16_t*)(GETPTR(ptr) + GETINT(offset)));+}++VAL idris_pokeB16(VAL ptr, VAL offset, VAL data) {+    *(uint16_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS16(data);+    return MKINT(0);+}++VAL idris_peekB32(VM* vm, VAL ptr, VAL offset) {+    return MKB32(vm, *(uint32_t*)(GETPTR(ptr) + GETINT(offset)));+}++VAL idris_pokeB32(VAL ptr, VAL offset, VAL data) {+    *(uint32_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS32(data);+    return MKINT(0);+}++VAL idris_peekB64(VM* vm, VAL ptr, VAL offset) {+    return MKB64(vm, *(uint64_t*)(GETPTR(ptr) + GETINT(offset)));+}++VAL idris_pokeB64(VAL ptr, VAL offset, VAL data) {+    *(uint64_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS64(data);+    return MKINT(0);+}
rts/idris_bitstring.h view
@@ -126,4 +126,14 @@ VAL idris_b64T16(VM *vm, VAL a); VAL idris_b64T32(VM *vm, VAL a); +// memory access+VAL idris_peekB8(VM* vm, VAL ptr, VAL offset);+VAL idris_pokeB8(VAL ptr, VAL offset, VAL data);+VAL idris_peekB16(VM* vm, VAL ptr, VAL offset);+VAL idris_pokeB16(VAL ptr, VAL offset, VAL data);+VAL idris_peekB32(VM* vm, VAL ptr, VAL offset);+VAL idris_pokeB32(VAL ptr, VAL offset, VAL data);+VAL idris_peekB64(VM* vm, VAL ptr, VAL offset);+VAL idris_pokeB64(VAL ptr, VAL offset, VAL data);+ #endif
rts/idris_gmp.c view
@@ -488,3 +488,16 @@     return MKSTR(vm, str); } +// Get 64 bits out of a big int with special handling+// for systems that have 32-bit longs which needs two limbs to+// fill that.+uint64_t idris_truncBigB64(const mpz_t bi) {+    if (sizeof(mp_limb_t) == 8) {+        return mpz_get_ui(bi);+    }+    int64_t out = mpz_get_ui(bi);+    if (bi->_mp_size > 1 ) {+        out |= (uint64_t)bi->_mp_d[1] << 32;+    }+    return out;+}
rts/idris_gmp.h view
@@ -43,6 +43,8 @@ VAL idris_bigShiftLeft(VM* vm, VAL x, VAL y); VAL idris_bigShiftRight(VM* vm, VAL x, VAL y); +uint64_t idris_truncBigB64(const mpz_t bi);+ #define GETMPZ(x) *((mpz_t*)((x)->info.ptr))  #endif
rts/idris_rts.c view
@@ -78,6 +78,14 @@     return vm; } +VM* get_vm(void) {+#ifdef HAS_PTHREAD+    return pthread_getspecific(vm_key);+#else+    return global_vm;+#endif+}+ void close_vm(VM* vm) {     terminate(vm); }@@ -113,7 +121,7 @@     pthread_mutex_destroy(&(vm -> inbox_block));     pthread_cond_destroy(&(vm -> inbox_waiting)); #endif-    // free(vm); +    // free(vm);     // Set the VM as inactive, so that if any message gets sent to it     // it will not get there, rather than crash the entire system.     // (TODO: We really need to be cleverer than this if we're going to@@ -414,6 +422,18 @@     *(((uint8_t*)ptr) + offset) = data; } ++VAL idris_peekPtr(VM* vm, VAL ptr, VAL offset) {+    void** addr = GETPTR(ptr) + GETINT(offset);+    return MKPTR(vm, *addr);+}++VAL idris_pokePtr(VAL ptr, VAL offset, VAL data) {+    void** addr = GETPTR(ptr) + GETINT(offset);+    *addr = GETPTR(data);+    return MKINT(0);+}+ void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {     memmove(dest + dest_offset, src + src_offset, size); }@@ -789,12 +809,12 @@     }      pthread_mutex_lock(&(dest->inbox_lock));-    +     if (dest->inbox_write >= dest->inbox_end) {         // FIXME: This is obviously bad in the long run. This should         // either block, make the inbox bigger, or return an error code,         // or possibly make it user configurable-        fprintf(stderr, "Inbox full"); +        fprintf(stderr, "Inbox full");         exit(-1);     } @@ -820,7 +840,7 @@  VM* idris_checkMessagesFrom(VM* vm, 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;@@ -854,7 +874,7 @@  Msg* idris_getMessageFrom(VM* vm, VM* sender) {     Msg* msg;-    +     for (msg = vm->inbox; msg < vm->inbox_write; ++msg) {         if (sender == NULL || msg->sender == sender) {             return msg;
rts/idris_rts.h view
@@ -115,6 +115,9 @@ // Create a new VM VM* init_vm(int stack_size, size_t heap_size,             int max_threads);++// Get the VM for the current thread+VM* get_vm(void); // Initialise thread-local data for this VM void init_threaddata(VM *vm); // Clean up a VM once it's no longer needed@@ -304,9 +307,12 @@  // Raw memory manipulation void idris_memset(void* ptr, i_int offset, uint8_t c, i_int size);+void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size); uint8_t idris_peek(void* ptr, i_int offset); void idris_poke(void* ptr, i_int offset, uint8_t data);-void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size);++VAL idris_peekPtr(VM* vm, VAL ptr, VAL offset);+VAL idris_pokePtr(VAL ptr, VAL offset, VAL data);  // String primitives VAL idris_concat(VM* vm, VAL l, VAL r);
samples/tutorial/interp.idr view
@@ -33,7 +33,7 @@             Expr G c       If  : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a -  interp : Env G -> [static] (e : Expr G t) -> interpTy t+  interp : Env G -> %static (e : Expr G t) -> interpTy t   interp env (Var i)     = lookup i env   interp env (Val x)     = x   interp env (Lam sc)    = \x => interp (x :: env) sc
src/IRTS/CodegenC.hs view
@@ -13,7 +13,7 @@ import Numeric import Data.Char import Data.Bits-import Data.List (intercalate)+import Data.List (intercalate, nubBy) import System.Process import System.Exit import System.IO@@ -48,19 +48,20 @@              [String] -> -- extra object files              [String] -> -- extra compiler flags (libraries)              [String] -> -- extra compiler flags (anything)-             [ExportIFace] -> +             [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+         let wrappers = genWrappers bc          let h = concatMap toDecl (map fst bc)          let cc = concatMap (uncurry toC) bc          let hi = concatMap ifaceC (concatMap getExp exports)          d <- getDataDir          mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")-         let cout = headers incs ++ debug dbg ++ h ++ cc +++         let cout = headers incs ++ debug dbg ++ h ++ wrappers ++ cc ++                      (if (exec == Executable) then mprog else hi)          case exec of            MavenProject -> putStrLn ("FAILURE: output type not supported")@@ -81,10 +82,10 @@                          "-I."] ++ objs ++ envFlags ++                         (if (exec == Executable) then [] else ["-c"]) ++                         [tmpn] ++-                        (if not iface then concatMap words libFlags else []) ++-                        concatMap words incFlags ++-                        (if not iface then concatMap words libs else []) ++-                        concatMap words flags +++                        (if not iface then libFlags else []) +++                        incFlags +++                        (if not iface then libs else []) +++                        flags ++                         ["-o", out] --              putStrLn (show args)              exit <- rawSystem comp args@@ -153,7 +154,7 @@                       headHex h (length bytes) : map toHex bytes       where         split acc 0 = acc-        split acc x = let xbits = x .&. 0x3f +        split acc x = let xbits = x .&. 0x3f                           xrest = shiftR x 6 in                           split (xbits : acc) xrest @@ -185,7 +186,7 @@     -- if it's a type constant, we won't use it, but equally it shouldn't     -- report an error. These might creep into generated for various reasons     -- (especially if erasure is disabled).-    mkConst c | isTypeConst c = "MKINT(42424242)" +    mkConst c | isTypeConst c = "MKINT(42424242)"     mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"  bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"@@ -317,18 +318,29 @@ bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n" bcc i STOREOLD = indent i ++ "STOREOLD;\n" bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"+bcc i (FOREIGNCALL l rty (FStr fn@('&':name)) [])+      = indent i +++        c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"+bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%wrapper"+      = indent i +++        c_irts (toFType rty) (creg l ++ " = ")+            ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"+bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%dynamic"+      = indent i ++ c_irts (toFType rty) (creg l ++ " = ")+            ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" +++             "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n" bcc i (FOREIGNCALL l rty (FStr fn) args)       = indent i ++         c_irts (toFType rty) (creg l ++ " = ")                    (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"-    where fcall (t, arg) = irts_c (toFType t) (creg arg) bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n" -- bcc i c = error (show c) -- indent i ++ "// not done yet\n" +fcall (t, arg) = irts_c (toFType t) (creg arg) -- Deconstruct the Foreign type in the defunctionalised expression and build -- a foreign type description for c_irts and irts_c-toAType (FCon i) +toAType (FCon i)     | i == sUN "C_IntChar" = ATInt ITChar     | i == sUN "C_IntNative" = ATInt ITNative     | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)@@ -337,18 +349,26 @@     | i == sUN "C_IntBits64" = ATInt (ITFixed IT64) toAType t = error (show t ++ " not defined in toAType") -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)-toFType (FApp c [_]) +    | c == sUN "C_FnT" = toFunType ity+toFType (FApp c [_])     | c == sUN "C_Any" = FAny toFType t = FAny +toFunType (FApp c [_,ity])+    | c == sUN "C_FnBase" = FFunction+    | c == sUN "C_FnIO" = FFunctionIO+toFunType (FApp c [_,_,_,ity])+    | c == sUN "C_Fn" = toFunType ity+toFunType _ = FAny+ c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))" c_irts (FArith (ATInt ITChar))  l x = c_irts (FArith (ATInt ITNative)) l x c_irts (FArith (ATInt (ITFixed ity))) l x@@ -359,6 +379,8 @@ c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")" c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")" c_irts FAny l x = l ++ x+c_irts FFunction l x = error "Return of function from foreign call is not supported"+c_irts FFunctionIO l x = error "Return of function from foreign call is not supported"  irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")" irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x@@ -370,7 +392,15 @@ irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")" irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")" irts_c FAny x = x+irts_c FFunctionIO x = wrapped x+irts_c FFunction x = wrapped x +cFnSig name rty [] = ctype rty ++ " (*" ++ name ++ ")(void) "+cFnSig name rty args = ctype rty ++ " (*" ++ name ++ ")("+        ++ showSep "," (map (ctype . fst) args) ++ ") "++wrapped x = "_idris_get_wrapper(" ++ x ++ ")"+ bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"  bitCoerce v op input output arg@@ -527,6 +557,8 @@     = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")" doOp v (LTrunc (ITFixed from) ITChar) [x]     = doOp v (LTrunc (ITFixed from) ITNative) [x]+doOp v (LTrunc ITBig (ITFixed IT64)) [x]+    = v ++ "idris_b64const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : idris_truncBigB64(GETMPZ(" ++ creg x ++ ")))" doOp v (LTrunc ITBig (ITFixed to)) [x]     = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))" doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]@@ -551,7 +583,7 @@ doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"  doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"-doOp v LWriteStr [_,s] +doOp v LWriteStr [_,s]              = v ++ "MKINT((i_int)(idris_writeStr(stdout"                  ++ ",GETSTR("                  ++ creg s ++ "))))"@@ -577,10 +609,10 @@ doOp v LNoOp args = v ++ creg (last args)  -- Pointer primitives (declared as %extern in Builtins.idr)-doOp v (LExternal rf) [_,x] +doOp v (LExternal rf) [_,x]    | rf == sUN "prim__readFile"        = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"-doOp v (LExternal wf) [_,x,s] +doOp v (LExternal wf) [_,x,s]    | wf == sUN "prim__writeFile"        = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x                               ++ "),GETSTR("@@ -591,15 +623,38 @@ doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"  doOp v (LExternal nul) [] | nul == sUN "prim__null" = v ++ "MKPTR(vm, NULL)"-doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqPtr" +doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqPtr"     = v ++ "MKINT((i_int)(GETPTR(" ++ creg x ++ ") == GETPTR(" ++ creg y ++ ")))"-doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqManagedPtr" +doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqManagedPtr"     = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))" doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"     = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ "), GETINT(" ++ creg i ++ "))"-+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek8"+    = v ++ "idris_peekB8(vm," ++ creg p ++ "," ++ creg o ++")"+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke8"+    = v ++ "idris_pokeB8(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek16"+    = v ++ "idris_peekB16(vm," ++ creg p ++ "," ++ creg o ++")"+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke16"+    = v ++ "idris_pokeB16(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek32"+    = v ++ "idris_peekB32(vm," ++ creg p ++ "," ++ creg o ++")"+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke32"+    = v ++ "idris_pokeB32(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek64"+    = v ++ "idris_peekB64(vm," ++ creg p ++ "," ++ creg o ++")"+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke64"+    = v ++ "idris_pokeB64(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekPtr"+    = v ++ "idris_peekPtr(vm," ++ creg p ++ "," ++ creg o ++")"+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokePtr"+    = v ++ "idris_pokePtr(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"+doOp v (LExternal pk) [] | pk == sUN "prim__sizeofPtr"+    = v ++ "MKINT(sizeof(void*))"+doOp v (LExternal mpt) [p] | mpt == sUN "prim__asPtr" = v ++ "MKPTR(vm, GETMPTR("++ creg p ++"))" doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")" + flUnOp :: String -> String -> String flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))" @@ -610,7 +665,7 @@ ifaceC :: Export -> String ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n" ifaceC (ExportFun n cn ret args)-   = ctype ret ++ " " ++ cdesc cn ++ +   = ctype ret ++ " " ++ cdesc cn ++          "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"        ++ mkBody n (zip argNames args) ret ++ "}\n\n"   where showArgs [] = ""@@ -623,7 +678,7 @@                 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++                 push 0 as ++ call n ++ retval t   where push i [] = ""-        push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t) +        push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t)                                       ("TOP(" ++ show i ++ ") = ") n                                    ++ ";\n" ++ push (i + 1) ts @@ -689,7 +744,7 @@ hdr_export :: Export -> String hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n" hdr_export (ExportFun n cn ret args)-   = ctype ret ++ " " ++ cdesc cn ++ +   = ctype ret ++ " " ++ cdesc cn ++          "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"   where showArgs [] = ""         showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++@@ -697,5 +752,112 @@          argNames = zipWith (++) (repeat "arg") (map show [0..]) +------------------ Callback wrapper generation ----------------+-- Generate callback wrappers and a function to select the+-- correct wrapper function to pass.+-- TODO: This is limited to functions that are specified in+-- the foreign call. Otherwise we would have to generate wrappers for all+-- functions with correct arity or do flow analysis+-- to find all possible inputs to the foreign call.+genWrappers :: [(Name, [BC])] -> String+genWrappers bcs = let+                    tags = nubBy (\x y -> snd x == snd y)  $ concatMap (getCallback . snd) bcs+                  in+                    case tags of+                        [] -> ""+                        t -> concatMap genWrapper t ++ genDispatcher t +genDispatcher :: [(FDesc, Int)] -> String+genDispatcher tags = "void* _idris_get_wrapper(VAL con)\n" +++                     "{\n" +++                     indent 1 ++ "switch(TAG(con)) {\n" +++                     concatMap makeSwitch tags +++                     indent 1 ++ "}\n" +++                     indent 1 ++ "fprintf(stderr, \"No wrapper for callback\");\n" +++                     indent 1 ++ "exit(-1);\n" +++                     "}\n\n"+                        where+                            makeSwitch (_, tag) =+                                    indent 1 ++ "case " ++ show tag ++ ":\n" +++                                    indent 2 ++ "return (void*) &" ++ wrapperName tag ++ ";\n" +genWrapper :: (FDesc, Int) -> String+genWrapper (desc, tag) | (toFType desc) == FFunctionIO =+    error $ "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"+genWrapper (desc, tag) =  ret ++ " " ++ wrapperName tag ++ "(" +++                          renderArgs argList ++")\n"  +++                          "{\n" +++                          (if ret /= "void" then indent 1 ++ ret ++ " ret;\n" else "") +++                          indent 1 ++ "VM* vm = get_vm();\n" +++                          indent 1 ++ "if (vm == NULL) {\n" +++                          indent 2 ++ "fprintf(stderr, \"No vm available in callback.\");\n" +++                          indent 2 ++ "exit(-1);\n" +++                          indent 1 ++ "}\n" +++                          indent 1 ++ "INITFRAME;\n" +++                          indent 1 ++ "RESERVE(" ++ show (len + 1) ++ ");\n" +++                          indent 1 ++ "allocCon(REG1, vm, " ++ show tag ++ ",0 , 0);\n" +++                          indent 1 ++ "TOP(0) = REG1;\n" ++++                          push 1 argList +++                          indent 1 ++ "STOREOLD;\n" +++                          indent 1 ++ "BASETOP(0);\n" +++                          indent 1 ++ "ADDTOP(" ++ show (len + 1) ++ ");\n" +++                          indent 1 ++ "CALL(_idris__123_APPLY0_125_);\n" +++                          if ret /= "void"+                            then indent 1 ++ "ret = " ++ irts_c (toFType ft) "RVAL" ++ ";\n"+                                          ++ indent 1 ++ "return ret;\n}\n\n"+                            else "}\n\n"+                    where+                        (ret, ft) = rty desc+                        argList = zip (args desc) [0..]+                        len = length argList+                        renderArgs [] = "void"+                        renderArgs [((s, _), n)] = s ++ " a" ++ (show n)+                        renderArgs (((s, _), n):xs) = s ++ " a" ++ (show n) ++ ", " +++                                    renderArgs xs+                        rty (FApp c [_,ty])+                            | c == sUN "C_FnBase" = (ctype ty, ty)+                            | c == sUN "C_FnIO" = (ctype ty, ty)+                            | c == sUN "C_FnT" = rty ty+                        rty (FApp c [_,_,ty,fn])+                            | c == sUN "C_Fn" = rty fn+                        rty x = ("", x)+                        args (FApp c [_,ty])+                            | c == sUN "C_FnBase" = []+                            | c == sUN "C_FnIO" = []+                            | c == sUN "C_FnT" = args ty+                        args (FApp c [_,_,ty,fn])+                            | toFType ty == FUnit = []+                            | c == sUN "C_Fn" = (ctype ty, ty) : args fn+                        args _ = []+                        push i [] = ""+                        push i (((c, t), n) : ts) = indent 1 ++ c_irts (toFType t)+                                      ("TOP(" ++ show i ++ ") = ") ("a" ++ show n)+                                   ++ ";\n" ++ push (i + 1) ts++wrapperName :: Int -> String+wrapperName tag = "_idris_wrapper_" ++ show tag++getCallback :: [BC] -> [(FDesc, Int)]+getCallback bc = getCallback' (reverse bc)+    where+        getCallback' (x:xs) = case hasCallback x of+                                [] -> getCallback' xs+                                cbs -> case findCons cbs xs of+                                        [] -> error "Idris function couldn't be wrapped."+                                        x -> x+        getCallback' [] = []+        findCons (c:cs) xs = findCon c xs ++ findCons cs xs+        findCons [] _ = []+        findCon c ((MKCON l loc tag args):xs) | snd c == l = [(fst c, tag)]+        findCon c (_:xs) = findCon c xs+        findCon c [] = []++hasCallback :: BC -> [(FDesc, Reg)]+hasCallback (FOREIGNCALL l rty (FStr fn) args) = filter isFn args+    where+        isFn (desc,_) = case toFType desc of+                            FFunction -> True+                            FFunctionIO -> True+                            _ -> False+hasCallback _ = []
src/IRTS/CodegenCommon.hs view
@@ -3,19 +3,9 @@ import Idris.Core.TT import IRTS.Simplified import IRTS.Defunctionalise-import IRTS.Lang -import Control.Exception-import Data.Word-import System.Environment- data DbgLevel = NONE | DEBUG | TRACE deriving Eq data OutputType = Raw | Object | Executable | MavenProject deriving (Eq, Show)--environment :: String -> IO (Maybe String)-environment x = Control.Exception.catch (do e <- getEnv x-                                            return (Just e))-                          (\y-> do return (y::SomeException);  return Nothing)  -- 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
src/IRTS/Compiler.hs view
@@ -462,7 +462,7 @@         = do let l' = toFDesc l              r' <- irTerm 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
src/IRTS/System.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE CPP #-} module IRTS.System(getDataFileName, getDataDir, getTargetDir,getCC,getLibFlags,getIdrisLibDir,-                   getIncFlags, getEnvFlags, getMvn,getExecutablePom, version) where+                   getIncFlags, getEnvFlags, version) where -import Util.System import Data.List.Split  import Control.Applicative ((<$>))@@ -17,28 +16,18 @@ import Paths_idris #endif +overrideDataDirWith :: String -> IO FilePath+overrideDataDirWith envVar = do envValue <- lookupEnv envVar+                                maybe getDataDir return envValue+ getCC :: IO String-getCC = fromMaybe "gcc" <$> environment "IDRIS_CC"+getCC = fromMaybe "gcc" <$> lookupEnv "IDRIS_CC"  getEnvFlags :: IO [String]-getEnvFlags = maybe [] (splitOn " ") <$> environment "IDRIS_CFLAGS"--mvnCommand :: String-#ifdef mingw32_HOST_OS-mvnCommand = "mvn.bat"-#else-mvnCommand = "mvn"-#endif--getMvn :: IO String-getMvn = fromMaybe mvnCommand <$> environment "IDRIS_MVN"--environment :: String -> IO (Maybe String)-environment x = catchIO (Just <$> getEnv x)-                        (\_ -> return Nothing)+getEnvFlags = maybe [] (splitOn " ") <$> lookupEnv "IDRIS_CFLAGS"  getTargetDir :: IO String-getTargetDir = environment "TARGET" >>= maybe getDataDir return+getTargetDir = overrideDataDirWith "TARGET"  #if defined(FREEBSD) || defined(DRAGONFLY) extraLib = ["-L/usr/local/lib"]@@ -56,9 +45,7 @@                  return $ ["-L" ++ (dir </> "rts"),                            "-lidris_rts"] ++ extraLib ++ gmpLib ++ ["-lpthread"] -getIdrisLibDir = do libPath <- environment "IDRIS_LIBRARY_PATH"-                    dir <- maybe getDataDir return libPath-                    return $ addTrailingPathSeparator dir+getIdrisLibDir = addTrailingPathSeparator <$> overrideDataDirWith "IDRIS_LIBRARY_PATH"  #if defined(FREEBSD) || defined(DRAGONFLY) extraInclude = ["-I/usr/local/include"]@@ -67,6 +54,3 @@ #endif getIncFlags = do dir <- getDataDir                  return $ ("-I" ++ dir </> "rts") : extraInclude--getExecutablePom = do dir <- getDataDir-                      return $ dir </> "java" </> "executable_pom.xml"
src/Idris/ASTUtils.hs view
@@ -118,16 +118,13 @@ ist_callgraph :: Name -> Field IState CGInfo ist_callgraph n =       maybe_default CGInfo-        { argsdef = [], calls = [], scg = []-        , argsused = [], usedpos = []+        { calls = [], scg = [], usedpos = []         }     . ctxt_lookup n     . Field idris_callgraph (\v ist -> ist{ idris_callgraph = v }) --- some fields of the CGInfo record cg_usedpos :: Field CGInfo [(Int, [UsageReason])] cg_usedpos = Field usedpos (\v cg -> cg{ usedpos = v })-  -- Commandline flags --------------------
src/Idris/AbsSyntax.hs view
@@ -77,7 +77,7 @@                                                      (\_ -> return Nothing)) $ libs                        case msum handle of                          Nothing -> return (Right $ "Could not load dynamic alternatives \"" ++-                                                    concat (intersperse "," libs) ++ "\"")+                                                    intercalate "," libs ++ "\"")                          Just x -> do putIState $ i { idris_dynamic_libs = x:ls }                                       return (Left x)     where findDyLib :: [DynamicLib] -> String -> Maybe DynamicLib@@ -96,6 +96,33 @@                       put (i { idris_options = opts { opt_autoImport =                                                        fp : opt_autoImport opts } } ) +addDefinedName :: Name -> Idris ()+addDefinedName n = do ist <- getIState+                      putIState $ ist { idris_inmodule = S.insert n (idris_inmodule ist) }++getDefinedNames :: Idris [Name]+getDefinedNames = do ist <- getIState+                     return (S.toList (idris_inmodule ist))++addTT :: Term -> Idris (Maybe Term)+addTT t = do ist <- getIState+             case M.lookup t (idris_ttstats ist) of+                  Nothing -> do let tt' = M.insert t (1, t) (idris_ttstats ist)+                                putIState $ ist { idris_ttstats = tt' }+                                return Nothing+                  Just (i, t') -> do let tt' = M.insert t' (i + 1, t') (idris_ttstats ist)+                                     putIState $ ist { idris_ttstats = tt' }+                                     return (Just t')++dumpTT :: Idris ()+dumpTT = do ist <- get+            let sts = sortBy count (M.toList (idris_ttstats ist))+            mapM_ dump sts+            return ()+  where+    count (_,x) (_,y) = compare y x+    dump (tm, val) = runIO $ putStrLn (show val ++ ": " ++ show tm)+ addHdr :: Codegen -> String -> Idris () addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i } @@ -180,6 +207,11 @@               let ctxt = setAccess n a (tt_ctxt i)               putIState $ i { tt_ctxt = ctxt } +-- | get the accessibility of a name outside this module+getFromHideList :: Name -> Idris (Maybe Accessibility)+getFromHideList n = do i <- getIState+                       return $ lookupCtxtExact n (hide_list i)+ setTotality :: Name -> Totality -> Idris () setTotality n a          = do i <- getIState@@ -203,8 +235,7 @@           findCoercions t (n : ns) =              let ps = case lookupTy n (tt_ctxt i) of                         [ty'] -> case unApply (getRetTy (normalise (tt_ctxt i) [] ty')) of-                                   (t', _) ->-                                      if t == t' then [n] else []+                                   (t', _) -> [n | t == t']                         _ -> [] in                  ps ++ findCoercions t ns @@ -213,6 +244,14 @@    = do i <- getIState         putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) } +addCalls :: Name -> [Name] -> Idris ()+addCalls n calls+   = do i <- getIState+        case lookupCtxtExact n (idris_callgraph i) of+             Nothing -> addToCG n (CGInfo calls [] [])+             Just (CGInfo cs scg used) ->+                addToCG n (CGInfo (nub (calls ++ cs)) scg used)+ addTyInferred :: Name -> Idris () addTyInferred n    = do i <- getIState@@ -228,7 +267,7 @@           findMVApps x y              = do let (fx, argsx) = unApply x                   let (fy, argsy) = unApply y-                  if (not (fx == fy))+                  if (fx /= fy)                      then do                        tryAddMV fx y                        tryAddMV fy x@@ -309,7 +348,7 @@ allNames ns n | n `elem` ns = return [] allNames ns n = do i <- getIState                    case lookupCtxtExact n (idris_callgraph i) of-                      Just ns' -> do more <- mapM (allNames (n:ns)) (map fst (calls ns'))+                      Just ns' -> do more <- mapM (allNames (n:ns)) (calls ns')                                      return (nub (n : concat more))                       _ -> return [n] @@ -341,11 +380,6 @@              [ns] -> ns              _ -> [] --- Issue #1737 in the Issue Tracker.---    https://github.com/idris-lang/Idris-dev/issues/1737-addToCalledG :: Name -> [Name] -> Idris ()-addToCalledG n ns = return () -- TODO- addDeprecated :: Name -> String -> Idris () addDeprecated n reason = do i <- getIState                             putIState $ i { idris_deprecated = addDef n reason (idris_deprecated i) }@@ -439,7 +473,8 @@ addIBC ibc = do i <- getIState; putIState $ i { ibc_write = ibc : ibc_write i }  clearIBC :: Idris ()-clearIBC = do i <- getIState; putIState $ i { ibc_write = [] }+clearIBC = do i <- getIState; putIState $ i { ibc_write = [],+                                              idris_inmodule = S.empty }  resetNameIdx :: Idris () resetNameIdx = do i <- getIState@@ -611,7 +646,7 @@  -- | Save information about a name that is not yet defined addDeferred' :: NameType-             -> [(Name, (Int, Maybe Name, Type, [Name], Bool))]+             -> [(Name, (Int, Maybe Name, Type, [Name], Bool, Bool))]                 -- ^ The Name is the name being made into a metavar,                 -- the Int is the number of vars that are part of a                 -- putative proof context, the Maybe Name is the@@ -620,10 +655,11 @@                 -- allowed              -> Idris () addDeferred' nt ns-  = do mapM_ (\(n, (i, _, t, _, _)) -> updateContext (addTyDecl n nt (tidyNames S.empty t))) ns+  = do mapM_ (\(n, (i, _, t, _, _, _)) -> updateContext (addTyDecl n nt (tidyNames S.empty t))) ns        mapM_ (\(n, _) -> when (not (n `elem` primDefs)) $ addIBC (IBCMetavar n)) ns        i <- getIState-       putIState $ i { idris_metavars = map (\(n, (i, top, _, ns, isTopLevel)) -> (n, (top, i, ns, isTopLevel))) ns +++       putIState $ i { idris_metavars = map (\(n, (i, top, _, ns, isTopLevel, isDefinable)) -> +                                                  (n, (top, i, ns, isTopLevel, isDefinable))) ns ++                                             idris_metavars i }   where         -- 'tidyNames' is to generate user accessible names in case they are@@ -636,9 +672,13 @@                   Bind n' b $ tidyNames (S.insert n' used) sc         tidyNames used b = b -solveDeferred :: Name -> Idris ()-solveDeferred n = do i <- getIState-                     putIState $ i { idris_metavars =+solveDeferred :: FC -> Name -> Idris ()+solveDeferred fc n +    = do i <- getIState+         case lookup n (idris_metavars i) of+              Just (_, _, _, _, False) ->+                   throwError $ At fc $ Msg ("Can't define hole " ++ show n ++ " as it depends on other holes")+              _ -> putIState $ i { idris_metavars =                                        filter (\(n', _) -> n/=n')                                           (idris_metavars i),                                      ibc_write =@@ -738,6 +778,16 @@ logLevel = do i <- getIState               return (opt_logLevel (idris_options i)) +setAutoImpls :: Bool -> Idris ()+setAutoImpls b = do i <- getIState+                    let opts = idris_options i+                    let opt' = opts { opt_autoimpls = b }+                    putIState $ i { idris_options = opt' }++getAutoImpls :: Idris Bool+getAutoImpls = do i <- getIState+                  return (opt_autoimpls (idris_options i))+ setErrContext :: Bool -> Idris () setErrContext t = do i <- getIState                      let opts = idris_options i@@ -1024,7 +1074,7 @@             runIO . hPutStrLn h $ convSExp "log" good n   where     inCat :: [LogCat] -> [LogCat] -> Bool-    inCat cs cats = or $ map (\x -> elem x cats) cs+    inCat cs cats = any (`elem` cats) cs  cmdOptType :: Opt -> Idris Bool cmdOptType x = do i <- getIState@@ -1101,25 +1151,25 @@         | n `nselem` ns = PQuote (Var (dec n))     en 0 (PApp fc (PInferRef fc' hl n) as)         | n `nselem` ns = PApp fc (PInferRef fc' hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))+                           (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))     en 0 (PApp fc (PRef fc' hl n) as)         | n `elem` infs = PApp fc (PInferRef fc' hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))+                           (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))         | n `nselem` ns = PApp fc (PRef fc' hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))+                           (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))     en 0 (PAppBind fc (PRef fc' hl n) as)         | n `elem` infs = PAppBind fc (PInferRef fc' hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))+                           (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))         | n `nselem` ns = PAppBind fc (PRef fc' hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))+                           (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))     en 0 (PRef fc hl n)         | n `elem` infs = PApp fc (PInferRef fc hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps))+                           (map ((pexp . (PRef fc hl)) . fst) ps)         | n `nselem` ns = PApp fc (PRef fc hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps))+                           (map ((pexp . (PRef fc hl)) . fst) ps)     en 0 (PInferRef fc hl n)         | n `nselem` ns = PApp fc (PInferRef fc hl (dec n))-                           (map (pexp . (PRef fc hl)) (map fst ps))+                           (map ((pexp . (PRef fc hl)) . fst) ps)     en 0 (PApp fc f as) = PApp fc (en 0 f) (map (fmap (en 0)) as)     en 0 (PAppBind fc f as) = PAppBind fc (en 0 f) (map (fmap (en 0)) as)     en 0 (PCase fc c os) = PCase fc (en 0 c) (map (pmap (en 0)) os)@@ -1191,7 +1241,7 @@     removeBound lhs ns = ns \\ nub (bnames lhs)      bnames (PRef _ _ n) = [n]-    bnames (PApp _ _ args) = concatMap bnames (map getTm args)+    bnames (PApp _ _ args) = concatMap (bnames . getTm) args     bnames (PPair _ _ _ l r) = bnames l ++ bnames r     bnames (PDPair _ _ _ l Placeholder r) = bnames l ++ bnames r     bnames _ = []@@ -1227,10 +1277,10 @@            (map (expandParamsD rhs ist dec ps ns) decls)            cn            cd-expandParamsD rhs ist dec ps ns (PInstance doc argDocs info f cs n nfc params ty cn decls)+expandParamsD rhs ist dec ps ns (PInstance doc argDocs info f cs acc opts n nfc params ty cn decls)    = PInstance doc argDocs info f            (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs)-           n+           acc opts n            nfc            (map (expandParams dec ps ns []) params)            (expandParams dec ps ns [] ty)@@ -1258,9 +1308,9 @@     pri (PPi _ _ _ x y) = max 5 (max (pri x) (pri y))     pri (PTrue _ _) = 0     pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r))-    pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))-    pri (PAppBind _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))-    pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as)))+    pri (PApp _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))+    pri (PAppBind _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))+    pri (PCase _ f as) = max 1 (max (pri f) (foldr (max . pri . snd) 0 as))     pri (PTyped l r) = pri l     pri (PPair _ _ _ l r) = max 1 (max (pri l) (pri r))     pri (PDPair _ _ _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))@@ -1277,11 +1327,11 @@        let paramnames               = nub $ case lookupCtxtExact n (idris_fninfo ist) of                            Just p -> getNamesFrom 0 (fn_params p) tm ++-                                     concatMap (getParamNames ist) (map snd statics)-                           _ -> concatMap (getParamNames ist) (map snd statics)+                                     concatMap (getParamNames ist . snd) statics+                           _ -> concatMap (getParamNames ist . snd) statics -       let stnames = nub $ concatMap freeArgNames (map snd statics)-       let dnames = (nub $ concatMap freeArgNames (map snd dynamics))+       let stnames = nub $ concatMap (freeArgNames . snd) statics+       let dnames = (nub $ concatMap (freeArgNames . snd) dynamics)                              \\ paramnames        -- also get the arguments which are 'uniquely inferrable' from        -- statics (see sec 4.2 of "Scrapping Your Inefficient Engine")@@ -1290,7 +1340,7 @@                               filter (\x -> not (elem x dnames)) stnames        let stpos = staticList statics' tm        i <- getIState-       when (not (null statics)) $+       unless (null statics) $           logLvl 3 $ "Statics for " ++ show n ++ " " ++ show tm ++ "\n"                         ++ showTmImpls ptm ++ "\n"                         ++ show statics ++ "\n" ++ show dynamics@@ -1376,7 +1426,7 @@              | otherwise = doAdd cs ns t           mkConst c args = PApp fc (PRef fc [] c)-                           (map (\n -> PExp 0 [] (sMN 0 "carg") (PRef fc [] n)) args)+                           (map (PExp 0 [] (sMN 0 "carg") . PRef fc []) args)           getConstraints (PPi (Constraint _ _) _ _ c sc)              = getcapp c ++ getConstraints sc@@ -1395,10 +1445,14 @@ addUsingImpls :: SyntaxInfo -> Name -> FC -> PTerm -> Idris PTerm addUsingImpls syn n fc t    = do ist <- getIState-        let ns = implicitNamesIn (map iname uimpls) ist t+        autoimpl <- getAutoImpls+        let ns_in = implicitNamesIn (map iname uimpls) ist t+        let ns = if autoimpl then ns_in+                    else filter (\n -> n `elem` (map iname uimpls)) ns_in+         let badnames = filter (\n -> not (implicitable n) &&                                      n `notElem` (map iname uimpls)) ns-        when (not (null badnames)) $+        unless (null badnames) $            throwError (At fc (Elaborating "type of " n Nothing                          (NoSuchVariable (head badnames))))         let cs = getArgnames t -- get already bound names@@ -1481,15 +1535,19 @@ implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm implicit' info syn ignore n ptm     = do i <- getIState-         let (tm', impdata) = implicitise syn ignore i ptm-         defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata---          let (tm'', spos) = findStatics i tm'-         putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }-         addIBC (IBCImp n)-         logLvl 5 ("Implicit " ++ show n ++ " " ++ show impdata)---          i <- get---          putIState $ i { idris_statics = addDef n spos (idris_statics i) }-         return tm'+         auto <- getAutoImpls+         if not auto+           then return ptm+           else do+             let (tm', impdata) = implicitise syn ignore i ptm+             defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata+    --          let (tm'', spos) = findStatics i tm'+             putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }+             addIBC (IBCImp n)+             logLvl 5 ("Implicit " ++ show n ++ " " ++ show impdata)+    --          i <- get+    --          putIState $ i { idris_statics = addDef n spos (idris_statics i) }+             return tm'   where     --  Detect unknown names in default arguments and throw error if found.     defaultArgCheck :: [Name] -> [PArg] -> Idris ()@@ -1534,12 +1592,12 @@     -- Find names in argument position in a type, suitable for implicit     -- binding     -- Not the function position, but do everything else...-    implNamesIn uv (PApp fc f args) = concatMap (implNamesIn uv) (map getTm args)+    implNamesIn uv (PApp fc f args) = concatMap (implNamesIn uv . getTm) args     implNamesIn uv t = namesIn uv ist t -    imps top env (PApp _ f as)+    imps top env ty@(PApp _ f as)        = do (decls, ns) <- get-            let isn = concatMap (namesIn uvars ist) (map getTm as)+            let isn = nub (implNamesIn uvars ty)             put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))     imps top env (PPi (Imp l _ _ _) n _ ty sc)         = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]@@ -1823,6 +1881,7 @@      notHidden n = case getAccessibility n of                         Hidden -> False+                        Private -> False                         _ -> True      getAccessibility n
src/Idris/AbsSyntaxTree.hs view
@@ -94,6 +94,7 @@   , opt_printdepth   :: Maybe Int   , opt_evaltypes    :: Bool           -- ^ normalise types in :t   , opt_desugarnats  :: Bool+  , opt_autoimpls    :: Bool   } deriving (Show, Eq)  defaultOpts = IOption { opt_logLevel   = 0@@ -121,6 +122,7 @@                       , opt_printdepth = Just 5000                       , opt_evaltypes  = True                       , opt_desugarnats = False+                      , opt_autoimpls  = True                       }  data PPOption = PPOption {@@ -194,7 +196,6 @@       -- ^ 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_calledgraph :: Ctxt [Name],     idris_docstrings :: Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]),     idris_moduledocs :: Ctxt (Docstring DocTerm),     -- ^ module documentation is saved in a special MN so the context@@ -210,12 +211,14 @@     idris_name :: Int,     idris_lineapps :: [((FilePath, Int), PTerm)],           -- ^ Full application LHS on source line-    idris_metavars :: [(Name, (Maybe Name, Int, [Name], Bool))],+    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 Bool is whether :p is-    -- allowed+    -- 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,@@ -235,7 +238,7 @@     brace_stack :: [Maybe Int],     lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?     idris_parsedSpan :: Maybe FC,-    hide_list :: [(Name, Maybe Accessibility)],+    hide_list :: Ctxt Accessibility,     default_access :: Accessibility,     default_total :: Bool,     ibc_write :: [IBCWrite],@@ -262,7 +265,9 @@     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_deprecated :: Ctxt String, -- ^ Deprecated names and explanation+    idris_inmodule :: S.Set Name, -- ^ Names defined in current module+    idris_ttstats :: M.Map Term (Int, Term)    }  -- Required for parsers library, and therefore trifecta@@ -279,11 +284,10 @@ type SCGEntry = (Name, [Maybe (Int, SizeChange)]) type UsageReason = (Name, Int)  -- fn_name, its_arg_number -data CGInfo = CGInfo { argsdef :: [Name],-                       calls :: [(Name, [[Name]])],+data CGInfo = CGInfo { calls :: [Name],                        scg :: [SCGEntry],-                       argsused :: [Name],-                       usedpos :: [(Int, [UsageReason])] }+                       usedpos :: [(Int, [UsageReason])]+                     }     deriving Show {-! deriving instance Binary CGInfo@@ -348,13 +352,14 @@                    emptyContext emptyContext emptyContext emptyContext                    emptyContext emptyContext emptyContext emptyContext                    emptyContext emptyContext emptyContext emptyContext-                   emptyContext emptyContext+                   emptyContext                    [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] []-                   [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] []+                   [] [] Nothing [] Nothing [] [] Nothing Nothing emptyContext Private False [] Nothing [] []                    (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty                    AutomaticWidth S.empty S.empty [] Nothing Nothing [] [] M.empty [] [] []-                   emptyContext+                   emptyContext S.empty M.empty + -- | 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))@@ -631,14 +636,18 @@ is_scoped (Imp _ _ _ s) = s is_scoped _ = Nothing -impl = Imp [] Dynamic False (Just (Impl False True))-forall_imp = Imp [] Dynamic False (Just (Impl False False))+impl              = Imp [] Dynamic False (Just (Impl False True))++forall_imp        = Imp [] Dynamic False (Just (Impl False False)) forall_constraint = Imp [] Dynamic False (Just (Impl True False))-expl = Exp [] Dynamic False-expl_param = Exp [] Dynamic True-constraint = Constraint [] Static-tacimpl t = TacImp [] Dynamic t +expl              = Exp [] Dynamic False+expl_param        = Exp [] Dynamic True++constraint        = Constraint [] Static++tacimpl t         = TacImp [] Dynamic t+ data FnOpt = Inlinable -- always evaluate when simplifying            | TotalFn | PartialFn | CoveringFn            | Coinductive | AssertTotal@@ -695,7 +704,7 @@               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), 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@@ -717,6 +726,8 @@        [(Name, Docstring (Either Err t))] -- Parameter docs        SyntaxInfo        FC [(Name, t)] -- constraints+       Accessibility+       FnOpts        Name -- class        FC -- precise location of class        [t] -- parameters@@ -756,6 +767,7 @@                  DErrorHandlers Name FC Name FC [(Name, FC)] |                  DLanguage LanguageExt |                  DDeprecate Name String |+                 DAutoImplicits Bool |                  DUsed FC Name Name  -- | A set of instructions for things that need to happen in IState@@ -875,10 +887,10 @@            (map (mapPDeclFC f g) body)            (fmap (\(n, nfc) -> (n, g nfc)) ctor)            ctorDoc-mapPDeclFC f g (PInstance doc paramDocs syn fc constrs cn cnfc params instTy instN body) =+mapPDeclFC f g (PInstance doc paramDocs syn fc constrs cn acc opts cnfc params instTy instN body) =     PInstance doc paramDocs syn (f fc)               (map (\(constrN, constrT) -> (constrN, mapPTermFC f g constrT)) constrs)-              cn (g cnfc) (map (mapPTermFC f g) params)+              cn acc opts (g cnfc) (map (mapPTermFC f g) params)               (mapPTermFC f g instTy)               instN               (map (mapPDeclFC f g) body)@@ -918,7 +930,7 @@ declared (PNamespace _ _ ds) = concatMap declared ds declared (PRecord _ _ _ _ n  _ _ _ _ cn _ _) = n : map fst (maybeToList cn) declared (PClass _ _ _ _ n _ _ _ _ ms cn cd) = n : (map fst (maybeToList cn) ++ concatMap declared ms)-declared (PInstance _ _ _ _ _ _ _ _ _ _ _) = []+declared (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _) = [] declared (PDSL n _) = [n] declared (PSyntax _ _) = [] declared (PMutual _ ds) = concatMap declared ds@@ -927,39 +939,39 @@  -- get the names declared, not counting nested parameter blocks tldeclared :: PDecl -> [Name]-tldeclared (PFix _ _ _) = []-tldeclared (PTy _ _ _ _ _ n _ t) = [n]-tldeclared (PPostulate _ _ _ _ _ _ n t) = [n]-tldeclared (PClauses _ _ n _) = [] -- not a declaration-tldeclared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)+tldeclared (PFix _ _ _)                           = []+tldeclared (PTy _ _ _ _ _ n _ t)                  = [n]+tldeclared (PPostulate _ _ _ _ _ _ n t)           = [n]+tldeclared (PClauses _ _ n _)                     = [] -- not a declaration+tldeclared (PRecord _ _ _ _ n _ _ _ _ cn _ _)     = n : map fst (maybeToList cn) tldeclared (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts    where fstt (_, _, a, _, _, _, _) = a-tldeclared (PParams _ _ ds) = []-tldeclared (PMutual _ ds) = concatMap tldeclared ds-tldeclared (PNamespace _ _ ds) = concatMap tldeclared ds-tldeclared (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap tldeclared ms)-tldeclared (PInstance _ _ _ _ _ _ _ _ _ _ _) = []-tldeclared _ = []+tldeclared (PParams _ _ ds)                       = []+tldeclared (PMutual _ ds)                         = concatMap tldeclared ds+tldeclared (PNamespace _ _ ds)                    = concatMap tldeclared ds+tldeclared (PClass _ _ _ _ n _ _ _ _ ms cn _)     = n : (map fst (maybeToList cn) ++ concatMap tldeclared ms)+tldeclared (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _)    = []+tldeclared _                                      = []  defined :: PDecl -> [Name]-defined (PFix _ _ _) = []-defined (PTy _ _ _ _ _ n _ t) = []-defined (PPostulate _ _ _ _ _ _ n t) = []-defined (PClauses _ _ n _) = [n] -- not a declaration-defined (PCAF _ n _) = [n]-defined (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts+defined (PFix _ _ _)                              = []+defined (PTy _ _ _ _ _ n _ t)                     = []+defined (PPostulate _ _ _ _ _ _ n t)              = []+defined (PClauses _ _ n _)                        = [n] -- not a declaration+defined (PCAF _ n _)                              = [n]+defined (PData _ _ _ _ _ (PDatadecl n _ _ ts))    = n : map fstt ts    where fstt (_, _, a, _, _, _, _) = a-defined (PData _ _ _ _ _ (PLaterdecl n _ _)) = []-defined (PParams _ _ ds) = concatMap defined ds-defined (PNamespace _ _ ds) = concatMap defined ds-defined (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)-defined (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap defined ms)-defined (PInstance _ _ _ _ _ _ _ _ _ _ _) = []-defined (PDSL n _) = [n]-defined (PSyntax _ _) = []-defined (PMutual _ ds) = concatMap defined ds-defined (PDirective _) = []-defined _ = []+defined (PData _ _ _ _ _ (PLaterdecl n _ _))      = []+defined (PParams _ _ ds)                          = concatMap defined ds+defined (PNamespace _ _ ds)                       = concatMap defined ds+defined (PRecord _ _ _ _ n _ _ _ _ cn _ _)        = n : map fst (maybeToList cn)+defined (PClass _ _ _ _ n _ _ _ _ ms cn _)        = n : (map fst (maybeToList cn) ++ concatMap defined ms)+defined (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _)     = []+defined (PDSL n _)                                = [n]+defined (PSyntax _ _)                             = []+defined (PMutual _ ds)                            = concatMap defined ds+defined (PDirective _)                            = []+defined _                                         = []  updateN :: [(Name, Name)] -> Name -> Name updateN ns n | Just n' <- lookup n ns = n'@@ -1040,33 +1052,33 @@ -- general-purpose FCs, and the second transforms those that are used -- for semantic source highlighting, so they can be treated specially. mapPTermFC :: (FC -> FC) -> (FC -> FC) -> PTerm -> PTerm-mapPTermFC f g (PQuote q) = PQuote q-mapPTermFC f g (PRef fc fcs n) = PRef (g fc) (map g fcs) n-mapPTermFC f g (PInferRef fc fcs n) = PInferRef (g fc) (map g fcs) n-mapPTermFC f g (PPatvar fc n) = PPatvar (g fc) n-mapPTermFC f g (PLam fc n fc' t1 t2) = PLam (f fc) n (g fc') (mapPTermFC f g t1) (mapPTermFC f g t2)-mapPTermFC f g (PPi plic n fc t1 t2) = PPi plic n (g fc) (mapPTermFC f g t1) (mapPTermFC f g t2)-mapPTermFC f g (PLet fc n fc' t1 t2 t3) = PLet (f fc) n (g fc') (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)-mapPTermFC f g (PTyped t1 t2) = PTyped (mapPTermFC f g t1) (mapPTermFC f g t2)-mapPTermFC f g (PApp fc t args) = PApp (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)-mapPTermFC f g (PAppImpl t1 impls) = PAppImpl (mapPTermFC f g t1) impls-mapPTermFC f g (PAppBind fc t args) = PAppBind (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)-mapPTermFC f g (PMatchApp fc n) = PMatchApp (f fc) n-mapPTermFC f g (PIfThenElse fc t1 t2 t3) = PIfThenElse (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)-mapPTermFC f g (PCase fc t cases) = PCase (f fc) (mapPTermFC f g t) (map (\(l,r) -> (mapPTermFC f g l, mapPTermFC f g r)) cases)-mapPTermFC f g (PTrue fc info) = PTrue (f fc) info-mapPTermFC f g (PResolveTC fc) =  PResolveTC (f fc)-mapPTermFC f g (PRewrite fc t1 t2 t3) = PRewrite (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (fmap (mapPTermFC f g) t3)-mapPTermFC f g (PPair fc hls info t1 t2) = PPair (f fc) (map g hls) info (mapPTermFC f g t1) (mapPTermFC f g t2)-mapPTermFC f g (PDPair fc hls info t1 t2 t3) = PDPair (f fc) (map g hls) info (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)-mapPTermFC f g (PAs fc n t) = PAs (f fc) n (mapPTermFC f g t)-mapPTermFC f g (PAlternative ns ty ts) = PAlternative ns ty (map (mapPTermFC f g) ts)-mapPTermFC f g (PHidden t) = PHidden (mapPTermFC f g t)-mapPTermFC f g (PType fc) = PType (f fc)-mapPTermFC f g (PUniverse u) = PUniverse u-mapPTermFC f g (PGoal fc t1 n t2) = PGoal (f fc) (mapPTermFC f g t1) n (mapPTermFC f g t2)-mapPTermFC f g (PConstant fc c) = PConstant (f fc) c-mapPTermFC f g Placeholder = Placeholder+mapPTermFC f g (PQuote q)                     = PQuote q+mapPTermFC f g (PRef fc fcs n)                = PRef (g fc) (map g fcs) n+mapPTermFC f g (PInferRef fc fcs n)           = PInferRef (g fc) (map g fcs) n+mapPTermFC f g (PPatvar fc n)                 = PPatvar (g fc) n+mapPTermFC f g (PLam fc n fc' t1 t2)          = PLam (f fc) n (g fc') (mapPTermFC f g t1) (mapPTermFC f g t2)+mapPTermFC f g (PPi plic n fc t1 t2)          = PPi plic n (g fc) (mapPTermFC f g t1) (mapPTermFC f g t2)+mapPTermFC f g (PLet fc n fc' t1 t2 t3)       = PLet (f fc) n (g fc') (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)+mapPTermFC f g (PTyped t1 t2)                 = PTyped (mapPTermFC f g t1) (mapPTermFC f g t2)+mapPTermFC f g (PApp fc t args)               = PApp (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)+mapPTermFC f g (PAppImpl t1 impls)            = PAppImpl (mapPTermFC f g t1) impls+mapPTermFC f g (PAppBind fc t args)           = PAppBind (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)+mapPTermFC f g (PMatchApp fc n)               = PMatchApp (f fc) n+mapPTermFC f g (PIfThenElse fc t1 t2 t3)      = PIfThenElse (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)+mapPTermFC f g (PCase fc t cases)             = PCase (f fc) (mapPTermFC f g t) (map (\(l,r) -> (mapPTermFC f g l, mapPTermFC f g r)) cases)+mapPTermFC f g (PTrue fc info)                = PTrue (f fc) info+mapPTermFC f g (PResolveTC fc)                = PResolveTC (f fc)+mapPTermFC f g (PRewrite fc t1 t2 t3)         = PRewrite (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (fmap (mapPTermFC f g) t3)+mapPTermFC f g (PPair fc hls info t1 t2)      = PPair (f fc) (map g hls) info (mapPTermFC f g t1) (mapPTermFC f g t2)+mapPTermFC f g (PDPair fc hls info t1 t2 t3)  = PDPair (f fc) (map g hls) info (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)+mapPTermFC f g (PAs fc n t)                   = PAs (f fc) n (mapPTermFC f g t)+mapPTermFC f g (PAlternative ns ty ts)        = PAlternative ns ty (map (mapPTermFC f g) ts)+mapPTermFC f g (PHidden t)                    = PHidden (mapPTermFC f g t)+mapPTermFC f g (PType fc)                     = PType (f fc)+mapPTermFC f g (PUniverse u)                  = PUniverse u+mapPTermFC f g (PGoal fc t1 n t2)             = PGoal (f fc) (mapPTermFC f g t1) n (mapPTermFC f g t2)+mapPTermFC f g (PConstant fc c)               = PConstant (f fc) c+mapPTermFC f g Placeholder                    = Placeholder mapPTermFC f g (PDoBlock dos) = PDoBlock (map mapPDoFC dos)   where mapPDoFC (DoExp  fc t) = DoExp (f fc) (mapPTermFC f g t)         mapPDoFC (DoBind fc n nfc t) = DoBind (f fc) n (g nfc) (mapPTermFC f g t)@@ -1074,22 +1086,22 @@           DoBindP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (map (\(l,r)-> (mapPTermFC f g l, mapPTermFC f g r)) alts)         mapPDoFC (DoLet fc n nfc t1 t2) = DoLet (f fc) n (g nfc) (mapPTermFC f g t1) (mapPTermFC f g t2)         mapPDoFC (DoLetP fc t1 t2) = DoLetP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2)-mapPTermFC f g (PIdiom fc t) = PIdiom (f fc) (mapPTermFC f g t)-mapPTermFC f g (PReturn fc) = PReturn (f fc)-mapPTermFC f g (PMetavar fc n) = PMetavar (g fc) n-mapPTermFC f g (PProof tacs) = PProof (map (fmap (mapPTermFC f g)) tacs)-mapPTermFC f g (PTactics tacs) = PTactics (map (fmap (mapPTermFC f g)) tacs)-mapPTermFC f g (PElabError err) = PElabError err-mapPTermFC f g PImpossible = PImpossible-mapPTermFC f g (PCoerced t) = PCoerced (mapPTermFC f g t)-mapPTermFC f g (PDisamb msg t) = PDisamb msg (mapPTermFC f g t)-mapPTermFC f g (PUnifyLog t) = PUnifyLog (mapPTermFC f g t)-mapPTermFC f g (PNoImplicits t) = PNoImplicits (mapPTermFC f g t)-mapPTermFC f g (PQuasiquote t1 t2) = PQuasiquote (mapPTermFC f g t1) (fmap (mapPTermFC f g) t2)-mapPTermFC f g (PUnquote t) = PUnquote (mapPTermFC f g t)-mapPTermFC f g (PRunElab fc tm ns) = PRunElab (f fc) (mapPTermFC f g tm) ns-mapPTermFC f g (PConstSugar fc tm) = PConstSugar (g fc) (mapPTermFC f g tm)-mapPTermFC f g (PQuoteName n x fc) = PQuoteName n x (g fc)+mapPTermFC f g (PIdiom fc t)                  = PIdiom (f fc) (mapPTermFC f g t)+mapPTermFC f g (PReturn fc)                   = PReturn (f fc)+mapPTermFC f g (PMetavar fc n)                = PMetavar (g fc) n+mapPTermFC f g (PProof tacs)                  = PProof (map (fmap (mapPTermFC f g)) tacs)+mapPTermFC f g (PTactics tacs)                = PTactics (map (fmap (mapPTermFC f g)) tacs)+mapPTermFC f g (PElabError err)               = PElabError err+mapPTermFC f g PImpossible                    = PImpossible+mapPTermFC f g (PCoerced t)                   = PCoerced (mapPTermFC f g t)+mapPTermFC f g (PDisamb msg t)                = PDisamb msg (mapPTermFC f g t)+mapPTermFC f g (PUnifyLog t)                  = PUnifyLog (mapPTermFC f g t)+mapPTermFC f g (PNoImplicits t)               = PNoImplicits (mapPTermFC f g t)+mapPTermFC f g (PQuasiquote t1 t2)            = PQuasiquote (mapPTermFC f g t1) (fmap (mapPTermFC f g) t2)+mapPTermFC f g (PUnquote t)                   = PUnquote (mapPTermFC f g t)+mapPTermFC f g (PRunElab fc tm ns)            = PRunElab (f fc) (mapPTermFC f g tm) ns+mapPTermFC f g (PConstSugar fc tm)            = PConstSugar (g fc) (mapPTermFC f g tm)+mapPTermFC f g (PQuoteName n x fc)            = PQuoteName n x (g fc)  {-! dg instance Binary PTerm@@ -1098,28 +1110,27 @@  mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm mapPT f t = f (mpt t) where-  mpt (PLam fc n nfc t s) = PLam fc n nfc (mapPT f t) (mapPT f s)-  mpt (PPi p n nfc t s) = PPi p n nfc (mapPT f t) (mapPT f s)-  mpt (PLet fc n nfc ty v s) = PLet fc n nfc (mapPT f ty) (mapPT f v) (mapPT f s)-  mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s)-                                 (fmap (mapPT f) g)-  mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)-  mpt (PAppBind fc t as) = PAppBind fc (mapPT f t) (map (fmap (mapPT f)) as)-  mpt (PCase fc c os) = PCase fc (mapPT f c) (map (pmap (mapPT f)) os)-  mpt (PIfThenElse fc c t e) = PIfThenElse fc (mapPT f c) (mapPT f t) (mapPT f e)-  mpt (PTyped l r) = PTyped (mapPT f l) (mapPT f r)-  mpt (PPair fc hls p l r) = PPair fc hls p (mapPT f l) (mapPT f r)+  mpt (PLam fc n nfc t s)     = PLam fc n nfc (mapPT f t) (mapPT f s)+  mpt (PPi p n nfc t s)       = PPi p n nfc (mapPT f t) (mapPT f s)+  mpt (PLet fc n nfc ty v s)  = PLet fc n nfc (mapPT f ty) (mapPT f v) (mapPT f s)+  mpt (PRewrite fc t s g)     = PRewrite fc (mapPT f t) (mapPT f s) (fmap (mapPT f) g)+  mpt (PApp fc t as)          = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)+  mpt (PAppBind fc t as)      = PAppBind fc (mapPT f t) (map (fmap (mapPT f)) as)+  mpt (PCase fc c os)         = PCase fc (mapPT f c) (map (pmap (mapPT f)) os)+  mpt (PIfThenElse fc c t e)  = PIfThenElse fc (mapPT f c) (mapPT f t) (mapPT f e)+  mpt (PTyped l r)            = PTyped (mapPT f l) (mapPT f r)+  mpt (PPair fc hls p l r)    = PPair fc hls p (mapPT f l) (mapPT f r)   mpt (PDPair fc hls p l t r) = PDPair fc hls p (mapPT f l) (mapPT f t) (mapPT f r)-  mpt (PAlternative ns a as) = PAlternative ns a (map (mapPT f) as)-  mpt (PHidden t) = PHidden (mapPT f t)-  mpt (PDoBlock ds) = PDoBlock (map (fmap (mapPT f)) ds)-  mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts)-  mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts)-  mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)-  mpt (PDisamb ns tm) = PDisamb ns (mapPT f tm)-  mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm)-  mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc)-  mpt x = x+  mpt (PAlternative ns a as)  = PAlternative ns a (map (mapPT f) as)+  mpt (PHidden t)             = PHidden (mapPT f t)+  mpt (PDoBlock ds)           = PDoBlock (map (fmap (mapPT f)) ds)+  mpt (PProof ts)             = PProof (map (fmap (mapPT f)) ts)+  mpt (PTactics ts)           = PTactics (map (fmap (mapPT f)) ts)+  mpt (PUnifyLog tm)          = PUnifyLog (mapPT f tm)+  mpt (PDisamb ns tm)         = PDisamb ns (mapPT f tm)+  mpt (PNoImplicits tm)       = PNoImplicits (mapPT f tm)+  mpt (PGoal fc r n sc)       = PGoal fc (mapPT f r) n (mapPT f sc)+  mpt x                       = x   data PTactic' t = Intro [Name] | Intros | Focus Name@@ -1160,39 +1171,39 @@ deriving instance NFData PTactic' !-} instance Sized a => Sized (PTactic' a) where-  size (Intro nms) = 1 + size nms-  size Intros = 1-  size (Focus nm) = 1 + size nm-  size (Refine nm bs) = 1 + size nm + length bs-  size (Rewrite t) = 1 + size t-  size (Induction t) = 1 + size t-  size (LetTac nm t) = 1 + size nm + size t-  size (Exact t) = 1 + size t-  size Compute = 1-  size Trivial = 1-  size Solve = 1-  size Attack = 1-  size ProofState = 1-  size ProofTerm = 1-  size Undo = 1-  size (Try l r) = 1 + size l + size r-  size (TSeq l r) = 1 + size l + size r-  size (ApplyTactic t) = 1 + size t-  size (Reflect t) = 1 + size t-  size (Fill t) = 1 + size t-  size Qed = 1-  size Abandon = 1-  size Skip = 1-  size (TFail ts) = 1 + size ts-  size SourceFC = 1-  size DoUnify = 1-  size (CaseTac x) = 1 + size x-  size (Equiv t) = 1 + size t-  size (Claim x y) = 1 + size x + size y-  size Unfocus = 1-  size (MatchRefine x) = 1 + size x+  size (Intro nms)      = 1 + size nms+  size Intros           = 1+  size (Focus nm)       = 1 + size nm+  size (Refine nm bs)   = 1 + size nm + length bs+  size (Rewrite t)      = 1 + size t+  size (Induction t)    = 1 + size t+  size (LetTac nm t)    = 1 + size nm + size t+  size (Exact t)        = 1 + size t+  size Compute          = 1+  size Trivial          = 1+  size Solve            = 1+  size Attack           = 1+  size ProofState       = 1+  size ProofTerm        = 1+  size Undo             = 1+  size (Try l r)        = 1 + size l + size r+  size (TSeq l r)       = 1 + size l + size r+  size (ApplyTactic t)  = 1 + size t+  size (Reflect t)      = 1 + size t+  size (Fill t)         = 1 + size t+  size Qed              = 1+  size Abandon          = 1+  size Skip             = 1+  size (TFail ts)       = 1 + size ts+  size SourceFC         = 1+  size DoUnify          = 1+  size (CaseTac x)      = 1 + size x+  size (Equiv t)        = 1 + size t+  size (Claim x y)      = 1 + size x + size y+  size Unfocus          = 1+  size (MatchRefine x)  = 1 + size x   size (LetTacTy x y z) = 1 + size x + size y + size z-  size TCInstance = 1+  size TCInstance       = 1  type PTactic = PTactic' PTerm @@ -1208,11 +1219,11 @@ !-}  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 (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  type PDo = PDo' PTerm @@ -1244,10 +1255,10 @@     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 (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm+  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 (PTacImplicit p l nm scr trm)  = 1 + size nm + size scr + size trm  {-! deriving instance Binary PArg'@@ -1255,43 +1266,43 @@ !-}  pimp n t mach = PImp 1 mach [] n t-pexp t = PExp 1 [] (sMN 0 "arg") t-pconst t = PConstraint 1 [] (sMN 0 "carg") t+pexp t        = PExp 1 [] (sMN 0 "arg") t+pconst t      = PConstraint 1 [] (sMN 0 "carg") t ptacimp n s t = PTacImplicit 2 [] n s t  type PArg = PArg' PTerm  -- | Get the highest FC in a term, if one exists highestFC :: PTerm -> Maybe FC-highestFC (PQuote _) = Nothing-highestFC (PRef fc _ _) = Just fc-highestFC (PInferRef fc _ _) = Just fc-highestFC (PPatvar fc _) = Just fc-highestFC (PLam fc _ _ _ _) = Just fc-highestFC (PPi _ _ _ _ _) = Nothing-highestFC (PLet fc _ _ _ _ _) = Just fc-highestFC (PTyped tm ty) = highestFC tm <|> highestFC ty-highestFC (PApp fc _ _) = Just fc-highestFC (PAppBind fc _ _) = Just fc-highestFC (PMatchApp fc _) = Just fc-highestFC (PCase fc _ _) = Just fc-highestFC (PIfThenElse fc _ _ _) = Just fc-highestFC (PTrue fc _) = Just fc-highestFC (PResolveTC fc) = Just fc-highestFC (PRewrite fc _ _ _) = Just fc-highestFC (PPair fc _ _ _ _) = Just fc-highestFC (PDPair fc _ _ _ _ _) = Just fc-highestFC (PAs fc _ _) = Just fc+highestFC (PQuote _)              = Nothing+highestFC (PRef fc _ _)           = Just fc+highestFC (PInferRef fc _ _)      = Just fc+highestFC (PPatvar fc _)          = Just fc+highestFC (PLam fc _ _ _ _)       = Just fc+highestFC (PPi _ _ _ _ _)         = Nothing+highestFC (PLet fc _ _ _ _ _)     = Just fc+highestFC (PTyped tm ty)          = highestFC tm <|> highestFC ty+highestFC (PApp fc _ _)           = Just fc+highestFC (PAppBind fc _ _)       = Just fc+highestFC (PMatchApp fc _)        = Just fc+highestFC (PCase fc _ _)          = Just fc+highestFC (PIfThenElse fc _ _ _)  = Just fc+highestFC (PTrue fc _)            = Just fc+highestFC (PResolveTC fc)         = Just fc+highestFC (PRewrite fc _ _ _)     = Just fc+highestFC (PPair fc _ _ _ _)      = Just fc+highestFC (PDPair fc _ _ _ _ _)   = Just fc+highestFC (PAs fc _ _)            = Just fc highestFC (PAlternative _ _ args) =   case mapMaybe highestFC args of     [] -> Nothing     (fc:_) -> Just fc-highestFC (PHidden _) = Nothing-highestFC (PType fc) = Just fc-highestFC (PUniverse _) = Nothing-highestFC (PGoal fc _ _ _) = Just fc-highestFC (PConstant fc _) = Just fc-highestFC Placeholder = Nothing+highestFC (PHidden _)             = Nothing+highestFC (PType fc)              = Just fc+highestFC (PUniverse _)           = Nothing+highestFC (PGoal fc _ _ _)        = Just fc+highestFC (PConstant fc _)        = Just fc+highestFC Placeholder             = Nothing highestFC (PDoBlock lines) =   case map getDoFC lines of     [] -> Nothing@@ -1303,23 +1314,23 @@     getDoFC (DoLet fc nm nfc l r) = fc     getDoFC (DoLetP fc l r)       = fc -highestFC (PIdiom fc _) = Just fc-highestFC (PReturn fc) = Just fc-highestFC (PMetavar fc _) = Just fc-highestFC (PProof _) = Nothing-highestFC (PTactics _) = Nothing-highestFC (PElabError _) = Nothing-highestFC PImpossible = Nothing-highestFC (PCoerced tm) = highestFC tm-highestFC (PDisamb _ opts) = highestFC opts-highestFC (PUnifyLog tm) = highestFC tm-highestFC (PNoImplicits tm) = highestFC tm-highestFC (PQuasiquote _ _) = Nothing-highestFC (PUnquote tm) = highestFC tm-highestFC (PQuoteName _ _ fc) = Just fc-highestFC (PRunElab fc _ _) = Just fc-highestFC (PConstSugar fc _) = Just fc-highestFC (PAppImpl t _) = highestFC t+highestFC (PIdiom fc _)           = Just fc+highestFC (PReturn fc)            = Just fc+highestFC (PMetavar fc _)         = Just fc+highestFC (PProof _)              = Nothing+highestFC (PTactics _)            = Nothing+highestFC (PElabError _)          = Nothing+highestFC PImpossible             = Nothing+highestFC (PCoerced tm)           = highestFC tm+highestFC (PDisamb _ opts)        = highestFC opts+highestFC (PUnifyLog tm)          = highestFC tm+highestFC (PNoImplicits tm)       = highestFC tm+highestFC (PQuasiquote _ _)       = Nothing+highestFC (PUnquote tm)           = highestFC tm+highestFC (PQuoteName _ _ fc)     = Just fc+highestFC (PRunElab fc _ _)       = Just fc+highestFC (PConstSugar fc _)      = Just fc+highestFC (PAppImpl t _)          = highestFC t  -- Type class data @@ -1397,11 +1408,11 @@  syntaxNames :: Syntax -> [Name] syntaxNames (Rule syms _ _) = mapMaybe ename syms-           where ename (Keyword n) = Just n-                 ename _           = Nothing+           where ename (Keyword n)  = Just n+                 ename _            = Nothing syntaxNames (DeclRule syms _) = mapMaybe ename syms-           where ename (Keyword n) = Just n-                 ename _           = Nothing+           where ename (Keyword n)  = Just n+                 ename _            = Nothing  syntaxSymbols :: Syntax -> [SSymbol] syntaxSymbols (Rule ss _ _) = ss@@ -1434,9 +1445,9 @@   where     newRules = sortBy (ruleSort `on` syntaxSymbols) (rules ++ sr) -    ruleSort [] [] = EQ-    ruleSort [] _ = LT-    ruleSort _ [] = GT+    ruleSort [] []  = EQ+    ruleSort [] _   = LT+    ruleSort _ []   = GT     ruleSort (s1:ss1) (s2:ss2) =       case symCompare s1 s2 of         EQ -> ruleSort ss1 ss2@@ -1444,25 +1455,25 @@      -- Better than creating Ord instance for SSymbol since     -- in general this ordering does not really make sense.-    symCompare (Keyword n1) (Keyword n2) = compare n1 n2-    symCompare (Keyword _) _ = LT-    symCompare (Symbol _) (Keyword _) = GT-    symCompare (Symbol s1) (Symbol s2) = compare s1 s2-    symCompare (Symbol _) _ = LT-    symCompare (Binding _) (Keyword _) = GT-    symCompare (Binding _) (Symbol _) = GT-    symCompare (Binding b1) (Binding b2) = compare b1 b2-    symCompare (Binding _) _ = LT-    symCompare (Expr _) (Keyword _) = GT-    symCompare (Expr _) (Symbol _) = GT-    symCompare (Expr _) (Binding _) = GT-    symCompare (Expr e1) (Expr e2) = compare e1 e2-    symCompare (Expr _) _ = LT-    symCompare (SimpleExpr _) (Keyword _) = GT-    symCompare (SimpleExpr _) (Symbol _) = GT-    symCompare (SimpleExpr _) (Binding _) = GT-    symCompare (SimpleExpr _) (Expr _) = GT-    symCompare (SimpleExpr e1) (SimpleExpr e2) = compare e1 e2+    symCompare (Keyword n1) (Keyword n2)        = compare n1 n2+    symCompare (Keyword _) _                    = LT+    symCompare (Symbol _) (Keyword _)           = GT+    symCompare (Symbol s1) (Symbol s2)          = compare s1 s2+    symCompare (Symbol _) _                     = LT+    symCompare (Binding _) (Keyword _)          = GT+    symCompare (Binding _) (Symbol _)           = GT+    symCompare (Binding b1) (Binding b2)        = compare b1 b2+    symCompare (Binding _) _                    = LT+    symCompare (Expr _) (Keyword _)             = GT+    symCompare (Expr _) (Symbol _)              = GT+    symCompare (Expr _) (Binding _)             = GT+    symCompare (Expr e1) (Expr e2)              = compare e1 e2+    symCompare (Expr _) _                       = LT+    symCompare (SimpleExpr _) (Keyword _)       = GT+    symCompare (SimpleExpr _) (Symbol _)        = GT+    symCompare (SimpleExpr _) (Binding _)       = GT+    symCompare (SimpleExpr _) (Expr _)          = GT+    symCompare (SimpleExpr e1) (SimpleExpr e2)  = compare e1 e2  initDSL = DSL (PRef f [] (sUN ">>="))               (PRef f [] (sUN "return"))@@ -1534,10 +1545,10 @@ getInferTerm (App _ (App _ _ _) tm) = tm 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))-        toTy (PVar t) = PVTy t-        toTy b = b+getInferType (Bind n b sc)  = Bind n (toTy b) $ getInferType sc+  where toTy (Lam t)        = Pi Nothing t (TType (UVar 0))+        toTy (PVar t)       = PVTy t+        toTy b              = b getInferType (App _ (App _ _ ty) _) = ty  @@ -1562,9 +1573,9 @@ upairTy    = sNS (sUN "UPair") ["Builtins"] upairCon   = sNS (sUN "MkUPair") ["Builtins"] -eqTy = sUN "="+eqTy  = sUN "=" eqCon = sUN "Refl"-eqDoc =  fmap (const (Left $ Msg "")) . parseDocstring . T.pack $+eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $           "The propositional equality type. A proof that `x` = `y`." ++           "\n\n" ++           "To use such a proof, pattern-match on it, and the two equal things will " ++@@ -1607,8 +1618,8 @@ modDocName = sMN 0 "ModuleDocs"  -- Defined in builtins.idr-sigmaTy   = sNS (sUN "Sigma") ["Builtins"]-sigmaCon = sNS (sUN "MkSigma") ["Builtins"]+sigmaTy   = sNS (sUN "DPair") ["Builtins"]+sigmaCon = sNS (sUN "MkDPair") ["Builtins"]  piBind :: [(Name, PTerm)] -> PTerm -> PTerm piBind = piBindp expl@@ -1648,11 +1659,11 @@     in Just $ if constIsType c                 then typeColour theme                 else dataColour theme-annotationColour ist (AnnData _ _) = Just $ dataColour (idris_colourTheme ist)-annotationColour ist (AnnType _ _) = Just $ typeColour (idris_colourTheme ist)-annotationColour ist (AnnBoundName _ True) = Just $ implicitColour (idris_colourTheme ist)+annotationColour ist (AnnData _ _)          = Just $ dataColour (idris_colourTheme ist)+annotationColour ist (AnnType _ _)          = Just $ typeColour (idris_colourTheme ist)+annotationColour ist (AnnBoundName _ True)  = Just $ implicitColour (idris_colourTheme ist) annotationColour ist (AnnBoundName _ False) = Just $ boundVarColour (idris_colourTheme ist)-annotationColour ist AnnKeyword = Just $ keywordColour (idris_colourTheme ist)+annotationColour ist AnnKeyword             = Just $ keywordColour (idris_colourTheme ist) annotationColour ist (AnnName n _ _ _) =   let ctxt = tt_ctxt ist       theme = idris_colourTheme ist@@ -1738,7 +1749,7 @@          st =           case s of-            Static -> text "[static]" <> space+            Static -> text "%static" <> space             _      -> empty     prettySe d p bnd (PPi (Imp l s _ fa) n _ ty sc)       | ppopt_impl ppo =@@ -1749,12 +1760,12 @@       where         st =           case s of-            Static -> text "[static]" <> space+            Static -> text "%static" <> space             _      -> empty     prettySe d p bnd (PPi (Constraint _ _) n _ ty sc) =       depth d . bracket p startPrec $       prettySe (decD d) (startPrec + 1) bnd ty <+> text "=>" </> prettySe (decD d) startPrec ((n, True):bnd) sc-    prettySe d p bnd (PPi (TacImp _ _ (PTactics [ProofSearch _ _ _ _ _ _])) n _ ty sc) =+    prettySe d p bnd (PPi (TacImp _ _ (PTactics [ProofSearch{}])) n _ ty sc) =       lbrace <> kwd "auto" <+> pretty n <+> colon <+> prettySe (decD d) startPrec bnd ty <>       rbrace <+> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc     prettySe d p bnd (PPi (TacImp _ _ s) n _ ty sc) =@@ -1791,7 +1802,7 @@             [x] -> group (opName True <$> group (prettySe (decD d) startPrec bnd (getTm x)))             [l,r] -> let precedence = maybe (startPrec - 1) prec f                      in depth d . bracket p precedence $ inFix (getTm l) (getTm r)-            (l@(PExp _ _ _ _) : r@(PExp _ _ _ _) : rest) ->+            (l@(PExp{}) : r@(PExp{}) : rest) ->                    depth d . bracket p funcAppPrec $                           enclose lparen rparen (inFix (getTm l) (getTm r)) <+>                           align (group (vsep (map (prettyArgS d bnd) rest)))@@ -1842,20 +1853,20 @@         -- disambiguation on PDPair.         vars tm = filter noNS (allNamesIn tm)         noNS (NS _ _) = False-        noNS _ = True+        noNS _        = True      prettySe d p bnd (PIfThenElse _ c t f) =       depth d . bracket p funcAppPrec . group . align . hang 2 . vsep $-        [ kwd "if" <+> prettySe (decD d) startPrec bnd c+        [ kwd "if"   <+> prettySe (decD d) startPrec bnd c         , kwd "then" <+> prettySe (decD d) startPrec bnd t         , kwd "else" <+> prettySe (decD d) startPrec bnd f         ]-    prettySe d p bnd (PHidden tm) = text "." <> prettySe (decD d) funcAppPrec bnd tm-    prettySe d p bnd (PResolveTC _) = kwd "%instance"-    prettySe d p bnd (PTrue _ IsType) = annName unitTy $ text "()"-    prettySe d p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"+    prettySe d p bnd (PHidden tm)         = text "." <> prettySe (decD d) funcAppPrec bnd tm+    prettySe d p bnd (PResolveTC _)       = kwd "%instance"+    prettySe d p bnd (PTrue _ IsType)     = annName unitTy $ text "()"+    prettySe d p bnd (PTrue _ IsTerm)     = annName unitCon $ text "()"     prettySe d p bnd (PTrue _ TypeOrTerm) = text "()"-    prettySe d p bnd (PRewrite _ l r _) =+    prettySe d p bnd (PRewrite _ l r _)   =       depth d . bracket p startPrec $       text "rewrite" <+> prettySe (decD d) (startPrec + 1) bnd l <+> text "in" <+> prettySe (decD d) startPrec bnd r     prettySe d p bnd (PTyped l r) =@@ -1865,9 +1876,9 @@                                      align . group . vsep . punctuate (ann comma) $                                      map (prettySe (decD d) startPrec bnd) elts         where ann = case pun of-                      TypeOrTerm -> id-                      IsType -> annName pairTy-                      IsTerm -> annName pairCon+                      TypeOrTerm  -> id+                      IsType      -> annName pairTy+                      IsTerm      -> annName pairCon     prettySe d p bnd (PDPair _ _ pun l t r) =       depth d $       annotated lparen <>@@ -1876,30 +1887,32 @@       prettySe (decD d) startPrec (addBinding bnd) r <>       annotated rparen       where annotated = case pun of-              IsType -> annName sigmaTy-              IsTerm -> annName sigmaCon-              TypeOrTerm -> id+              IsType      -> annName sigmaTy+              IsTerm      -> annName sigmaCon+              TypeOrTerm  -> id             (left, addBinding) = case (l, pun) of               (PRef _ _ n, IsType) -> (bindingOf n False <+> text ":" <+> prettySe (decD d) startPrec bnd t, ((n, False) :))-              _ ->                    (prettySe (decD d) startPrec bnd l, id)+              _                    -> (prettySe (decD d) startPrec bnd l, id)     prettySe d p bnd (PAlternative ns a as) =       lparen <> text "|" <> prettyAs <> text "|" <> rparen         where           prettyAs =-            foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (depth d . prettySe (decD d) startPrec bnd) as-    prettySe d p bnd (PType _) = annotate (AnnType "Type" "The type of types") $ text "Type"-    prettySe d p bnd (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u)-    prettySe d p bnd (PConstant _ c) = annotate (AnnConst c) (text (show c))+            foldr ((\ l r -> l <+> text "," <+> r) .+                    depth d . prettySe (decD d) startPrec bnd)+                  empty as+    prettySe d p bnd (PType _)        = annotate (AnnType "Type" "The type of types") $ text "Type"+    prettySe d p bnd (PUniverse u)    = annotate (AnnType (show u) "The type of unique types") $ text (show u)+    prettySe d p bnd (PConstant _ c)  = annotate (AnnConst c) (text (show c))     -- XXX: add pretty for tactics-    prettySe d p bnd (PProof ts) =+    prettySe d p bnd (PProof ts)      =       kwd "proof" <+> lbrace <> ellipsis <> rbrace-    prettySe d p bnd (PTactics ts) =+    prettySe d p bnd (PTactics ts)    =       kwd "tactics" <+> lbrace <> ellipsis <> rbrace-    prettySe d p bnd (PMetavar _ n) = annotate (AnnName n (Just MetavarOutput) Nothing Nothing) $  text "?" <> pretty n-    prettySe d p bnd (PReturn f) = kwd "return"-    prettySe d p bnd PImpossible = kwd "impossible"-    prettySe d p bnd Placeholder = text "_"-    prettySe d p bnd (PDoBlock dos) =+    prettySe d p bnd (PMetavar _ n)   = annotate (AnnName n (Just MetavarOutput) Nothing Nothing) $  text "?" <> pretty n+    prettySe d p bnd (PReturn f)      = kwd "return"+    prettySe d p bnd PImpossible      = kwd "impossible"+    prettySe d p bnd Placeholder      = text "_"+    prettySe d p bnd (PDoBlock dos)   =       bracket p startPrec $       kwd "do" <+> align (vsep (map (group . align . hang 2) (ppdo bnd dos)))        where ppdo bnd (DoExp _ tm:dos) = prettySe (decD d) startPrec bnd tm : ppdo bnd dos@@ -1921,47 +1934,46 @@                text "no pretty printer for pattern-matching do binding" :                ppdo bnd dos              ppdo _ [] = []-    prettySe d p bnd (PCoerced t) = prettySe d p bnd t-    prettySe d p bnd (PElabError s) = pretty s+    prettySe d p bnd (PCoerced t)             = prettySe d p bnd t+    prettySe d p bnd (PElabError s)           = pretty s     -- Quasiquote pprinting ignores bound vars-    prettySe d p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe (decD d) p [] t <> text ")"+    prettySe d p bnd (PQuasiquote t Nothing)  = text "`(" <> prettySe (decD d) p [] t <> text ")"     prettySe d p bnd (PQuasiquote t (Just g)) = text "`(" <> prettySe (decD d) p [] t <+> colon <+> prettySe (decD d) p [] g <> text ")"-    prettySe d p bnd (PUnquote t) = text "~" <> prettySe (decD d) p bnd t-    prettySe d p bnd (PQuoteName n res _) = text start <> prettyName True (ppopt_impl ppo) bnd n <> text end+    prettySe d p bnd (PUnquote t)             = text "~" <> prettySe (decD d) p bnd t+    prettySe d p bnd (PQuoteName n res _)     = text start <> prettyName True (ppopt_impl ppo) bnd n <> text end       where start = if res then "`{" else "`{{"             end = if res then "}" else "}}"-    prettySe d p bnd (PRunElab _ tm _) =+    prettySe d p bnd (PRunElab _ tm _)        =       bracket p funcAppPrec . group . align . hang 2 $       text "%runElab" <$>       prettySe (decD d) funcAppPrec bnd tm-    prettySe d p bnd (PConstSugar fc tm) = prettySe d p bnd tm -- should never occur, but harmless--    prettySe d p bnd _ = text "missing pretty-printer for term"+    prettySe d p bnd (PConstSugar fc tm)      = prettySe d p bnd tm -- should never occur, but harmless+    prettySe d p bnd _                        = text "missing pretty-printer for term"      prettyBindingOf :: Name -> Bool -> Doc OutputAnnotation     prettyBindingOf n imp = annotate (AnnBoundName n imp) (text (display n))       where display (UN n)    = T.unpack n             display (MN _ n)  = T.unpack n             -- If a namespace is specified on a binding form, we'd better show it regardless of the implicits settings-            display (NS n ns) = (concat . intersperse "." . map T.unpack . reverse) ns ++ "." ++ display n+            display (NS n ns) = (intercalate "." . map T.unpack . reverse) ns ++ "." ++ display n             display n         = show n -    prettyArgS d bnd (PImp _ _ _ n tm) = prettyArgSi d bnd (n, tm)-    prettyArgS d bnd (PExp _ _ _ tm)   = prettyArgSe d bnd tm-    prettyArgS d bnd (PConstraint _ _ _ tm) = prettyArgSc d bnd tm-    prettyArgS d bnd (PTacImplicit _ _ n _ tm) = prettyArgSti d bnd (n, tm)+    prettyArgS d bnd (PImp _ _ _ n tm)          = prettyArgSi d bnd (n, tm)+    prettyArgS d bnd (PExp _ _ _ tm)            = prettyArgSe d bnd tm+    prettyArgS d bnd (PConstraint _ _ _ tm)     = prettyArgSc d bnd tm+    prettyArgS d bnd (PTacImplicit _ _ n _ tm)  = prettyArgSti d bnd (n, tm) -    prettyArgSe d bnd arg = prettySe d (funcAppPrec + 1) bnd arg-    prettyArgSi d bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace-    prettyArgSc d bnd val = lbrace <> lbrace <> prettySe (decD d) startPrec bnd val <> rbrace <> rbrace+    prettyArgSe d bnd arg       = prettySe d (funcAppPrec + 1) bnd arg+    prettyArgSi d bnd (n, val)  = lbrace <> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace+    prettyArgSc d bnd val       = lbrace <> lbrace <> prettySe (decD d) startPrec bnd val <> rbrace <> rbrace     prettyArgSti d bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace      annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation     annName n = annotate (AnnName n Nothing Nothing Nothing)      opStr :: Name -> String-    opStr (NS n _) = opStr n-    opStr (UN n) = T.unpack n+    opStr (NS n _)  = opStr n+    opStr (UN n)    = T.unpack n      slist' :: Maybe Int -> Int -> [(Name, Bool)] -> PTerm -> Maybe [Doc OutputAnnotation]     slist' (Just d) _ _ _ | d <= 0 = Nothing@@ -2023,7 +2035,7 @@     ellipsis = text "..."      depth Nothing = id-    depth (Just d) = if d <= 0 then const (ellipsis) else id+    depth (Just d) = if d <= 0 then const ellipsis else id      decD = fmap (\x -> x - 1) @@ -2038,7 +2050,7 @@ -- | Strip away namespace information basename :: Name -> Name basename (NS n _) = basename n-basename n = n+basename n        = n  -- | Determine whether a name was the one inserted for a hole or -- guess by the delaborator@@ -2058,15 +2070,15 @@   -> 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 "_"-    | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName-    | otherwise                = annotate (AnnName n Nothing Nothing Nothing) fullName+    | (MN _ s)  <- n, isPrefixOf "_" $ T.unpack s = text "_"+    | (UN n')   <- n, T.unpack n' == "_" = text "_"+    | Just imp  <- lookup n bnd = annotate (AnnBoundName n imp) fullName+    | otherwise                 = annotate (AnnName n Nothing Nothing Nothing) fullName   where fullName = text nameSpace <> parenthesise (text (baseName n))-        baseName (UN n) = T.unpack n-        baseName (NS n ns) = baseName n-        baseName (MN i s) = T.unpack s-        baseName other = show other+        baseName (UN n)     = T.unpack n+        baseName (NS n ns)  = baseName n+        baseName (MN i s)   = T.unpack s+        baseName other      = show other         nameSpace = case n of           (NS n' ns) -> if showNS then (concatMap (++ ".") . map T.unpack . reverse) ns else ""           _ -> ""@@ -2081,13 +2093,13 @@  = prettyImp ppo l <+> showWs ws <+> text "=" <+> prettyImp ppo r              <+> text "where" <+> text (show w)   where-    showWs [] = empty+    showWs []       = empty     showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs showCImp ppo (PWith _ n l ws r pn w)  = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r                  <+> braces (text (show w))   where-    showWs [] = empty+    showWs []       = empty     showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs  @@ -2099,43 +2111,43 @@ showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation showDecls o ds = vsep (map (showDeclImp o) ds) -showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))+showDeclImp _ (PFix _ f ops)        = text (show f) <+> cat (punctuate (text ",") (map text ops)) showDeclImp o (PTy _ _ _ _ _ n _ t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp o t-showDeclImp o (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>+showDeclImp o (PClauses _ _ n cs)   = text "pat" <+> text (showCG n) <+> text "\t" <+>                                       indent 2 (vsep (map (showCImp o) cs))-showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d-showDeclImp o (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)-showDeclImp o (PNamespace n fc ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)+showDeclImp o (PData _ _ _ _ _ d)   = showDImp o { ppopt_impl = True } d+showDeclImp o (PParams _ ns ps)     = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)+showDeclImp o (PNamespace n fc ps)  = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line) showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn) showDeclImp o (PClass _ _ _ cs n _ ps _ _ ds _ _)    = text "interface" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds-showDeclImp o (PInstance _ _ _ _ cs n _ _ t _ ds)+showDeclImp o (PInstance _ _ _ _ cs acc _ n _ _ t _ ds)    = text "implementation" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds showDeclImp _ _ = text "..." -- showDeclImp (PImport o) = "import " ++ o  getImps :: [PArg] -> [(Name, PTerm)] getImps [] = []-getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs-getImps (_ : xs) = getImps xs+getImps (PImp _ _ _ n tm : xs)  = (n, tm) : getImps xs+getImps (_ : xs)                = getImps xs  getExps :: [PArg] -> [PTerm] getExps [] = []-getExps (PExp _ _ _ tm : xs) = tm : getExps xs-getExps (_ : xs) = getExps xs+getExps (PExp _ _ _ tm : xs)  = tm : getExps xs+getExps (_ : xs)              = getExps xs  getShowArgs :: [PArg] -> [PArg] getShowArgs [] = [] getShowArgs (e@(PExp _ _ _ tm) : xs) = e : getShowArgs xs getShowArgs (e : xs) | AlwaysShow `elem` argopts e = e : getShowArgs xs                      | PImp _ _ _ _ tm <- e-                     , containsHole tm       = e : getShowArgs xs+                     , containsHole tm = e : getShowArgs xs getShowArgs (_ : xs) = getShowArgs xs  getConsts :: [PArg] -> [PTerm]-getConsts [] = []+getConsts []                          = [] getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs-getConsts (_ : xs) = getConsts xs+getConsts (_ : xs)                    = getConsts xs  getAll :: [PArg] -> [PTerm] getAll = map getTm@@ -2149,13 +2161,13 @@          -> 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-                                   Nothing -> showbasic n+                                   Just i   -> if colour then colourise n (idris_colourTheme i) else showbasic n+                                   Nothing  -> showbasic n     where name = if ppopt_impl ppo then show n else showbasic n-          showbasic n@(UN _) = showCG n-          showbasic (MN i s) = str s-          showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n-          showbasic (SN s) = show s+          showbasic n@(UN _)  = showCG n+          showbasic (MN i s)  = str s+          showbasic (NS n s)  = showSep "." (map str (reverse s)) ++ "." ++ showbasic n+          showbasic (SN s)    = show s           fst3 (x, _, _) = x           colourise n t = let ctxt' = fmap tt_ctxt ist in                           case ctxt' of@@ -2187,42 +2199,42 @@   instance Sized PTerm where-  size (PQuote rawTerm) = size rawTerm-  size (PRef fc _ name) = size name-  size (PLam fc name _ ty bdy) = 1 + size ty + size bdy-  size (PPi plicity name fc ty bdy) = 1 + size ty + size fc + size bdy-  size (PLet fc name nfc ty def bdy) = 1 + size ty + size def + size bdy-  size (PTyped trm ty) = 1 + size trm + size ty-  size (PApp fc name args) = 1 + size args-  size (PAppBind fc name args) = 1 + size args-  size (PCase fc trm bdy) = 1 + size trm + size bdy-  size (PIfThenElse fc c t f) = 1 + sum (map size [c, t, f])-  size (PTrue fc _) = 1-  size (PResolveTC fc) = 1-  size (PRewrite fc left right _) = 1 + size left + size right-  size (PPair fc _ _ left right) = 1 + size left + size right-  size (PDPair fs _ _ left ty right) = 1 + size left + size ty + size right-  size (PAlternative _ a alts) = 1 + size alts-  size (PHidden hidden) = size hidden-  size (PUnifyLog tm) = size tm-  size (PDisamb _ tm) = size tm-  size (PNoImplicits tm) = size tm-  size (PType _) = 1-  size (PUniverse _) = 1-  size (PConstant fc const) = 1 + size fc + size const-  size Placeholder = 1-  size (PDoBlock dos) = 1 + size dos-  size (PIdiom fc term) = 1 + size term-  size (PReturn fc) = 1-  size (PMetavar _ name) = 1-  size (PProof tactics) = size tactics-  size (PElabError err) = size err-  size PImpossible = 1-  size _ = 0+  size (PQuote rawTerm)               = size rawTerm+  size (PRef fc _ name)               = size name+  size (PLam fc name _ ty bdy)        = 1 + size ty + size bdy+  size (PPi plicity name fc ty bdy)   = 1 + size ty + size fc + size bdy+  size (PLet fc name nfc ty def bdy)  = 1 + size ty + size def + size bdy+  size (PTyped trm ty)                = 1 + size trm + size ty+  size (PApp fc name args)            = 1 + size args+  size (PAppBind fc name args)        = 1 + size args+  size (PCase fc trm bdy)             = 1 + size trm + size bdy+  size (PIfThenElse fc c t f)         = 1 + sum (map size [c, t, f])+  size (PTrue fc _)                   = 1+  size (PResolveTC fc)                = 1+  size (PRewrite fc left right _)     = 1 + size left + size right+  size (PPair fc _ _ left right)      = 1 + size left + size right+  size (PDPair fs _ _ left ty right)  = 1 + size left + size ty + size right+  size (PAlternative _ a alts)        = 1 + size alts+  size (PHidden hidden)               = size hidden+  size (PUnifyLog tm)                 = size tm+  size (PDisamb _ tm)                 = size tm+  size (PNoImplicits tm)              = size tm+  size (PType _)                      = 1+  size (PUniverse _)                  = 1+  size (PConstant fc const)           = 1 + size fc + size const+  size Placeholder                    = 1+  size (PDoBlock dos)                 = 1 + size dos+  size (PIdiom fc term)               = 1 + size term+  size (PReturn fc)                   = 1+  size (PMetavar _ name)              = 1+  size (PProof tactics)               = size tactics+  size (PElabError err)               = size err+  size PImpossible                    = 1+  size _                              = 0  getPArity :: PTerm -> Int-getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc-getPArity _ = 0+getPArity (PPi _ _ _ _ sc)  = 1 + getPArity sc+getPArity _                 = 0  -- Return all names, free or globally bound, in the given term. @@ -2230,31 +2242,30 @@ allNamesIn tm = nub $ ni 0 [] tm   where -- TODO THINK added niTacImp, but is it right?     ni 0 env (PRef _ _ n)-        | not (n `elem` env) = [n]-    ni 0 env (PPatvar _ n) = [n]-    ni 0 env (PApp _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)-    ni 0 env (PAppBind _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)-    ni 0 env (PCase _ c os)  = ni 0 env c ++ concatMap (ni 0 env) (map snd os)-    ni 0 env (PIfThenElse _ c t f) = ni 0 env c ++ ni 0 env t ++ ni 0 env f-    ni 0 env (PLam fc n _ ty sc)  = ni 0 env ty ++ ni 0 (n:env) sc-    ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc-    ni 0 env (PLet _ n _ ty val sc) = ni 0 env ty ++ ni 0 env val ++ ni 0 (n:env) sc-    ni 0 env (PHidden tm)    = ni 0 env tm-    ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r-    ni 0 env (PTyped l r)    = ni 0 env l ++ ni 0 env r-    ni 0 env (PPair _ _ _ l r)   = ni 0 env l ++ ni 0 env r-    ni 0 env (PDPair _ _ _ (PRef _ _ n) Placeholder r)  = n : ni 0 env r-    ni 0 env (PDPair _ _ _ (PRef _ _ n) t r)  = ni 0 env t ++ ni 0 (n:env) r-    ni 0 env (PDPair _ _ _ l t r)  = ni 0 env l ++ ni 0 env t ++ ni 0 env r-    ni 0 env (PAlternative ns a ls) = concatMap (ni 0 env) ls-    ni 0 env (PUnifyLog tm)    = ni 0 env tm-    ni 0 env (PDisamb _ tm)    = ni 0 env tm-    ni 0 env (PNoImplicits tm)    = ni 0 env tm--    ni i env (PQuasiquote tm ty) = ni (i+1) env tm ++ maybe [] (ni i env) ty-    ni i env (PUnquote tm) = ni (i - 1) env tm+        | not (n `elem` env)          = [n]+    ni 0 env (PPatvar _ n)            = [n]+    ni 0 env (PApp _ f as)            = ni 0 env f ++ concatMap (ni 0 env . getTm) as+    ni 0 env (PAppBind _ f as)        = ni 0 env f ++ concatMap (ni 0 env . getTm) as+    ni 0 env (PCase _ c os)           = ni 0 env c ++ concatMap (ni 0 env . snd) os+    ni 0 env (PIfThenElse _ c t f)    = ni 0 env c ++ ni 0 env t ++ ni 0 env f+    ni 0 env (PLam fc n _ ty sc)      = ni 0 env ty ++ ni 0 (n:env) sc+    ni 0 env (PPi p n _ ty sc)        = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc+    ni 0 env (PLet _ n _ ty val sc)   = ni 0 env ty ++ ni 0 env val ++ ni 0 (n:env) sc+    ni 0 env (PHidden tm)             = ni 0 env tm+    ni 0 env (PRewrite _ l r _)       = ni 0 env l ++ ni 0 env r+    ni 0 env (PTyped l r)             = ni 0 env l ++ ni 0 env r+    ni 0 env (PPair _ _ _ l r)        = ni 0 env l ++ ni 0 env r+    ni 0 env (PDPair _ _ _ (PRef _ _ n) Placeholder r) = n : ni 0 env r+    ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r+    ni 0 env (PDPair _ _ _ l t r)     = ni 0 env l ++ ni 0 env t ++ ni 0 env r+    ni 0 env (PAlternative ns a ls)   = concatMap (ni 0 env) ls+    ni 0 env (PUnifyLog tm)           = ni 0 env tm+    ni 0 env (PDisamb _ tm)           = ni 0 env tm+    ni 0 env (PNoImplicits tm)        = ni 0 env tm -    ni i env tm               = concatMap (ni i env) (children tm)+    ni i env (PQuasiquote tm ty)  = ni (i+1) env tm ++ maybe [] (ni i env) ty+    ni i env (PUnquote tm)        = ni (i - 1) env tm+    ni i env tm                   = concatMap (ni i env) (children tm)      niTacImp i env (TacImp _ _ scr) = ni i env scr     niTacImp _ _ _                  = []@@ -2265,32 +2276,32 @@ boundNamesIn tm = S.toList (ni 0 S.empty tm)   where -- TODO THINK Added niTacImp, but is it right?     ni :: Int -> S.Set Name -> PTerm -> S.Set Name-    ni 0 set (PApp _ f as) = niTms 0 (ni 0 set f) (map getTm as)-    ni 0 set (PAppBind _ f as) = niTms 0 (ni 0 set f) (map getTm as)-    ni 0 set (PCase _ c os)  = niTms 0 (ni 0 set c) (map snd os)-    ni 0 set (PIfThenElse _ c t f) = niTms 0 set [c, t, f]-    ni 0 set (PLam fc n _ ty sc)  = S.insert n $ ni 0 (ni 0 set ty) sc-    ni 0 set (PLet fc n nfc ty val sc) = S.insert n $ ni 0 (ni 0 (ni 0 set ty) val) sc-    ni 0 set (PPi p n _ ty sc) = niTacImp 0 (S.insert n $ ni 0 (ni 0 set ty) sc) p-    ni 0 set (PRewrite _ l r _) = ni 0 (ni 0 set l) r-    ni 0 set (PTyped l r) = ni 0 (ni 0 set l) r-    ni 0 set (PPair _ _ _ l r) = ni 0 (ni 0 set l) r+    ni 0 set (PApp _ f as)              = niTms 0 (ni 0 set f) (map getTm as)+    ni 0 set (PAppBind _ f as)          = niTms 0 (ni 0 set f) (map getTm as)+    ni 0 set (PCase _ c os)             = niTms 0 (ni 0 set c) (map snd os)+    ni 0 set (PIfThenElse _ c t f)      = niTms 0 set [c, t, f]+    ni 0 set (PLam fc n _ ty sc)        = S.insert n $ ni 0 (ni 0 set ty) sc+    ni 0 set (PLet fc n nfc ty val sc)  = S.insert n $ ni 0 (ni 0 (ni 0 set ty) val) sc+    ni 0 set (PPi p n _ ty sc)          = niTacImp 0 (S.insert n $ ni 0 (ni 0 set ty) sc) p+    ni 0 set (PRewrite _ l r _)         = ni 0 (ni 0 set l) r+    ni 0 set (PTyped l r)               = ni 0 (ni 0 set l) r+    ni 0 set (PPair _ _ _ l r)          = ni 0 (ni 0 set l) r     ni 0 set (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 (ni 0 set t) r-    ni 0 set (PDPair _ _ _ l t r) = ni 0 (ni 0 (ni 0 set l) t) r-    ni 0 set (PAlternative ns a as) = niTms 0 set as-    ni 0 set (PHidden tm) = ni 0 set tm-    ni 0 set (PUnifyLog tm) = ni 0 set tm-    ni 0 set (PDisamb _ tm) = ni 0 set tm-    ni 0 set (PNoImplicits tm) = ni 0 set tm+    ni 0 set (PDPair _ _ _ l t r)       = ni 0 (ni 0 (ni 0 set l) t) r+    ni 0 set (PAlternative ns a as)     = niTms 0 set as+    ni 0 set (PHidden tm)               = ni 0 set tm+    ni 0 set (PUnifyLog tm)             = ni 0 set tm+    ni 0 set (PDisamb _ tm)             = ni 0 set tm+    ni 0 set (PNoImplicits tm)          = ni 0 set tm -    ni i set (PQuasiquote tm ty) = ni (i + 1) set tm `S.union` maybe S.empty (ni i set) ty-    ni i set (PUnquote tm) = ni (i - 1) set tm+    ni i set (PQuasiquote tm ty)        = ni (i + 1) set tm `S.union` maybe S.empty (ni i set) ty+    ni i set (PUnquote tm)              = ni (i - 1) set tm -    ni i set tm               = foldr S.union set (map (ni i set) (children tm))+    ni i set tm                         = foldr (S.union . ni i set) set (children tm)      niTms :: Int -> S.Set Name -> [PTerm] -> S.Set Name-    niTms i set [] = set-    niTms i set (x : xs) = niTms i (ni i set x) xs+    niTms i set []        = set+    niTms i set (x : xs)  = niTms i (ni i set x) xs      niTacImp i set (TacImp _ _ scr) = ni i set scr     niTacImp i set _                = set@@ -2306,18 +2317,19 @@     addFn n = do (imps, fns) <- get                  put (imps, n: fns) -    notCAF [] = False+    notCAF []                 = False     notCAF (PExp _ _ _ _ : _) = True-    notCAF (_ : xs) = notCAF xs+    notCAF (_ : xs)           = notCAF xs      notHidden (n, _) = case getAccessibility n of-                            Hidden -> False-                            _ -> True+                            Hidden  -> False+                            Private -> False+                            _       -> True      getAccessibility n              = case lookupDefAccExact n False (tt_ctxt ist) of-                    Just (n,t) -> t-                    _ -> Public+                    Just (n,t)  -> t+                    _           -> Public      ni 0 env (PRef _ _ n@(NS _ _))         | not (n `elem` env)@@ -2327,44 +2339,44 @@         | not (n `elem` env) && implicitable n || n `elem` uvars = addImp n     ni 0 env (PApp _ f@(PRef _ _ n) as)         | n `elem` uvars = do ni 0 env f-                              mapM_ (ni 0 env) (map getTm as)+                              mapM_ (ni 0 env . getTm) as         | otherwise = do case lookupTy n (tt_ctxt ist) of-                              [] -> return ()-                              _ -> addFn n-                         mapM_ (ni 0 env) (map getTm as)+                              []  -> return ()+                              _   -> addFn n+                         mapM_ (ni 0 env . getTm) as     ni 0 env (PApp _ f as) = do ni 0 env f-                                mapM_ (ni 0 env) (map getTm as)+                                mapM_ (ni 0 env . getTm) as     ni 0 env (PAppBind _ f as) = do ni 0 env f-                                    mapM_ (ni 0 env) (map getTm as)+                                    mapM_ (ni 0 env . getTm) as     ni 0 env (PCase _ c os)  = do ni 0 env c     -- names in 'os', not counting the names bound in the cases-                                  mapM_ (ni 0 env) (map snd os)+                                  mapM_ (ni 0 env . snd) os                                   (imps, fns) <- get                                   put ([] ,[])-                                  mapM_ (ni 0 env) (map fst os)+                                  mapM_ (ni 0 env . fst) os                                   (impsfst, _) <- get                                   put (nub imps \\ nub impsfst, fns)-    ni 0 env (PIfThenElse _ c t f) = mapM_ (ni 0 env) [c, t, f]-    ni 0 env (PLam fc n _ ty sc)  = do ni 0 env ty; ni 0 (n:env) sc-    ni 0 env (PPi p n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc-    ni 0 env (PRewrite _ l r _) = do ni 0 env l; ni 0 env r-    ni 0 env (PTyped l r)    = do ni 0 env l; ni 0 env r-    ni 0 env (PPair _ _ _ l r)   = do ni 0 env l; ni 0 env r-    ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = do ni 0 env t; ni 0 (n:env) r-    ni 0 env (PDPair _ _ _ l t r) = do ni 0 env l-                                       ni 0 env t-                                       ni 0 env r-    ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as-    ni 0 env (PHidden tm)    = ni 0 env tm-    ni 0 env (PUnifyLog tm)    = ni 0 env tm-    ni 0 env (PDisamb _ tm)    = ni 0 env tm-    ni 0 env (PNoImplicits tm) = ni 0 env tm+    ni 0 env (PIfThenElse _ c t f)            = mapM_ (ni 0 env) [c, t, f]+    ni 0 env (PLam fc n _ ty sc)              = do ni 0 env ty; ni 0 (n:env) sc+    ni 0 env (PPi p n _ ty sc)                = do ni 0 env ty; ni 0 (n:env) sc+    ni 0 env (PRewrite _ l r _)               = do ni 0 env l; ni 0 env r+    ni 0 env (PTyped l r)                     = do ni 0 env l; ni 0 env r+    ni 0 env (PPair _ _ _ l r)                = do ni 0 env l; ni 0 env r+    ni 0 env (PDPair _ _ _ (PRef _ _ n) t r)  = do ni 0 env t; ni 0 (n:env) r+    ni 0 env (PDPair _ _ _ l t r)             = do ni 0 env l+                                                   ni 0 env t+                                                   ni 0 env r+    ni 0 env (PAlternative ns a as)           = mapM_ (ni 0 env) as+    ni 0 env (PHidden tm)                     = ni 0 env tm+    ni 0 env (PUnifyLog tm)                   = ni 0 env tm+    ni 0 env (PDisamb _ tm)                   = ni 0 env tm+    ni 0 env (PNoImplicits tm)                = ni 0 env tm      ni i env (PQuasiquote tm ty) = do ni (i + 1) env tm                                       maybe (return ()) (ni i env) ty     ni i env (PUnquote tm) = ni (i - 1) env tm -    ni i env tm               = mapM_ (ni i env) (children tm)+    ni i env tm = mapM_ (ni i env) (children tm)  -- Return names which are free in the given term. namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]@@ -2373,32 +2385,32 @@     ni 0 env (PRef _ _ n)         | not (n `elem` env)             = case lookupTy n (tt_ctxt ist) of-                [] -> [n]-                _ -> if n `elem` (map fst uvars) then [n] else []-    ni 0 env (PApp _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)-    ni 0 env (PAppBind _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)-    ni 0 env (PCase _ c os)  = ni 0 env c +++                []  -> [n]+                _   -> [n | n `elem` (map fst uvars)]+    ni 0 env (PApp _ f as)      = ni 0 env f ++ concatMap (ni 0 env . getTm) as+    ni 0 env (PAppBind _ f as)  = ni 0 env f ++ concatMap (ni 0 env . getTm) as+    ni 0 env (PCase _ c os)     = ni 0 env c ++     -- names in 'os', not counting the names bound in the cases-                                (nub (concatMap (ni 0 env) (map snd os))-                                     \\ nub (concatMap (ni 0 env) (map fst os)))-    ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]+                                (nub (concatMap (ni 0 env . snd) os)+                                     \\ nub (concatMap (ni 0 env . fst) os))+    ni 0 env (PIfThenElse _ c t f)  = concatMap (ni 0 env) [c, t, f]     ni 0 env (PLam fc n nfc ty sc)  = ni 0 env ty ++ ni 0 (n:env) sc-    ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc-    ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r-    ni 0 env (PTyped l r)    = ni 0 env l ++ ni 0 env r-    ni 0 env (PPair _ _ _ l r)   = ni 0 env l ++ ni 0 env r+    ni 0 env (PPi p n _ ty sc)      = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc+    ni 0 env (PRewrite _ l r _)     = ni 0 env l ++ ni 0 env r+    ni 0 env (PTyped l r)           = ni 0 env l ++ ni 0 env r+    ni 0 env (PPair _ _ _ l r)      = ni 0 env l ++ ni 0 env r     ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r-    ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r+    ni 0 env (PDPair _ _ _ l t r)   = ni 0 env l ++ ni 0 env t ++ ni 0 env r     ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as-    ni 0 env (PHidden tm)    = ni 0 env tm-    ni 0 env (PUnifyLog tm)    = ni 0 env tm-    ni 0 env (PDisamb _ tm)    = ni 0 env tm-    ni 0 env (PNoImplicits tm) = ni 0 env tm+    ni 0 env (PHidden tm)           = ni 0 env tm+    ni 0 env (PUnifyLog tm)         = ni 0 env tm+    ni 0 env (PDisamb _ tm)         = ni 0 env tm+    ni 0 env (PNoImplicits tm)      = ni 0 env tm -    ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty-    ni i env (PUnquote tm) = ni (i - 1) env tm+    ni i env (PQuasiquote tm ty)    = ni (i + 1) env tm ++ maybe [] (ni i env) ty+    ni i env (PUnquote tm)          = ni (i - 1) env tm -    ni i env tm               = concatMap (ni i env) (children tm)+    ni i env tm                     = concatMap (ni i env) (children tm)      niTacImp i env (TacImp _ _ scr) = ni i env scr     niTacImp _ _ _                  = []@@ -2413,27 +2425,27 @@             = case lookupDefExact n (tt_ctxt ist) of                 Nothing -> [n]                 _ -> []-    ni 0 env (PApp _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)-    ni 0 env (PAppBind _ f as)   = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)-    ni 0 env (PCase _ c os)  = ni 0 env c ++ concatMap (ni 0 env) (map snd os)-    ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]-    ni 0 env (PLam fc n _ ty sc)  = ni 0 env ty ++ ni 0 (n:env) sc-    ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc-    ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r-    ni 0 env (PTyped l r)    = ni 0 env l ++ ni 0 env r-    ni 0 env (PPair _ _ _ l r)   = ni 0 env l ++ ni 0 env r+    ni 0 env (PApp _ f as)          = ni 0 env f ++ concatMap (ni 0 env . getTm) as+    ni 0 env (PAppBind _ f as)      = ni 0 env f ++ concatMap (ni 0 env . getTm) as+    ni 0 env (PCase _ c os)         = ni 0 env c ++ concatMap (ni 0 env . snd) os+    ni 0 env (PIfThenElse _ c t f)  = concatMap (ni 0 env) [c, t, f]+    ni 0 env (PLam fc n _ ty sc)    = ni 0 env ty ++ ni 0 (n:env) sc+    ni 0 env (PPi p n _ ty sc)      = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc+    ni 0 env (PRewrite _ l r _)     = ni 0 env l ++ ni 0 env r+    ni 0 env (PTyped l r)           = ni 0 env l ++ ni 0 env r+    ni 0 env (PPair _ _ _ l r)      = ni 0 env l ++ ni 0 env r     ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r-    ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r+    ni 0 env (PDPair _ _ _ l t r)   = ni 0 env l ++ ni 0 env t ++ ni 0 env r     ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as-    ni 0 env (PHidden tm)    = ni 0 env tm-    ni 0 env (PUnifyLog tm)    = ni 0 env tm-    ni 0 env (PDisamb _ tm)    = ni 0 env tm-    ni 0 env (PNoImplicits tm) = ni 0 env tm+    ni 0 env (PHidden tm)           = ni 0 env tm+    ni 0 env (PUnifyLog tm)         = ni 0 env tm+    ni 0 env (PDisamb _ tm)         = ni 0 env tm+    ni 0 env (PNoImplicits tm)      = ni 0 env tm -    ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty-    ni i env (PUnquote tm) = ni (i - 1) env tm+    ni i env (PQuasiquote tm ty)    = ni (i + 1) env tm ++ maybe [] (ni i env) ty+    ni i env (PUnquote tm)          = ni (i - 1) env tm -    ni i env tm               = concatMap (ni i env) (children tm)+    ni i env tm                     = concatMap (ni i env) (children tm)      niTacImp i env (TacImp _ _ scr) = ni i env scr     niTacImp _ _ _                = []
src/Idris/CaseSplit.hs view
@@ -77,7 +77,7 @@                    logElab 1 ("New patterns " ++ showSep ", "                          (map showTmImpls splits))                    let newPats_in = zipWith (replaceVar ctxt n) splits (repeat t)-                   logElab 4 ("Working from " ++ show t)+                   logElab 4 ("Working from " ++ showTmImpls t)                    logElab 4 ("Trying " ++ showSep "\n"                                (map (showTmImpls) newPats_in))                    newPats_in <- mapM elabNewPat newPats_in@@ -227,7 +227,8 @@                               i <- getIState                               return (True, delab i tm))                           (\e -> do i <- getIState-                                    logElab 5 $ "Not a valid split:\n" ++ pshow i e+                                    logElab 5 $ "Not a valid split:\n" ++ showTmImpls t ++ "\n" +                                                     ++ pshow i e                                     return (False, t))  findPats :: IState -> Type -> [PTerm]
src/Idris/Colours.hs view
@@ -47,9 +47,9 @@ mkSGR :: IdrisColour -> [SGR] mkSGR (IdrisColour c v u b i) =     fg c ++-    (if u then [SetUnderlining SingleUnderline] else []) ++-    (if b then [SetConsoleIntensity BoldIntensity] else []) ++-    (if i then [SetItalicized True] else [])+    [SetUnderlining SingleUnderline | u] +++    [SetConsoleIntensity BoldIntensity | b] +++    [SetItalicized True | i]   where     fg Nothing = []     fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]@@ -71,9 +71,9 @@ colouriseWithSTX :: IdrisColour -> String -> String colouriseWithSTX (IdrisColour c v u b i) str = setSGRCode sgr ++ "\STX" ++ str ++ setSGRCode [Reset] ++ "\STX"     where sgr = fg c ++-                (if u then [SetUnderlining SingleUnderline] else []) ++-                (if b then [SetConsoleIntensity BoldIntensity] else []) ++-                (if i then [SetItalicized True] else [])+                [SetUnderlining SingleUnderline | u] +++                [SetConsoleIntensity BoldIntensity | b] +++                [SetItalicized True | i]           fg Nothing = []           fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]
src/Idris/Completion.hs view
@@ -9,10 +9,10 @@ import Idris.Help import Idris.Imports (installedPackages) import Idris.Colours-import Idris.ParseHelpers(opChars)-import qualified Idris.ParseExpr (constants, tactics)-import Idris.ParseExpr (TacticArg (..))-import Idris.REPLParser (allHelp, setOptions)+import Idris.Parser.Helpers(opChars)+import qualified Idris.Parser.Expr (constants, tactics)+import Idris.Parser.Expr (TacticArg (..))+import Idris.REPL.Parser (allHelp, setOptions) import Control.Monad.State.Strict  import Data.List@@ -26,7 +26,7 @@ commands = [ n | (names, _, _) <- allHelp ++ extraHelp, n <- names ]  tacticArgs :: [(String, Maybe TacticArg)]-tacticArgs = [ (name, args) | (names, args, _) <- Idris.ParseExpr.tactics+tacticArgs = [ (name, args) | (names, args, _) <- Idris.Parser.Expr.tactics                             , name <- names ] tactics = map fst tacticArgs @@ -48,11 +48,11 @@            let ctxt = tt_ctxt i            return . nub $              mapMaybe (nameString . fst) (ctxtAlist ctxt) ++-             "Type" : map fst Idris.ParseExpr.constants+             "Type" : map fst Idris.Parser.Expr.constants  metavars :: Idris [String] metavars = do i <- get-              return . map (show . nsroot) $ map fst (filter (\(_, (_,_,_,t)) -> not t) (idris_metavars i)) \\ primDefs+              return . map (show . nsroot) $ map fst (filter (\(_, (_,_,_,t,_)) -> not t) (idris_metavars i)) \\ primDefs   modules :: Idris [String]
src/Idris/Core/Binary.hs view
@@ -113,8 +113,9 @@                                 put x                                 put y                                 put z-  put (CantResolve _ t) = do putWord8 15-                             put t+  put (CantResolve _ t u) = do putWord8 15+                               put t+                               put u   put (CantResolveAlts ns) = do putWord8 16                                 put ns   put (IncompleteTerm t) = do putWord8 17@@ -218,7 +219,7 @@              13 -> fmap NoTypeDecl get              14 -> do x <- get ; y <- get ; z <- get                       return $ NotInjective x y z-             15 -> fmap (CantResolve False) get+             15 -> CantResolve False <$> get <*> get              16 -> fmap CantResolveAlts get              17 -> fmap IncompleteTerm get              18 -> UniverseError <$> get <*> get <*> get <*> get <*> get
src/Idris/Core/CaseTree.hs view
@@ -152,10 +152,10 @@     nua ps (SucCase _ sc) = nu' ps sc     nua ps (DefaultCase sc) = nu' ps sc -    nut ps (P Ref n _) | n `elem` ps = []+    nut ps (P _ n _) | n `elem` ps = []                      | otherwise = [(n, [])] -- tmp     nut ps fn@(App _ f a)-        | (P Ref n _, args) <- unApply fn+        | (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         | (P (TCon _ _) n _, _) <- unApply fn = []
src/Idris/Core/DeepSeq.hs view
@@ -134,7 +134,7 @@         rnf (NoTypeDecl x1) = rnf x1 `seq` ()         rnf (NotInjective x1 x2 x3)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()-        rnf (CantResolve x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+        rnf (CantResolve x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()         rnf (InvalidTCArg x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (CantResolveAlts x1) = rnf x1 `seq` ()         rnf (NoValidAlts x1) = rnf x1 `seq` ()@@ -239,6 +239,7 @@         rnf Public = ()         rnf Frozen = ()         rnf Hidden = ()+        rnf Private = ()    instance NFData Totality where
src/Idris/Core/Evaluate.hs view
@@ -12,7 +12,7 @@                 addDatatype, addCasedef, simplifyCasedef, addOperator,                 lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact,                 lookupP, lookupP_all, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal,-                mapDefCtxt,+                mapDefCtxt,                  lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, canBeDConName, isTConName, isConName, isFnName,                 Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions,                 isUniverse) where@@ -247,18 +247,16 @@       | otherwise          = do (u, ntimes) <- usable spec n ntimes_in               if u then-               do let val = lookupDefAcc n (spec || atRepl) ctxt+               do let val = lookupDefAcc n (spec || atRepl || runtime) ctxt                   case val of                     [(Function _ tm, _)] | sUN "assert_total" `elem` stk ->                            ev ntimes (n:stk) True env tm                     [(Function _ tm, Public)] ->                            ev ntimes (n:stk) True env tm-                    [(Function _ tm, Hidden)] ->-                           ev ntimes (n:stk) True env tm                     [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty                                               return $ VP nt n vty                     [(CaseOp ci _ _ _ _ cd, acc)]-                         | (acc /= Frozen || sUN "assert_total" `elem` stk) &&+                         | (acc == Public || acc == Hidden || sUN "assert_total" `elem` stk) &&                              null (fst (cases_totcheck cd)) -> -- unoptimised version                        let (ns, tree) = getCases cd in                          if blockSimplify ci n stk@@ -319,7 +317,7 @@                  evApply ntimes' stk top env [l',t',arg'] d'     -- Treat "assert_total" specially, as long as it's defined!     ev ntimes stk top env (App _ (App _ (P _ n@(UN at) _) _) arg)-       | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,+       | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl || runtime) ctxt,          at == txt "assert_total" && not simpl             = ev ntimes (n : stk) top env arg     ev ntimes stk top env (App _ f a)@@ -347,7 +345,7 @@           = apply ntimes stk top env f args      reapply ntimes stk top env f@(VP Ref n ty) args-       = let val = lookupDefAcc n (spec || atRepl) ctxt in+       = let val = lookupDefAcc n (spec || atRepl || runtime) ctxt in          case val of               [(CaseOp ci _ _ _ _ cd, acc)] ->                  let (ns, tree) = getCases cd in@@ -373,10 +371,10 @@       | otherwise          = do (u, ntimes) <- usable spec n ntimes_in               if u then-                 do let val = lookupDefAcc n (spec || atRepl) ctxt+                 do let val = lookupDefAcc n (spec || atRepl || runtime) ctxt                     case val of                       [(CaseOp ci _ _ _ _ cd, acc)]-                           | acc /= Frozen || sUN "assert_total" `elem` stk ->+                           | acc == Public || acc == Hidden || sUN "assert_total" `elem` stk ->                            -- unoptimised version                        let (ns, tree) = getCases cd in                          if blockSimplify ci n stk@@ -742,15 +740,23 @@  ------- --- Frozen => doesn't reduce--- Hidden => doesn't reduce and invisible to type checker+-- 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  -data Accessibility = Public | Frozen | Hidden-    deriving (Show, Eq)+data Accessibility = Hidden | Public | Frozen | Private +    deriving (Eq, Ord) {-! deriving instance NFData Accessibility !-} +instance Show Accessibility where+  show Public = "public export"+  show Frozen = "export"+  show Private = "private"+  show Hidden = "hidden"+ -- | The result of totality checking data Totality = Total [Int] -- ^ well-founded arguments               | Productive -- ^ productive@@ -1039,6 +1045,7 @@           (Operator ty _ _, a, _, _)     -> return (P Ref n' ty, a)         case snd p of           Hidden -> if all then return (fst p) else []+          Private -> if all then return (fst p) else []           _      -> return (fst p)   where     names = let ns = lookupCtxtName n (definitions ctxt) in
src/Idris/Core/ProofState.hs view
@@ -206,6 +206,14 @@                    merge acc ns           | otherwise = merge ((n, t): acc) ns +dropSwaps :: [(Name, TT Name)] -> [(Name, TT Name)]+dropSwaps [] = []+dropSwaps (p@(x, P _ y _) : xs) | solvedIn y x xs = dropSwaps xs+  where solvedIn _ _ [] = False+        solvedIn y x ((y', P _ x' _) : xs) | y == y' && x == x' = True+        solvedIn y x (_ : xs) = solvedIn y x xs+dropSwaps (p : xs) = p : dropSwaps xs+ unify' :: Context -> Env ->            (TT Name, Maybe Provenance) ->            (TT Name, Maybe Provenance) ->@@ -242,7 +250,8 @@            -- problem for each.            uns <- mergeSolutions env (u' ++ ns)            ps <- get-           let (ns', probs') = updateProblems ps uns (fails ++ problems ps)+           let (ns_p, probs') = updateProblems ps uns (fails ++ problems ps)+           let ns' = dropSwaps ns_p            let (notu', probs_notu) = mergeNotunified env (holes ps) (notu ++ notunified ps)            traceWhen (unifylog ps)             ("Now solved: " ++ show ns' ++
src/Idris/Core/TT.hs view
@@ -268,7 +268,7 @@           | NoTypeDecl Name           | NotInjective t t t           | CantResolve Bool -- True if postponed, False if fatal-                        t+                        t (Err' t) -- any further information           | InvalidTCArg Name t           | CantResolveAlts [Name]           | NoValidAlts [Name]@@ -354,7 +354,7 @@   size (NoSuchVariable name) = size name   size (NoTypeDecl name) = size name   size (NotInjective l c r) = size l + size c + size r-  size (CantResolve _ trm) = size trm+  size (CantResolve _ trm _) = size trm   size (NoRewriting trm) = size trm   size (CantResolveAlts _) = 1   size (IncompleteTerm trm) = size trm@@ -397,7 +397,7 @@     show (WithFnType _) = "WithFnType"     show (NoTypeDecl _) = "NoTypeDecl"     show (NotInjective _ _ _) = "NotInjective"-    show (CantResolve _ _) = "CantResolve"+    show (CantResolve _ _ _) = "CantResolve"     show (InvalidTCArg _ _) = "InvalidTCArg"     show (CantResolveAlts _) = "CantResolveAlts"     show (NoValidAlts _) = "NoValidAlts"@@ -588,7 +588,7 @@ tcname (SN (ParentN _ _)) = True tcname _ = False -implicitable (NS n _) = implicitable n+implicitable (NS n _) = False implicitable (UN xs) | T.null xs = False                      | otherwise = isLower (T.head xs) || T.head xs == '_' implicitable (MN _ x) = not (tnull x) && thead x /= '_'
src/Idris/Coverage.hs view
@@ -59,10 +59,16 @@         let lhs_tms' = zipWith mergePlaceholders lhs_tms                           (map (stripUnmatchable i) (map flattenArgs given))         let lhss = map pUnApply lhs_tms'+        nty <- case lookupTyExact n (tt_ctxt i) of+                    Just t -> return (normalise (tt_ctxt i) [] t)+                    _ -> fail "Can't happen - genClauses, lookupTyExact"          let argss = transpose lhss-        let all_args = map (genAll i) argss+        let all_args = map (genAll i) (zip (genPH i nty) argss)         logCoverage 5 $ "COVERAGE of " ++ show n+        logCoverage 5 $ "using type " ++ show nty+        logCoverage 5 $ "non-concrete args " ++ show (genPH i nty)+         logCoverage 5 $ show (lhs_tms, lhss)         logCoverage 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)         logCoverage 10 $ show argss ++ "\n" ++ show all_args@@ -89,6 +95,18 @@             | (f, args) <- unApply term = map (\t -> delab' i t True True) args             | otherwise = [] +        -- if an argument has a non-concrete type (i.e. it's a function+        -- that calculates something from a previous argument) we'll also+        -- need to generate a placeholder pattern for it since it could be+        -- 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 = [] ++        notConcrete ist t | (P _ n _, args) <- unApply t,+                           not (isConName n (tt_ctxt ist)) = True+        notConcrete _ _ = False+         pUnApply (PApp _ f args) = map getTm args         pUnApply _ = [] @@ -135,6 +153,7 @@             = case (unApply topx, unApply topy) of                    ((P _ x _, _), (P _ y _, _)) -> x == y                    _ -> False+validCoverageCase ctxt (InfiniteUnify _ _ _) = False validCoverageCase ctxt (CantConvert _ _ _) = False validCoverageCase ctxt (At _ e) = validCoverageCase ctxt e validCoverageCase ctxt (Elaborating _ _ _ e) = validCoverageCase ctxt e@@ -171,16 +190,14 @@ recoverableCoverage ctxt (ElaboratingArg _ _ _ e) = recoverableCoverage ctxt e recoverableCoverage _ _ = False --- FIXME: Just look for which one is the deepest, then generate all--- possibilities up to that depth.--- This and below issues for this function are tracked as Issue #1741 on the issue tracker.---     https://github.com/idris-lang/Idris-dev/issues/1741-genAll :: IState -> [PTerm] -> [PTerm]-genAll i args+genAll :: IState -> (Bool, [PTerm]) -> [PTerm]+genAll i (addPH, args)    = case filter (/=Placeholder) $ fnub (concatMap otherPats (fnub args)) of           [] -> [Placeholder]-          xs -> inventConsts xs+          xs -> ph $ inventConsts xs   where+    ph ts = if addPH then Placeholder : ts else ts+     -- if they're constants, invent a new one to make sure that     -- constants which are not explicitly handled are covered     inventConsts cs@(PConstant fc c : _) = map (PConstant NoFC) (ic' (mapMaybe getConst cs))@@ -203,7 +220,6 @@     ic' xs@(B64 _ : _) = firstMissing xs (lotsOfNums B64)     ic' xs@(Ch _ : _) = firstMissing xs lotsOfChars     ic' xs@(Str _ : _) = firstMissing xs lotsOfStrings-    -- TODO: Bit vectors     -- The rest are types with only one case     ic' xs = xs @@ -218,19 +234,19 @@     nubMap f acc (x : xs) = nubMap f (fnub' acc (f x)) xs      otherPats :: PTerm -> [PTerm]-    otherPats o@(PRef fc hl n) = ops fc n [] o-    otherPats o@(PApp _ (PRef fc hl n) xs) = ops fc n xs o+    otherPats o@(PRef fc hl n) = ph $ ops fc n [] o+    otherPats o@(PApp _ (PRef fc hl n) xs) = ph $ ops fc n xs o     otherPats o@(PPair fc hls _ l r)-        = ops fc pairCon+        = ph $ ops fc pairCon                 ([pimp (sUN "A") Placeholder True,                   pimp (sUN "B") Placeholder True] ++                  [pexp l, pexp r]) o     otherPats o@(PDPair fc hls p t _ v)-        = ops fc sigmaCon+        = ph $ ops fc sigmaCon                 ([pimp (sUN "a") Placeholder True,                   pimp (sUN "P") Placeholder True] ++                  [pexp t,pexp v]) o-    otherPats o@(PConstant _ c) = inventConsts [o] -- return o+    otherPats o@(PConstant _ c) = ph $ inventConsts [o] -- return o     otherPats arg = return Placeholder      ops fc n xs o@@ -313,7 +329,7 @@              [Partial _] ->                 case lookupCtxt n (idris_callgraph i) of                      [cg] -> mapM_ (checkAllCovering fc (n : done) top)-                                   (map fst (calls cg))+                                   (calls cg)                      _ -> return ()              x -> return () -- stop if total checkAllCovering _ _ _ _ = return ()@@ -324,9 +340,9 @@  checkPositive :: [Name] -> (Name, Type) -> Idris Totality checkPositive mut_ns (cn, ty')-    = do let ty = delazy' True ty'+    = do i <- getIState+         let ty = delazy' True (normalise (tt_ctxt i) [] ty')          let p = cp ty-         i <- getIState          let tot = if p then Total (args ty) else Partial NotPositive          let ctxt' = setTotal cn tot (tt_ctxt i)          putIState (i { tt_ctxt = ctxt' })@@ -441,12 +457,18 @@                               _ -> []          when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n          t <- checkTotality [] fc n+         let acc = case lookupDefAccExact n False (tt_ctxt i) of+                        Just (n, a) -> a+                        _ -> Public          case t of               -- if it's not total, it can't reduce, to keep-              -- typechecking decidable-              p@(Partial _) -> do setAccessibility n Frozen-                                  addIBC (IBCAccess n Frozen)-                                  logCoverage 5 $ "HIDDEN: "+              -- typechecking decidable.+              -- So if it's currently public export, set it as+              -- export instead.+              p@(Partial _) -> do let newacc = max Frozen acc+                                  setAccessibility n newacc+                                  addIBC (IBCAccess n newacc)+                                  logCoverage 5 $ "Set to " ++ show newacc ++ ":"                                                ++ show n ++ show p               _ -> return ()          return t@@ -474,6 +496,7 @@                   let newscg = buildSCG' ist (rights pats) args                   logCoverage 5 $ "SCG is: " ++ show newscg                   addToCG n ( cg { scg = newscg } )+           _ -> return () -- CG comes from a type declaration only        [] -> logCoverage 5 $ "Could not build SCG for " ++ show n ++ "\n"        x -> error $ "buildSCG: " ++ show (n, x) @@ -574,7 +597,7 @@       toJust (n, t) = Just t        getType n = case lookupTy n (tt_ctxt ist) of-                       [ty] -> delazy ty -- must exist+                       [ty] -> delazy (normalise (tt_ctxt ist) [] ty) -- must exist        isInductive (P _ nty _) (P _ nty' _) =           let co = case lookupCtxt nty (idris_datatypes ist) of
src/Idris/DeepSeq.hs view
@@ -199,7 +199,8 @@          opt_optimise          opt_printdepth          opt_evaltypes-         opt_desugarnats) =+         opt_desugarnats+         opt_autoimpls) =          rnf opt_logLevel          `seq` rnf opt_typecase          `seq` rnf opt_typeintype@@ -224,6 +225,7 @@          `seq` rnf opt_printdepth          `seq` rnf opt_evaltypes          `seq` rnf opt_desugarnats+         `seq` rnf opt_autoimpls          `seq` ()  instance NFData LanguageExt where@@ -365,9 +367,9 @@        rnf _ = ()  instance NFData CGInfo where-        rnf (CGInfo x1 x2 x3 x4 x5)+        rnf (CGInfo x1 x2 x3)           = rnf x1 `seq`-              rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()+              rnf x2 `seq` rnf x3 `seq` ()  instance NFData Fixity where         rnf (Infixl x1) = rnf x1 `seq` ()@@ -466,7 +468,7 @@                             rnf x9 `seq`                               rnf x10 `seq`                                 rnf x11 `seq` rnf x12 `seq` ()-        rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)+        rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)           = rnf x1 `seq`               rnf x2 `seq`                 rnf x3 `seq`@@ -475,7 +477,7 @@                       rnf x6 `seq`                         rnf x7 `seq`                           rnf x8 `seq`-                            rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` ()+                            rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` ()         rnf (PDSL x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()@@ -696,8 +698,8 @@   rnf (IState x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20               x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40               x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60-              x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74)+              x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75)      = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` () `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` rnf x14 `seq` rnf x15 `seq` rnf x16 `seq` rnf x17 `seq` rnf x18 `seq` rnf x19 `seq` rnf x20 `seq`        rnf x21 `seq` rnf x22 `seq` rnf x23 `seq` rnf x24 `seq` rnf x25 `seq` rnf x26 `seq` rnf x27 `seq` rnf x28 `seq` rnf x29 `seq` rnf x30 `seq` rnf x31 `seq` rnf x32 `seq` rnf x33 `seq` rnf x34 `seq` rnf x35 `seq` rnf x36 `seq` rnf x37 `seq` rnf x38 `seq` rnf x39 `seq` rnf x40 `seq`        rnf x41 `seq` rnf x42 `seq` rnf x43 `seq` rnf x44 `seq` rnf x45 `seq` rnf x46 `seq` rnf x47 `seq` rnf x48 `seq` rnf x49 `seq` rnf x50 `seq` rnf x51 `seq` rnf x52 `seq` rnf x53 `seq` rnf x54 `seq` rnf x55 `seq` rnf x56 `seq` rnf x57 `seq` rnf x58 `seq` rnf x59 `seq` rnf x60 `seq`-       rnf x61 `seq` rnf x62 `seq` rnf x63 `seq` rnf x64 `seq` rnf x65 `seq` rnf x66 `seq` rnf x67 `seq` rnf x68 `seq` rnf x69 `seq` rnf x70 `seq` rnf x71 `seq` rnf x72 `seq` rnf x73 `seq` rnf x74 `seq` ()+       rnf x61 `seq` rnf x62 `seq` rnf x63 `seq` rnf x64 `seq` rnf x65 `seq` rnf x66 `seq` rnf x67 `seq` rnf x68 `seq` rnf x69 `seq` rnf x70 `seq` rnf x71 `seq` rnf x72 `seq` rnf x73 `seq` rnf x74 `seq` rnf x75 `seq` ()
src/Idris/Delaborate.hs view
@@ -106,7 +106,7 @@                        | Just n' <- lookup n env = PRef un [] n'                        | otherwise                             = case lookup n (idris_metavars ist) of-                                  Just (Just _, mi, _, _) -> mkMVApp n []+                                  Just (Just _, mi, _, _, _) -> mkMVApp n []                                   _ -> PRef un [] n     de env _ (Bind n (Lam ty) sc)           = PLam un n NoFC (de env [] ty) (de ((n,n):env) [] sc)@@ -172,7 +172,7 @@               = PApp un (de env [] f) (map pexp (map (de env []) args))     deFn env (P _ n _) args          | not mvs = case lookup n (idris_metavars ist) of-                        Just (Just _, mi, _, _) ->+                        Just (Just _, mi, _, _, _) ->                             mkMVApp n (drop mi (map (de env []) args))                         _ -> mkPApp n (map (de env []) args)          | otherwise = mkPApp n (map (de env []) args)@@ -317,7 +317,7 @@           flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc)           flagUnique t = t pprintErr' i (CantSolveGoal x env) =-  text "Can't solve goal " <>+  text "Can't find a value of type " <>   indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delabSugared i x))) <>   if (opt_errContext (idris_options i)) then line <> showSc i env else empty pprintErr' i (UnifyScope n out tm env) =@@ -346,7 +346,13 @@   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) = text "Can't find implementation for" <+> pprintTerm i (delabSugared i c)+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)     = annTm t (pprintTerm i (delabSugared i t)) <+> text " cannot be a parameter of "         <> annName n <$>
src/Idris/Directives.hs view
@@ -21,8 +21,10 @@                                      addIBC (IBCObj cgn obj) -- just name, search on loading ibc                                      addObjectFile cgn o -directiveAction (DFlag cgn flag) = do addIBC (IBCCGFlag cgn flag)-                                      addFlag cgn flag+directiveAction (DFlag cgn flag) = do+                                      let flags = words flag+                                      mapM_ (\f -> addIBC (IBCCGFlag cgn f)) flags+                                      mapM_ (addFlag cgn) flags  directiveAction (DInclude cgn hdr) = do addHdr cgn hdr                                         addIBC (IBCHeader cgn hdr)@@ -68,6 +70,8 @@     = do n' <- disambiguate n          addDeprecated n' reason          addIBC (IBCDeprecate n' reason)+directiveAction (DAutoImplicits b)+    = setAutoImpls b directiveAction (DUsed fc fn arg) = addUsedName fc fn arg  disambiguate :: Name -> Idris Name
src/Idris/Docs.hs view
@@ -19,7 +19,7 @@ import Data.List import qualified Data.Text as T --- TODO: Only include names with public/abstract accessibility+-- TODO: Only include names with public/export accessibility -- -- Issue #1573 on the Issue tracker. --    https://github.com/idris-lang/Idris-dev/issues/1573@@ -319,8 +319,8 @@     namedInst n@(UN _)  = Just n     namedInst _         = Nothing     -    getDInst (PInstance _ _ _ _ _ _ _ _ t _ _) = Just t-    getDInst _                                 = Nothing+    getDInst (PInstance _ _ _ _ _ _ _ _ _ _ t _ _) = Just t+    getDInst _                                     = Nothing      isSubclass (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ _ nm) args'))       = nm == n && map getTm args == map getTm args'
src/Idris/Elab/Class.hs view
@@ -78,6 +78,12 @@          let idecls = filter instdecl ds -- default superclass instance declarations          mapM_ checkDefaultSuperclassInstance idecls          let mnames = map getMName mdecls+         ist <- getIState+         let constraintNames = nub $ +                 concatMap (namesIn [] ist) (map snd constraints)++         mapM_ (checkConstraintName (map (\(x, _, _) -> x) ps)) constraintNames+          logElab 1 $ "Building methods " ++ show mnames          ims <- mapM (tdecl mnames) mdecls          defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint)@@ -138,7 +144,7 @@      -- TODO: probably should normalise     checkDefaultSuperclassInstance :: PDecl -> Idris ()-    checkDefaultSuperclassInstance (PInstance _ _ _ fc cs n _ ps _ _ _)+    checkDefaultSuperclassInstance (PInstance _ _ _ fc cs _ _ n _ ps _ _ _)         = do when (not $ null cs) . tclift                 $ tfail (At fc (Msg $ "Default superclass instances can't have constraints."))              i <- getIState@@ -148,6 +154,14 @@                 $ 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 ++ +                         " is not bound in interface " ++ show tn+                         ++ " " ++ showSep " " (map show bound))) +        | otherwise = return ()+     impbind :: [(Name, PTerm)] -> PTerm -> PTerm     impbind [] x = x     impbind ((n, ty): ns) x = PPi impl n NoFC ty (impbind ns x)@@ -184,7 +198,7 @@      tydecl (PTy _ _ _ _ _ _ _ _) = True     tydecl _ = False-    instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _) = True+    instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _) = True     instdecl _ = False     clause (PClauses _ _ _ _) = True     clause _ = False
src/Idris/Elab/Clause.hs view
@@ -80,19 +80,21 @@            let atys = map snd (getArgTys fty)            cs_elab <- mapM (elabClause info opts)                            (zip [0..] cs)+           ctxt <- getContext            -- pats_raw is the version we'll work with at compile time:            -- no simplification or PE            let (pats_in, cs_full) = unzip cs_elab-           let pats_raw = map (simple_lhs (tt_ctxt ist)) pats_in+           let pats_raw = map (simple_lhs ctxt) pats_in            logElab 3 $ "Elaborated patterns:\n" ++ show pats_raw -           solveDeferred n+           solveDeferred fc n             -- just ensure that the structure exists            fmodifyState (ist_optimisation n) id            addIBC (IBCOpt n)             ist <- getIState+           ctxt <- getContext            -- Don't apply rules if this is a partial evaluation definition,            -- or we'll make something that just runs itself!            let tpats = case specNames opts of@@ -103,7 +105,7 @@            -- RHS            pe_tm <- doPartialEval ist tpats            let pats_pe = if petrans-                            then map (simple_lhs (tt_ctxt ist)) pe_tm+                            then map (simple_lhs ctxt) pe_tm                             else pats_raw             let tcase = opt_typecase (idris_options ist)@@ -163,9 +165,12 @@            cov <- coverage            pmissing <-                    if cov && not (hasDefault pats_raw)-                      then do missing <- genClauses fc n (map getLHS pdef) cs_full+                      then do -- Generate clauses from the given possible cases+                              missing <- genClauses fc n (map getLHS pdef) cs_full                               -- missing <- genMissing n scargs sc                               missing' <- filterM (checkPossible info fc True n) missing+                              -- Filter out the ones which match one of the+                              -- given cases (including impossible ones)                               let clhs = map getLHS pdef                               logElab 2 $ "Must be unreachable:\n" ++                                           showSep "\n" (map showTmImpls missing') ++@@ -183,7 +188,8 @@            -- pdef' is the version that gets compiled for run-time,            -- so we start from the partially evaluated version            pdef_in' <- applyOpts $ map (\(ns, lhs, rhs) -> (map fst ns, lhs, rhs)) pdef_pe-           let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in'+           ctxt <- getContext+           let pdef' = map (simple_rt ctxt) pdef_in'             logElab 5 $ "After data structure transformations:\n" ++ show pdef' @@ -241,24 +247,28 @@                                                    ctxt                       setContext ctxt'                       addIBC (IBCDef n)+                      addDefinedName n                       setTotality n tot                       when (not reflect && PEGenerated `notElem` opts) $                                            do totcheck (fc, n)                                               defer_totcheck (fc, n)                       when (tot /= Unchecked) $ addIBC (IBCTotal n tot)                       i <- getIState-                      case lookupDef n (tt_ctxt i) of+                      ctxt <- getContext+                      case lookupDef n ctxt of                           (CaseOp _ _ _ _ _ cd : _) ->-                            let (scargs, sc) = cases_compiletime cd-                                (scargs', sc') = cases_runtime cd in-                              do let calls = findCalls sc' scargs'-                                 let used = findUsedArgs sc' scargs'+                            let (scargs, sc) = cases_compiletime cd in+                              do let calls = map fst $ findCalls sc scargs                                  -- let scg = buildSCG i sc scargs                                  -- add SCG later, when checking totality-                                 let cg = CGInfo scargs' calls [] used []  -- TODO: remove this, not needed anymore-                                 logElab 2 $ "Called names: " ++ show cg-                                 addToCG n cg-                                 addToCalledG n (nub (map fst calls)) -- plus names in type!+                                 logElab 2 $ "Called names: " ++ show calls+                                 -- if the definition is public, make sure+                                 -- it only uses public names+                                 nvis <- getFromHideList n+                                 case nvis of+                                      Just Public -> mapM_ (checkVisibility fc n Public Public) calls+                                      _ -> return ()+                                 addCalls n calls                                  addIBC (IBCCG n)                           _ -> return ()                       return ()@@ -305,7 +315,6 @@                   , (f, args) <- unApply tm = all (isPatVar pvs) args     hasDefault _ = False -     getLHS (_, l, _) = l      simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y)@@ -353,11 +362,12 @@     mkSpecialised :: (Name, [(PEArgType, Term)]) -> Idris [(Term, Term)]     mkSpecialised specapp_in = do         ist <- getIState+        ctxt <- getContext         let (specTy, specapp) = getSpecTy ist specapp_in         let (n, newnm, specdecl) = getSpecClause ist specapp         let lhs = pe_app specdecl         let rhs = pe_def specdecl-        let undef = case lookupDefExact newnm (tt_ctxt ist) of+        let undef = case lookupDefExact newnm ctxt of                          Nothing -> True                          _ -> False         logElab 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp))@@ -370,7 +380,7 @@                 let cgns' = filter (\x -> x /= n &&                                           notStatic ist x) cgns                 -- set small reduction limit on partial/productive things-                let maxred = case lookupTotal n (tt_ctxt ist) of+                let maxred = case lookupTotal n ctxt of                                   [Total _] -> 65536                                   [Productive] -> 16                                   _ -> 1@@ -485,7 +495,7 @@                   processTacticDecls info newDecls                   sendHighlighting highlights                   let lhs_tm = orderPats (getInferTerm lhs')-                  case recheck ctxt [] (forget lhs_tm) lhs_tm of+                  case recheck ctxt' [] (forget lhs_tm) lhs_tm of                        OK _ -> return True                        err -> return False             -- if it's a recoverable error, the case may become possible@@ -558,7 +568,7 @@                              (Msg "unexpected patterns outside of \"with\" block")))          -- get the parameters first, to pass through to any where block-        let fn_ty = case lookupTy fname (tt_ctxt i) of+        let fn_ty = case lookupTy fname ctxt of                          [t] -> t                          _ -> error "Can't happen (elabClause function type)"         let fn_is = case lookupCtxt fname (idris_implicits i) of@@ -573,7 +583,7 @@ --         let lhs = mkLHSapp $ --                     propagateParams i params fn_ty (addImplPat i lhs_in)         logElab 10 (show (params, fn_ty) ++ " " ++ showTmImpls (addImplPat i lhs_in))-        logElab 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs)+        logElab 5 ("LHS: " ++ show opts ++ "\n" ++ show fc ++ " " ++ showTmImpls lhs)         logElab 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++                   "\n" ++ show (fn_ty, fn_is)) @@ -602,6 +612,7 @@          -- If we're inferring metavariables in the type, don't recheck,         -- because we're only doing this to try to work out those metavariables+        ctxt <- getContext         (clhs_c, clhsty) <- if not inf                                then recheckC_borrowing False (PEGenerated `notElem` opts)                                                        [] fc id [] lhs_tm@@ -627,6 +638,8 @@         logElab 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)         -- Elaborate where block         ist <- getIState+        ctxt <- getContext+         windex <- getName         let decls = nub (concatMap declared whereblock)         let defs = nub (decls ++ concatMap defined whereblock)@@ -635,7 +648,7 @@         -- Unique arguments must be passed to the where block explicitly         -- (since we can't control "usage" easlily otherwise). Remove them         -- from newargs here-        let uniqargs = findUnique (tt_ctxt ist) [] lhs_tm+        let uniqargs = findUnique ctxt [] lhs_tm         let newargs = filter (\(n,_) -> n `notElem` uniqargs) newargs_all          let winfo = (pinfo info newargs defs windex) { elabFC = Just fc }@@ -657,7 +670,7 @@         logElab 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs         ctxt <- getContext -- new context with where block added         logElab 5 "STARTING CHECK"-        ((rhs', defer, is, probs, ctxt', newDecls, highlights), _) <-+        ((rhs', defer, holes, is, probs, ctxt', newDecls, highlights), _) <-            tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patRHS") clhsty initEState                     (do pbinds ist lhs_tm                         -- proof search can use explicitly written names@@ -674,7 +687,8 @@                         let (tm, ds) = runState (collectDeferred (Just fname)                                                      (map fst $ case_decls aux) ctxt tt) []                         probs <- get_probs-                        return (tm, ds, is, probs, ctxt', newDecls, highlights))+                        hs <- get_holes+                        return (tm, ds, hs, is, probs, ctxt', newDecls, highlights))         setContext ctxt'         processTacticDecls info newDecls         sendHighlighting highlights@@ -685,9 +699,12 @@         logElab 4 $ "---> " ++ show rhs'         when (not (null defer)) $ logElab 1 $ "DEFERRED " ++                     show (map (\ (n, (_,_,t,_)) -> (n, t)) defer)-        def' <- checkDef fc (\n -> Elaborating "deferred type of " n Nothing) defer-        let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'++        -- If there's holes, set the metavariables as undefinable+        def' <- checkDef 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''+         mapM_ (\(n, _) -> addIBC (IBCDef n)) def''          when (not (null def')) $ do@@ -703,11 +720,23 @@         logElab 5 $ "Rechecking"         logElab 6 $ " ==> " ++ show (forget rhs') -        (crhs, crhsty) <- if not inf-                             then recheckC_borrowing True (PEGenerated `notElem` opts)-                                                     borrowed fc id [] rhs'-                             else return (rhs', clhsty)+        (crhs, crhsty) -- if there's holes && deferred things, it's okay+                       -- but we'll need to freeze the definition and not+                       -- allow the deferred things to be definable+                       -- (this is just to allow users to inspect intermediate+                       -- things)+             <- if (null holes || null def') && not inf +                   then recheckC_borrowing True (PEGenerated `notElem` opts)+                                       borrowed fc id [] rhs'+                   else return (rhs', clhsty)+         logElab 6 $ " ==> " ++ showEnvDbg [] crhsty ++ "   against   " ++ showEnvDbg [] clhsty++        -- If there's holes, make sure this definition is frozen+        when (not (null holes)) $ do+           logElab 5 $ "Making " ++ show fname ++ " frozen due to " ++ show holes+           setAccessibility fname Frozen+         ctxt <- getContext         let constv = next_tvar ctxt         case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of@@ -798,7 +827,7 @@         -- pattern bindings         i <- getIState         -- get the parameters first, to pass through to any where block-        let fn_ty = case lookupTy fname (tt_ctxt i) of+        let fn_ty = case lookupTy fname ctxt of                          [t] -> t                          _ -> error "Can't happen (elabClause function type)"         let fn_is = case lookupCtxt fname (idris_implicits i) of@@ -819,6 +848,7 @@         processTacticDecls info newDecls         sendHighlighting highlights +        ctxt <- getContext         let lhs_tm = orderPats (getInferTerm lhs')         let lhs_ty = getInferType lhs'         let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))@@ -847,11 +877,13 @@         processTacticDecls info newDecls         sendHighlighting highlights -        def' <- checkDef fc iderr defer-        let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'+        def' <- checkDef 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')         let cwvaltyN = explicitNames (normalise ctxt [] cwvalty)         let cwvalN = explicitNames (normalise ctxt [] cwval)@@ -910,8 +942,8 @@         addIBC (IBCImp wname)         addIBC (IBCStatic wname) -        def' <- checkDef fc iderr [(wname, (-1, Nothing, wtype, []))]-        let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'+        def' <- checkDef 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''          -- in the subdecls, lhs becomes:@@ -951,8 +983,8 @@         processTacticDecls info newDecls         sendHighlighting highlights -        def' <- checkDef fc iderr defer-        let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'+        def' <- checkDef 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')
src/Idris/Elab/Data.hs view
@@ -60,7 +60,7 @@     = do let codata = Codata `elem` opts          logElab 1 (show (fc, doc))          checkUndefined fc n-         when (implicitable n) $ warnLC fc n+         when (implicitable (nsroot n)) $ warnLC fc n          (cty, _, t, inacc) <- buildType info syn fc [] n t_in           addIBC (IBCDef n)@@ -71,7 +71,7 @@     = do let codata = Codata `elem` opts          logElab 1 (show fc)          undef <- isUndefined fc n-         when (implicitable n) $ warnLC fc n+         when (implicitable (nsroot n)) $ warnLC fc n          (cty, ckind, t, inacc) <- buildType info syn fc [] n t_in          -- if n is defined already, make sure it is just a type declaration          -- with the same type we've just elaborated, and no constructors@@ -231,7 +231,7 @@            Idris (Name, Type) elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcenames)     = do checkUndefined fc n-         when (implicitable n) $ warnLC fc n+         when (implicitable (nsroot n)) $ warnLC fc n          logElab 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t_in          (cty, ckind, t, inacc) <- buildType info syn fc [Constructor] n (if codata then mkLazy t_in else t_in)          ctxt <- getContext@@ -244,7 +244,7 @@           logElab 5 $ show fc ++ ":Constructor " ++ show n ++ " elaborated : " ++ show t          logElab 5 $ "Inaccessible args: " ++ show inacc-         logElab 2 $ "---> " ++ show n ++ " : " ++ show cty'+         logElab 2 $ "---> " ++ show n ++ " : " ++ show cty           -- Add to the context (this is temporary, so that later constructors          -- can be indexed by it)@@ -259,9 +259,14 @@          addIBC (IBCDoc n)          fputState (opt_inaccessible . ist_optimisation n) inacc          addIBC (IBCOpt n)-         return (n, cty')+         return (n, cty)   where-    tyIs con (Bind n b sc) = tyIs con sc+    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 +                         (Msg ("Type level variable " ++ show n' ++ " is not " ++ show tn))))+             else return ()     tyIs con t | (P _ n' _, _) <- unApply t         = if n' /= tn then tclift $ tfail (At fc (Elaborating "constructor " con Nothing (Msg (show n' ++ " is not " ++ show tn))))              else return ()@@ -350,7 +355,7 @@                     (ierror . Elaborating "type declaration of " elimDeclName Nothing)   -- Do not elaborate clauses if there aren't any   case eliminatorClauses of-    [] -> State.lift $ solveDeferred elimDeclName -- Remove meta-variable for type+    [] -> State.lift $ solveDeferred emptyFC 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 ()
src/Idris/Elab/Instance.hs view
@@ -55,28 +55,35 @@                 [(Name, Docstring (Either Err PTerm))] ->                 ElabWhat -> -- phase                 FC -> [(Name, PTerm)] -> -- constraints+                Accessibility ->+                FnOpts ->                 Name -> -- the class                 FC -> -- precise location of class name                 [PTerm] -> -- class parameters (i.e. instance)                 PTerm -> -- full instance type                 Maybe Name -> -- explicit name                 [PDecl] -> Idris ()-elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do-    i <- getIState-    (n, ci) <- case lookupCtxtName n (idris_classes i) of+elabInstance info syn doc argDocs what fc cs acc opts n nfc ps t expn ds = do+    ist <- getIState+    (n, ci) <- case lookupCtxtName n (idris_classes ist) of                   [c] -> return c                   [] -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"                   cs -> tclift $ tfail $ At fc                            (CantResolveAlts (map fst cs))     let constraint = PApp fc (PRef fc [] n) (map pexp ps)     let iname = mkiname n (namespace info) ps expn+    putIState (ist { hide_list = addDef iname acc (hide_list ist) })+    ist <- getIState++    let totopts = Dictionary : opts+     let emptyclass = null (class_methods ci)     when (what /= EDefns) $ do-         nty <- elabType' True info syn doc argDocs fc [] iname NoFC t+         nty <- elabType' True info syn doc argDocs fc totopts iname NoFC 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          case expn of-            Nothing -> do mapM_ (maybe (return ()) overlapping . findOverlapping i (class_determiners ci) (delab i nty))+            Nothing -> do mapM_ (maybe (return ()) overlapping . findOverlapping ist (class_determiners ci) (delab ist nty))                                 (map fst $ class_instances ci)                           addInstance intInst True n iname             Just _ -> addInstance intInst False n iname@@ -95,7 +102,7 @@          let pnames = nub $ map pname (concat (nub wparams)) ++                           concatMap (namesIn [] ist) ps          let superclassInstances = map (substInstance ips pnames) (class_default_superclasses ci)-         undefinedSuperclassInstances <- filterM (fmap not . isOverlapping i) superclassInstances+         undefinedSuperclassInstances <- filterM (fmap not . isOverlapping ist) superclassInstances          mapM_ (rec_elabDecl info EAll info) undefinedSuperclassInstances          let all_meths = map (nsroot . fst) (class_methods ci)          let mtys = map (\ (n, (op, t)) ->@@ -108,7 +115,7 @@               (class_methods ci)          logElab 3 (show (mtys, ips))          logElab 5 ("Before defaults: " ++ show ds ++ "\n" ++ show (map fst (class_methods ci)))-         let ds_defs = insertDefaults i iname (class_defaults ci) ns ds+         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          logElab 1 ("Reordered: " ++ show ds' ++ "\n")@@ -134,10 +141,10 @@          let rhs = PApp fc (PRef fc [] (instanceCtorName ci))                            (map (pexp . mkMethApp) mtys) -         logElab 5 $ "Instance LHS " ++ show lhs ++ " " ++ show headVars+         logElab 5 $ "Instance LHS " ++ show totopts ++ "\n" ++ show lhs ++ " " ++ show headVars          logElab 5 $ "Instance RHS " ++ show rhs -         let idecls = [PClauses fc [Dictionary] iname+         let idecls = [PClauses fc totopts iname                                  [PClause fc iname lhs [] rhs wb]]          logElab 1 (show idecls)          push_estack iname True@@ -159,10 +166,10 @@                           Just m -> sNS (SN (sInstanceN n' (map show ps'))) m           Just nm -> nm -    substInstance ips pnames (PInstance doc argDocs syn _ cs n nfc ps t expn ds)-        = PInstance doc argDocs syn fc cs n nfc (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds+    substInstance ips pnames (PInstance doc argDocs syn _ cs acc opts n nfc ps t expn ds)+        = PInstance doc argDocs syn fc cs acc opts n nfc (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds -    isOverlapping i (PInstance doc argDocs syn _ _ n nfc ps t expn _)+    isOverlapping i (PInstance doc argDocs syn _ _ _ _ n nfc ps t expn _)         = case lookupCtxtName n (idris_classes i) of             [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in                             case lookupTy iname (tt_ctxt i) of
+ src/Idris/Elab/Quasiquote.hs view
@@ -0,0 +1,173 @@+module Idris.Elab.Quasiquote (extractUnquotes) where++import Idris.Core.Elaborate hiding (Tactic(..))+import Idris.Core.TT+import Idris.AbsSyntax+++extract1 :: Int -> (PTerm -> a) -> PTerm -> Elab' aux (a, [(Name, PTerm)])+extract1 n c tm = do (tm', ex) <- extractUnquotes n tm+                     return (c tm', ex)++extract2 :: Int -> (PTerm -> PTerm -> a) -> PTerm -> PTerm -> Elab' aux (a, [(Name, PTerm)])+extract2 n c a b = do (a', ex1) <- extractUnquotes n a+                      (b', ex2) <- extractUnquotes n b+                      return (c a' b', ex1 ++ ex2)++extractTUnquotes :: Int -> PTactic -> Elab' aux (PTactic, [(Name, PTerm)])+extractTUnquotes n (Rewrite t) = extract1 n Rewrite t+extractTUnquotes n (Induction t) = extract1 n Induction t+extractTUnquotes n (LetTac name t) = extract1 n (LetTac name) t+extractTUnquotes n (LetTacTy name t1 t2) = extract2 n (LetTacTy name) t1 t2+extractTUnquotes n (Exact tm) = extract1 n Exact tm+extractTUnquotes n (Try tac1 tac2)+  = do (tac1', ex1) <- extractTUnquotes n tac1+       (tac2', ex2) <- extractTUnquotes n tac2+       return (Try tac1' tac2', ex1 ++ ex2)+extractTUnquotes n (TSeq tac1 tac2)+  = do (tac1', ex1) <- extractTUnquotes n tac1+       (tac2', ex2) <- extractTUnquotes n tac2+       return (TSeq tac1' tac2', ex1 ++ ex2)+extractTUnquotes n (ApplyTactic t) = extract1 n ApplyTactic t+extractTUnquotes n (ByReflection t) = extract1 n ByReflection t+extractTUnquotes n (Reflect t) = extract1 n Reflect t+extractTUnquotes n (GoalType s tac)+  = do (tac', ex) <- extractTUnquotes n tac+       return (GoalType s tac', ex)+extractTUnquotes n (TCheck t) = extract1 n TCheck t+extractTUnquotes n (TEval t) = extract1 n TEval t+extractTUnquotes n (Claim name t) = extract1 n (Claim name) t+extractTUnquotes n tac = return (tac, []) -- the rest don't contain PTerms, or have been desugared away++extractPArgUnquotes :: Int -> PArg -> Elab' aux (PArg, [(Name, PTerm)])+extractPArgUnquotes d (PImp p m opts n t) =+  do (t', ex) <- extractUnquotes d t+     return (PImp p m opts n t', ex)+extractPArgUnquotes d (PExp p opts n t) =+  do (t', ex) <- extractUnquotes d t+     return (PExp p opts n t', ex)+extractPArgUnquotes d (PConstraint p opts n t) =+  do (t', ex) <- extractUnquotes d t+     return (PConstraint p opts n t', ex)+extractPArgUnquotes d (PTacImplicit p opts n scpt t) =+  do (scpt', ex1) <- extractUnquotes d scpt+     (t', ex2) <- extractUnquotes d t+     return (PTacImplicit p opts n scpt' t', ex1 ++ ex2)++extractDoUnquotes :: Int -> PDo -> Elab' aux (PDo, [(Name, PTerm)])+extractDoUnquotes d (DoExp fc tm)+  = do (tm', ex) <- extractUnquotes d tm+       return (DoExp fc tm', ex)+extractDoUnquotes d (DoBind fc n nfc tm)+  = do (tm', ex) <- extractUnquotes d tm+       return (DoBind fc n nfc tm', ex)+extractDoUnquotes d (DoBindP fc t t' alts)+  = fail "Pattern-matching binds cannot be quasiquoted"+extractDoUnquotes d (DoLet  fc n nfc v b)+  = do (v', ex1) <- extractUnquotes d v+       (b', ex2) <- extractUnquotes d b+       return (DoLet fc n nfc v' b', ex1 ++ ex2)+extractDoUnquotes d (DoLetP fc t t') = fail "Pattern-matching lets cannot be quasiquoted"+++extractUnquotes :: Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)])+extractUnquotes n (PLam fc name nfc ty body)+  = do (ty', ex1) <- extractUnquotes n ty+       (body', ex2) <- extractUnquotes n body+       return (PLam fc name nfc ty' body', ex1 ++ ex2)+extractUnquotes n (PPi plicity name fc ty body)+  = do (ty', ex1) <- extractUnquotes n ty+       (body', ex2) <- extractUnquotes n body+       return (PPi plicity name fc ty' body', ex1 ++ ex2)+extractUnquotes n (PLet fc name nfc ty val body)+  = do (ty', ex1) <- extractUnquotes n ty+       (val', ex2) <- extractUnquotes n val+       (body', ex3) <- extractUnquotes n body+       return (PLet fc name nfc ty' val' body', ex1 ++ ex2 ++ ex3)+extractUnquotes n (PTyped tm ty)+  = do (tm', ex1) <- extractUnquotes n tm+       (ty', ex2) <- extractUnquotes n ty+       return (PTyped tm' ty', ex1 ++ ex2)+extractUnquotes n (PApp fc f args)+  = do (f', ex1) <- extractUnquotes n f+       args' <- mapM (extractPArgUnquotes n) args+       let (args'', exs) = unzip args'+       return (PApp fc f' args'', ex1 ++ concat exs)+extractUnquotes n (PAppBind fc f args)+  = do (f', ex1) <- extractUnquotes n f+       args' <- mapM (extractPArgUnquotes n) args+       let (args'', exs) = unzip args'+       return (PAppBind fc f' args'', ex1 ++ concat exs)+extractUnquotes n (PCase fc expr cases)+  = do (expr', ex1) <- extractUnquotes n expr+       let (pats, rhss) = unzip cases+       (pats', exs1) <- fmap unzip $ mapM (extractUnquotes n) pats+       (rhss', exs2) <- fmap unzip $ mapM (extractUnquotes n) rhss+       return (PCase fc expr' (zip pats' rhss'), ex1 ++ concat exs1 ++ concat exs2)+extractUnquotes n (PIfThenElse fc c t f)+  = do (c', ex1) <- extractUnquotes n c+       (t', ex2) <- extractUnquotes n t+       (f', ex3) <- extractUnquotes n f+       return (PIfThenElse fc c' t' f', ex1 ++ ex2 ++ ex3)+extractUnquotes n (PRewrite fc x y z)+  = do (x', ex1) <- extractUnquotes n x+       (y', ex2) <- extractUnquotes n y+       case z of+         Just zz -> do (z', ex3) <- extractUnquotes n zz+                       return (PRewrite fc x' y' (Just z'), ex1 ++ ex2 ++ ex3)+         Nothing -> return (PRewrite fc x' y' Nothing, ex1 ++ ex2)+extractUnquotes n (PPair fc hls info l r)+  = do (l', ex1) <- extractUnquotes n l+       (r', ex2) <- extractUnquotes n r+       return (PPair fc hls info l' r', ex1 ++ ex2)+extractUnquotes n (PDPair fc hls info a b c)+  = do (a', ex1) <- extractUnquotes n a+       (b', ex2) <- extractUnquotes n b+       (c', ex3) <- extractUnquotes n c+       return (PDPair fc hls info a' b' c', ex1 ++ ex2 ++ ex3)+extractUnquotes n (PAlternative ms b alts)+  = do alts' <- mapM (extractUnquotes n) alts+       let (alts'', exs) = unzip alts'+       return (PAlternative ms b alts'', concat exs)+extractUnquotes n (PHidden tm)+  = do (tm', ex) <- extractUnquotes n tm+       return (PHidden tm', ex)+extractUnquotes n (PGoal fc a name b)+  = do (a', ex1) <- extractUnquotes n a+       (b', ex2) <- extractUnquotes n b+       return (PGoal fc a' name b', ex1 ++ ex2)+extractUnquotes n (PDoBlock steps)+  = do steps' <- mapM (extractDoUnquotes n) steps+       let (steps'', exs) = unzip steps'+       return (PDoBlock steps'', concat exs)+extractUnquotes n (PIdiom fc tm)+  = fmap (\(tm', ex) -> (PIdiom fc tm', ex)) $ extractUnquotes n tm+extractUnquotes n (PProof tacs)+  = do (tacs', exs) <- fmap unzip $ mapM (extractTUnquotes n) tacs+       return (PProof tacs', concat exs)+extractUnquotes n (PTactics tacs)+  = do (tacs', exs) <- fmap unzip $ mapM (extractTUnquotes n) tacs+       return (PTactics tacs', concat exs)+extractUnquotes n (PElabError err) = fail "Can't quasiquote an error"+extractUnquotes n (PCoerced tm)+  = do (tm', ex) <- extractUnquotes n tm+       return (PCoerced tm', ex)+extractUnquotes n (PDisamb ns tm)+  = do (tm', ex) <- extractUnquotes n tm+       return (PDisamb ns tm', ex)+extractUnquotes n (PUnifyLog tm)+  = fmap (\(tm', ex) -> (PUnifyLog tm', ex)) $ extractUnquotes n tm+extractUnquotes n (PNoImplicits tm)+  = fmap (\(tm', ex) -> (PNoImplicits tm', ex)) $ extractUnquotes n tm+extractUnquotes n (PQuasiquote tm goal)+  = fmap (\(tm', ex) -> (PQuasiquote tm' goal, ex)) $ extractUnquotes (n+1) tm+extractUnquotes n (PUnquote tm)+  | n == 0 = do n <- getNameFrom (sMN 0 "unquotation")+                return (PRef (fileFC "(unquote)") [] n, [(n, tm)])+  | otherwise = fmap (\(tm', ex) -> (PUnquote tm', ex)) $+                extractUnquotes (n-1) tm+extractUnquotes n (PRunElab fc tm ns)+  = fmap (\(tm', ex) -> (PRunElab fc tm' ns, ex)) $ extractUnquotes n tm+extractUnquotes n (PConstSugar fc tm)+  = extractUnquotes n tm+extractUnquotes n x = return (x, []) -- no subterms!
src/Idris/Elab/Record.hs view
@@ -17,7 +17,7 @@ import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting) import IRTS.Lang -import Idris.ParseExpr (tryFullExpr)+import Idris.Parser.Expr (tryFullExpr)  import Idris.Elab.Type import Idris.Elab.Data
src/Idris/Elab/Term.hs view
@@ -20,7 +20,7 @@ import Idris.Core.WHNF (whnf) import Idris.Coverage (buildSCG, checkDeclTotality, genClauses, recoverableCoverage, validCoverageCase) import Idris.ErrReverse (errReverse)-import Idris.ElabQuasiquote (extractUnquotes)+import Idris.Elab.Quasiquote (extractUnquotes) import Idris.Elab.Utils import Idris.Reflection import qualified Util.Pretty as U@@ -236,6 +236,7 @@     pattern = emode == ELHS     intransform = emode == ETransLHS     bindfree = emode == ETyDecl || emode == ELHS || emode == ETransLHS+    autoimpls = opt_autoimpls (idris_options ist)      get_delayed_elab est =         let ds = delayed_elab est in@@ -614,7 +615,8 @@                                 [] -> False                                 _ -> True             bindable (NS _ _) = False-            bindable n = implicitable n+            bindable (MN _ _) = True+            bindable n = implicitable n && autoimpls     elab' ina _ f@(PInferRef fc hls n) = elab' ina (Just fc) (PApp NoFC f [])     elab' ina fc' tm@(PRef fc hls n)           | pattern && not reflection && not (e_qq ina) && not (e_intype ina)@@ -1702,8 +1704,8 @@ -- Return true if the given error suggests a type class failure is -- recoverable tcRecoverable :: ElabMode -> Err -> Bool-tcRecoverable ERHS (CantResolve f g) = f-tcRecoverable ETyDecl (CantResolve f g) = f+tcRecoverable ERHS (CantResolve f g _) = f+tcRecoverable ETyDecl (CantResolve f g _) = f tcRecoverable e (ElaboratingArg _ _ _ err) = tcRecoverable e err tcRecoverable e (At _ err) = tcRecoverable e err tcRecoverable _ _ = True@@ -2476,8 +2478,10 @@                                        OK hs   -> return hs                           -- Normalize error handler terms to produce the new messages+                         -- Need to use 'normaliseAll' since we have to reduce private+                         -- names in error handlers too                          ctxt <- getContext-                         let results = map (normalise ctxt []) (map fst handlers)+                         let results = map (normaliseAll ctxt []) (map fst handlers)                          logElab 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))                           -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent@@ -2504,7 +2508,7 @@          updateIState $ \i -> i { idris_implicits =                                     addDef n impls (idris_implicits i) }          addIBC (IBCImp n)-         ds <- checkDef fc (\_ e -> e) [(n, (-1, Nothing, ty, []))]+         ds <- checkDef fc (\_ e -> e) True [(n, (-1, Nothing, ty, []))]          addIBC (IBCDef n)          ctxt <- getContext          case lookupDef n ctxt of@@ -2513,7 +2517,7 @@              -- then it must be added as a metavariable. This needs guarding              -- to prevent overwriting case defs with a metavar, if the case              -- defs come after the type decl in the same script!-             let ds' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, True))) ds+             let ds' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, True, True))) ds              in addDeferred ds'            _ -> return ()     RAddInstance className instName ->@@ -2524,7 +2528,7 @@          addIBC (IBCInstance False True className instName)     RClausesInstrs n cs ->       do logElab 3 $ "Pattern-matching definition from tactics: " ++ show n-         solveDeferred n+         solveDeferred emptyFC n          let lhss = map (\(_, lhs, _) -> lhs) cs          let fc = fileFC "elab_reflected"          pmissing <-@@ -2549,13 +2553,9 @@              -- we refer to, so that if they aren't total, the whole              -- thing won't be.              let (scargs, sc) = cases_compiletime cd-                 (scargs', sc') = cases_runtime cd-                 calls = findCalls sc' scargs-                 used = findUsedArgs sc' scargs'-                 cg = CGInfo scargs' calls [] used []-             in do logElab 2 $ "Called names in reflected elab: " ++ show cg-                   addToCG n cg-                   addToCalledG n (nub (map fst calls))+                 calls = map fst $ findCalls sc scargs+             in do logElab 2 $ "Called names in reflected elab: " ++ show calls+                   addCalls n calls                    addIBC $ IBCCG n            Just _ -> return () -- TODO throw internal error            Nothing -> return ()
src/Idris/Elab/Type.hs view
@@ -78,7 +78,7 @@           logElab 3 $ show ty ++ "\nElaborated: " ++ show tyT' -         ds <- checkAddDef True False fc iderr defer+         ds <- checkAddDef True False 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@@ -102,6 +102,18 @@          logElab 3 ("Implicit " ++ show n ++ " " ++ show impls)          addIBC (IBCImp n) +         -- 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 +         -- private, but can refer to any public/export+         let refs = freeNames cty+         nvis <- getFromHideList n+         case nvis of+              Nothing -> return ()+              Just acc -> mapM_ (checkVisibility fc n (max Frozen acc) acc) refs+         addCalls n refs+         addIBC (IBCCG n)+          when (Constructor `notElem` opts) $ do              let pnames = getParamsInType i [] impls cty              let fninfo = FnInfo (param_pos 0 pnames cty)@@ -161,9 +173,10 @@          -- 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 [(n, (-1, Nothing, usety, []))]+         ds <- checkDef fc iderr True [(n, (-1, Nothing, usety, []))]          addIBC (IBCDef n)-         let ds' = map (\(n, (i, top, fam, ns)) -> (n, (i, top, fam, ns, True))) ds+         addDefinedName n+         let ds' = map (\(n, (i, top, fam, ns)) -> (n, (i, top, fam, ns, True, True))) ds          addDeferred ds'          setFlags n opts'          checkDocs fc argDocs ty@@ -242,7 +255,7 @@     sendHighlighting [(nfc, AnnName n (Just PostulateOutput) Nothing Nothing)]      -- remove it from the deferred definitions list-    solveDeferred n+    solveDeferred fc n  elabExtern :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->                  FC -> FC -> FnOpts -> Name -> PTerm -> Idris ()@@ -255,4 +268,4 @@     addIBC (IBCExtern (n, arity))      -- remove it from the deferred definitions list-    solveDeferred n+    solveDeferred fc n
src/Idris/Elab/Utils.hs view
@@ -56,21 +56,23 @@ iderr :: Name -> Err -> Err iderr _ e = e -checkDef :: FC -> (Name -> Err -> Err) -> [(Name, (Int, Maybe Name, Type, [Name]))]-         -> Idris [(Name, (Int, Maybe Name, Type, [Name]))]-checkDef fc mkerr ns = checkAddDef False True fc mkerr ns+checkDef :: 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 -checkAddDef :: Bool -> Bool -> FC -> (Name -> Err -> Err)+checkAddDef :: Bool -> Bool -> FC -> (Name -> Err -> Err) -> Bool             -> [(Name, (Int, Maybe Name, Type, [Name]))]             -> Idris [(Name, (Int, Maybe Name, Type, [Name]))]-checkAddDef add toplvl fc mkerr [] = return []-checkAddDef add toplvl fc mkerr ((n, (i, top, t, psns)) : ns)+checkAddDef add toplvl fc mkerr def [] = return []+checkAddDef add toplvl fc mkerr definable ((n, (i, top, t, psns)) : ns)                = do ctxt <- getContext-                    logElab 5 $ "Rechecking deferred name " ++ show (n, t)+                    logElab 5 $ "Rechecking deferred name " ++ show (n, t, definable)                     (t', _) <- recheckC fc (mkerr n) [] t-                    when add $ do addDeferred [(n, (i, top, t, psns, toplvl))]+                    when add $ do addDeferred [(n, (i, top, t, psns, toplvl, definable))]                                   addIBC (IBCDef n)-                    ns' <- checkAddDef add toplvl fc mkerr ns+                    ns' <- checkAddDef add toplvl fc mkerr definable ns                     return ((n, (i, top, t', psns)) : ns')  -- | Get the list of (index, name) of inaccessible arguments from an elaborated@@ -314,3 +316,19 @@     | n `elem` ns = PPi (p { pstatic = Static }) n fc ty (mkStaticTy ns sc)     | otherwise = PPi p n fc ty (mkStaticTy ns sc) mkStaticTy ns t = t++-- Check that a name has the minimum required accessibility+checkVisibility :: FC -> Name -> Accessibility -> Accessibility -> Name -> Idris ()+checkVisibility fc n minAcc acc ref +    = do nvis <- getFromHideList ref+         case nvis of+              Nothing -> return ()+              Just acc' -> if acc' > minAcc +                              then tclift $ tfail (At fc +                                      (Msg $ show acc ++ " " ++ show n ++ +                                             " can't refer to " ++ +                                             show acc' ++ " " ++ show ref))+                              else return ()+++
src/Idris/Elab/Value.hs view
@@ -75,8 +75,8 @@          let vtm = orderPats (getInferTerm tm') -        def' <- checkDef (fileFC "(input)") iderr defer-        let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, True))) def'+        def' <- checkDef (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
src/Idris/ElabDecls.hs view
@@ -242,9 +242,9 @@   | what /= EDefns     = do logElab 1 $ "Elaborating class " ++ show n          elabClass info (s { syn_params = [] }) doc f cs n nfc ps pdocs fds ds cn cd-elabDecl' what info (PInstance doc argDocs s f cs n nfc ps t expn ds)+elabDecl' what info (PInstance doc argDocs s f cs acc fnopts n nfc ps t expn ds)     = do logElab 1 $ "Elaborating instance " ++ show n-         elabInstance info s doc argDocs what f cs n nfc ps t expn ds+         elabInstance info s doc argDocs what f cs acc fnopts n nfc ps t expn ds elabDecl' what info (PRecord doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn)     = do logElab 1 $ "Elaborating record " ++ show name          elabRecord info what doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn
− src/Idris/ElabQuasiquote.hs 
@@ -1,175 +0,0 @@-module Idris.ElabQuasiquote (extractUnquotes) where--import Idris.Core.Elaborate hiding (Tactic(..))-import Idris.Core.TT-import Idris.AbsSyntax---extract1 :: Int -> (PTerm -> a) -> PTerm -> Elab' aux (a, [(Name, PTerm)])-extract1 n c tm = do (tm', ex) <- extractUnquotes n tm-                     return (c tm', ex)--extract2 :: Int -> (PTerm -> PTerm -> a) -> PTerm -> PTerm -> Elab' aux (a, [(Name, PTerm)])-extract2 n c a b = do (a', ex1) <- extractUnquotes n a-                      (b', ex2) <- extractUnquotes n b-                      return (c a' b', ex1 ++ ex2)--extractTUnquotes :: Int -> PTactic -> Elab' aux (PTactic, [(Name, PTerm)])-extractTUnquotes n (Rewrite t) = extract1 n Rewrite t-extractTUnquotes n (Induction t) = extract1 n Induction t-extractTUnquotes n (LetTac name t) = extract1 n (LetTac name) t-extractTUnquotes n (LetTacTy name t1 t2) = extract2 n (LetTacTy name) t1 t2-extractTUnquotes n (Exact tm) = extract1 n Exact tm-extractTUnquotes n (Try tac1 tac2)-  = do (tac1', ex1) <- extractTUnquotes n tac1-       (tac2', ex2) <- extractTUnquotes n tac2-       return (Try tac1' tac2', ex1 ++ ex2)-extractTUnquotes n (TSeq tac1 tac2)-  = do (tac1', ex1) <- extractTUnquotes n tac1-       (tac2', ex2) <- extractTUnquotes n tac2-       return (TSeq tac1' tac2', ex1 ++ ex2)-extractTUnquotes n (ApplyTactic t) = extract1 n ApplyTactic t-extractTUnquotes n (ByReflection t) = extract1 n ByReflection t-extractTUnquotes n (Reflect t) = extract1 n Reflect t-extractTUnquotes n (GoalType s tac)-  = do (tac', ex) <- extractTUnquotes n tac-       return (GoalType s tac', ex)-extractTUnquotes n (TCheck t) = extract1 n TCheck t-extractTUnquotes n (TEval t) = extract1 n TEval t-extractTUnquotes n (Claim name t) = extract1 n (Claim name) t-extractTUnquotes n tac = return (tac, []) -- the rest don't contain PTerms, or have been desugared away--extractPArgUnquotes :: Int -> PArg -> Elab' aux (PArg, [(Name, PTerm)])-extractPArgUnquotes d (PImp p m opts n t) =-  do (t', ex) <- extractUnquotes d t-     return (PImp p m opts n t', ex)-extractPArgUnquotes d (PExp p opts n t) =-  do (t', ex) <- extractUnquotes d t-     return (PExp p opts n t', ex)-extractPArgUnquotes d (PConstraint p opts n t) =-  do (t', ex) <- extractUnquotes d t-     return (PConstraint p opts n t', ex)-extractPArgUnquotes d (PTacImplicit p opts n scpt t) =-  do (scpt', ex1) <- extractUnquotes d scpt-     (t', ex2) <- extractUnquotes d t-     return (PTacImplicit p opts n scpt' t', ex1 ++ ex2)--extractDoUnquotes :: Int -> PDo -> Elab' aux (PDo, [(Name, PTerm)])-extractDoUnquotes d (DoExp fc tm)-  = do (tm', ex) <- extractUnquotes d tm-       return (DoExp fc tm', ex)-extractDoUnquotes d (DoBind fc n nfc tm)-  = do (tm', ex) <- extractUnquotes d tm-       return (DoBind fc n nfc tm', ex)-extractDoUnquotes d (DoBindP fc t t' alts)-  = fail "Pattern-matching binds cannot be quasiquoted"-extractDoUnquotes d (DoLet  fc n nfc v b)-  = do (v', ex1) <- extractUnquotes d v-       (b', ex2) <- extractUnquotes d b-       return (DoLet fc n nfc v' b', ex1 ++ ex2)-extractDoUnquotes d (DoLetP fc t t') = fail "Pattern-matching lets cannot be quasiquoted"---extractUnquotes :: Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)])-extractUnquotes n (PLam fc name nfc ty body)-  = do (ty', ex1) <- extractUnquotes n ty-       (body', ex2) <- extractUnquotes n body-       return (PLam fc name nfc ty' body', ex1 ++ ex2)-extractUnquotes n (PPi plicity name fc ty body)-  = do (ty', ex1) <- extractUnquotes n ty-       (body', ex2) <- extractUnquotes n body-       return (PPi plicity name fc ty' body', ex1 ++ ex2)-extractUnquotes n (PLet fc name nfc ty val body)-  = do (ty', ex1) <- extractUnquotes n ty-       (val', ex2) <- extractUnquotes n val-       (body', ex3) <- extractUnquotes n body-       return (PLet fc name nfc ty' val' body', ex1 ++ ex2 ++ ex3)-extractUnquotes n (PTyped tm ty)-  = do (tm', ex1) <- extractUnquotes n tm-       (ty', ex2) <- extractUnquotes n ty-       return (PTyped tm' ty', ex1 ++ ex2)-extractUnquotes n (PApp fc f args)-  = do (f', ex1) <- extractUnquotes n f-       args' <- mapM (extractPArgUnquotes n) args-       let (args'', exs) = unzip args'-       return (PApp fc f' args'', ex1 ++ concat exs)-extractUnquotes n (PAppBind fc f args)-  = do (f', ex1) <- extractUnquotes n f-       args' <- mapM (extractPArgUnquotes n) args-       let (args'', exs) = unzip args'-       return (PAppBind fc f' args'', ex1 ++ concat exs)-extractUnquotes n (PCase fc expr cases)-  = do (expr', ex1) <- extractUnquotes n expr-       let (pats, rhss) = unzip cases-       (pats', exs1) <- fmap unzip $ mapM (extractUnquotes n) pats-       (rhss', exs2) <- fmap unzip $ mapM (extractUnquotes n) rhss-       return (PCase fc expr' (zip pats' rhss'), ex1 ++ concat exs1 ++ concat exs2)-extractUnquotes n (PIfThenElse fc c t f)-  = do (c', ex1) <- extractUnquotes n c-       (t', ex2) <- extractUnquotes n t-       (f', ex3) <- extractUnquotes n f-       return (PIfThenElse fc c' t' f', ex1 ++ ex2 ++ ex3)-extractUnquotes n (PRewrite fc x y z)-  = do (x', ex1) <- extractUnquotes n x-       (y', ex2) <- extractUnquotes n y-       case z of-         Just zz -> do (z', ex3) <- extractUnquotes n zz-                       return (PRewrite fc x' y' (Just z'), ex1 ++ ex2 ++ ex3)-         Nothing -> return (PRewrite fc x' y' Nothing, ex1 ++ ex2)-extractUnquotes n (PPair fc hls info l r)-  = do (l', ex1) <- extractUnquotes n l-       (r', ex2) <- extractUnquotes n r-       return (PPair fc hls info l' r', ex1 ++ ex2)-extractUnquotes n (PDPair fc hls info a b c)-  = do (a', ex1) <- extractUnquotes n a-       (b', ex2) <- extractUnquotes n b-       (c', ex3) <- extractUnquotes n c-       return (PDPair fc hls info a' b' c', ex1 ++ ex2 ++ ex3)-extractUnquotes n (PAlternative ms b alts)-  = do alts' <- mapM (extractUnquotes n) alts-       let (alts'', exs) = unzip alts'-       return (PAlternative ms b alts'', concat exs)-extractUnquotes n (PHidden tm)-  = do (tm', ex) <- extractUnquotes n tm-       return (PHidden tm', ex)-extractUnquotes n (PGoal fc a name b)-  = do (a', ex1) <- extractUnquotes n a-       (b', ex2) <- extractUnquotes n b-       return (PGoal fc a' name b', ex1 ++ ex2)-extractUnquotes n (PDoBlock steps)-  = do steps' <- mapM (extractDoUnquotes n) steps-       let (steps'', exs) = unzip steps'-       return (PDoBlock steps'', concat exs)-extractUnquotes n (PIdiom fc tm)-  = fmap (\(tm', ex) -> (PIdiom fc tm', ex)) $ extractUnquotes n tm-extractUnquotes n (PProof tacs)-  = do (tacs', exs) <- fmap unzip $ mapM (extractTUnquotes n) tacs-       return (PProof tacs', concat exs)-extractUnquotes n (PTactics tacs)-  = do (tacs', exs) <- fmap unzip $ mapM (extractTUnquotes n) tacs-       return (PTactics tacs', concat exs)-extractUnquotes n (PElabError err) = fail "Can't quasiquote an error"-extractUnquotes n (PCoerced tm)-  = do (tm', ex) <- extractUnquotes n tm-       return (PCoerced tm', ex)-extractUnquotes n (PDisamb ns tm)-  = do (tm', ex) <- extractUnquotes n tm-       return (PDisamb ns tm', ex)-extractUnquotes n (PUnifyLog tm)-  = fmap (\(tm', ex) -> (PUnifyLog tm', ex)) $ extractUnquotes n tm-extractUnquotes n (PNoImplicits tm)-  = fmap (\(tm', ex) -> (PNoImplicits tm', ex)) $ extractUnquotes n tm-extractUnquotes n (PQuasiquote tm goal)-  = fmap (\(tm', ex) -> (PQuasiquote tm' goal, ex)) $ extractUnquotes (n+1) tm-extractUnquotes n (PUnquote tm)-  | n == 0 = do n <- getNameFrom (sMN 0 "unquotation")-                return (PRef (fileFC "(unquote)") [] n, [(n, tm)])-  | otherwise = fmap (\(tm', ex) -> (PUnquote tm', ex)) $-                extractUnquotes (n-1) tm-extractUnquotes n (PRunElab fc tm ns)-  = fmap (\(tm', ex) -> (PRunElab fc tm' ns, ex)) $ extractUnquotes n tm-extractUnquotes n (PConstSugar fc tm)-  = extractUnquotes n tm-extractUnquotes n x = return (x, []) -- no subterms!--
src/Idris/IBC.hs view
@@ -3,7 +3,7 @@  module Idris.IBC (loadIBC, loadPkgIndex,                   writeIBC, writePkgIndex,-                  hasValidIBCVersion) where+                  hasValidIBCVersion, IBCPhase(..)) where  import Idris.Core.Evaluate import Idris.Core.TT@@ -40,10 +40,18 @@ import Codec.Archive.Zip  ibcVersion :: Word16-ibcVersion = 128+ibcVersion = 136 +-- 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])],@@ -62,13 +70,10 @@                          ibc_cgflags :: ![(Codegen, String)],                          ibc_dynamic_libs :: ![String],                          ibc_hdrs :: ![(Codegen, String)],-                         ibc_access :: ![(Name, Accessibility)],-                         ibc_total :: ![(Name, Totality)],                          ibc_totcheckfail :: ![(FC, String)],                          ibc_flags :: ![(Name, [FnOpt])],                          ibc_fninfo :: ![(Name, FnInfo)],                          ibc_cg :: ![(Name, CGInfo)],-                         ibc_defs :: ![(Name, Def)],                          ibc_docstrings :: ![(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))],                          ibc_moduledocs :: ![(Name, Docstring D.DocTerm)],                          ibc_transforms :: ![(Name, (Term, Term))],@@ -79,7 +84,7 @@                          ibc_metainformation :: ![(Name, MetaInformation)],                          ibc_errorhandlers :: ![Name],                          ibc_function_errorhandlers :: ![(Name, Name, Name)], -- fn, arg, handler-                         ibc_metavars :: ![(Name, (Maybe Name, Int, [Name], Bool))],+                         ibc_metavars :: ![(Name, (Maybe Name, Int, [Name], Bool, Bool))],                          ibc_patdefs :: ![(Name, ([([(Name, Term)], Term, Term)], [PTerm]))],                          ibc_postulates :: ![Name],                          ibc_externs :: ![(Name, Int)],@@ -87,7 +92,10 @@                          ibc_usage :: ![(Name, Int)],                          ibc_exports :: ![Name],                          ibc_autohints :: ![(Name, Name)],-                         ibc_deprecated :: ![(Name, String)]+                         ibc_deprecated :: ![(Name, String)],+                         ibc_defs :: ![(Name, Def)],+                         ibc_total :: ![(Name, Totality)],+                         ibc_access :: ![(Name, Accessibility)]                        }    deriving Show {-!@@ -95,7 +103,7 @@ !-}  initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] []+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] [] [] [] []  hasValidIBCVersion :: FilePath -> Idris Bool hasValidIBCVersion fp = do@@ -106,8 +114,9 @@                         return (ver == ibcVersion)  loadIBC :: Bool -- ^ True = reexport, False = make everything private+        -> IBCPhase         -> FilePath -> Idris ()-loadIBC reexport fp+loadIBC reexport phase fp            = do imps <- getImported                 let redo = case lookup fp imps of                                 Nothing -> True@@ -118,15 +127,16 @@                      case toArchiveOrFail archiveFile of                         Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"                                           ++ "Please clean and rebuild it."-                        Right archive -> do process reexport archive fp+                        Right archive -> do process reexport phase archive fp                                             addImported reexport fp+--                                             dumpTT  -- | Load an entire package from its index file loadPkgIndex :: String -> Idris () loadPkgIndex pkg = do ddir <- runIO $ getIdrisLibDir                       addImportDir (ddir </> pkg)                       fp <- findPkgIndex pkg-                      loadIBC True fp+                      loadIBC True IBC_Building fp   makeEntry :: (Binary b) => String -> [b] -> Maybe Entry@@ -156,13 +166,10 @@                        makeEntry "ibc_cgflags"  (ibc_cgflags i),                        makeEntry "ibc_dynamic_libs"  (ibc_dynamic_libs i),                        makeEntry "ibc_hdrs"  (ibc_hdrs i),-                       makeEntry "ibc_access"  (ibc_access i),-                       makeEntry "ibc_total"  (ibc_total i),                        makeEntry "ibc_totcheckfail"  (ibc_totcheckfail i),                        makeEntry "ibc_flags"  (ibc_flags i),                        makeEntry "ibc_fninfo"  (ibc_fninfo i),                        makeEntry "ibc_cg"  (ibc_cg i),-                       makeEntry "ibc_defs"  (ibc_defs i),                        makeEntry "ibc_docstrings"  (ibc_docstrings i),                        makeEntry "ibc_moduledocs"  (ibc_moduledocs i),                        makeEntry "ibc_transforms"  (ibc_transforms i),@@ -181,7 +188,10 @@                        makeEntry "ibc_usage"  (ibc_usage i),                        makeEntry "ibc_exports"  (ibc_exports i),                        makeEntry "ibc_autohints"  (ibc_autohints i),-                       makeEntry "ibc_deprecated"  (ibc_deprecated i)]+                       makeEntry "ibc_deprecated"  (ibc_deprecated i),+                       makeEntry "ibc_defs"  (ibc_defs i),+                       makeEntry "ibc_total"  (ibc_total i),+                       makeEntry "ibc_access"  (ibc_access i)]  writeArchive :: FilePath -> IBCFile -> Idris () writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArchive (entries i)@@ -315,8 +325,9 @@                 Just e -> return $! (force . decode . fromEntry) e  process :: Bool -- ^ Reexporting+           -> IBCPhase             -> Archive -> FilePath -> Idris ()-process reexp i fn = do+process reexp phase i fn = do                 ver <- getEntry 0 "ver" i                 when (ver /= ibcVersion) $ do                                     logIBC 1 "ibc out of date"@@ -328,7 +339,7 @@                 srcok <- runIO $ doesFileExist source                 when srcok $ timestampOlder source fn                 pImportDirs =<< getEntry [] "ibc_importdirs" i-                pImports reexp =<< getEntry [] "ibc_imports" i+                pImports reexp phase =<< getEntry [] "ibc_imports" i                 pImps =<< getEntry [] "ibc_implicits" i                 pFixes =<< getEntry [] "ibc_fixes" i                 pStatics =<< getEntry [] "ibc_statics" i@@ -345,12 +356,9 @@                 pCGFlags =<< getEntry [] "ibc_cgflags" i                 pDyLibs =<< getEntry [] "ibc_dynamic_libs" i                 pHdrs =<< getEntry [] "ibc_hdrs" i-                pDefs reexp =<< getEntry [] "ibc_defs" i                 pPatdefs =<< getEntry [] "ibc_patdefs" i-                pAccess reexp =<< getEntry [] "ibc_access" i                 pFlags =<< getEntry [] "ibc_flags" i                 pFnInfo =<< getEntry [] "ibc_fninfo" i-                pTotal =<< getEntry [] "ibc_total" i                 pTotCheckErr =<< getEntry [] "ibc_totcheckfail" i                 pCG =<< getEntry [] "ibc_cg" i                 pDocs =<< getEntry [] "ibc_docstrings" i@@ -371,6 +379,9 @@                 pExports =<< getEntry [] "ibc_exports" i                 pAutoHints =<< getEntry [] "ibc_autohints" i                 pDeprecate =<< getEntry [] "ibc_deprecated" i+                pDefs reexp =<< getEntry [] "ibc_defs" i+                pTotal =<< getEntry [] "ibc_total" i+                pAccess reexp phase =<< getEntry [] "ibc_access" i  timestampOlder :: FilePath -> FilePath -> Idris () timestampOlder src ibc = do srct <- runIO $ getModificationTime src@@ -404,8 +415,8 @@ pImportDirs :: [FilePath] -> Idris () pImportDirs fs = mapM_ addImportDir fs -pImports :: Bool -> [(Bool, FilePath)] -> Idris ()-pImports reexp fs+pImports :: Bool -> IBCPhase -> [(Bool, FilePath)] -> Idris ()+pImports reexp phase fs   = do mapM_ (\(re, f) ->                     do i <- getIState                        ibcsd <- valIBCSubDir i@@ -414,6 +425,9 @@ --                        if (f `elem` imported i) --                         then logLvl 1 $ "Already read " ++ f                        putIState (i { imported = f : imported i })+                       let phase' = case phase of+                                         IBC_REPL _ -> IBC_REPL False+                                         p -> p                        case fp of                             LIDR fn -> do                               logIBC 1 $ "Failed at " ++ fn@@ -421,7 +435,7 @@                             IDR fn -> do                               logIBC 1 $ "Failed at " ++ fn                               ifail "Must be an ibc"-                            IBC fn src -> loadIBC (reexp && re) fn)+                            IBC fn src -> loadIBC (reexp && re) phase' fn)              fs  pImps :: [(Name, [PArg])] -> Idris ()@@ -429,6 +443,7 @@                         do i <- getIState                            case lookupDefAccExact n False (tt_ctxt i) of                               Just (n, Hidden) -> return ()+                              Just (n, Private) -> return ()                               _ -> putIState (i { idris_implicits                                             = addDef n imp (idris_implicits i) }))                    imps@@ -518,12 +533,9 @@                   case d' of                        TyDecl _ _ -> return ()                        _ -> do logIBC 1 $ "SOLVING " ++ show n-                               solveDeferred n+                               solveDeferred emptyFC n                   updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })---                   logLvl 1 $ "Added " ++ show (n, d')-                  if (not reexp) then do logIBC 1 $ "Not exporting " ++ show n-                                         setAccessibility n Hidden-                                 else logIBC 1 $ "Exporting " ++ show n) ds+            ) ds   where     updateDef (CaseOp c t args o s cd)       = do o' <- mapM updateOrig o@@ -537,11 +549,9 @@                                    return $ Right (l', r')      updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))-        = do t' <- updateSC t-             c' <- updateSC c-             i' <- updateSC i+        = do c' <- updateSC c              r' <- updateSC r-             return $ CaseDefs (ts, t') (cs, c') (is, i') (rs, r')+             return $ CaseDefs (cs, c') (cs, c') (cs, c') (rs, r')      updateSC (Case t n alts) = do alts' <- mapM updateAlt alts                                   return (Case t n alts')@@ -562,19 +572,28 @@     updateAlt (DefaultCase t) = do t' <- updateSC t                                    return (DefaultCase t') -    update (P t n ty) = do n' <- getSymbol n-                           return $ P t n' ty-    update (App s f a) = liftM2 (App s) (update f) (update a)-    update (Bind n b sc) = do b' <- updateB b-                              sc' <- update sc-                              return $ Bind n b' sc'+    -- We get a lot of repetition in sub terms and can save a fair chunk+    -- of memory if we make sure they're shared. addTT looks for a term+    -- and returns it if it exists already, while also keeping stats of+    -- how many times a subterm is repeated.+    update t = do tm <- addTT t+                  case tm of+                       Nothing -> update' t+                       Just t' -> return t'++    update' (P t n ty) = do n' <- getSymbol n+                            return $ P t n' ty+    update' (App s f a) = liftM2 (App s) (update' f) (update' a)+    update' (Bind n b sc) = do b' <- updateB b+                               sc' <- update sc+                               return $ Bind n b' sc'       where-        updateB (Let t v) = liftM2 Let (update t) (update v)-        updateB b = do ty' <- update (binderTy b)+        updateB (Let t v) = liftM2 Let (update' t) (update' v)+        updateB b = do ty' <- update' (binderTy b)                        return (b { binderTy = ty' })-    update (Proj t i) = do t' <- update t-                           return $ Proj t' i-    update t = return t+    update' (Proj t i) = do t' <- update' t+                            return $ Proj t' i+    update' t = return t  pDocs :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))] -> Idris () pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds@@ -584,13 +603,23 @@             i { idris_moduledocs = addDef n d (idris_moduledocs i) })) ds  pAccess :: Bool -- ^ Reexporting?+           -> IBCPhase            -> [(Name, Accessibility)] -> Idris ()-pAccess reexp ds+pAccess reexp phase ds         = mapM_ (\ (n, a_in) ->                       do let a = if reexp then a_in else Hidden                          logIBC 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a-                         updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })) ds+                         updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) }) +                         if (not reexp) then do logIBC 1 $ "Not exporting " ++ show n+                                                setAccessibility n Hidden+                                        else logIBC 1 $ "Exporting " ++ show n+                         -- Everything should be available at the REPL from+                         -- things imported publicly+                         when (phase == IBC_REPL True) $ +                              setAccessibility n Public+                ) ds+ pFlags :: [(Name, [FnOpt])] -> Idris () pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds @@ -633,7 +662,7 @@ pFunctionErrorHandlers ns =  mapM_ (\ (fn,arg,handler) ->                                 addFunctionErrorHandlers fn arg [handler]) ns -pMetavars :: [(Name, (Maybe Name, Int, [Name], Bool))] -> Idris ()+pMetavars :: [(Name, (Maybe Name, Int, [Name], Bool, Bool))] -> Idris () pMetavars ns = updateIState (\i -> i { idris_metavars = L.reverse ns ++ idris_metavars i })  ----- For Cheapskate and docstrings@@ -753,18 +782,14 @@                    _ -> error "Corrupted binary data for SizeChange"  instance Binary CGInfo where-        put (CGInfo x1 x2 x3 x4 x5)+        put (CGInfo x1 x2 x3)           = do put x1-               put x2 --                put x3 -- Already used SCG info for totality check-               put x4-               put x5+               put x3         get           = do x1 <- get-               x2 <- get-               x4 <- get-               x5 <- get-               return (CGInfo x1 x2 [] x4 x5)+               x3 <- get+               return (CGInfo x1 [] x3)  instance Binary CaseType where         put x = case x of@@ -883,13 +908,13 @@                                    put x2                 -- all primitives just get added at the start, don't write                 Operator x1 x2 x3 -> do return ()-                CaseOp x1 x2 x2a x3 x3a x4 -> do putWord8 3-                                                 put x1-                                                 put x2-                                                 put x2a-                                                 put x3-                                                 -- no x3a-                                                 put x4+                -- no need to add/load original patterns, because they're not+                -- used again after totality checking+                CaseOp x1 x2 x3 _ _ x4 -> do putWord8 3+                                             put x1+                                             put x2+                                             put x3+                                             put x4         get           = do i <- getWord8                case i of@@ -903,10 +928,10 @@                    3 -> do x1 <- get                            x2 <- get                            x3 <- get-                           x4 <- get+--                            x4 <- get                            -- x3 <- get always []                            x5 <- get-                           return (CaseOp x1 x2 x3 x4 [] x5)+                           return (CaseOp x1 x2 x3 [] [] x5)                    _ -> error "Corrupted binary data for Def"  instance Binary Accessibility where@@ -914,13 +939,15 @@           = case x of                 Public -> putWord8 0                 Frozen -> putWord8 1-                Hidden -> putWord8 2+                Private -> putWord8 2+                Hidden -> putWord8 3         get           = do i <- getWord8                case i of                    0 -> return Public                    1 -> return Frozen-                   2 -> return Hidden+                   2 -> return Private+                   3 -> return Hidden                    _ -> error "Corrupted binary data for Accessibility"  safeToEnum :: (Enum a, Bounded a, Integral int) => String -> int -> a@@ -1235,7 +1262,7 @@                                                put x10                                                put x11                                                put x12-                PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 ->+                PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 ->                   do putWord8 8                      put x1                      put x2@@ -1248,6 +1275,8 @@                      put x9                      put x10                      put x11+                     put x12+                     put x13                 PDSL x1 x2 -> do putWord8 9                                  put x1                                  put x2@@ -1362,7 +1391,9 @@                            x9 <- get                            x10 <- get                            x11 <- get-                           return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)+                           x12 <- get+                           x13 <- get+                           return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)                    9 -> do x1 <- get                            x2 <- get                            return (PDSL x1 x2)
src/Idris/IdrisDoc.hs view
@@ -10,7 +10,7 @@ import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,                             Accessibility (..), isDConName, isFnName,                             isTConName)-import Idris.ParseHelpers (opChars)+import Idris.Parser.Helpers (opChars) import Idris.AbsSyntax import Idris.Docs import Idris.Docstrings (nullDocstring)@@ -182,7 +182,7 @@   -- | Whether a NsItem should be included in the documentation.---   It must not be Hidden and filterName must return True for the name.+--   It must not be Hidden/Private and filterName must return True for the name. --   Also it must have Docs -- without Docs, nothing can be done. filterInclude :: NsItem -- ^ Accessibility to check               -> Bool   -- ^ Predicate result@@ -254,7 +254,7 @@   let res = lookupDefAcc n False (tt_ctxt ist)   in case res of      [(_, acc)] -> acc-     _          -> Hidden+     _          -> Private  -- | Simple predicate for whether an NsItem has Docs hasDoc :: NsItem -- ^ The NsItem to test
src/Idris/Interactive.hs view
@@ -76,7 +76,7 @@     getIndent i n xs | take 9 xs == "instance " = i     getIndent i n xs | take (length n) xs == n = i     getIndent i n (x : xs) = getIndent (i + 1) n xs-          +     getAppName (PApp _ r _) = getAppName r     getAppName (PRef _ _ r) = r     getAppName (PTyped n _) = getAppName n@@ -120,7 +120,7 @@         if updatefile           then do let fb = fn ++ "~"                   runIO $ writeSource fb (unlines (before ++ nonblank)-                                        ++ extras ++ +                                        ++ extras ++                                            (if null extras then ""                                                     else "\n" ++ unlines rest))                   runIO $ copyFile fb fn@@ -193,7 +193,7 @@             case findSubstr ('?':n) line of                  Just (before, pos, after) ->                       [before ++ (if b then "(" else "") ++ "case _ of",-                       take (pos + (if b then 6 else 5)) (repeat ' ') ++ +                       take (pos + (if b then 6 else 5)) (repeat ' ') ++                              "case_val => ?" ++ n ++ (if b then ")" else "")                              ++ after]                  Nothing -> fail "No such metavariable"@@ -208,7 +208,7 @@          findSubstr n xs = findSubstr' [] 0 n xs -        findSubstr' acc i n xs | take (length n) xs == n +        findSubstr' acc i n xs | take (length n) xs == n                 = Just (reverse acc, i, drop (length n) xs)         findSubstr' acc i n [] = Nothing         findSubstr' acc i n (x : xs) = findSubstr' (x : acc) (i + 1) n xs@@ -217,7 +217,7 @@   -doProofSearch :: FilePath -> Bool -> Bool -> +doProofSearch :: FilePath -> Bool -> Bool ->                  Int -> Name -> [Name] -> Maybe Int -> Idris () doProofSearch fn updatefile rec l n hints Nothing     = doProofSearch fn updatefile rec l n hints (Just 20)@@ -230,15 +230,15 @@                     [] -> return n                     ns -> ierror (CantResolveAlts ns)          i <- getIState-         let (top, envlen, psnames, _) +         let (top, envlen, psnames)               = case lookup mn (idris_metavars i) of-                     Just (t, e, ns, False) -> (t, e, ns, False)-                     _ -> (Nothing, 0, [], True)+                     Just (t, e, ns, False, d) -> (t, e, ns)+                     _ -> (Nothing, 0, [])          let fc = fileFC fn          let body t = PProof [Try (TSeq Intros (ProofSearch rec False depth t psnames hints))                                   (ProofSearch rec False depth t psnames hints)]          let def = PClause fc mn (PRef fc [] mn) [] (body top) []-         newmv <- idrisCatch+         newmv_pre <- idrisCatch              (do elabDecl' EAll recinfo (PClauses fc [] mn [def])                  (tm, ty) <- elabVal recinfo ERHS (PRef fc [] mn)                  ctxt <- getContext@@ -249,10 +249,11 @@                         (dropCtxt envlen                            (delab i (fst (specialise ctxt [] [(mn, 1)] tm))))))              (\e -> return ("?" ++ show n))+         let newmv = guessBrackets False tyline (show n) newmv_pre          if updatefile then             do let fb = fn ++ "~"                runIO $ writeSource fb (unlines before ++-                                     updateMeta False tyline (show n) newmv ++ "\n"+                                     updateMeta tyline (show n) newmv ++ "\n"                                        ++ unlines later)                runIO $ copyFile fb fn             else iPrintResult newmv@@ -270,18 +271,34 @@           nsroot (SN (WhereN _ _ n)) = nsroot n           nsroot n = n -updateMeta brack ('?':cs) n new+updateMeta ('?':cs) n new     | length cs >= length n       = case splitAt (length n) cs of              (mv, c:cs) ->                   if ((isSpace c || c == ')' || c == '}') && mv == n)-                     then addBracket brack new ++ (c : cs)-                     else '?' : mv ++ c : updateMeta True cs n new+                     then new ++ (c : cs)+                     else '?' : mv ++ c : updateMeta cs n new+             (mv, []) -> if (mv == n) then new else '?' : mv+updateMeta ('=':'>':cs) n new = '=':'>':updateMeta cs n new+updateMeta ('=':cs) n new = '=':updateMeta cs n new+updateMeta (c:cs) n new+  = c : updateMeta cs n new+updateMeta [] n new = ""++guessBrackets brack ('?':cs) n new+    | length cs >= length n+      = case splitAt (length n) cs of+             (mv, c:cs) ->+                  if ((isSpace c || c == ')' || c == '}') && mv == n)+                     then addBracket brack new+                     else guessBrackets True cs n new              (mv, []) -> if (mv == n) then addBracket brack new else '?' : mv-updateMeta brack ('=':cs) n new = '=':updateMeta False cs n new-updateMeta brack (c:cs) n new -  = c : updateMeta (brack || not (isSpace c)) cs n new-updateMeta brack [] n new = ""+guessBrackets brack ('=':'>':cs) n new = guessBrackets False cs n new+guessBrackets brack ('-':'>':cs) n new = guessBrackets False cs n new+guessBrackets brack ('=':cs) n new = guessBrackets False cs n new+guessBrackets brack (c:cs) n new+  = guessBrackets (brack || not (isSpace c)) cs n new+guessBrackets brack [] n new = ""  checkProv line n = isProv' False line n   where@@ -291,7 +308,7 @@     isProv' _ ('}':cs) n = isProv' True cs n     isProv' p (_:cs) n = isProv' p cs n     isProv' _ [] n = False-    + addBracket False new = new addBracket True new@('(':xs) | last xs == ')' = new addBracket True new | any isSpace new = '(' : new ++ ")"@@ -305,7 +322,7 @@          -- if the name is in braces, rather than preceded by a ?, treat it         -- as a lemma in a provisional definition-        +         let isProv = checkProv tyline (show n)          ctxt <- getContext@@ -315,18 +332,19 @@                           ns -> ierror (CantResolveAlts (map fst ns))         i <- getIState         margs <- case lookup fname (idris_metavars i) of-                      Just (_, arity, _, _) -> return arity+                      Just (_, arity, _, _, _) -> return arity                       _ -> return (-1)          if (not isProv) then do             let skip = guessImps i (tt_ctxt i) mty-            let classes = guessClasses i (tt_ctxt i) mty+            let impty = stripMNBind skip margs (delab i mty)+            let classes = guessClasses i (tt_ctxt i) [] (allNamesIn impty) mty -            let lem = show n ++ " : " ++ +            let lem = show n ++ " : " ++                             constraints i classes mty ++                             showTmOpts (defaultPPOption { ppopt_pinames = True })-                                       (stripMNBind skip margs (delab i mty))-            let lem_app = show n ++ appArgs skip margs mty+                                       impty+            let lem_app = guessBrackets False tyline (show n) (show n ++ appArgs skip margs mty)              if updatefile then                do let fb = fn ++ "~"@@ -362,27 +380,34 @@   where getIndent s = length (takeWhile isSpace s)          appArgs skip 0 _ = ""-        appArgs skip i (Bind n@(UN c) (Pi _ _ _) sc) +        appArgs skip i (Bind n@(UN c) (Pi _ _ _) sc)            | (thead c /= '_' && n `notElem` skip)                 = " " ++ show n ++ appArgs skip (i - 1) sc         appArgs skip i (Bind _ (Pi _ _ _) sc) = appArgs skip (i - 1) sc         appArgs skip i _ = "" -        stripMNBind _ args t | args <= 0 = t-        stripMNBind skip args (PPi b n@(UN c) _ ty sc) +        stripMNBind _ args t | args <= 0 = stripImp t+        stripMNBind skip args (PPi b n@(UN c) _ ty sc)            | n `notElem` skip ||                take 4 (str c) == "__pi" -- keep in type, but not in app-                = PPi b n NoFC ty (stripMNBind skip (args - 1) sc)+                = PPi b n NoFC (stripImp ty) (stripMNBind skip (args - 1) sc)         stripMNBind skip args (PPi b _ _ ty sc) = stripMNBind skip (args - 1) sc-        stripMNBind skip args t = t+        stripMNBind skip args t = stripImp t +        stripImp (PApp fc f as) = PApp fc (stripImp f) (map placeholderImp as)+          where+            placeholderImp tm@(PImp _ _ _ _ _) = tm { getTm = Placeholder }+            placeholderImp tm = tm { getTm = stripImp (getTm tm) }+        stripImp (PPi b n f ty sc) = PPi b n f (stripImp ty) (stripImp sc)+        stripImp t = t+         constraints :: IState -> [Name] -> Type -> String         constraints i [] ty = ""         constraints i [n] ty = showSep ", " (showConstraints i [n] ty) ++ " => "         constraints i ns ty = "(" ++ showSep ", " (showConstraints i ns ty) ++ ") => "          showConstraints i ns (Bind n (Pi _ ty _) sc)-            | n `elem` ns = show (delab i ty) : +            | n `elem` ns = show (delab i ty) :                               showConstraints i ns (substV (P Bound n Erased) sc)             | otherwise = showConstraints i ns (substV (P Bound n Erased) sc)         showConstraints _ _ _ = []@@ -393,10 +418,10 @@         -- Also, make type class instances implicit         guessImps :: IState -> Context -> Term -> [Name]         -- machine names aren't lifted-        guessImps ist ctxt (Bind n@(MN _ _) (Pi _ ty _) sc) +        guessImps ist ctxt (Bind n@(MN _ _) (Pi _ ty _) sc)            = n : guessImps ist ctxt sc         guessImps ist ctxt (Bind n (Pi _ ty _) sc)-           | guarded ctxt n (substV (P Bound n Erased) sc) +           | guarded ctxt n (substV (P Bound n Erased) sc)                 = n : guessImps ist ctxt sc            | isClass ist ty                 = n : guessImps ist ctxt sc@@ -404,30 +429,37 @@            | ignoreName n = n : guessImps ist ctxt sc            | otherwise = guessImps ist ctxt sc         guessImps ist ctxt _ = []-       +         paramty (TType _) = True         paramty (Bind _ (Pi _ (TType _) _) sc) = paramty sc         paramty _ = False-        +         -- TMP HACK unusable name so don't lift         ignoreName n = case show n of                             "_aX" -> True                             _ -> False -        guessClasses :: IState -> Context -> Term -> [Name]-        guessClasses ist ctxt (Bind n (Pi _ ty _) sc)-           | isParamClass ist ty-                = n : guessClasses ist ctxt sc-           | otherwise = guessClasses ist ctxt sc-        guessClasses ist ctxt _ = []+        guessClasses :: IState -> Context -> [Name] -> [Name] -> Term -> [Name]+        guessClasses ist ctxt binders usednames (Bind n (Pi _ ty _) sc)+           | isParamClass ist ty && any (\x -> elem x usednames)+                                        (paramNames binders ty)+                = n : guessClasses ist ctxt (n : binders) usednames sc+           | otherwise = guessClasses ist ctxt (n : binders) usednames sc+        guessClasses ist ctxt _ _ _ = [] +        paramNames bs ty | (P _ _ _, args) <- unApply ty+             = vnames args+          where vnames [] = []+                vnames (V i : xs) | i < length bs = bs !! i : vnames xs+                vnames (_ : xs) = vnames xs+         isClass ist t            | (P _ n _, args) <- unApply t                 = case lookupCtxtExact n (idris_classes ist) of                        Just _ -> True                        _ -> False            | otherwise = False-        +         isParamClass ist t            | (P _ n _, args) <- unApply t                 = case lookupCtxtExact n (idris_classes ist) of@@ -443,18 +475,18 @@               isConName f ctxt = any (guarded ctxt n) args --         guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows --             | thead cn /= '_' = guarded ctxt n t || guarded ctxt n sc-        guarded ctxt n (Bind _ (Pi _ t _) sc) +        guarded ctxt n (Bind _ (Pi _ t _) sc)             = guarded ctxt n t || guarded ctxt n sc         guarded ctxt n _ = False          blank = all isSpace          addLem before tyline lem lem_app later-            = let (bef_end, blankline : bef_start) +            = let (bef_end, blankline : bef_start)                        = case span (not . blank) (reverse before) of                               (bef, []) -> (bef, "" : [])                               x -> x-                  mvline = updateMeta False tyline (show n) lem_app in+                  mvline = updateMeta tyline (show n) lem_app in                 unlines $ reverse bef_start ++                           [blankline, lem, blankline] ++                           reverse bef_end ++ mvline : later@@ -464,6 +496,6 @@                       = case span (not . blank) later of                              (bef, []) -> (bef, "" : [])                              x -> x in-                  unlines $ before ++ tyline : +                  unlines $ before ++ tyline :                             (later_bef ++ [blankline, lem_app, blankline] ++                                       later_end)
− src/Idris/ParseData.hs 
@@ -1,338 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}-module Idris.ParseData 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 qualified Text.Parser.Token as Tok-import qualified Text.Parser.Char as Chr-import qualified Text.Parser.Token.Highlight as Hi--import Idris.AbsSyntax-import Idris.ParseHelpers-import Idris.ParseOps-import Idris.ParseExpr-import Idris.DSL--import Idris.Core.TT-import Idris.Core.Evaluate--import Idris.Docstrings--import Control.Applicative-import Control.Monad-import Control.Monad.State.Strict--import Data.Maybe-import qualified Data.List.Split as Spl-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-Record ::=-    DocComment Accessibility? 'record' FnName TypeSig 'where' OpenBlock Constructor KeepTerminator CloseBlock;--}-record :: SyntaxInfo -> IdrisParser PDecl-record syn = do (doc, paramDocs, acc, opts) <- try (do-                      (doc, paramDocs) <- option noDocs docComment-                      ist <- get-                      let doc' = annotCode (tryFullExpr syn ist) doc-                          paramDocs' = [ (n, annotCode (tryFullExpr syn ist) d)-                                     | (n, d) <- paramDocs ]-                      acc <- optional accessibility-                      opts <- dataOpts []-                      co <- recordI-                      return (doc', paramDocs', acc, opts ++ co))-                fc <- getFC-                (tyn_in, nfc) <- fnName-                let tyn = expandNS syn tyn_in-                let rsyn = syn { syn_namespace = show (nsroot tyn) :-                                                    syn_namespace syn }-                params <- manyTill (recordParameter rsyn) (reservedHL "where")-                (fields, cname, cdoc) <- indentedBlockS $ recordBody rsyn tyn-                case cname of-                     Just cn' -> accData acc tyn [fst cn']-                     Nothing -> return ()-                return $ PRecord doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc syn-             <?> "record type declaration"-  where-    getRecNames :: SyntaxInfo -> PTerm -> [Name]-    getRecNames syn (PPi _ n _ _ sc) = [expandNS syn n, expandNS syn (mkType n)]-                                         ++ getRecNames syn sc-    getRecNames _ _ = []--    toFreeze :: Maybe Accessibility -> Maybe Accessibility-    toFreeze (Just Frozen) = Just Hidden-    toFreeze x = x--    recordBody :: SyntaxInfo -> Name -> IdrisParser ([((Maybe (Name, FC)), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))], Maybe (Name, FC), Docstring (Either Err PTerm))-    recordBody syn tyn = do-        ist <- get-        fc  <- getFC--        (constructorName, constructorDoc) <- option (Nothing, emptyDocstring)-                                             (do (doc, _) <- option noDocs docComment-                                                 n <- constructor-                                                 return (Just n, doc))--        let constructorDoc' = annotate syn ist constructorDoc--        fields <- many . indented $ fieldLine syn--        return (concat fields, constructorName, constructorDoc')-      where-        fieldLine :: SyntaxInfo -> IdrisParser [(Maybe (Name, FC), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))]-        fieldLine syn = do-            doc <- optional docComment-            c <- optional $ lchar '{'-            let oneName = (do (n, nfc) <- fnName-                              return $ Just (expandNS syn n, nfc))-                          <|> (symbol "_" >> return Nothing)-            ns <- commaSeparated oneName-            lchar ':'-            t <- typeExpr (allowImp syn)-            p <- endPlicity c-            ist <- get-            let doc' = case doc of -- Temp: Throws away any possible arg docs-                        Just (d,_) -> Just $ annotate syn ist d-                        Nothing    -> Nothing-            return $ map (\n -> (n, p, t, doc')) ns--        constructor :: IdrisParser (Name, FC)-        constructor = (reservedHL "constructor") *> fnName---        endPlicity :: Maybe Char -> IdrisParser Plicity-        endPlicity (Just _) = do lchar '}'-                                 return impl-        endPlicity Nothing = return expl--        annotate :: SyntaxInfo -> IState -> Docstring () -> Docstring (Either Err PTerm)-        annotate syn ist = annotCode $ tryFullExpr syn ist--recordParameter :: SyntaxInfo -> IdrisParser (Name, FC, Plicity, PTerm)-recordParameter syn =-  (do lchar '('-      (n, nfc, pt) <- (namedTy syn <|> onlyName syn)-      lchar ')'-      return (n, nfc, expl, pt))-  <|>-  (do (n, nfc, pt) <- onlyName syn-      return (n, nfc, expl, pt))-  where-    namedTy :: SyntaxInfo -> IdrisParser (Name, FC, PTerm)-    namedTy syn =-      do (n, nfc) <- fnName-         lchar ':'-         ty <- typeExpr (allowImp syn)-         return (expandNS syn n, nfc, ty)-    onlyName :: SyntaxInfo -> IdrisParser (Name, FC, PTerm)-    onlyName syn =-      do (n, nfc) <- fnName-         fc <- getFC-         return (expandNS syn n, nfc, PType fc)--{- | Parses data declaration type (normal or codata)-DataI ::= 'data' | 'codata';--}-dataI :: IdrisParser DataOpts-dataI = do reservedHL "data"; return []-    <|> do reservedHL "codata"; return [Codata]--recordI :: IdrisParser DataOpts-recordI = do reservedHL "record"; return []-          <|> do reservedHL "corecord"; return [Codata]--{- | Parses if a data should not have a default eliminator-DefaultEliminator ::= 'noelim'?- -}-dataOpts :: DataOpts -> IdrisParser DataOpts-dataOpts opts-    = do fc <- reservedFC "%elim"-         warnElim fc-         dataOpts (DefaultEliminator : DefaultCaseFun : opts)-  <|> do fc <- reservedFC "%case"-         warnElim fc-         dataOpts (DefaultCaseFun : opts)-  <|> do reserved "%error_reverse"; dataOpts (DataErrRev : opts)-  <|> return opts-  <?> "data options"-  where warnElim fc =-          do ist <- get-             let cmdline = opt_cmdline (idris_options ist)-             unless (NoElimDeprecationWarnings `elem` cmdline) $-               put ist { parserWarnings =-                           (fc, Msg "Eliminator generation is deprecated. Use an eliminator generator in a library instead.") : parserWarnings ist }--{- | Parses a data type declaration-Data ::= DocComment? Accessibility? DataI DefaultEliminator FnName TypeSig ExplicitTypeDataRest?-       | DocComment? Accessibility? DataI DefaultEliminator FnName Name*   DataRest?-       ;-Constructor' ::= Constructor KeepTerminator;-ExplicitTypeDataRest ::= 'where' OpenBlock Constructor'* CloseBlock;--DataRest ::= '=' SimpleConstructorList Terminator-            | 'where'!-           ;-SimpleConstructorList ::=-    SimpleConstructor-  | SimpleConstructor '|' SimpleConstructorList-  ;--}-data_ :: SyntaxInfo -> IdrisParser PDecl-data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do-                    (doc, argDocs) <- option noDocs docComment-                    pushIndent-                    acc <- optional accessibility-                    elim <- dataOpts []-                    co <- dataI-                    ist <- get-                    let dataOpts = combineDataOpts (elim ++ co)-                        doc' = annotCode (tryFullExpr syn ist) doc-                        argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)-                                   | (n, d) <- argDocs ]-                    return (doc', argDocs', acc, dataOpts))-               fc <- getFC-               (tyn_in, nfc) <- fnName-               (do try (lchar ':')-                   popIndent-                   ty <- typeExpr (allowImp syn)-                   let tyn = expandNS syn tyn_in-                   option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn nfc ty)) (do-                     reservedHL "where"-                     cons <- indentedBlock (constructor syn)-                     accData acc tyn (map (\ (_, _, n, _, _, _, _) -> n) cons)-                     return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn nfc ty cons))) <|> (do-                    args <- many (fst <$> name)-                    let ty = bindArgs (map (const (PType fc)) args) (PType fc)-                    let tyn = expandNS syn tyn_in-                    option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn nfc ty)) (do-                      try (lchar '=') <|> do reservedHL "where"-                                             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 ns = concat (intersperse " -> " $ map ((\x -> "(" ++ x ++ " : Type)") . show) args)-                                             let ss = concat (intersperse " -> " $ map (const "Type") args)-                                             let fix1 = s ++ as ++ " = ..."-                                             let fix2 = s ++ ": " ++ ns ++ " -> Type where\n  ..."-                                             let fix3 = s ++ ": " ++ ss ++ " -> Type where\n  ..."-                                             fail $ fixErrorMsg "unexpected \"where\"" [fix1, fix2, fix3]-                      cons <- sepBy1 (simpleConstructor syn) (reservedOp "|")-                      terminator-                      let conty = mkPApp fc (PRef fc [] tyn) (map (PRef fc []) args)-                      cons' <- mapM (\ (doc, argDocs, x, xfc, cargs, cfc, fs) ->-                                   do let cty = bindArgs cargs conty-                                      return (doc, argDocs, x, xfc, cty, cfc, fs)) cons-                      accData acc tyn (map (\ (_, _, n, _, _, _, _) -> n) cons')-                      return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn nfc ty cons')))-           <?> "data type declaration"-  where-    mkPApp :: FC -> PTerm -> [PTerm] -> PTerm-    mkPApp fc t [] = t-    mkPApp fc t xs = PApp fc t (map pexp xs)-    bindArgs :: [PTerm] -> PTerm -> PTerm-    bindArgs xs t = foldr (PPi expl (sMN 0 "_t") NoFC) t xs-    combineDataOpts :: DataOpts -> DataOpts-    combineDataOpts opts = if Codata `elem` opts-                              then delete DefaultEliminator opts-                              else opts---{- | Parses a type constructor declaration-  Constructor ::= DocComment? FnName TypeSig;--}-constructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name])-constructor syn-    = do (doc, argDocs) <- option noDocs docComment-         (cn_in, nfc) <- fnName; fc <- getFC-         let cn = expandNS syn cn_in-         lchar ':'-         fs <- option [] (do lchar '%'; reserved "erase"-                             sepBy1 (fst <$> name) (lchar ','))-         ty <- typeExpr (allowImp syn)-         ist <- get-         let doc' = annotCode (tryFullExpr syn ist) doc-             argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)-                        | (n, d) <- argDocs ]-         return (doc', argDocs', cn, nfc, ty, fc, fs)-      <?> "constructor"--{- | Parses a constructor for simple discriminated union data types-  SimpleConstructor ::= FnName SimpleExpr* DocComment?--}-simpleConstructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, [PTerm], FC, [Name])-simpleConstructor syn-     = do (doc, _) <- option noDocs (try docComment)-          ist <- get-          let doc' = annotCode (tryFullExpr syn ist) doc-          (cn_in, nfc) <- fnName-          let cn = expandNS syn cn_in-          fc <- getFC-          args <- many (do notEndApp-                           simpleExpr syn)-          return (doc', [], cn, nfc, args, fc, [])-       <?> "constructor"--{- | Parses a dsl block declaration-DSL ::= 'dsl' FnName OpenBlock Overload'+ CloseBlock;- -}-dsl :: SyntaxInfo -> IdrisParser PDecl-dsl syn = do reservedHL "dsl"-             n <- fst <$> fnName-             bs <- indentedBlock (overload syn)-             let dsl = mkDSL bs (dsl_info syn)-             checkDSL dsl-             i <- get-             put (i { idris_dsls = addDef n dsl (idris_dsls i) })-             return (PDSL n dsl)-          <?> "dsl block declaration"-    where mkDSL :: [(String, PTerm)] -> DSL -> DSL-          mkDSL bs dsl = let var    = lookup "variable" bs-                             first  = lookup "index_first" bs-                             next   = lookup "index_next" bs-                             leto   = lookup "let" bs-                             lambda = lookup "lambda" bs-                             pi     = lookup "pi" bs in-                             initDSL { dsl_var = var,-                                       index_first = first,-                                       index_next = next,-                                       dsl_lambda = lambda,-                                       dsl_let = leto,-                                       dsl_pi = pi }--{- | Checks DSL for errors -}--- FIXME: currently does nothing, check if DSL is really sane------ Issue #1595 on the Issue Tracker------     https://github.com/idris-lang/Idris-dev/issues/1595----checkDSL :: DSL -> IdrisParser ()-checkDSL dsl = return ()--{- | Parses a DSL overload declaration-OverloadIdentifier ::= 'let' | Identifier;-Overload ::= OverloadIdentifier '=' Expr;--}-overload :: SyntaxInfo -> IdrisParser (String, PTerm)-overload syn = do (o, fc) <- identifier <|> do fc <- reservedFC "let"-                                               return ("let", fc)-                  if o `notElem` overloadable-                     then fail $ show o ++ " is not an overloading"-                     else do-                       highlightP fc AnnKeyword-                       lchar '='-                       t <- expr syn-                       return (o, t)-               <?> "dsl overload declaratioN"-    where overloadable = ["let","lambda","pi","index_first","index_next","variable"]
− src/Idris/ParseExpr.hs 
@@ -1,1553 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, TupleSections #-}-module Idris.ParseExpr 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 qualified Text.Parser.Token as Tok-import qualified Text.Parser.Char as Chr-import qualified Text.Parser.Token.Highlight as Hi--import Idris.AbsSyntax-import Idris.ParseHelpers-import Idris.ParseOps-import Idris.DSL--import Idris.Core.TT--import Control.Applicative-import Control.Monad-import Control.Monad.State.Strict--import Data.Function (on)-import Data.Maybe-import qualified Data.List.Split as Spl-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---- | Allow implicit type declarations-allowImp :: SyntaxInfo -> SyntaxInfo-allowImp syn = syn { implicitAllowed = True }---- | Disallow implicit type declarations-disallowImp :: SyntaxInfo -> SyntaxInfo-disallowImp syn = syn { implicitAllowed = False }--{-| Parses an expression as a whole-@-  FullExpr ::= Expr EOF_t;-@- -}-fullExpr :: SyntaxInfo -> IdrisParser PTerm-fullExpr syn = do x <- expr syn-                  eof-                  i <- get-                  return $ debindApp syn (desugar syn i x)--tryFullExpr :: SyntaxInfo -> IState -> String -> Either Err PTerm-tryFullExpr syn st input =-  case runparser (fullExpr syn) st "" input of-    Success tm -> Right tm-    Failure e -> Left (Msg (show e))--{- | Parses an expression-@-  Expr ::= Pi-@- -}-expr :: SyntaxInfo -> IdrisParser PTerm-expr = pi--{- | Parses an expression with possible operator applied-@-  OpExpr ::= {- Expression Parser with Operators based on Expr' -};-@--}-opExpr :: SyntaxInfo -> IdrisParser PTerm-opExpr syn = do i <- get-                buildExpressionParser (table (idris_infixes i)) (expr' syn)--{- | Parses either an internally defined expression or-    a user-defined one-@-Expr' ::=  "External (User-defined) Syntax"-      |   InternalExpr;-@- -}-expr' :: SyntaxInfo -> IdrisParser PTerm-expr' syn = try (externalExpr syn)-            <|> internalExpr syn-            <?> "expression"--{- | Parses a user-defined expression -}-externalExpr :: SyntaxInfo -> IdrisParser PTerm-externalExpr syn = do i <- get-                      (FC fn start _) <- getFC-                      expr <- extensions syn (syntaxRulesList $ syntax_rules i)-                      (FC _ _ end) <- getFC-                      let outerFC = FC fn start end-                      return (mapPTermFC (fixFC outerFC) (fixFCH fn outerFC) expr)-                   <?> "user-defined expression"-  where -- Fix non-highlighting FCs by approximating with the span of the syntax application-        fixFC outer inner | inner `fcIn` outer = inner-                          | otherwise          = outer-        -- Fix highlighting FCs by making them useless, to avoid spurious highlights-        fixFCH fn outer inner | inner `fcIn` outer = inner-                              | otherwise          = FileFC fn--{- | Parses a simple user-defined expression -}-simpleExternalExpr :: SyntaxInfo -> IdrisParser PTerm-simpleExternalExpr syn = do i <- get-                            extensions syn (filter isSimple (syntaxRulesList $ syntax_rules i))-  where-    isSimple (Rule (Expr x:xs) _ _) = False-    isSimple (Rule (SimpleExpr x:xs) _ _) = False-    isSimple (Rule [Keyword _] _ _) = True-    isSimple (Rule [Symbol _]  _ _) = True-    isSimple (Rule (_:xs) _ _) = case last xs of-        Keyword _ -> True-        Symbol _  -> True-        _ -> False-    isSimple _ = False--{- | Tries to parse a user-defined expression given a list of syntactic extensions -}-extensions :: SyntaxInfo -> [Syntax] -> IdrisParser PTerm-extensions syn rules = extension syn [] (filter isValid rules)-                       <?> "user-defined expression"-  where-    isValid :: Syntax -> Bool-    isValid (Rule _ _ AnySyntax) = True-    isValid (Rule _ _ PatternSyntax) = inPattern syn-    isValid (Rule _ _ TermSyntax) = not (inPattern syn)-    isValid (DeclRule _ _) = False--data SynMatch = SynTm PTerm | SynBind FC Name -- ^ the FC is for highlighting information-  deriving Show--extension :: SyntaxInfo -> [Maybe (Name, SynMatch)] -> [Syntax] -> IdrisParser PTerm-extension syn ns rules =-  choice $ flip map (groupBy (ruleGroup `on` syntaxSymbols) rules) $ \rs ->-    case head rs of -- can never be []-      Rule (symb:_) _ _ -> try $ do-        n <- extensionSymbol symb-        extension syn (n : ns) [Rule ss t ctx | (Rule (_:ss) t ctx) <- rs]-      -- If we have more than one Rule in this bucket, our grammar is-      -- nondeterministic.-      Rule [] ptm _ -> return (flatten (updateSynMatch (mapMaybe id ns) ptm))-  where-    ruleGroup [] [] = True-    ruleGroup (s1:_) (s2:_) = s1 == s2-    ruleGroup _ _ = False--    extensionSymbol :: SSymbol -> IdrisParser (Maybe (Name, SynMatch))-    extensionSymbol (Keyword n)    = do fc <- reservedFC (show n)-                                        highlightP fc AnnKeyword-                                        return Nothing-    extensionSymbol (Expr n)       = do tm <- expr syn-                                        return $ Just (n, SynTm tm)-    extensionSymbol (SimpleExpr n) = do tm <- simpleExpr syn-                                        return $ Just (n, SynTm tm)-    extensionSymbol (Binding n)    = do (b, fc) <- name-                                        return $ Just (n, SynBind fc b)-    extensionSymbol (Symbol s)     = do fc <- symbolFC s-                                        highlightP fc AnnKeyword-                                        return Nothing-    -    flatten :: PTerm -> PTerm -- flatten application-    flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))-    flatten t = t--updateSynMatch = update-  where-    updateB :: [(Name, SynMatch)] -> (Name, FC) -> (Name, FC)-    updateB ns (n, fc) = case lookup n ns of-                           Just (SynBind tfc t) -> (t, tfc)-                           _ -> (n, fc)--    update :: [(Name, SynMatch)] -> PTerm -> PTerm-    update ns (PRef fc hls n) = case lookup n ns of-                                  Just (SynTm t) -> t-                                  _ -> PRef fc hls n-    update ns (PPatvar fc n) = uncurry (flip PPatvar) $ updateB ns (n, fc)-    update ns (PLam fc n nfc ty sc)-      = let (n', nfc') = updateB ns (n, nfc)-        in PLam fc n' nfc' (update ns ty) (update (dropn n ns) sc)-    update ns (PPi p n fc ty sc)-      = let (n', nfc') = updateB ns (n, fc)-        in PPi (updTacImp ns p) n' nfc'-               (update ns ty) (update (dropn n ns) sc)-    update ns (PLet fc n nfc ty val sc)-      = let (n', nfc') = updateB ns (n, nfc)-        in PLet fc n' nfc' (update ns ty)-                (update ns val) (update (dropn n ns) sc)-    update ns (PApp fc t args)-      = PApp fc (update ns t) (map (fmap (update ns)) args)-    update ns (PAppBind fc t args)-      = PAppBind fc (update ns t) (map (fmap (update ns)) args)-    update ns (PMatchApp fc n) = let (n', nfc') = updateB ns (n, fc)-                                 in PMatchApp nfc' n'-    update ns (PIfThenElse fc c t f)-      = PIfThenElse fc (update ns c) (update ns t) (update ns f)-    update ns (PCase fc c opts)-      = PCase fc (update ns c) (map (pmap (update ns)) opts)-    update ns (PRewrite fc eq tm mty)-      = PRewrite fc (update ns eq) (update ns tm) (fmap (update ns) mty)-    update ns (PPair fc hls p l r) = PPair fc hls p (update ns l) (update ns r)-    update ns (PDPair fc hls p l t r)-      = PDPair fc hls p (update ns l) (update ns t) (update ns r)-    update ns (PAs fc n t) = PAs fc (fst $ updateB ns (n, NoFC)) (update ns t)-    update ns (PAlternative ms a as) = PAlternative ms a (map (update ns) as)-    update ns (PHidden t) = PHidden (update ns t)-    update ns (PGoal fc r n sc) = PGoal fc (update ns r) n (update ns sc)-    update ns (PDoBlock ds) = PDoBlock $ map (upd ns) ds-      where upd :: [(Name, SynMatch)] -> PDo -> PDo-            upd ns (DoExp fc t) = DoExp fc (update ns t)-            upd ns (DoBind fc n nfc t) = DoBind fc n nfc (update ns t)-            upd ns (DoLet fc n nfc ty t) = DoLet fc n nfc (update ns ty) (update ns t)-            upd ns (DoBindP fc i t ts)-                    = DoBindP fc (update ns i) (update ns t)-                                 (map (\(l,r) -> (update ns l, update ns r)) ts)-            upd ns (DoLetP fc i t) = DoLetP fc (update ns i) (update ns t)-    update ns (PIdiom fc t) = PIdiom fc $ update ns t-    update ns (PMetavar fc n) = uncurry (flip PMetavar) $ updateB ns (n, fc)-    update ns (PProof tacs) = PProof $ map (updTactic ns) tacs-    update ns (PTactics tacs) = PTactics $ map (updTactic ns) tacs-    update ns (PDisamb nsps t) = PDisamb nsps $ update ns t-    update ns (PUnifyLog t) = PUnifyLog $ update ns t-    update ns (PNoImplicits t) = PNoImplicits $ update ns t-    update ns (PQuasiquote tm mty) = PQuasiquote (update ns tm) (fmap (update ns) mty)-    update ns (PUnquote t) = PUnquote $ update ns t-    update ns (PQuoteName n res fc) = let (n', fc') = (updateB ns (n, fc))-                                      in PQuoteName n' res fc'-    update ns (PRunElab fc t nsp) = PRunElab fc (update ns t) nsp-    update ns (PConstSugar fc t) = PConstSugar fc $ update ns t-    -- PConstSugar probably can't contain anything substitutable, but it's hard to track-    update ns t = t--    updTactic :: [(Name, SynMatch)] -> PTactic -> PTactic-    -- handle all the ones with Names explicitly, then use fmap for the rest with PTerms-    updTactic ns (Intro ns') = Intro $ map (fst . updateB ns . (, NoFC)) ns'-    updTactic ns (Focus n) = Focus . fst $ updateB ns (n, NoFC)-    updTactic ns (Refine n bs) = Refine (fst $ updateB ns (n, NoFC)) bs-    updTactic ns (Claim n t) = Claim (fst $ updateB ns (n, NoFC)) (update ns t)-    updTactic ns (MatchRefine n) = MatchRefine (fst $ updateB ns (n, NoFC))-    updTactic ns (LetTac n t) = LetTac (fst $ updateB ns (n, NoFC)) (update ns t)-    updTactic ns (LetTacTy n ty tm) = LetTacTy (fst $ updateB ns (n, NoFC)) (update ns ty) (update ns tm)-    updTactic ns (ProofSearch rec prover depth top psns hints) = ProofSearch rec prover depth-      (fmap (fst . updateB ns . (, NoFC)) top) (map (fst . updateB ns . (, NoFC)) psns) (map (fst . updateB ns . (, NoFC)) hints)-    updTactic ns (Try l r) = Try (updTactic ns l) (updTactic ns r)-    updTactic ns (TSeq l r) = TSeq (updTactic ns l) (updTactic ns r)-    updTactic ns (GoalType s tac) = GoalType s $ updTactic ns tac-    updTactic ns (TDocStr (Left n)) = TDocStr . Left . fst $ updateB ns (n, NoFC)-    updTactic ns t = fmap (update ns) t--    updTacImp ns (TacImp o st scr)  = TacImp o st (update ns scr)-    updTacImp _  x                  = x-    -    dropn :: Name -> [(Name, a)] -> [(Name, a)]-    dropn n [] = []-    dropn n ((x,t) : xs) | n == x = xs-                         | otherwise = (x,t):dropn n xs---{- | Parses a (normal) built-in expression-@-InternalExpr ::=-    UnifyLog-  | RecordType-  | SimpleExpr-  | Lambda-  | QuoteGoal-  | Let-  | If-  | RewriteTerm-  | CaseExpr-  | DoBlock-  | App-  ;-@--}-internalExpr :: SyntaxInfo -> IdrisParser PTerm-internalExpr syn =-         unifyLog syn-     <|> runElab syn-     <|> disamb syn-     <|> noImplicits syn-     <|> recordType syn-     <|> if_ syn-     <|> lambda syn-     <|> quoteGoal syn-     <|> let_ syn-     <|> rewriteTerm syn-     <|> doBlock syn-     <|> caseExpr syn-     <|> app syn-     <?> "expression"--{- | Parses the "impossible" keyword-@-Impossible ::= 'impossible'-@--}-impossible :: IdrisParser PTerm-impossible = do fc <- reservedFC "impossible"-                highlightP fc AnnKeyword-                return PImpossible--{- | Parses a case expression-@-CaseExpr ::=-  'case' Expr 'of' OpenBlock CaseOption+ CloseBlock;-@--}-caseExpr :: SyntaxInfo -> IdrisParser PTerm-caseExpr syn = do kw1 <- reservedFC "case"; fc <- getFC-                  scr <- expr syn; kw2 <- reservedFC "of";-                  opts <- indentedBlock1 (caseOption syn)-                  highlightP kw1 AnnKeyword-                  highlightP kw2 AnnKeyword-                  return (PCase fc scr opts)-               <?> "case expression"--{- | Parses a case in a case expression-@-CaseOption ::=-  Expr (Impossible | '=>' Expr) Terminator-  ;-@--}-caseOption :: SyntaxInfo -> IdrisParser (PTerm, PTerm)-caseOption syn = do lhs <- expr (syn { inPattern = True })-                    r <- impossible <|> symbol "=>" *> expr syn-                    return (lhs, r)-                 <?> "case option"--warnTacticDeprecation :: FC -> IdrisParser ()-warnTacticDeprecation fc =-    do ist <- get-       let cmdline = opt_cmdline (idris_options ist)-       unless (NoOldTacticDeprecationWarnings `elem` cmdline) $-         put ist { parserWarnings =-                     (fc, Msg "This style of tactic proof is deprecated. See %runElab for the replacement.") : parserWarnings ist }--{- | Parses a proof block-@-ProofExpr ::=-  'proof' OpenBlock Tactic'* CloseBlock-  ;-@--}-proofExpr :: SyntaxInfo -> IdrisParser PTerm-proofExpr syn = do kw <- reservedFC "proof"-                   ts <- indentedBlock1 (tactic syn)-                   highlightP kw AnnKeyword-                   warnTacticDeprecation kw-                   return $ PProof ts-                <?> "proof block"--{- | Parses a tactics block-@-TacticsExpr :=-  'tactics' OpenBlock Tactic'* CloseBlock-;-@--}-tacticsExpr :: SyntaxInfo -> IdrisParser PTerm-tacticsExpr syn = do kw <- reservedFC "tactics"-                     ts <- indentedBlock1 (tactic syn)-                     highlightP kw AnnKeyword-                     warnTacticDeprecation kw-                     return $ PTactics ts-                  <?> "tactics block"--{- | Parses a simple expression-@-SimpleExpr ::=-    {- External (User-defined) Simple Expression -}-  | '?' Name-  | % 'instance'-  | 'Refl' ('{' Expr '}')?-  | ProofExpr-  | TacticsExpr-  | FnName-  | Idiom-  | List-  | Alt-  | Bracketed-  | Constant-  | Type-  | 'Void'-  | Quasiquote-  | NameQuote-  | Unquote-  | '_'-  ;-@--}-simpleExpr :: SyntaxInfo -> IdrisParser PTerm-simpleExpr syn =-            try (simpleExternalExpr syn)-        <|> do (x, FC f (l, c) end) <- try (lchar '?' *> name)-               return (PMetavar (FC f (l, c-1) end) x)-        <|> do lchar '%'; fc <- getFC; reserved "instance"; return (PResolveTC fc)-        <|> do reserved "elim_for"; fc <- getFC; t <- fst <$> fnName; return (PRef fc [] (SN $ ElimN t))-        <|> proofExpr syn-        <|> tacticsExpr syn-        <|> try (do reserved "Type"; symbol "*"; return $ PUniverse AllTypes)-        <|> do reserved "AnyType"; return $ PUniverse AllTypes-        <|> PType <$> reservedFC "Type"-        <|> do reserved "UniqueType"; return $ PUniverse UniqueType-        <|> do reserved "NullType"; return $ PUniverse NullType-        <|> do (c, cfc) <- constant-               fc <- getFC-               return (modifyConst syn fc (PConstant cfc c))-        <|> do symbol "'"; fc <- getFC; str <- fst <$> name-               return (PApp fc (PRef fc [] (sUN "Symbol_"))-                          [pexp (PConstant NoFC (Str (show str)))])-        <|> do (x, fc) <- fnName-               if inPattern syn-                  then option (PRef fc [fc] x)-                              (do reservedOp "@"-                                  s <- simpleExpr syn-                                  fcIn <- getFC-                                  return (PAs fcIn x s))-                  else return (PRef fc [fc] x)-        <|> idiom syn-        <|> listExpr syn-        <|> alt syn-        <|> do reservedOp "!"-               s <- simpleExpr syn-               fc <- getFC-               return (PAppBind fc s [])-        <|> bracketed (disallowImp syn)-        <|> quasiquote syn-        <|> namequote syn-        <|> unquote syn-        <|> do lchar '_'; return Placeholder-        <?> "expression"--{- |Parses an expression in braces-@-Bracketed ::= '(' Bracketed'-@- -}-bracketed :: SyntaxInfo -> IdrisParser PTerm-bracketed syn = do (FC fn (sl, sc) _) <- getFC-                   lchar '(' <?> "parenthesized expression"-                   bracketed' (FC fn (sl, sc) (sl, sc+1)) syn-{- |Parses the rest of an expression in braces-@-Bracketed' ::=-  ')'-  | Expr ')'-  | ExprList ')'-  | Expr '**' Expr ')'-  | Operator Expr ')'-  | Expr Operator ')'-  | Name ':' Expr '**' Expr ')'-  ;-@--}-bracketed' :: FC -> SyntaxInfo -> IdrisParser PTerm-bracketed' open syn =-            do (FC f start (l, c)) <- getFC-               lchar ')'-               return $ PTrue (spanFC open (FC f start (l, c+1))) TypeOrTerm-        <|> try (do (ln, lnfc) <- name-                    colonFC <- lcharFC ':'-                    lty <- expr syn-                    starsFC <- reservedOpFC "**"-                    fc <- getFC-                    r <- expr syn-                    close <- lcharFC ')'-                    return (PDPair fc [open, colonFC, starsFC, close] TypeOrTerm (PRef lnfc [] ln) lty r))-        <|> try (do fc <- getFC; o <- operator; e <- expr syn; lchar ')'-                    -- No prefix operators! (bit of a hack here...)-                    if (o == "-" || o == "!")-                      then fail "minus not allowed in section"-                      else return $ PLam fc (sMN 1000 "ARG") NoFC Placeholder-                         (PApp fc (PRef fc [] (sUN o)) [pexp (PRef fc [] (sMN 1000 "ARG")),-                                                        pexp e]))-        <|> try (do l <- simpleExpr syn-                    op <- option Nothing (do o <- operator-                                             lchar ')'-                                             return (Just o)) -                    fc0 <- getFC-                    case op of-                         Nothing -> bracketedExpr syn open l-                         Just o -> return $ PLam fc0 (sMN 1000 "ARG") NoFC Placeholder-                             (PApp fc0 (PRef fc0 [] (sUN o)) [pexp l,-                                                              pexp (PRef fc0 [] (sMN 1000 "ARG"))]))-        <|> do l <- expr syn-               bracketedExpr syn open l---- | Parse the contents of parentheses, after an expression has been parsed.-bracketedExpr :: SyntaxInfo -> FC -> PTerm -> IdrisParser PTerm-bracketedExpr syn openParenFC e =-             do lchar ')'; return e-        <|>  do exprs <- many (do comma <- lcharFC ','-                                  r <- expr syn-                                  return (r, comma))-                closeParenFC <- lcharFC ')'-                let hilite = [openParenFC, closeParenFC] ++ map snd exprs-                return $ PPair openParenFC hilite TypeOrTerm e (mergePairs exprs)-        <|>  do starsFC <- reservedOpFC "**"-                r <- expr syn-                closeParenFC <- lcharFC ')'-                return (PDPair starsFC [openParenFC, starsFC, closeParenFC] TypeOrTerm e Placeholder r)-        <?> "end of bracketed expression"-  where mergePairs :: [(PTerm, FC)] -> PTerm-        mergePairs [(t, fc)]    = t-        mergePairs ((t, fc):rs) = PPair fc [] TypeOrTerm t (mergePairs rs)---- bit of a hack here. If the integer doesn't fit in an Int, treat it as a--- big integer, otherwise try fromInteger and the constants as alternatives.--- a better solution would be to fix fromInteger to work with Integer, as the--- name suggests, rather than Int-{-| Finds optimal type for integer constant -}-modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm-modifyConst syn fc (PConstant inFC (BI x))-    | not (inPattern syn)-        = PConstSugar inFC $ -- wrap in original location for highlighting-            PAlternative [] FirstSuccess-              (PApp fc (PRef fc [] (sUN "fromInteger")) [pexp (PConstant NoFC (BI (fromInteger x)))]-              : consts)-    | otherwise = PConstSugar inFC $-                    PAlternative [] FirstSuccess consts-    where-      consts = [ PConstant inFC (BI x)-               , PConstant inFC (I (fromInteger x))-               , PConstant inFC (B8 (fromInteger x))-               , PConstant inFC (B16 (fromInteger x))-               , PConstant inFC (B32 (fromInteger x))-               , PConstant inFC (B64 (fromInteger x))-               ]-modifyConst syn fc x = x--{- | Parses an alternative expression-@-  Alt ::= '(|' Expr_List '|)';--  Expr_List ::=-    Expr'-    | Expr' ',' Expr_List-  ;-@--}-alt :: SyntaxInfo -> IdrisParser PTerm-alt syn = do symbol "(|"; alts <- sepBy1 (expr' syn) (lchar ','); symbol "|)"-             return (PAlternative [] FirstSuccess alts)--{- | Parses a possibly hidden simple expression-@-HSimpleExpr ::=-  '.' SimpleExpr-  | SimpleExpr-  ;-@--}-hsimpleExpr :: SyntaxInfo -> IdrisParser PTerm-hsimpleExpr syn =-  do lchar '.'-     e <- simpleExpr syn-     return $ PHidden e-  <|> simpleExpr syn-  <?> "expression"--{- | Parses a unification log expression-UnifyLog ::=-  '%' 'unifyLog' SimpleExpr-  ;--}-unifyLog :: SyntaxInfo -> IdrisParser PTerm-unifyLog syn = do (FC fn (sl, sc) kwEnd) <- try (lchar '%' *> reservedFC "unifyLog")-                  tm <- simpleExpr syn-                  highlightP (FC fn (sl, sc-1) kwEnd) AnnKeyword-                  return (PUnifyLog tm)-               <?> "unification log expression"--{- | Parses a new-style tactics expression-RunTactics ::=-  '%' 'runElab' SimpleExpr-  ;--}-runElab :: SyntaxInfo -> IdrisParser PTerm-runElab syn = do (FC fn (sl, sc) kwEnd) <- try (lchar '%' *> reservedFC "runElab")-                 fc <- getFC-                 tm <- simpleExpr syn-                 highlightP (FC fn (sl, sc-1) kwEnd) AnnKeyword-                 return $ PRunElab fc tm (syn_namespace syn)-              <?> "new-style tactics expression"--{- | Parses a disambiguation expression -Disamb ::=-  '%' 'disamb' NameList Expr-  ;--}-disamb :: SyntaxInfo -> IdrisParser PTerm-disamb syn = do kw <- reservedFC "with"-                ns <- sepBy1 (fst <$> name) (lchar ',')-                tm <- expr' syn-                highlightP kw AnnKeyword-                return (PDisamb (map tons ns) tm)-               <?> "namespace disambiguation expression"-  where tons (NS n s) = txt (show n) : s-        tons n = [txt (show n)]-{- | Parses a no implicits expression-@-NoImplicits ::=-  '%' 'noImplicits' SimpleExpr-  ;-@--}-noImplicits :: SyntaxInfo -> IdrisParser PTerm-noImplicits syn = do try (lchar '%' *> reserved "noImplicits")-                     tm <- simpleExpr syn-                     return (PNoImplicits tm)-                 <?> "no implicits expression"--{- | Parses a function application expression-@-App ::=-  'mkForeign' Arg Arg*-  | MatchApp-  | SimpleExpr Arg*-  ;-MatchApp ::=-  SimpleExpr '<==' FnName-  ;-@--}-app :: SyntaxInfo -> IdrisParser PTerm-app syn = do f <- simpleExpr syn-             (do try $ reservedOp "<=="-                 fc <- getFC-                 ff <- fst <$> fnName-                 return (PLet fc (sMN 0 "match") NoFC-                               f-                               (PMatchApp fc ff)-                               (PRef fc [] (sMN 0 "match")))-              <?> "matching application expression") <|> (do-             fc <- getFC-             i <- get-             args <- many (do notEndApp; arg syn)-             case args of-               [] -> return f-               _  -> return (flattenFromInt fc f args))-       <?> "function application"-   where-    -- bit of a hack to deal with the situation where we're applying a-    -- literal to an argument, which we may want for obscure applications-    -- of fromInteger, and this will help disambiguate better.-    -- We know, at least, it won't be one of the constants!-    flattenFromInt fc (PAlternative _ x alts) args-      | Just i <- getFromInt alts-           = PApp fc (PRef fc [] (sUN "fromInteger")) (i : args)-    flattenFromInt fc f args = PApp fc f args--    getFromInt ((PApp _ (PRef _ _ n) [a]) : _) | n == sUN "fromInteger" = Just a-    getFromInt (_ : xs) = getFromInt xs-    getFromInt _ = Nothing--{-| Parses a function argument-@-Arg ::=-  ImplicitArg-  | ConstraintArg-  | SimpleExpr-  ;-@--}-arg :: SyntaxInfo -> IdrisParser PArg-arg syn =  implicitArg syn-       <|> constraintArg syn-       <|> do e <- simpleExpr syn-              return (pexp e)-       <?> "function argument"--{-| Parses an implicit function argument-@-ImplicitArg ::=-  '{' Name ('=' Expr)? '}'-  ;-@--}-implicitArg :: SyntaxInfo -> IdrisParser PArg-implicitArg syn = do lchar '{'-                     (n, nfc) <- name-                     fc <- getFC-                     v <- option (PRef nfc [nfc] n) (do lchar '='-                                                        expr syn)-                     lchar '}'-                     return (pimp n v True)-                  <?> "implicit function argument"--{-| Parses a constraint argument (for selecting a named type class instance)-->    ConstraintArg ::=->      '@{' Expr '}'->      ;---}-constraintArg :: SyntaxInfo -> IdrisParser PArg-constraintArg syn = do symbol "@{"-                       e <- expr syn-                       symbol "}"-                       return (pconst e)-                    <?> "constraint argument"--{-| Parses a quasiquote expression (for building reflected terms using the elaborator)--> Quasiquote ::= '`(' Expr ')'---}-quasiquote :: SyntaxInfo -> IdrisParser PTerm-quasiquote syn = do startFC <- symbolFC "`("-                    e <- expr syn { syn_in_quasiquote = (syn_in_quasiquote syn) + 1 ,-                                    inPattern = False }-                    g <- optional $-                           do fc <- symbolFC ":"-                              ty <- expr syn { inPattern = False } -- don't allow antiquotes-                              return (ty, fc)-                    endFC <- symbolFC ")"-                    mapM_ (uncurry highlightP) [(startFC, AnnKeyword), (endFC, AnnKeyword), (spanFC startFC endFC, AnnQuasiquote)]-                    case g of-                      Just (_, fc) -> highlightP fc AnnKeyword-                      _ -> return ()-                    return $ PQuasiquote e (fst <$> g)-                 <?> "quasiquotation"--{-| Parses an unquoting inside a quasiquotation (for building reflected terms using the elaborator)--> Unquote ::= ',' Expr---}-unquote :: SyntaxInfo -> IdrisParser PTerm-unquote syn = do guard (syn_in_quasiquote syn > 0)-                 startFC <- symbolFC "~"-                 e <- simpleExpr syn { syn_in_quasiquote = syn_in_quasiquote syn - 1 }-                 endFC <- getFC-                 highlightP startFC AnnKeyword-                 highlightP (spanFC startFC endFC) AnnAntiquote-                 return $ PUnquote e-              <?> "unquotation"--{-| Parses a quotation of a name (for using the elaborator to resolve boring details)--> NameQuote ::= '`{' Name '}'---}-namequote :: SyntaxInfo -> IdrisParser PTerm-namequote syn = do (startFC, res) <--                     try (do fc <- symbolFC "`{{"-                             return (fc, False)) <|>-                       (do fc <- symbolFC "`{"-                           return (fc, True))-                   (n, nfc) <- fnName-                   endFC <- if res then symbolFC "}" else symbolFC "}}"-                   mapM_ (uncurry highlightP)-                         [ (startFC, AnnKeyword)-                         , (endFC, AnnKeyword)-                         , (spanFC startFC endFC, AnnQuasiquote)-                         ]-                   return $ PQuoteName n res nfc-                <?> "quoted name"---{-| Parses a record field setter expression-@-RecordType ::=-  'record' '{' FieldTypeList '}';-@-@-FieldTypeList ::=-  FieldType-  | FieldType ',' FieldTypeList-  ;-@-@-FieldType ::=-  FnName '=' Expr-  ;-@--}-recordType :: SyntaxInfo -> IdrisParser PTerm-recordType syn =-      do kw <- reservedFC "record"-         lchar '{'-         fgs <- fieldGetOrSet-         lchar '}'-         fc <- getFC-         rec <- optional (simpleExpr syn)-         highlightP kw AnnKeyword-         case fgs of-              Left fields ->-                case rec of-                   Nothing ->-                       return (PLam fc (sMN 0 "fldx") NoFC Placeholder-                                   (applyAll fc fields (PRef fc [] (sMN 0 "fldx"))))-                   Just v -> return (applyAll fc fields v)-              Right fields ->-                case rec of-                   Nothing ->-                       return (PLam fc (sMN 0 "fldx") NoFC Placeholder-                                 (getAll fc (reverse fields)-                                     (PRef fc [] (sMN 0 "fldx"))))-                   Just v -> return (getAll fc (reverse fields) v)--       <?> "record setting expression"-   where fieldSet :: IdrisParser ([Name], PTerm)-         fieldSet = do ns <- fieldGet-                       lchar '='-                       e <- expr syn-                       return (ns, e)-                    <?> "field setter"--         fieldGet :: IdrisParser [Name]-         fieldGet = sepBy1 (fst <$> fnName) (symbol "->")--         fieldGetOrSet :: IdrisParser (Either [([Name], PTerm)] [Name])-         fieldGetOrSet = try (do fs <- sepBy1 fieldSet (lchar ',')-                                 return (Left fs))-                     <|> do f <- fieldGet-                            return (Right f)--         applyAll :: FC -> [([Name], PTerm)] -> PTerm -> PTerm-         applyAll fc [] x = x-         applyAll fc ((ns, e) : es) x-            = applyAll fc es (doUpdate fc ns e x)--         doUpdate fc [n] e get-              = PApp fc (PRef fc [] (mkType n)) [pexp e, pexp get]-         doUpdate fc (n : ns) e get-              = PApp fc (PRef fc [] (mkType n))-                  [pexp (doUpdate fc ns e (PApp fc (PRef fc [] n) [pexp get])),-                   pexp get]--         getAll :: FC -> [Name] -> PTerm -> PTerm-         getAll fc [n] e = PApp fc (PRef fc [] n) [pexp e]-         getAll fc (n:ns) e = PApp fc (PRef fc [] n) [pexp (getAll fc ns e)]----- | Creates setters for record types on necessary functions-mkType :: Name -> Name-mkType (UN n) = sUN ("set_" ++ str n)-mkType (MN 0 n) = sMN 0 ("set_" ++ str n)-mkType (NS n s) = NS (mkType n) s--{- | Parses a type signature-@-TypeSig ::=-  ':' Expr-  ;-@-@-TypeExpr ::= ConstraintList? Expr;-@- -}-typeExpr :: SyntaxInfo -> IdrisParser PTerm-typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []-                  sc <- expr syn-                  return (bindList (PPi constraint) cs sc)-               <?> "type signature"--{- | Parses a lambda expression-@-Lambda ::=-    '\\' TypeOptDeclList LambdaTail-  | '\\' SimpleExprList  LambdaTail-  ;-@-@-SimpleExprList ::=-  SimpleExpr-  | SimpleExpr ',' SimpleExprList-  ;-@-@-LambdaTail ::=-    Impossible-  | '=>' Expr-@--}-lambda :: SyntaxInfo -> IdrisParser PTerm-lambda syn = do lchar '\\' <?> "lambda expression"-                ((do xt <- try $ tyOptDeclList syn-                     fc <- getFC-                     sc <- lambdaTail-                     return (bindList (PLam fc) xt sc))-                 <|>-                 (do ps <- sepBy (do fc <- getFC-                                     e <- simpleExpr (syn { inPattern = True })-                                     return (fc, e))-                                 (lchar ',')-                     sc <- lambdaTail-                     return (pmList (zip [0..] ps) sc)))-                  <?> "lambda expression"-    where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm-          pmList [] sc = sc-          pmList ((i, (fc, x)) : xs) sc-                = PLam fc (sMN i "lamp") NoFC Placeholder-                        (PCase fc (PRef fc [] (sMN i "lamp"))-                                [(x, pmList xs sc)])-          lambdaTail :: IdrisParser PTerm-          lambdaTail = impossible <|> symbol "=>" *> expr syn--{- | Parses a term rewrite expression-@-RewriteTerm ::=-  'rewrite' Expr ('==>' Expr)? 'in' Expr-  ;-@--}-rewriteTerm :: SyntaxInfo -> IdrisParser PTerm-rewriteTerm syn = do kw <- reservedFC "rewrite"-                     fc <- getFC-                     prf <- expr syn-                     giving <- optional (do symbol "==>"; expr' syn)-                     kw' <- reservedFC "in";  sc <- expr syn-                     highlightP kw AnnKeyword-                     highlightP kw' AnnKeyword-                     return (PRewrite fc-                             (PApp fc (PRef fc [] (sUN "sym")) [pexp prf]) sc-                               giving)-                  <?> "term rewrite expression"--{- |Parses a let binding-@-Let ::=-  'let' Name TypeSig'? '=' Expr  'in' Expr-| 'let' Expr'          '=' Expr' 'in' Expr--TypeSig' ::=-  ':' Expr'-  ;-@- -}-let_ :: SyntaxInfo -> IdrisParser PTerm-let_ syn = try (do kw <- reservedFC "let"-                   ls <- indentedBlock (let_binding syn)-                   kw' <- reservedFC "in";  sc <- expr syn-                   highlightP kw AnnKeyword; highlightP kw' AnnKeyword-                   return (buildLets ls sc))-           <?> "let binding"-  where buildLets [] sc = sc-        buildLets ((fc, PRef nfc _ n, ty, v, []) : ls) sc-          = PLet fc n nfc ty v (buildLets ls sc)-        buildLets ((fc, pat, ty, v, alts) : ls) sc-          = PCase fc v ((pat, buildLets ls sc) : alts)--let_binding syn = do fc <- getFC;-                     pat <- expr' (syn { inPattern = True })-                     ty <- option Placeholder (do lchar ':'; expr' syn)-                     lchar '='-                     v <- expr syn-                     ts <- option [] (do lchar '|'-                                         sepBy1 (do_alt syn) (lchar '|'))-                     return (fc,pat,ty,v,ts)--{- | Parses a conditional expression-@-If ::= 'if' Expr 'then' Expr 'else' Expr-@---}-if_ :: SyntaxInfo -> IdrisParser PTerm-if_ syn = (do ifFC <- reservedFC "if"-              fc <- getFC-              c <- expr syn-              thenFC <- reservedFC "then"-              t <- expr syn-              elseFC <- reservedFC "else"-              f <- expr syn-              mapM_ (flip highlightP AnnKeyword) [ifFC, thenFC, elseFC]-              return (PIfThenElse fc c t f))-          <?> "conditional expression"---{- | Parses a quote goal--@-QuoteGoal ::=-  'quoteGoal' Name 'by' Expr 'in' Expr-  ;-@- -}-quoteGoal :: SyntaxInfo -> IdrisParser PTerm-quoteGoal syn = do kw1 <- reservedFC "quoteGoal"; n <- fst <$> name;-                   kw2 <- reservedFC "by"-                   r <- expr syn-                   kw3 <- reservedFC "in"-                   fc <- getFC-                   sc <- expr syn-                   mapM_ (flip highlightP AnnKeyword) [kw1, kw2, kw3]-                   return (PGoal fc r n sc)-                <?> "quote goal expression"--{- | Parses a dependent type signature--@-Pi ::= PiOpts Static? Pi'-@--@-Pi' ::=-    OpExpr ('->' Pi)?-  | '(' TypeDeclList           ')'            '->' Pi-  | '{' TypeDeclList           '}'            '->' Pi-  | '{' 'auto'    TypeDeclList '}'            '->' Pi-  | '{' 'default' SimpleExpr TypeDeclList '}' '->' Pi-  ;-@- -}--bindsymbol opts st syn -     = do symbol "->"-          return (Exp opts st False)--explicitPi opts st syn-   = do xt <- try (lchar '(' *> typeDeclList syn <* lchar ')')-        binder <- bindsymbol opts st syn-        sc <- expr syn-        return (bindList (PPi binder) xt sc)-       -autoImplicit opts st syn-   = do kw <- reservedFC "auto"-        when (st == Static) $ fail "auto implicits can not be static"-        xt <- typeDeclList syn-        lchar '}'-        symbol "->"-        sc <- expr syn-        highlightP kw AnnKeyword-        return (bindList (PPi-          (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing [] []]))) xt sc) --defaultImplicit opts st syn = do-   kw <- reservedFC "default"-   when (st == Static) $ fail "default implicits can not be static"-   ist <- get-   script' <- simpleExpr syn-   let script = debindApp syn . desugar syn ist $ script'-   xt <- typeDeclList syn-   lchar '}'-   symbol "->"-   sc <- expr syn-   highlightP kw AnnKeyword-   return (bindList (PPi (TacImp [] Dynamic script)) xt sc)--normalImplicit opts st syn = do-   xt <- typeDeclList syn <* lchar '}'-   symbol "->"-   cs <- constraintList syn-   sc <- expr syn-   let (im,cl)-          = if implicitAllowed syn-               then (Imp opts st False (Just (Impl False True)),-                      constraint)-               else (Imp opts st False (Just (Impl False False)),-                     Imp opts st False (Just (Impl True False)))-   return (bindList (PPi im) xt -           (bindList (PPi cl) cs sc))--implicitPi opts st syn =-      autoImplicit opts st syn-        <|> defaultImplicit opts st syn-          <|> normalImplicit opts st syn--unboundPi opts st syn = do-       x <- opExpr syn-       (do binder <- bindsymbol opts st syn-           sc <- expr syn-           return (PPi binder (sUN "__pi_arg") NoFC x sc))-              <|> 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)-            <|> unboundPi opts st syn-  <?> "dependent type signature"--{- | Parses Possible Options for Pi Expressions-@-  PiOpts ::= '.'?-@--}-piOpts :: SyntaxInfo -> IdrisParser [ArgOpt]-piOpts syn | implicitAllowed syn =-        lchar '.' *> return [InaccessibleArg]-    <|> return []-piOpts syn = return []--{- | Parses a type constraint list--@-ConstraintList ::=-    '(' Expr_List ')' '=>'-  | Expr              '=>'-  ;-@--}-constraintList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]-constraintList syn = try (constraintList1 syn)-                     <|> return []--constraintList1 :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]-constraintList1 syn = try (do lchar '('-                              tys <- sepBy1 nexpr (lchar ',')-                              lchar ')'-                              reservedOp "=>"-                              return tys)-                  <|> try (do t <- opExpr (disallowImp syn)-                              reservedOp "=>"-                              return [(defname, NoFC, t)])-                  <?> "type constraint list"-  where nexpr = try (do (n, fc) <- name; lchar ':'-                        e <- expr syn-                        return (n, fc, e))-                <|> do e <- expr syn-                       return (defname, NoFC, e)-        defname = sMN 0 "constraint"--{- | Parses a type declaration list-@-TypeDeclList ::=-    FunctionSignatureList-  | NameList TypeSig-  ;-@--@-FunctionSignatureList ::=-    Name TypeSig-  | Name TypeSig ',' FunctionSignatureList-  ;-@--}-typeDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]-typeDeclList syn = try (sepBy1 (do (x, xfc) <- fnName-                                   lchar ':'-                                   t <- typeExpr (disallowImp syn)-                                   return (x, xfc, t))-                           (lchar ','))-                   <|> do ns <- sepBy1 name (lchar ',')-                          lchar ':'-                          t <- typeExpr (disallowImp syn)-                          return (map (\(x, xfc) -> (x, xfc, t)) ns)-                   <?> "type declaration list"--{- | Parses a type declaration list with optional parameters-@-TypeOptDeclList ::=-    NameOrPlaceholder TypeSig?-  | NameOrPlaceholder TypeSig? ',' TypeOptDeclList-  ;-@--@-NameOrPlaceHolder ::= Name | '_';-@--}-tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]-tyOptDeclList syn = sepBy1 (do (x, fc) <- nameOrPlaceholder-                               t <- option Placeholder (do lchar ':'-                                                           expr syn)-                               return (x, fc, t))-                           (lchar ',')-                    <?> "type declaration list"-    where  nameOrPlaceholder :: IdrisParser (Name, FC)-           nameOrPlaceholder = fnName-                           <|> do symbol "_"-                                  return (sMN 0 "underscore", NoFC)-                           <?> "name or placeholder"--{- | Parses a list literal expression e.g. [1,2,3] or a comprehension [ (x, y) | x <- xs , y <- ys ]-@-ListExpr ::=-     '[' ']'-  | '[' Expr '|' DoList ']'-  | '[' ExprList ']'-;-@-@-DoList ::=-    Do-  | Do ',' DoList-  ;-@-@-ExprList ::=-  Expr-  | Expr ',' ExprList-  ;-@- -}-listExpr :: SyntaxInfo -> IdrisParser PTerm-listExpr syn = do (FC f (l, c) _) <- getFC-                  lchar '['; fc <- getFC;-                  (try . token $ do (char ']' <?> "end of list expression")-                                    (FC _ _ (l', c')) <- getFC-                                    return (mkNil (FC f (l, c) (l', c'))))-                   <|> (do x <- expr syn <?> "expression"-                           (do try (lchar '|') <?> "list comprehension"-                               qs <- sepBy1 (do_ syn) (lchar ',')-                               lchar ']'-                               return (PDoBlock (map addGuard qs ++-                                          [DoExp fc (PApp fc (PRef fc [] (sUN "return"))-                                                       [pexp x])]))) <|>-                            (do xs <- many (do (FC fn (sl, sc) _) <- getFC-                                               lchar ',' <?> "list element"-                                               let commaFC = FC fn (sl, sc) (sl, sc + 1)-                                               elt <- expr syn-                                               return (elt, commaFC))-                                (FC fn (sl, sc) _) <- getFC-                                lchar ']' <?> "end of list expression"-                                let rbrackFC = FC fn (sl, sc) (sl, sc+1)-                                return (mkList fc rbrackFC ((x, (FC f (l, c) (l, c+1))) : xs))))-                <?> "list expression"-  where-    mkNil :: FC -> PTerm-    mkNil fc = PRef fc [fc] (sUN "Nil")-    mkList :: FC -> FC -> [(PTerm, FC)] -> PTerm-    mkList errFC nilFC [] = PRef nilFC [nilFC] (sUN "Nil")-    mkList errFC nilFC ((x, fc) : xs) = PApp errFC (PRef fc [fc] (sUN "::")) [pexp x, pexp (mkList errFC nilFC xs)]-    addGuard :: PDo -> PDo-    addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc [] (sUN "guard"))-                                              [pexp e])-    addGuard x = x--{- | Parses a do-block-@-Do' ::= Do KeepTerminator;-@--@-DoBlock ::=-  'do' OpenBlock Do'+ CloseBlock-  ;-@- -}-doBlock :: SyntaxInfo -> IdrisParser PTerm-doBlock syn-    = do kw <- reservedFC "do"-         ds <- indentedBlock1 (do_ syn)-         highlightP kw AnnKeyword-         return (PDoBlock ds)-      <?> "do block"--{- | Parses an expression inside a do block-@-Do ::=-    'let' Name  TypeSig'?      '=' Expr-  | 'let' Expr'                '=' Expr-  | Name  '<-' Expr-  | Expr' '<-' Expr-  | Expr-  ;-@--}-do_ :: SyntaxInfo -> IdrisParser PDo-do_ syn-     = try (do kw <- reservedFC "let"-               (i, ifc) <- name-               ty <- option Placeholder (do lchar ':'-                                            expr' syn)-               reservedOp "="-               fc <- getFC-               e <- expr syn-               highlightP kw AnnKeyword-               return (DoLet fc i ifc ty e))-   <|> try (do kw <- reservedFC "let"-               i <- expr' syn-               reservedOp "="-               fc <- getFC-               sc <- expr syn-               highlightP kw AnnKeyword-               return (DoLetP fc i sc))-   <|> try (do (i, ifc) <- name-               symbol "<-"-               fc <- getFC-               e <- expr syn;-               option (DoBind fc i ifc e)-                      (do lchar '|'-                          ts <- sepBy1 (do_alt syn) (lchar '|')-                          return (DoBindP fc (PRef ifc [ifc] i) e ts)))-   <|> try (do i <- expr' syn-               symbol "<-"-               fc <- getFC-               e <- expr syn;-               option (DoBindP fc i e [])-                      (do lchar '|'-                          ts <- sepBy1 (do_alt syn) (lchar '|')-                          return (DoBindP fc i e ts)))-   <|> do e <- expr syn-          fc <- getFC-          return (DoExp fc e)-   <?> "do block expression"--do_alt syn = do l <- expr' syn-                option (Placeholder, l)-                       (do symbol "=>"-                           r <- expr' syn-                           return (l, r))--{- | Parses an expression in idiom brackets-@-Idiom ::= '[|' Expr '|]';-@--}-idiom :: SyntaxInfo -> IdrisParser PTerm-idiom syn-    = do symbol "[|"-         fc <- getFC-         e <- expr syn-         symbol "|]"-         return (PIdiom fc e)-      <?> "expression in idiom brackets"--{- |Parses a constant or literal expression--@-Constant ::=-    'Integer'-  | 'Int'-  | 'Char'-  | 'Double'-  | 'String'-  | 'Bits8'-  | 'Bits16'-  | 'Bits32'-  | 'Bits64'-  | Float_t-  | Natural_t-  | VerbatimString_t-  | String_t-  | Char_t-  ;-@--}--constants :: [(String, Idris.Core.TT.Const)]-constants =-  [ ("Integer",            AType (ATInt ITBig))-  , ("Int",                AType (ATInt ITNative))-  , ("Char",               AType (ATInt ITChar))-  , ("Double",             AType ATFloat)-  , ("String",             StrType)-  , ("prim__WorldType",    WorldType)-  , ("prim__TheWorld",     TheWorld)-  , ("Bits8",              AType (ATInt (ITFixed IT8)))-  , ("Bits16",             AType (ATInt (ITFixed IT16)))-  , ("Bits32",             AType (ATInt (ITFixed IT32)))-  , ("Bits64",             AType (ATInt (ITFixed IT64)))-  ]---- | Parse a constant and its source span-constant :: IdrisParser (Idris.Core.TT.Const, FC)-constant = choice [ do fc <- reservedFC name; return (ty, fc)-                  | (name, ty) <- constants-                  ]-        <|> do (f, fc) <- try float; return (Fl f, fc)-        <|> do (i, fc) <- natural; return (BI i, fc)-        <|> do (s, fc) <- verbatimStringLiteral; return (Str s, fc)-        <|> do (s, fc) <- stringLiteral;  return (Str s, fc)-        <|> do (c, fc) <- try charLiteral; return (Ch c, fc) --Currently ambigous with symbols-        <?> "constant or literal"--{- | Parses a verbatim multi-line string literal (triple-quoted)--@-VerbatimString_t ::=-  '\"\"\"' ~'\"\"\"' '\"\"\"'-;-@- -}-verbatimStringLiteral :: MonadicParsing m => m (String, FC)-verbatimStringLiteral = token $ do (FC f start _) <- getFC-                                   try $ string "\"\"\""-                                   str <- manyTill anyChar $ try (string "\"\"\"")-                                   (FC _ _ end) <- getFC-                                   return (str, FC f start end)--{- | Parses a static modifier--@-Static ::=-  '[' static ']'-;-@--}-static :: IdrisParser Static-static =     do reserved "[static]"; return Static-         <|> return Dynamic-         <?> "static modifier"--{- | Parses a tactic script--@-Tactic ::= 'intro' NameList?-       |   'intros'-       |   'refine'      Name Imp+-       |   'mrefine'     Name-       |   'rewrite'     Expr-       |   'induction'   Expr-       |   'equiv'       Expr-       |   'let'         Name ':' Expr' '=' Expr-       |   'let'         Name           '=' Expr-       |   'focus'       Name-       |   'exact'       Expr-       |   'applyTactic' Expr-       |   'reflect'     Expr-       |   'fill'        Expr-       |   'try'         Tactic '|' Tactic-       |   '{' TacticSeq '}'-       |   'compute'-       |   'trivial'-       |   'solve'-       |   'attack'-       |   'state'-       |   'term'-       |   'undo'-       |   'qed'-       |   'abandon'-       |   ':' 'q'-       ;--Imp ::= '?' | '_';--TacticSeq ::=-    Tactic ';' Tactic-  | Tactic ';' TacticSeq-  ;-@--}---- | A specification of the arguments that tactics can take-data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n-               | ExprTArg-               | AltsTArg-               | StringLitTArg---- The FIXMEs are Issue #1766 in the issue tracker.---     https://github.com/idris-lang/Idris-dev/issues/1766--- | A list of available tactics and their argument requirements-tactics :: [([String], Maybe TacticArg, SyntaxInfo -> IdrisParser PTactic)]-tactics = -  [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name)-      do ns <- sepBy (spaced (fst <$> name)) (lchar ','); return $ Intro ns)-  , noArgs ["intros"] Intros-  , noArgs ["unfocus"] Unfocus-  , (["refine"], Just ExprTArg, const $-       do n <- spaced (fst <$> fnName)-          imps <- many imp-          return $ Refine n imps)-  , (["claim"], Nothing, \syn ->-       do n <- indentPropHolds gtProp *> (fst <$> name)-          goal <- indentPropHolds gtProp *> expr syn-          return $ Claim n goal)-  , (["mrefine"], Just ExprTArg, const $-       do n <- spaced (fst <$> fnName)-          return $ MatchRefine n)-  , expressionTactic ["rewrite"] Rewrite-  , expressionTactic ["case"] CaseTac-  , expressionTactic ["induction"] Induction-  , expressionTactic ["equiv"] Equiv-  , (["let"], Nothing, \syn -> -- FIXME syntax for let-       do n <- (indentPropHolds gtProp *> (fst <$> name))-          (do indentPropHolds gtProp *> lchar ':'-              ty <- indentPropHolds gtProp *> expr' syn-              indentPropHolds gtProp *> lchar '='-              t <- indentPropHolds gtProp *> expr syn-              i <- get-              return $ LetTacTy n (desugar syn i ty) (desugar syn i t))-            <|> (do indentPropHolds gtProp *> lchar '='-                    t <- indentPropHolds gtProp *> expr syn-                    i <- get-                    return $ LetTac n (desugar syn i t)))--  , (["focus"], Just ExprTArg, const $-       do n <- spaced (fst <$> name)-          return $ Focus n)-  , expressionTactic ["exact"] Exact-  , expressionTactic ["applyTactic"] ApplyTactic-  , expressionTactic ["byReflection"] ByReflection-  , expressionTactic ["reflect"] Reflect-  , expressionTactic ["fill"] Fill-  , (["try"], Just AltsTArg, \syn ->-        do t <- spaced (tactic syn)-           lchar '|'-           t1 <- spaced (tactic syn)-           return $ Try t t1)-  , noArgs ["compute"] Compute-  , noArgs ["trivial"] Trivial-  , noArgs ["unify"] DoUnify-  , (["search"], Nothing, const $-      do depth <- option 10 $ fst <$> natural-         return (ProofSearch True True (fromInteger depth) Nothing [] []))-  , noArgs ["instance"] TCInstance-  , noArgs ["solve"] Solve-  , noArgs ["attack"] Attack-  , noArgs ["state", ":state"] ProofState-  , noArgs ["term", ":term"] ProofTerm-  , noArgs ["undo", ":undo"] Undo-  , noArgs ["qed", ":qed"] Qed-  , noArgs ["abandon", ":q"] Abandon-  , noArgs ["skip"] Skip-  , noArgs ["sourceLocation"] SourceFC-  , expressionTactic [":e", ":eval"] TEval-  , expressionTactic [":t", ":type"] TCheck-  , expressionTactic [":search"] TSearch-  , (["fail"], Just StringLitTArg, const $-       do msg <- fst <$> stringLiteral-          return $ TFail [Idris.Core.TT.TextPart msg])-  , ([":doc"], Just ExprTArg, const $-       do whiteSpace-          doc <- (Right . fst <$> constant) <|> (Left . fst <$> fnName)-          eof-          return (TDocStr doc))-  ]-  where-  expressionTactic names tactic = (names, Just ExprTArg, \syn ->-     do t <- spaced (expr syn)-        i <- get-        return $ tactic (desugar syn i t))-  noArgs names tactic = (names, Nothing, const (return tactic))-  spaced parser = indentPropHolds gtProp *> parser-  imp :: IdrisParser Bool-  imp = do lchar '?'; return False-    <|> do lchar '_'; return True-  --tactic :: SyntaxInfo -> IdrisParser PTactic-tactic syn = choice [ do choice (map reserved names); parser syn-                    | (names, _, parser) <- tactics ]-          <|> do lchar '{'-                 t <- tactic syn;-                 lchar ';';-                 ts <- sepBy1 (tactic syn) (lchar ';')-                 lchar '}'-                 return $ TSeq t (mergeSeq ts)-          <|> ((lchar ':' >> empty) <?> "prover command")-          <?> "tactic"-  where-    mergeSeq :: [PTactic] -> PTactic-    mergeSeq [t]    = t-    mergeSeq (t:ts) = TSeq t (mergeSeq ts)---- | Parses a tactic as a whole-fullTactic :: SyntaxInfo -> IdrisParser PTactic-fullTactic syn = do t <- tactic syn-                    eof-                    return t-
− src/Idris/ParseHelpers.hs 
@@ -1,668 +0,0 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, StandaloneDeriving #-}-#if !(MIN_VERSION_base(4,8,0))-{-# LANGUAGE OverlappingInstances #-}-#endif-module Idris.ParseHelpers where--import Prelude hiding (pi)--import Text.Trifecta.Delta-import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)-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--import Idris.AbsSyntax--import Idris.Core.TT-import Idris.Core.Evaluate-import Idris.Delaborate (pprintErr)-import Idris.Docstrings-import Idris.Output (iWarn)--import qualified Util.Pretty as Pretty (text)--import Control.Applicative-import Control.Monad-import Control.Monad.State.Strict--import Data.Maybe-import qualified Data.List.Split as Spl-import Data.List-import Data.Monoid-import Data.Char-import qualified Data.Map as M-import qualified Data.HashSet as HS-import qualified Data.Text as T-import qualified Data.ByteString.UTF8 as UTF8--import System.FilePath--import Debug.Trace---- | Idris parser with state used during parsing-type IdrisParser = StateT IState IdrisInnerParser--newtype IdrisInnerParser a = IdrisInnerParser { runInnerParser :: Parser a }-  deriving (Monad, Functor, MonadPlus, Applicative, Alternative, CharParsing, LookAheadParsing, DeltaParsing, MarkParsing Delta, Monoid, TokenParsing)--deriving instance Parsing IdrisInnerParser--#if MIN_VERSION_base(4,8,0)-instance {-# OVERLAPPING #-} TokenParsing IdrisParser where-#else-instance TokenParsing IdrisParser where-#endif-  someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()-  token p = do s <- get-               (FC fn (sl, sc) _) <- getFC --TODO: Update after fixing getFC-                                           -- See Issue #1594-               r <- p-               (FC fn _ (el, ec)) <- getFC-               whiteSpace-               put (s { lastTokenSpan = Just (FC fn (sl, sc) (el, ec)) })-               return r--- | Generalized monadic parsing constraint type-type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m)--class HasLastTokenSpan m where-  getLastTokenSpan :: m (Maybe FC)--instance HasLastTokenSpan IdrisParser where-  getLastTokenSpan = lastTokenSpan <$> get---- | Helper to run Idris inner parser based stateT parsers-runparser :: StateT st IdrisInnerParser res -> st -> String -> String -> Result res-runparser p i inputname =-  parseString (runInnerParser (evalStateT p i))-              (Directed (UTF8.fromString inputname) 0 0 0 0)--highlightP :: FC -> OutputAnnotation -> IdrisParser ()-highlightP fc annot = do ist <- get-                         put ist { idris_parserHighlights = (fc, annot) : idris_parserHighlights ist}--noDocCommentHere :: String -> IdrisParser ()-noDocCommentHere msg =-  optional (do fc <- getFC-               docComment-               ist <- get-               put ist { parserWarnings = (fc, Msg msg) : parserWarnings ist}) *>-  pure ()--clearParserWarnings :: Idris ()-clearParserWarnings = do ist <- getIState-                         putIState ist { parserWarnings = [] }--reportParserWarnings :: Idris ()-reportParserWarnings = do ist <- getIState-                          mapM_ (uncurry iWarn)-                                (map (\ (fc, err) -> (fc, pprintErr ist err)) .-                                 reverse .-                                 nubBy (\(fc, err) (fc', err') ->-                                         FC' fc == FC' fc' && err == err') $-                                 parserWarnings ist)-                          clearParserWarnings--{- * Space, comments and literals (token/lexing like parsers) -}---- | Consumes any simple whitespace (any character which satisfies Char.isSpace)-simpleWhiteSpace :: MonadicParsing m => m ()-simpleWhiteSpace = satisfy isSpace *> pure ()---- | Checks if a charcter is end of line-isEol :: Char -> Bool-isEol '\n' = True-isEol  _   = False---- | A parser that succeeds at the end of the line-eol :: MonadicParsing m => m ()-eol = (satisfy isEol *> pure ()) <|> lookAhead eof <?> "end of line"--{- | Consumes a single-line comment--@-     SingleLineComment_t ::= '--' ~EOL_t* EOL_t ;-@- -}-singleLineComment :: MonadicParsing m => m ()-singleLineComment = (string "--" *>-                     many (satisfy (not . isEol)) *>-                     eol *> pure ())-                    <?> ""--{- | Consumes a multi-line comment--@-  MultiLineComment_t ::=-     '{ -- }'-   | '{ -' InCommentChars_t-  ;-@--@-  InCommentChars_t ::=-   '- }'-   | MultiLineComment_t InCommentChars_t-   | ~'- }'+ InCommentChars_t-  ;-@--}-multiLineComment :: MonadicParsing m => m ()-multiLineComment =     try (string "{-" *> (string "-}") *> pure ())-                   <|> string "{-" *> inCommentChars-                   <?> ""-  where inCommentChars :: MonadicParsing m => m ()-        inCommentChars =     string "-}" *> pure ()-                         <|> try (multiLineComment) *> inCommentChars-                         <|> string "|||" *> many (satisfy (not . isEol)) *> eol *> inCommentChars-                         <|> skipSome (noneOf startEnd) *> inCommentChars-                         <|> oneOf startEnd *> inCommentChars-                         <?> "end of comment"-        startEnd :: String-        startEnd = "{}-"--{-| Parses a documentation comment--@-  DocComment_t ::=   '|||' ~EOL_t* EOL_t-                 ;-@- -}-docComment :: IdrisParser (Docstring (), [(Name, Docstring ())])-docComment = do dc <- pushIndent *> docCommentLine-                rest <- many (indented docCommentLine)-                args <- many $ do (name, first) <- indented argDocCommentLine-                                  rest <- many (indented docCommentLine)-                                  return (name, concat (intersperse "\n" (first:rest)))-                popIndent-                return (parseDocstring $ T.pack (concat (intersperse "\n" (dc:rest))),-                        map (\(n, d) -> (n, parseDocstring (T.pack d))) args)--  where docCommentLine :: MonadicParsing m => m String-        docCommentLine = try (do string "|||"-                                 many (satisfy (==' '))-                                 contents <- option "" (do first <- satisfy (\c -> not (isEol c || c == '@'))-                                                           res <- many (satisfy (not . isEol))-                                                           return $ first:res)-                                 eol ; someSpace-                                 return contents)-- ++ concat rest))-                        <?> ""--        argDocCommentLine = do string "|||"-                               many (satisfy isSpace)-                               char '@'-                               many (satisfy isSpace)-                               n <- fst <$> name-                               many (satisfy isSpace)-                               docs <- many (satisfy (not . isEol))-                               eol ; someSpace-                               return (n, docs)---- | Parses some white space-whiteSpace :: MonadicParsing m => m ()-whiteSpace = Tok.whiteSpace---- | Parses a string literal-stringLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (String, FC)-stringLiteral = do str <- Tok.stringLiteral-                   fc <- getLastTokenSpan-                   return (str, fromMaybe NoFC fc)---- | Parses a char literal-charLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (Char, FC)-charLiteral = do ch <- Tok.charLiteral-                 fc <- getLastTokenSpan-                 return (ch, fromMaybe NoFC fc)---- | Parses a natural number-natural :: (MonadicParsing m, HasLastTokenSpan m) => m (Integer, FC)-natural = do n <- Tok.natural-             fc <- getLastTokenSpan-             return (n, fromMaybe NoFC fc)---- | Parses an integral number-integer :: MonadicParsing m => m Integer-integer = Tok.integer---- | Parses a floating point number-float :: (MonadicParsing m, HasLastTokenSpan m) => m (Double, FC)-float = do f <- Tok.double-           fc <- getLastTokenSpan-           return (f, fromMaybe NoFC fc)--{- * Symbols, identifiers, names and operators -}----- | Idris Style for parsing identifiers/reserved keywords-idrisStyle :: MonadicParsing m => IdentifierStyle m-idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved Hi.Identifier Hi.ReservedIdentifier-  where _styleName = "Idris"-        _styleStart = satisfy isAlpha <|> oneOf "_"-        _styleLetter = satisfy isAlphaNum <|> oneOf "_'."-        _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "corecord", "Type",-                                      "do", "dsl", "import", "impossible",-                                      "case", "of", "total", "partial", "mutual",-                                      "infix", "infixl", "infixr", "rewrite",-                                      "where", "with", "syntax", "proof", "postulate",-                                      "using", "namespace", "class", "instance", -                                      "interface", "implementation", "parameters",-                                      "public", "private", "abstract", "implicit",-                                      "quoteGoal", "constructor",-                                      "if", "then", "else"]--char :: MonadicParsing m => Char -> m Char-char = Chr.char--string :: MonadicParsing m => String -> m String-string = Chr.string---- | Parses a character as a token-lchar :: MonadicParsing m => Char -> m Char-lchar = token . char---- | Parses a character as a token, returning the source span of the character-lcharFC :: MonadicParsing m => Char -> m FC-lcharFC ch = do (FC file (l, c) _) <- getFC-                _ <- token (char ch)-                return $ FC file (l, c) (l, c+1)---- | Parses string as a token-symbol :: MonadicParsing m => String -> m String-symbol = Tok.symbol--symbolFC :: MonadicParsing m => String -> m FC-symbolFC str = do (FC file (l, c) _) <- getFC-                  Tok.symbol str-                  return $ FC file (l, c) (l, c + length str)---- | Parses a reserved identifier-reserved :: MonadicParsing m => String -> m ()-reserved = Tok.reserve idrisStyle---- | Parses a reserved identifier, computing its span. Assumes that--- reserved identifiers never contain line breaks.-reservedFC :: MonadicParsing m => String -> m FC-reservedFC str = do (FC file (l, c) _) <- getFC-                    Tok.reserve idrisStyle str-                    return $ FC file (l, c) (l, c + length str)---- | Parse a reserved identfier, highlighting its span as a keyword-reservedHL :: String -> IdrisParser ()-reservedHL str = reservedFC str >>= flip highlightP AnnKeyword---- Taken from Parsec (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007--- | Parses a reserved operator-reservedOp :: MonadicParsing m => String -> m ()-reservedOp name = token $ try $-  do string name-     notFollowedBy (operatorLetter) <?> ("end of " ++ show name)--reservedOpFC :: MonadicParsing m => String -> m FC-reservedOpFC name = token $ try $ do (FC f (l, c) _) <- getFC-                                     string name-                                     notFollowedBy (operatorLetter) <?> ("end of " ++ show name)-                                     return (FC f (l, c) (l, c + length name))---- | Parses an identifier as a token-identifier :: (MonadicParsing m) => m (String, FC)-identifier = try(do (i, fc) <--                      token $ do (FC f (l, c) _) <- getFC-                                 i <- Tok.ident idrisStyle-                                 return (i, FC f (l, c) (l, c + length i))-                    when (i == "_") $ unexpected "wildcard"-                    return (i, fc))---- | Parses an identifier with possible namespace as a name-iName :: (MonadicParsing m, HasLastTokenSpan m) => [String] -> m (Name, FC)-iName bad = do (n, fc) <- maybeWithNS identifier False bad-               return (n, fc)-            <?> "name"---- | Parses an string possibly prefixed by a namespace-maybeWithNS :: (MonadicParsing m, HasLastTokenSpan m) => m (String, FC) -> Bool -> [String] -> m (Name, FC)-maybeWithNS parser ascend bad = do-  fc <- getFC-  i <- option "" (lookAhead (fst <$> identifier))-  when (i `elem` bad) $ unexpected "reserved identifier"-  let transf = if ascend then id else reverse-  (x, xs, fc) <- choice (transf (parserNoNS parser : parsersNS parser i))-  return (mkName (x, xs), fc)-  where parserNoNS :: MonadicParsing m => m (String, FC) -> m (String, String, FC)-        parserNoNS parser = do startFC <- getFC-                               (x, nameFC) <- parser-                               return (x, "", spanFC startFC nameFC)-        parserNS   :: MonadicParsing m => m (String, FC) -> String -> m (String, String, FC)-        parserNS   parser ns = do startFC <- getFC-                                  xs <- string ns-                                  lchar '.';  (x, nameFC) <- parser-                                  return (x, xs, spanFC startFC nameFC)-        parsersNS  :: MonadicParsing m => m (String, FC) -> String -> [m (String, String, FC)]-        parsersNS parser i = [try (parserNS parser ns) | ns <- (initsEndAt (=='.') i)]---- | Parses a name-name :: IdrisParser (Name, FC)-name = (<?> "name") $ do-    keywords <- syntax_keywords <$> get-    aliases  <- module_aliases  <$> get-    (n, fc) <- iName keywords-    return (unalias aliases n, fc)-  where-    unalias :: M.Map [T.Text] [T.Text] -> Name -> Name-    unalias aliases (NS n ns) | Just ns' <- M.lookup ns aliases = NS n ns'-    unalias aliases name = name--{- | List of all initial segments in ascending order of a list.  Every-such initial segment ends right before an element satisfying the given-condition.--}-initsEndAt :: (a -> Bool) -> [a] -> [[a]]-initsEndAt p [] = []-initsEndAt p (x:xs) | p x = [] : x_inits_xs-                    | otherwise = x_inits_xs-  where x_inits_xs = [x : cs | cs <- initsEndAt p xs]---{- | Create a `Name' from a pair of strings representing a base name and its- namespace.--}-mkName :: (String, String) -> Name-mkName (n, "") = sUN n-mkName (n, ns) = sNS (sUN n) (reverse (parseNS ns))-  where parseNS x = case span (/= '.') x of-                      (x, "")    -> [x]-                      (x, '.':y) -> x : parseNS y--opChars :: String-opChars = ":!#$%&*+./<=>?@\\^|-~"--operatorLetter :: MonadicParsing m => m Char-operatorLetter = oneOf opChars---commentMarkers :: [String]-commentMarkers = [ "--", "|||" ]--invalidOperators :: [String]-invalidOperators = [":", "=>", "->", "<-", "=", "?=", "|", "**", "==>", "\\", "%", "~", "?", "!"]---- | Parses an operator-operator :: MonadicParsing m => m String-operator = do op <- token . some $ operatorLetter-              when (op `elem` (invalidOperators ++ commentMarkers)) $-                   fail $ op ++ " is not a valid operator"-              return op---- | Parses an operator-operatorFC :: MonadicParsing m => m (String, FC)-operatorFC = do (op, fc) <- token $ do (FC f (l, c) _) <- getFC-                                       op <- some operatorLetter-                                       return (op, FC f (l, c) (l, c + length op))-                when (op `elem` (invalidOperators ++ commentMarkers)) $-                     fail $ op ++ " is not a valid operator"-                return (op, fc)--{- * Position helpers -}-{- | Get filename from position (returns "(interactive)" when no source file is given)  -}-fileName :: Delta -> String-fileName (Directed fn _ _ _ _) = UTF8.toString fn-fileName _                     = "(interactive)"--{- | Get line number from position -}-lineNum :: Delta -> Int-lineNum (Lines l _ _ _)      = fromIntegral l + 1-lineNum (Directed _ l _ _ _) = fromIntegral l + 1-lineNum _ = 0--{- | Get column number from position -}-columnNum :: Delta -> Int-columnNum pos = fromIntegral (column pos) + 1---{- | Get file position as FC -}-getFC :: MonadicParsing m => m FC-getFC = do s <- position-           let (dir, file) = splitFileName (fileName s)-           let f = if dir == addTrailingPathSeparator "." then file else fileName s-           return $ FC f (lineNum s, columnNum s) (lineNum s, columnNum s) -- TODO: Change to actual spanning-           -- Issue #1594 on the Issue Tracker.-           -- https://github.com/idris-lang/Idris-dev/issues/1594---{-* Syntax helpers-}--- | Bind constraints to term-bindList :: (Name -> FC -> PTerm -> PTerm -> PTerm) -> [(Name, FC, PTerm)] -> PTerm -> PTerm-bindList b []              sc = sc-bindList b ((n, fc, t):bs) sc = b n fc t (bindList b bs sc)--{- | @commaSeparated p@ parses one or more occurences of `p`,-     separated by commas and optional whitespace. -}-commaSeparated :: MonadicParsing m => m a -> m [a]-commaSeparated p = p `sepBy1` (spaces >> char ',' >> spaces)--{- * Layout helpers -}---- | Push indentation to stack-pushIndent :: IdrisParser ()-pushIndent = do pos <- position-                ist <- get-                put (ist { indent_stack = (fromIntegral (column pos) + 1) : indent_stack ist })---- | Pops indentation from stack-popIndent :: IdrisParser ()-popIndent = do ist <- get-               case indent_stack ist of-                 [] -> error "The impossible happened! Tried to pop an indentation level where none was pushed (underflow)."-                 (x : xs) -> put (ist { indent_stack = xs })----- | Gets current indentation-indent :: IdrisParser Int-indent = liftM ((+1) . fromIntegral . column) position---- | Gets last indentation-lastIndent :: IdrisParser Int-lastIndent = do ist <- get-                case indent_stack ist of-                  (x : xs) -> return x-                  _        -> return 1---- | Applies parser in an indented position-indented :: IdrisParser a -> IdrisParser a-indented p = notEndBlock *> p <* keepTerminator---- | Applies parser to get a block (which has possibly indented statements)-indentedBlock :: IdrisParser a -> IdrisParser [a]-indentedBlock p = do openBlock-                     pushIndent-                     res <- many (indented p)-                     popIndent-                     closeBlock-                     return res---- | Applies parser to get a block with at least one statement (which has possibly indented statements)-indentedBlock1 :: IdrisParser a -> IdrisParser [a]-indentedBlock1 p = do openBlock-                      pushIndent-                      res <- some (indented p)-                      popIndent-                      closeBlock-                      return res---- | Applies parser to get a block with exactly one (possibly indented) statement-indentedBlockS :: IdrisParser a -> IdrisParser a-indentedBlockS p = do openBlock-                      pushIndent-                      res <- indented p-                      popIndent-                      closeBlock-                      return res----- | Checks if the following character matches provided parser-lookAheadMatches :: MonadicParsing m => m a -> m Bool-lookAheadMatches p = do match <- lookAhead (optional p)-                        return $ isJust match---- | Parses a start of block-openBlock :: IdrisParser ()-openBlock =     do lchar '{'-                   ist <- get-                   put (ist { brace_stack = Nothing : brace_stack ist })-            <|> do ist <- get-                   lvl' <- indent-                    -- if we're not indented further, it's an empty block, so-                    -- increment lvl to ensure we get to the end-                   let lvl = case brace_stack ist of-                                   Just lvl_old : _ ->-                                       if lvl' <= lvl_old then lvl_old+1-                                                          else lvl'-                                   [] -> if lvl' == 1 then 2 else lvl'-                                   _ -> lvl'-                   put (ist { brace_stack = Just lvl : brace_stack ist })-            <?> "start of block"---- | Parses an end of block-closeBlock :: IdrisParser ()-closeBlock = do ist <- get-                bs <- case brace_stack ist of-                        []  -> eof >> return []-                        Nothing : xs -> lchar '}' >> return xs <?> "end of block"-                        Just lvl : xs -> (do i   <- indent-                                             isParen <- lookAheadMatches (char ')')-                                             isIn <- lookAheadMatches (reserved "in")-                                             if i >= lvl && not (isParen || isIn)-                                                then fail "not end of block"-                                                else return xs)-                                          <|> (do notOpenBraces-                                                  eof-                                                  return [])-                put (ist { brace_stack = bs })---- | Parses a terminator-terminator :: IdrisParser ()-terminator =     do lchar ';'; popIndent-             <|> do c <- indent; l <- lastIndent-                    if c <= l then popIndent else fail "not a terminator"-             <|> do isParen <- lookAheadMatches (oneOf ")}")-                    if isParen then popIndent else fail "not a terminator"-             <|> lookAhead eof---- | Parses and keeps a terminator-keepTerminator :: IdrisParser ()-keepTerminator =  do lchar ';'; return ()-              <|> do c <- indent; l <- lastIndent-                     unless (c <= l) $ fail "not a terminator"-              <|> do isParen <- lookAheadMatches (oneOf ")}|")-                     isIn <- lookAheadMatches (reserved "in")-                     unless (isIn || isParen) $ fail "not a terminator"-              <|> lookAhead eof---- | Checks if application expression does not end-notEndApp :: IdrisParser ()-notEndApp = do c <- indent; l <- lastIndent-               when (c <= l) (fail "terminator")---- | Checks that it is not end of block-notEndBlock :: IdrisParser ()-notEndBlock = do ist <- get-                 case brace_stack ist of-                      Just lvl : xs -> do i <- indent-                                          isParen <- lookAheadMatches (char ')')-                                          when (i < lvl || isParen) (fail "end of block")-                      _ -> return ()---- | Representation of an operation that can compare the current indentation with the last indentation, and an error message if it fails-data IndentProperty = IndentProperty (Int -> Int -> Bool) String---- | Allows comparison of indent, and fails if property doesn't hold-indentPropHolds :: IndentProperty -> IdrisParser ()-indentPropHolds (IndentProperty op msg) = do-  li <- lastIndent-  i <- indent-  when (not $ op i li) $ fail ("Wrong indention: " ++ msg)---- | Greater-than indent property-gtProp :: IndentProperty-gtProp = IndentProperty (>) "should be greater than context indentation"---- | Greater-than or equal to indent property-gteProp :: IndentProperty-gteProp = IndentProperty (>=) "should be greater than or equal context indentation"---- | Equal indent property-eqProp :: IndentProperty-eqProp = IndentProperty (==) "should be equal to context indentation"---- | Less-than indent property-ltProp :: IndentProperty-ltProp = IndentProperty (<) "should be less than context indentation"---- | Less-than or equal to indent property-lteProp :: IndentProperty-lteProp = IndentProperty (<=) "should be less than or equal to context indentation"----- | Checks that there are no braces that are not closed-notOpenBraces :: IdrisParser ()-notOpenBraces = do ist <- get-                   when (hasNothing $ brace_stack ist) $ fail "end of input"-  where hasNothing :: [Maybe a] -> Bool-        hasNothing = any isNothing--{- | Parses an accessibilty modifier (e.g. public, private) -}-accessibility :: IdrisParser Accessibility-accessibility = do reserved "public";   return Public-            <|> do reserved "abstract"; return Frozen-            <|> do reserved "private";  return Hidden-            <?> "accessibility modifier"---- | Adds accessibility option for function-addAcc :: Name -> Maybe Accessibility -> IdrisParser ()-addAcc n a = do i <- get-                put (i { hide_list = (n, a) : hide_list i })--{- | Add accessbility option for data declarations- (works for classes too - 'abstract' means the data/class is visible but members not) -}-accData :: Maybe Accessibility -> Name -> [Name] -> IdrisParser ()-accData (Just Frozen) n ns = do addAcc n (Just Frozen)-                                mapM_ (\n -> addAcc n (Just Hidden)) ns-accData a n ns = do addAcc n a-                    mapM_ (`addAcc` a) ns---{- * Error reporting helpers -}-{- | Error message with possible fixes list -}-fixErrorMsg :: String -> [String] -> String-fixErrorMsg msg fixes = msg ++ ", possible fixes:\n" ++ (concat $ intersperse "\n\nor\n\n" fixes)---- | Collect 'PClauses' with the same function name-collect :: [PDecl] -> [PDecl]-collect (c@(PClauses _ o _ _) : ds)-    = clauses (cname c) [] (c : ds)-  where clauses :: Maybe Name -> [PClause] -> [PDecl] -> [PDecl]-        clauses j@(Just n) acc (PClauses fc _ _ [PClause fc' n' l ws r w] : ds)-           | n == n' = clauses j (PClause fc' n' l ws r (collect w) : acc) ds-        clauses j@(Just n) acc (PClauses fc _ _ [PWith fc' n' l ws r pn w] : ds)-           | n == n' = clauses j (PWith fc' n' l ws r pn (collect w) : acc) ds-        clauses (Just n) acc xs = PClauses (fcOf c) o n (reverse acc) : collect xs-        clauses Nothing acc (x:xs) = collect xs-        clauses Nothing acc [] = []--        cname :: PDecl -> Maybe Name-        cname (PClauses fc _ _ [PClause _ n _ _ _ _]) = Just n-        cname (PClauses fc _ _ [PWith   _ n _ _ _ _ _]) = Just n-        cname (PClauses fc _ _ [PClauseR _ _ _ _]) = Nothing-        cname (PClauses fc _ _ [PWithR _ _ _ _ _]) = Nothing-        fcOf :: PDecl -> FC-        fcOf (PClauses fc _ _ _) = fc-collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds-collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds-collect (PNamespace ns fc ps : ds) = PNamespace ns fc (collect ps) : collect ds-collect (PClass doc f s cs n nfc ps pdocs fds ds cn cd : ds')-    = PClass doc f s cs n nfc ps pdocs fds (collect ds) cn cd : collect ds'-collect (PInstance doc argDocs f s cs n nfc ps t en ds : ds')-    = PInstance doc argDocs f s cs n nfc ps t en (collect ds) : collect ds'-collect (d : ds) = d : collect ds-collect [] = []
− src/Idris/ParseOps.hs 
@@ -1,173 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}-module Idris.ParseOps where--import Prelude hiding (pi)--import Text.Trifecta.Delta-import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)-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--import Idris.AbsSyntax-import Idris.ParseHelpers--import Idris.Core.TT--import Control.Applicative-import Control.Monad-import Control.Monad.State.Strict--import Data.Maybe-import qualified Data.List.Split as Spl-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---- | Creates table for fixity declarations to build expression parser--- using pre-build and user-defined operator/fixity declarations-table :: [FixDecl] -> OperatorTable IdrisParser PTerm-table fixes-   = [[prefix "-" (\fc x -> PApp fc (PRef fc [fc] (sUN "negate")) [pexp x])]] ++-     toTable (reverse fixes) ++-     [[backtick],-      [binary "$" (\fc x y -> flatten $ PApp fc x [pexp y]) AssocRight],-      [binary "="  (\fc x y -> PApp fc (PRef fc [fc] eqTy) [pexp x, pexp y]) AssocLeft],-      [nofixityoperator]]-  where-    flatten :: PTerm -> PTerm -- flatten application-    flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))-    flatten t = t----- | Calculates table for fixity declarations-toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm-toTable fs = map (map toBin)-                 (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)-   where toBin (Fix (PrefixN _) op) = prefix op-                                       (\fc x -> PApp fc (PRef fc [] (sUN op)) [pexp x])-         toBin (Fix f op)-            = binary op (\fc x y -> PApp fc (PRef fc [] (sUN op)) [pexp x,pexp y]) (assoc f)-         assoc (Infixl _) = AssocLeft-         assoc (Infixr _) = AssocRight-         assoc (InfixN _) = AssocNone---- | Binary operator-binary :: String -> (FC -> PTerm -> PTerm -> PTerm) -> Assoc -> Operator IdrisParser PTerm-binary name f = Infix (do indentPropHolds gtProp-                          fc <- reservedOpFC name-                          indentPropHolds gtProp-                          return (f fc))---- | Prefix operator-prefix :: String -> (FC -> PTerm -> PTerm) -> Operator IdrisParser PTerm-prefix name f = Prefix (do reservedOp name-                           fc <- getFC-                           indentPropHolds gtProp-                           return (f fc))---- | Backtick operator-backtick :: Operator IdrisParser PTerm-backtick = Infix (do indentPropHolds gtProp-                     lchar '`'; (n, fc) <- fnName-                     lchar '`'-                     indentPropHolds gtProp-                     return (\x y -> PApp fc (PRef fc [fc] n) [pexp x, pexp y])) AssocNone---- | Operator without fixity (throws an error)-nofixityoperator :: Operator IdrisParser PTerm-nofixityoperator = Infix (do indentPropHolds gtProp-                             op <- try operator-                             unexpected $ "Operator without known fixity: " ++ op) AssocNone---{- | Parses an operator in function position i.e. enclosed by `()', with an- optional namespace--@-  OperatorFront ::=-    '(' '=' ')'-    | (Identifier_t '.')? '(' Operator_t ')'-    ;-@---}-operatorFront :: IdrisParser (Name, FC)-operatorFront = try (do (FC f (l, c) _) <- getFC-                        op <- lchar '(' *> reservedOp "="  <* lchar ')'-                        return (eqTy, FC f (l, c) (l, c+3)))-            <|> maybeWithNS (do (FC f (l, c) _) <- getFC-                                op <- lchar '(' *> operator-                                (FC _ _ (l', c')) <- getFC-                                lchar ')'-                                return (op, (FC f (l, c) (l', c' + 1)))) False []--{- | Parses a function (either normal name or operator)--@-  FnName ::= Name | OperatorFront;-@--}-fnName :: IdrisParser (Name, FC)-fnName = try operatorFront <|> name <?> "function name"--{- | Parses a fixity declaration-@-Fixity ::=-  FixityType Natural_t OperatorList Terminator-  ;-@--}-fixity :: IdrisParser PDecl-fixity = do pushIndent-            f <- fixityType; i <- fst <$> natural;-            ops <- sepBy1 operator (lchar ',')-            terminator-            let prec = fromInteger i-            istate <- get-            let infixes = idris_infixes istate-            let fs      = map (Fix (f prec)) ops-            let redecls = map (alreadyDeclared infixes) fs-            let ill     = filter (not . checkValidity) redecls-            if null ill-               then do put (istate { idris_infixes = nub $ sort (fs ++ infixes)-                                     , ibc_write     = map IBCFix fs ++ ibc_write istate-                                   })-                       fc <- getFC-                       return (PFix fc (f prec) ops)-               else fail $ concatMap (\(f, (x:xs)) -> "Illegal redeclaration of fixity:\n\t\""-                                                ++ show f ++ "\" overrides \"" ++ show x ++ "\"") ill-         <?> "fixity declaration"-             where alreadyDeclared :: [FixDecl] -> FixDecl -> (FixDecl, [FixDecl])-                   alreadyDeclared fs f = (f, filter ((extractName f ==) . extractName) fs)--                   checkValidity :: (FixDecl, [FixDecl]) -> Bool-                   checkValidity (f, fs) = all (== f) fs--                   extractName :: FixDecl -> String-                   extractName (Fix _ n) = n--{- | Parses a fixity declaration type (i.e. infix or prefix, associtavity)-@-    FixityType ::=-      'infixl'-      | 'infixr'-      | 'infix'-      | 'prefix'-      ;-@- -}-fixityType :: IdrisParser (Int -> Fixity)-fixityType = do reserved "infixl"; return Infixl-         <|> do reserved "infixr"; return Infixr-         <|> do reserved "infix";  return InfixN-         <|> do reserved "prefix"; return PrefixN-         <?> "fixity type"-
src/Idris/Parser.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-} {-# OPTIONS_GHC -O0 #-} module Idris.Parser(module Idris.Parser,-                    module Idris.ParseExpr,-                    module Idris.ParseData,-                    module Idris.ParseHelpers,-                    module Idris.ParseOps) where+                    module Idris.Parser.Expr,+                    module Idris.Parser.Data,+                    module Idris.Parser.Helpers,+                    module Idris.Parser.Ops) where  import Prelude hiding (pi) @@ -35,10 +35,10 @@ import Idris.Providers import Idris.Output -import Idris.ParseHelpers-import Idris.ParseOps-import Idris.ParseExpr-import Idris.ParseData+import Idris.Parser.Helpers+import Idris.Parser.Ops+import Idris.Parser.Expr+import Idris.Parser.Data  import Idris.Docstrings hiding (Unchecked) @@ -211,7 +211,7 @@                              declBody continue)                      <|> fail "End of readable input"   where declBody :: Bool -> IdrisParser [PDecl]-        declBody b = +        declBody b =                    try (instance_ True syn)                    <|> declBody' b                    <|> using_ syn@@ -337,8 +337,8 @@                   (map (updateNs ns) ds)                   (updateRecCon ns cname)                   cdocs-    updateNs ns (PInstance docs pdocs s fc cs cn fc' ps ity ni ds)-         = PInstance docs pdocs s fc cs (updateB ns cn) fc'+    updateNs ns (PInstance docs pdocs s fc cs acc opts cn fc' ps ity ni ds)+         = PInstance docs pdocs s fc cs acc opts (updateB ns cn) fc'                      ps ity (fmap (updateB ns) ni)                             (map (updateNs ns) ds)     updateNs ns (PMutual fc ds) = PMutual fc (map (updateNs ns) ds)@@ -502,7 +502,9 @@                body' <- fixBind ((n,n'):rens) body                return $ PLam fc n' nfc ty' body'         fixBind rens (PPi plic n nfc argTy body)-          | n `elem` userNames = liftM2 (PPi plic n nfc) (fixBind rens argTy) (fixBind rens body)+          | n `elem` userNames = liftM2 (PPi plic n nfc)+                                        (fixBind rens argTy)+                                        (fixBind rens body)           | otherwise =             do ty' <- fixBind rens argTy                n' <- gensym n@@ -521,6 +523,10 @@                return $ PLet fc n' nfc ty' val' body'         fixBind rens (PMatchApp fc n) | Just n' <- lookup n rens =           return $ PMatchApp fc n'+        -- Also rename resolved quotations, to allow syntax rules to+        -- have quoted references to their own bindings.+        fixBind rens (PQuoteName n True fc) | Just n' <- lookup n rens =+          return $ PQuoteName n' True fc         fixBind rens x = descendM (fixBind rens) x          gensym :: Name -> IdrisParser Name@@ -584,7 +590,7 @@                                           then [TotalFn]                                           else []                         opts <- fnOpts initOpts-                        acc <- optional accessibility+                        acc <- accessibility                         opts' <- fnOpts opts                         (n_in, nfc) <- fnName                         let n = expandNS syn n_in@@ -698,7 +704,7 @@                                      then [TotalFn]                                      else []                    opts <- fnOpts initOpts-                   acc <- optional accessibility+                   acc <- accessibility                    opts' <- fnOpts opts                    (n_in, nfc) <- fnName                    let n = expandNS syn n_in@@ -856,7 +862,7 @@ class_ :: SyntaxInfo -> IdrisParser [PDecl] class_ syn = do (doc, argDocs, acc)                   <- try (do (doc, argDocs) <- docstring syn-                             acc <- optional accessibility+                             acc <- accessibility                              classKeyword                              return (doc, argDocs, acc))                 fc <- getFC@@ -873,15 +879,12 @@   where     fundeps :: IdrisParser [(Name, FC)]     fundeps = do lchar '|'; sepBy name (lchar ',')-                             +     classKeyword :: IdrisParser ()     classKeyword = reservedHL "interface"                <|> do reservedHL "class"                       fc <- getFC-                      ist <- get-                      put ist { parserWarnings = -                         (fc, Msg "The 'class' keyword is deprecated. Use 'interface' instead.")-                              : parserWarnings ist }+                      parserWarning fc Nothing (Msg "The 'class' keyword is deprecated. Use 'interface' instead.")      carg :: IdrisParser (Name, FC, PTerm)     carg = do lchar '('; (i, ifc) <- name; lchar ':'; ty <- expr syn; lchar ')'@@ -903,8 +906,16 @@ @ -} instance_ :: Bool -> SyntaxInfo -> IdrisParser [PDecl]-instance_ kwopt syn -              = do (doc, argDocs)+instance_ kwopt syn+              = do ist <- get+                   let initOpts = if default_total ist+                                          then [TotalFn]+                                          else []+                   opts <- fnOpts initOpts+                   acc <- accessibility+                   opts' <- fnOpts opts++                   (doc, argDocs)                      <- try (docstring syn <* if kwopt then optional instanceKeyword                                                        else do instanceKeyword                                                                return (Just ()))@@ -917,7 +928,7 @@                    let sc = PApp fc (PRef cnfc [cnfc] cn) (map pexp args)                    let t = bindList (PPi constraint) cs sc                    ds <- instanceBlock syn-                   return [PInstance doc argDocs syn fc cs' cn cnfc args t en ds]+                   return [PInstance doc argDocs syn fc cs' acc opts' cn cnfc args t en ds]                  <?> "implementation declaration"   where instanceName :: IdrisParser Name         instanceName = do lchar '['; n_in <- fst <$> fnName; lchar ']'@@ -928,11 +939,7 @@         instanceKeyword = reservedHL "implementation"                       <|> do reservedHL "instance"                              fc <- getFC-                             ist <- get-                             put ist { parserWarnings = -                                (fc, Msg "The 'instance' keyword is deprecated. Use 'implementation' (or omit it) instead.")-                                     : parserWarnings ist }-+                             parserWarning fc Nothing (Msg "The 'instance' keyword is deprecated. Use 'implementation' (or omit it) instead.")  -- | Parse a docstring docstring :: SyntaxInfo@@ -1321,7 +1328,10 @@                     return [PDirective (DHide n)]              <|> do try (lchar '%' *> reserved "freeze"); n <- fst <$> iName []                     return [PDirective (DFreeze n)]-             <|> do try (lchar '%' *> reserved "access"); acc <- accessibility+             <|> do try (lchar '%' *> reserved "access")+                    acc <- accessibility+                    ist <- get+                    put ist { default_access = acc }                     return [PDirective (DAccess acc)]              <|> do try (lchar '%' *> reserved "default"); tot <- totality                     i <- get@@ -1353,7 +1363,12 @@                     fn <- fst <$> fnName                     arg <- fst <$> iName []                     return [PDirective (DUsed fc fn arg)]+             <|> do try (lchar '%' *> reserved "auto_implicits")+                    b <- on_off+                    return [PDirective (DAutoImplicits b)]              <?> "directive"+  where on_off = do reserved "on"; return True+             <|> do reserved "off"; return False  pLangExt :: IdrisParser LanguageExt pLangExt = (reserved "TypeProviders" >> return TypeProviders)@@ -1491,14 +1506,23 @@                                 [(FC, OutputAnnotation)], IState)         imports = do whiteSpace                      (mdoc, mname, annots) <- moduleHeader-                     ps            <- many import_+                     ps_exp        <- many import_                      mrk           <- mark                      isEof         <- lookAheadMatches eof                      let mrk' = if isEof                                    then Nothing                                    else Just mrk                      i     <- get+                     -- add Builtins and Prelude, unless options say+                     -- not to+                     let ps = ps_exp -- imp "Builtins" : imp "Prelude" : ps_exp                      return ((mdoc, mname, ps, mrk'), annots, i)++        imp m = ImportInfo False (toPath m)+                           Nothing [] NoFC NoFC+        ns = Spl.splitOn "."+        toPath = foldl1' (</>) . ns+         addPath :: [(FC, OutputAnnotation)] -> FilePath -> [(FC, OutputAnnotation)]         addPath [] _ = []         addPath ((fc, AnnNamespace ns Nothing) : annots) path =@@ -1556,17 +1580,17 @@                           return (ds, i')  {- | Load idris module and show error if something wrong happens -}-loadModule :: FilePath -> Idris (Maybe String)-loadModule f-   = idrisCatch (loadModule' f)+loadModule :: FilePath -> IBCPhase -> Idris (Maybe String)+loadModule f phase+   = idrisCatch (loadModule' f phase)                 (\e -> do setErrSpan (getErrSpan e)                           ist <- getIState                           iWarn (getErrSpan e) $ pprintErr ist e                           return Nothing)  {- | Load idris module -}-loadModule' :: FilePath -> Idris (Maybe String)-loadModule' f+loadModule' :: FilePath -> IBCPhase -> Idris (Maybe String)+loadModule' f phase    = do i <- getIState         let file = takeWhile (/= ' ') f         ibcsd <- valIBCSubDir i@@ -1580,7 +1604,7 @@                     IDR fn  -> loadSource False fn Nothing                     LIDR fn -> loadSource True  fn Nothing                     IBC fn src ->-                      idrisCatch (loadIBC True fn)+                      idrisCatch (loadIBC True phase fn)                                  (\c -> do logParser 1 $ fn ++ " failed " ++ pshow i c                                            case src of                                              IDR sfn -> loadSource False sfn Nothing@@ -1588,18 +1612,18 @@                   return $ Just file  {- | Load idris code from file -}-loadFromIFile :: Bool -> IFileType -> Maybe Int -> Idris ()-loadFromIFile reexp i@(IBC fn src) maxline+loadFromIFile :: Bool -> IBCPhase -> IFileType -> Maybe Int -> Idris ()+loadFromIFile reexp phase i@(IBC fn src) maxline    = do logParser 1 $ "Skipping " ++ getSrcFile i-        idrisCatch (loadIBC reexp fn)+        idrisCatch (loadIBC reexp phase fn)                 (\err -> ierror $ LoadingFailed fn err)   where     getSrcFile (IDR fn) = fn     getSrcFile (LIDR fn) = fn     getSrcFile (IBC f src) = getSrcFile src -loadFromIFile _ (IDR fn) maxline = loadSource' False fn maxline-loadFromIFile _ (LIDR fn) maxline = loadSource' True fn maxline+loadFromIFile _ _ (IDR fn) maxline = loadSource' False fn maxline+loadFromIFile _ _ (LIDR fn) maxline = loadSource' True fn maxline  {-| Load idris source code and show error if something wrong happens -} loadSource' :: Bool -> FilePath -> Maybe Int -> Idris ()@@ -1630,7 +1654,7 @@                                       LIDR fn -> ifail $ "No ibc for " ++ f                                       IDR fn -> ifail $ "No ibc for " ++ f                                       IBC fn src ->-                                        do loadIBC True fn+                                        do loadIBC True IBC_Building fn                                            let srcFn = case src of                                                          IDR fn -> Just fn                                                          LIDR fn -> Just fn@@ -1662,7 +1686,7 @@                     (n,fc):_ -> throwError . At fc . Msg $ "import alias not unique: " ++ show n                    i <- getIState-                  putIState (i { default_access = Hidden, module_aliases = modAliases })+                  putIState (i { default_access = Private, module_aliases = modAliases })                   clearIBC -- start a new .ibc file                   -- record package info in .ibc                   imps <- allImportDirs@@ -1760,7 +1784,7 @@                   clearHighlights                   i <- getIState                   putIState (i { default_total = def_total,-                                 hide_list = [] })+                                 hide_list = emptyContext })                   return ()   where     namespaces :: [String] -> [PDecl] -> [PDecl]@@ -1790,16 +1814,9 @@         parsedDocs ist = annotCode (tryFullExpr syn ist) docs  {- | Adds names to hide list -}-addHides :: [(Name, Maybe Accessibility)] -> Idris ()+addHides :: Ctxt Accessibility -> Idris () addHides xs = do i <- getIState                  let defh = default_access i-                 let (hs, as) = partition isNothing xs-                 unless (null as) $-                   mapM_ doHide-                     (map (\ (n, _) -> (n, defh)) hs ++-                       map (\ (n, Just a) -> (n, a)) as)-  where isNothing (_, Nothing) = True-        isNothing _            = False--        doHide (n, a) = do setAccessibility n a+                 mapM_ doHide (toAlist xs)+  where doHide (n, a) = do setAccessibility n a                            addIBC (IBCAccess n a)
+ src/Idris/Parser/Data.hs view
@@ -0,0 +1,338 @@+{-# 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 qualified Text.Parser.Token as Tok+import qualified Text.Parser.Char as Chr+import qualified Text.Parser.Token.Highlight as Hi++import Idris.AbsSyntax+import Idris.Parser.Helpers+import Idris.Parser.Ops+import Idris.Parser.Expr+import Idris.DSL++import Idris.Core.TT+import Idris.Core.Evaluate++import Idris.Docstrings++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict++import Data.Maybe+import qualified Data.List.Split as Spl+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+Record ::=+    DocComment Accessibility? 'record' FnName TypeSig 'where' OpenBlock Constructor KeepTerminator CloseBlock;+-}+record :: SyntaxInfo -> IdrisParser PDecl+record syn = do (doc, paramDocs, acc, opts) <- try (do+                      (doc, paramDocs) <- option noDocs docComment+                      ist <- get+                      let doc' = annotCode (tryFullExpr syn ist) doc+                          paramDocs' = [ (n, annotCode (tryFullExpr syn ist) d)+                                     | (n, d) <- paramDocs ]+                      acc <- accessibility+                      opts <- dataOpts []+                      co <- recordI+                      return (doc', paramDocs', acc, opts ++ co))+                fc <- getFC+                (tyn_in, nfc) <- fnName+                let tyn = expandNS syn tyn_in+                let rsyn = syn { syn_namespace = show (nsroot tyn) :+                                                    syn_namespace syn }+                params <- manyTill (recordParameter rsyn) (reservedHL "where")+                (fields, cname, cdoc) <- indentedBlockS $ recordBody rsyn tyn+                let fnames = map (expandNS rsyn) (mapMaybe getName fields)+                case cname of+                     Just cn' -> accData acc tyn (fst cn' : fnames)+                     Nothing -> return ()+                return $ PRecord doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc syn+             <?> "record type declaration"+  where+    getRecNames :: SyntaxInfo -> PTerm -> [Name]+    getRecNames syn (PPi _ n _ _ sc) = [expandNS syn n, expandNS syn (mkType n)]+                                         ++ getRecNames syn sc+    getRecNames _ _ = []++    getName (Just (n, _), _, _, _) = Just n+    getName _ = Nothing++    toFreeze :: Maybe Accessibility -> Maybe Accessibility+    toFreeze (Just Frozen) = Just Private+    toFreeze x = x++    recordBody :: SyntaxInfo -> Name -> IdrisParser ([((Maybe (Name, FC)), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))], Maybe (Name, FC), Docstring (Either Err PTerm))+    recordBody syn tyn = do+        ist <- get+        fc  <- getFC++        (constructorName, constructorDoc) <- option (Nothing, emptyDocstring)+                                             (do (doc, _) <- option noDocs docComment+                                                 n <- constructor+                                                 return (Just n, doc))++        let constructorDoc' = annotate syn ist constructorDoc++        fields <- many . indented $ fieldLine syn++        return (concat fields, constructorName, constructorDoc')+      where+        fieldLine :: SyntaxInfo -> IdrisParser [(Maybe (Name, FC), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))]+        fieldLine syn = do+            doc <- optional docComment+            c <- optional $ lchar '{'+            let oneName = (do (n, nfc) <- fnName+                              return $ Just (expandNS syn n, nfc))+                          <|> (symbol "_" >> return Nothing)+            ns <- commaSeparated oneName+            lchar ':'+            t <- typeExpr (allowImp syn)+            p <- endPlicity c+            ist <- get+            let doc' = case doc of -- Temp: Throws away any possible arg docs+                        Just (d,_) -> Just $ annotate syn ist d+                        Nothing    -> Nothing+            return $ map (\n -> (n, p, t, doc')) ns++        constructor :: IdrisParser (Name, FC)+        constructor = (reservedHL "constructor") *> fnName+++        endPlicity :: Maybe Char -> IdrisParser Plicity+        endPlicity (Just _) = do lchar '}'+                                 return impl+        endPlicity Nothing = return expl++        annotate :: SyntaxInfo -> IState -> Docstring () -> Docstring (Either Err PTerm)+        annotate syn ist = annotCode $ tryFullExpr syn ist++recordParameter :: SyntaxInfo -> IdrisParser (Name, FC, Plicity, PTerm)+recordParameter syn =+  (do lchar '('+      (n, nfc, pt) <- (namedTy syn <|> onlyName syn)+      lchar ')'+      return (n, nfc, expl, pt))+  <|>+  (do (n, nfc, pt) <- onlyName syn+      return (n, nfc, expl, pt))+  where+    namedTy :: SyntaxInfo -> IdrisParser (Name, FC, PTerm)+    namedTy syn =+      do (n, nfc) <- fnName+         lchar ':'+         ty <- typeExpr (allowImp syn)+         return (expandNS syn n, nfc, ty)+    onlyName :: SyntaxInfo -> IdrisParser (Name, FC, PTerm)+    onlyName syn =+      do (n, nfc) <- fnName+         fc <- getFC+         return (expandNS syn n, nfc, PType fc)++{- | Parses data declaration type (normal or codata)+DataI ::= 'data' | 'codata';+-}+dataI :: IdrisParser DataOpts+dataI = do reservedHL "data"; return []+    <|> do reservedHL "codata"; return [Codata]++recordI :: IdrisParser DataOpts+recordI = do reservedHL "record"; return []+          <|> do reservedHL "corecord"; return [Codata]++{- | Parses if a data should not have a default eliminator+DefaultEliminator ::= 'noelim'?+ -}+dataOpts :: DataOpts -> IdrisParser DataOpts+dataOpts opts+    = do fc <- reservedFC "%elim"+         warnElim fc+         dataOpts (DefaultEliminator : DefaultCaseFun : opts)+  <|> do fc <- reservedFC "%case"+         warnElim fc+         dataOpts (DefaultCaseFun : opts)+  <|> do reserved "%error_reverse"; dataOpts (DataErrRev : opts)+  <|> return opts+  <?> "data options"+  where warnElim fc =+          parserWarning fc (Just NoElimDeprecationWarnings) (Msg "The 'class' keyword is deprecated. Use 'interface' instead.")++{- | Parses a data type declaration+Data ::= DocComment? Accessibility? DataI DefaultEliminator FnName TypeSig ExplicitTypeDataRest?+       | DocComment? Accessibility? DataI DefaultEliminator FnName Name*   DataRest?+       ;+Constructor' ::= Constructor KeepTerminator;+ExplicitTypeDataRest ::= 'where' OpenBlock Constructor'* CloseBlock;++DataRest ::= '=' SimpleConstructorList Terminator+            | 'where'!+           ;+SimpleConstructorList ::=+    SimpleConstructor+  | SimpleConstructor '|' SimpleConstructorList+  ;+-}+data_ :: SyntaxInfo -> IdrisParser PDecl+data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do+                    (doc, argDocs) <- option noDocs docComment+                    pushIndent+                    acc <- accessibility+                    elim <- dataOpts []+                    co <- dataI+                    ist <- get+                    let dataOpts = combineDataOpts (elim ++ co)+                        doc' = annotCode (tryFullExpr syn ist) doc+                        argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)+                                   | (n, d) <- argDocs ]+                    return (doc', argDocs', acc, dataOpts))+               fc <- getFC+               (tyn_in, nfc) <- fnName+               (do try (lchar ':')+                   popIndent+                   ty <- typeExpr (allowImp syn)+                   let tyn = expandNS syn tyn_in+                   option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn nfc ty)) (do+                     reservedHL "where"+                     cons <- indentedBlock (constructor syn)+                     accData acc tyn (map (\ (_, _, n, _, _, _, _) -> n) cons)+                     return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn nfc ty cons))) <|> (do+                    args <- many (fst <$> name)+                    let ty = bindArgs (map (const (PType fc)) args) (PType fc)+                    let tyn = expandNS syn tyn_in+                    option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn nfc ty)) (do+                      try (lchar '=') <|> do reservedHL "where"+                                             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 ns = concat (intersperse " -> " $ map ((\x -> "(" ++ x ++ " : Type)") . show) args)+                                             let ss = concat (intersperse " -> " $ map (const "Type") args)+                                             let fix1 = s ++ as ++ " = ..."+                                             let fix2 = s ++ ": " ++ ns ++ " -> Type where\n  ..."+                                             let fix3 = s ++ ": " ++ ss ++ " -> Type where\n  ..."+                                             fail $ fixErrorMsg "unexpected \"where\"" [fix1, fix2, fix3]+                      cons <- sepBy1 (simpleConstructor syn) (reservedOp "|")+                      terminator+                      let conty = mkPApp fc (PRef fc [] tyn) (map (PRef fc []) args)+                      cons' <- mapM (\ (doc, argDocs, x, xfc, cargs, cfc, fs) ->+                                   do let cty = bindArgs cargs conty+                                      return (doc, argDocs, x, xfc, cty, cfc, fs)) cons+                      accData acc tyn (map (\ (_, _, n, _, _, _, _) -> n) cons')+                      return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn nfc ty cons')))+           <?> "data type declaration"+  where+    mkPApp :: FC -> PTerm -> [PTerm] -> PTerm+    mkPApp fc t [] = t+    mkPApp fc t xs = PApp fc t (map pexp xs)+    bindArgs :: [PTerm] -> PTerm -> PTerm+    bindArgs xs t = foldr (PPi expl (sMN 0 "_t") NoFC) t xs+    combineDataOpts :: DataOpts -> DataOpts+    combineDataOpts opts = if Codata `elem` opts+                              then delete DefaultEliminator opts+                              else opts+++{- | Parses a type constructor declaration+  Constructor ::= DocComment? FnName TypeSig;+-}+constructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, PTerm, FC, [Name])+constructor syn+    = do (doc, argDocs) <- option noDocs docComment+         (cn_in, nfc) <- fnName; fc <- getFC+         let cn = expandNS syn cn_in+         lchar ':'+         fs <- option [] (do lchar '%'; reserved "erase"+                             sepBy1 (fst <$> name) (lchar ','))+         ty <- typeExpr (allowImp syn)+         ist <- get+         let doc' = annotCode (tryFullExpr syn ist) doc+             argDocs' = [ (n, annotCode (tryFullExpr syn ist) d)+                        | (n, d) <- argDocs ]+         return (doc', argDocs', cn, nfc, ty, fc, fs)+      <?> "constructor"++{- | Parses a constructor for simple discriminated union data types+  SimpleConstructor ::= FnName SimpleExpr* DocComment?+-}+simpleConstructor :: SyntaxInfo -> IdrisParser (Docstring (Either Err PTerm), [(Name, Docstring (Either Err PTerm))], Name, FC, [PTerm], FC, [Name])+simpleConstructor syn+     = do (doc, _) <- option noDocs (try docComment)+          ist <- get+          let doc' = annotCode (tryFullExpr syn ist) doc+          (cn_in, nfc) <- fnName+          let cn = expandNS syn cn_in+          fc <- getFC+          args <- many (do notEndApp+                           simpleExpr syn)+          return (doc', [], cn, nfc, args, fc, [])+       <?> "constructor"++{- | Parses a dsl block declaration+DSL ::= 'dsl' FnName OpenBlock Overload'+ CloseBlock;+ -}+dsl :: SyntaxInfo -> IdrisParser PDecl+dsl syn = do reservedHL "dsl"+             n <- fst <$> fnName+             bs <- indentedBlock (overload syn)+             let dsl = mkDSL bs (dsl_info syn)+             checkDSL dsl+             i <- get+             put (i { idris_dsls = addDef n dsl (idris_dsls i) })+             return (PDSL n dsl)+          <?> "dsl block declaration"+    where mkDSL :: [(String, PTerm)] -> DSL -> DSL+          mkDSL bs dsl = let var    = lookup "variable" bs+                             first  = lookup "index_first" bs+                             next   = lookup "index_next" bs+                             leto   = lookup "let" bs+                             lambda = lookup "lambda" bs+                             pi     = lookup "pi" bs in+                             initDSL { dsl_var = var,+                                       index_first = first,+                                       index_next = next,+                                       dsl_lambda = lambda,+                                       dsl_let = leto,+                                       dsl_pi = pi }++{- | Checks DSL for errors -}+-- FIXME: currently does nothing, check if DSL is really sane+--+-- Issue #1595 on the Issue Tracker+--+--     https://github.com/idris-lang/Idris-dev/issues/1595+--+checkDSL :: DSL -> IdrisParser ()+checkDSL dsl = return ()++{- | Parses a DSL overload declaration+OverloadIdentifier ::= 'let' | Identifier;+Overload ::= OverloadIdentifier '=' Expr;+-}+overload :: SyntaxInfo -> IdrisParser (String, PTerm)+overload syn = do (o, fc) <- identifier <|> do fc <- reservedFC "let"+                                               return ("let", fc)+                  if o `notElem` overloadable+                     then fail $ show o ++ " is not an overloading"+                     else do+                       highlightP fc AnnKeyword+                       lchar '='+                       t <- expr syn+                       return (o, t)+               <?> "dsl overload declaratioN"+    where overloadable = ["let","lambda","pi","index_first","index_next","variable"]
+ src/Idris/Parser/Expr.hs view
@@ -0,0 +1,1552 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, TupleSections #-}+module Idris.Parser.Expr 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 qualified Text.Parser.Token as Tok+import qualified Text.Parser.Char as Chr+import qualified Text.Parser.Token.Highlight as Hi++import Idris.AbsSyntax+import Idris.Parser.Helpers+import Idris.Parser.Ops+import Idris.DSL++import Idris.Core.TT++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict++import Data.Function (on)+import Data.Maybe+import qualified Data.List.Split as Spl+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++-- | Allow implicit type declarations+allowImp :: SyntaxInfo -> SyntaxInfo+allowImp syn = syn { implicitAllowed = True }++-- | Disallow implicit type declarations+disallowImp :: SyntaxInfo -> SyntaxInfo+disallowImp syn = syn { implicitAllowed = False }++{-| Parses an expression as a whole+@+  FullExpr ::= Expr EOF_t;+@+ -}+fullExpr :: SyntaxInfo -> IdrisParser PTerm+fullExpr syn = do x <- expr syn+                  eof+                  i <- get+                  return $ debindApp syn (desugar syn i x)++tryFullExpr :: SyntaxInfo -> IState -> String -> Either Err PTerm+tryFullExpr syn st input =+  case runparser (fullExpr syn) st "" input of+    Success tm -> Right tm+    Failure e -> Left (Msg (show e))++{- | Parses an expression+@+  Expr ::= Pi+@+ -}+expr :: SyntaxInfo -> IdrisParser PTerm+expr = pi++{- | Parses an expression with possible operator applied+@+  OpExpr ::= {- Expression Parser with Operators based on Expr' -};+@+-}+opExpr :: SyntaxInfo -> IdrisParser PTerm+opExpr syn = do i <- get+                buildExpressionParser (table (idris_infixes i)) (expr' syn)++{- | Parses either an internally defined expression or+    a user-defined one+@+Expr' ::=  "External (User-defined) Syntax"+      |   InternalExpr;+@+ -}+expr' :: SyntaxInfo -> IdrisParser PTerm+expr' syn = try (externalExpr syn)+            <|> internalExpr syn+            <?> "expression"++{- | Parses a user-defined expression -}+externalExpr :: SyntaxInfo -> IdrisParser PTerm+externalExpr syn = do i <- get+                      (FC fn start _) <- getFC+                      expr <- extensions syn (syntaxRulesList $ syntax_rules i)+                      (FC _ _ end) <- getFC+                      let outerFC = FC fn start end+                      return (mapPTermFC (fixFC outerFC) (fixFCH fn outerFC) expr)+                   <?> "user-defined expression"+  where -- Fix non-highlighting FCs by approximating with the span of the syntax application+        fixFC outer inner | inner `fcIn` outer = inner+                          | otherwise          = outer+        -- Fix highlighting FCs by making them useless, to avoid spurious highlights+        fixFCH fn outer inner | inner `fcIn` outer = inner+                              | otherwise          = FileFC fn++{- | Parses a simple user-defined expression -}+simpleExternalExpr :: SyntaxInfo -> IdrisParser PTerm+simpleExternalExpr syn = do i <- get+                            extensions syn (filter isSimple (syntaxRulesList $ syntax_rules i))+  where+    isSimple (Rule (Expr x:xs) _ _) = False+    isSimple (Rule (SimpleExpr x:xs) _ _) = False+    isSimple (Rule [Keyword _] _ _) = True+    isSimple (Rule [Symbol _]  _ _) = True+    isSimple (Rule (_:xs) _ _) = case last xs of+        Keyword _ -> True+        Symbol _  -> True+        _ -> False+    isSimple _ = False++{- | Tries to parse a user-defined expression given a list of syntactic extensions -}+extensions :: SyntaxInfo -> [Syntax] -> IdrisParser PTerm+extensions syn rules = extension syn [] (filter isValid rules)+                       <?> "user-defined expression"+  where+    isValid :: Syntax -> Bool+    isValid (Rule _ _ AnySyntax) = True+    isValid (Rule _ _ PatternSyntax) = inPattern syn+    isValid (Rule _ _ TermSyntax) = not (inPattern syn)+    isValid (DeclRule _ _) = False++data SynMatch = SynTm PTerm | SynBind FC Name -- ^ the FC is for highlighting information+  deriving Show++extension :: SyntaxInfo -> [Maybe (Name, SynMatch)] -> [Syntax] -> IdrisParser PTerm+extension syn ns rules =+  choice $ flip map (groupBy (ruleGroup `on` syntaxSymbols) rules) $ \rs ->+    case head rs of -- can never be []+      Rule (symb:_) _ _ -> try $ do+        n <- extensionSymbol symb+        extension syn (n : ns) [Rule ss t ctx | (Rule (_:ss) t ctx) <- rs]+      -- If we have more than one Rule in this bucket, our grammar is+      -- nondeterministic.+      Rule [] ptm _ -> return (flatten (updateSynMatch (mapMaybe id ns) ptm))+  where+    ruleGroup [] [] = True+    ruleGroup (s1:_) (s2:_) = s1 == s2+    ruleGroup _ _ = False++    extensionSymbol :: SSymbol -> IdrisParser (Maybe (Name, SynMatch))+    extensionSymbol (Keyword n)    = do fc <- reservedFC (show n)+                                        highlightP fc AnnKeyword+                                        return Nothing+    extensionSymbol (Expr n)       = do tm <- expr syn+                                        return $ Just (n, SynTm tm)+    extensionSymbol (SimpleExpr n) = do tm <- simpleExpr syn+                                        return $ Just (n, SynTm tm)+    extensionSymbol (Binding n)    = do (b, fc) <- name+                                        return $ Just (n, SynBind fc b)+    extensionSymbol (Symbol s)     = do fc <- symbolFC s+                                        highlightP fc AnnKeyword+                                        return Nothing++    flatten :: PTerm -> PTerm -- flatten application+    flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))+    flatten t = t++updateSynMatch = update+  where+    updateB :: [(Name, SynMatch)] -> (Name, FC) -> (Name, FC)+    updateB ns (n, fc) = case lookup n ns of+                           Just (SynBind tfc t) -> (t, tfc)+                           _ -> (n, fc)++    update :: [(Name, SynMatch)] -> PTerm -> PTerm+    update ns (PRef fc hls n) = case lookup n ns of+                                  Just (SynTm t) -> t+                                  _ -> PRef fc hls n+    update ns (PPatvar fc n) = uncurry (flip PPatvar) $ updateB ns (n, fc)+    update ns (PLam fc n nfc ty sc)+      = let (n', nfc') = updateB ns (n, nfc)+        in PLam fc n' nfc' (update ns ty) (update (dropn n ns) sc)+    update ns (PPi p n fc ty sc)+      = let (n', nfc') = updateB ns (n, fc)+        in PPi (updTacImp ns p) n' nfc'+               (update ns ty) (update (dropn n ns) sc)+    update ns (PLet fc n nfc ty val sc)+      = let (n', nfc') = updateB ns (n, nfc)+        in PLet fc n' nfc' (update ns ty)+                (update ns val) (update (dropn n ns) sc)+    update ns (PApp fc t args)+      = PApp fc (update ns t) (map (fmap (update ns)) args)+    update ns (PAppBind fc t args)+      = PAppBind fc (update ns t) (map (fmap (update ns)) args)+    update ns (PMatchApp fc n) = let (n', nfc') = updateB ns (n, fc)+                                 in PMatchApp nfc' n'+    update ns (PIfThenElse fc c t f)+      = PIfThenElse fc (update ns c) (update ns t) (update ns f)+    update ns (PCase fc c opts)+      = PCase fc (update ns c) (map (pmap (update ns)) opts)+    update ns (PRewrite fc eq tm mty)+      = PRewrite fc (update ns eq) (update ns tm) (fmap (update ns) mty)+    update ns (PPair fc hls p l r) = PPair fc hls p (update ns l) (update ns r)+    update ns (PDPair fc hls p l t r)+      = PDPair fc hls p (update ns l) (update ns t) (update ns r)+    update ns (PAs fc n t) = PAs fc (fst $ updateB ns (n, NoFC)) (update ns t)+    update ns (PAlternative ms a as) = PAlternative ms a (map (update ns) as)+    update ns (PHidden t) = PHidden (update ns t)+    update ns (PGoal fc r n sc) = PGoal fc (update ns r) n (update ns sc)+    update ns (PDoBlock ds) = PDoBlock $ map (upd ns) ds+      where upd :: [(Name, SynMatch)] -> PDo -> PDo+            upd ns (DoExp fc t) = DoExp fc (update ns t)+            upd ns (DoBind fc n nfc t) = DoBind fc n nfc (update ns t)+            upd ns (DoLet fc n nfc ty t) = DoLet fc n nfc (update ns ty) (update ns t)+            upd ns (DoBindP fc i t ts)+                    = DoBindP fc (update ns i) (update ns t)+                                 (map (\(l,r) -> (update ns l, update ns r)) ts)+            upd ns (DoLetP fc i t) = DoLetP fc (update ns i) (update ns t)+    update ns (PIdiom fc t) = PIdiom fc $ update ns t+    update ns (PMetavar fc n) = uncurry (flip PMetavar) $ updateB ns (n, fc)+    update ns (PProof tacs) = PProof $ map (updTactic ns) tacs+    update ns (PTactics tacs) = PTactics $ map (updTactic ns) tacs+    update ns (PDisamb nsps t) = PDisamb nsps $ update ns t+    update ns (PUnifyLog t) = PUnifyLog $ update ns t+    update ns (PNoImplicits t) = PNoImplicits $ update ns t+    update ns (PQuasiquote tm mty) = PQuasiquote (update ns tm) (fmap (update ns) mty)+    update ns (PUnquote t) = PUnquote $ update ns t+    update ns (PQuoteName n res fc) = let (n', fc') = (updateB ns (n, fc))+                                      in PQuoteName n' res fc'+    update ns (PRunElab fc t nsp) = PRunElab fc (update ns t) nsp+    update ns (PConstSugar fc t) = PConstSugar fc $ update ns t+    -- PConstSugar probably can't contain anything substitutable, but it's hard to track+    update ns t = t++    updTactic :: [(Name, SynMatch)] -> PTactic -> PTactic+    -- handle all the ones with Names explicitly, then use fmap for the rest with PTerms+    updTactic ns (Intro ns') = Intro $ map (fst . updateB ns . (, NoFC)) ns'+    updTactic ns (Focus n) = Focus . fst $ updateB ns (n, NoFC)+    updTactic ns (Refine n bs) = Refine (fst $ updateB ns (n, NoFC)) bs+    updTactic ns (Claim n t) = Claim (fst $ updateB ns (n, NoFC)) (update ns t)+    updTactic ns (MatchRefine n) = MatchRefine (fst $ updateB ns (n, NoFC))+    updTactic ns (LetTac n t) = LetTac (fst $ updateB ns (n, NoFC)) (update ns t)+    updTactic ns (LetTacTy n ty tm) = LetTacTy (fst $ updateB ns (n, NoFC)) (update ns ty) (update ns tm)+    updTactic ns (ProofSearch rec prover depth top psns hints) = ProofSearch rec prover depth+      (fmap (fst . updateB ns . (, NoFC)) top) (map (fst . updateB ns . (, NoFC)) psns) (map (fst . updateB ns . (, NoFC)) hints)+    updTactic ns (Try l r) = Try (updTactic ns l) (updTactic ns r)+    updTactic ns (TSeq l r) = TSeq (updTactic ns l) (updTactic ns r)+    updTactic ns (GoalType s tac) = GoalType s $ updTactic ns tac+    updTactic ns (TDocStr (Left n)) = TDocStr . Left . fst $ updateB ns (n, NoFC)+    updTactic ns t = fmap (update ns) t++    updTacImp ns (TacImp o st scr)  = TacImp o st (update ns scr)+    updTacImp _  x                  = x++    dropn :: Name -> [(Name, a)] -> [(Name, a)]+    dropn n [] = []+    dropn n ((x,t) : xs) | n == x = xs+                         | otherwise = (x,t):dropn n xs+++{- | Parses a (normal) built-in expression+@+InternalExpr ::=+    UnifyLog+  | RecordType+  | SimpleExpr+  | Lambda+  | QuoteGoal+  | Let+  | If+  | RewriteTerm+  | CaseExpr+  | DoBlock+  | App+  ;+@+-}+internalExpr :: SyntaxInfo -> IdrisParser PTerm+internalExpr syn =+         unifyLog syn+     <|> runElab syn+     <|> disamb syn+     <|> noImplicits syn+     <|> recordType syn+     <|> if_ syn+     <|> lambda syn+     <|> quoteGoal syn+     <|> let_ syn+     <|> rewriteTerm syn+     <|> doBlock syn+     <|> caseExpr syn+     <|> app syn+     <?> "expression"++{- | Parses the "impossible" keyword+@+Impossible ::= 'impossible'+@+-}+impossible :: IdrisParser PTerm+impossible = do fc <- reservedFC "impossible"+                highlightP fc AnnKeyword+                return PImpossible++{- | Parses a case expression+@+CaseExpr ::=+  'case' Expr 'of' OpenBlock CaseOption+ CloseBlock;+@+-}+caseExpr :: SyntaxInfo -> IdrisParser PTerm+caseExpr syn = do kw1 <- reservedFC "case"; fc <- getFC+                  scr <- expr syn; kw2 <- reservedFC "of";+                  opts <- indentedBlock1 (caseOption syn)+                  highlightP kw1 AnnKeyword+                  highlightP kw2 AnnKeyword+                  return (PCase fc scr opts)+               <?> "case expression"++{- | Parses a case in a case expression+@+CaseOption ::=+  Expr (Impossible | '=>' Expr) Terminator+  ;+@+-}+caseOption :: SyntaxInfo -> IdrisParser (PTerm, PTerm)+caseOption syn = do lhs <- expr (syn { inPattern = True })+                    r <- impossible <|> symbol "=>" *> expr syn+                    return (lhs, r)+                 <?> "case option"++warnTacticDeprecation :: FC -> IdrisParser ()+warnTacticDeprecation fc =+ parserWarning fc (Just NoOldTacticDeprecationWarnings) (Msg "This style of tactic proof is deprecated. See %runElab for the replacement.")++{- | Parses a proof block+@+ProofExpr ::=+  'proof' OpenBlock Tactic'* CloseBlock+  ;+@+-}+proofExpr :: SyntaxInfo -> IdrisParser PTerm+proofExpr syn = do kw <- reservedFC "proof"+                   ts <- indentedBlock1 (tactic syn)+                   highlightP kw AnnKeyword+                   warnTacticDeprecation kw+                   return $ PProof ts+                <?> "proof block"++{- | Parses a tactics block+@+TacticsExpr :=+  'tactics' OpenBlock Tactic'* CloseBlock+;+@+-}+tacticsExpr :: SyntaxInfo -> IdrisParser PTerm+tacticsExpr syn = do kw <- reservedFC "tactics"+                     ts <- indentedBlock1 (tactic syn)+                     highlightP kw AnnKeyword+                     warnTacticDeprecation kw+                     return $ PTactics ts+                  <?> "tactics block"++{- | Parses a simple expression+@+SimpleExpr ::=+    {- External (User-defined) Simple Expression -}+  | '?' Name+  | % 'instance'+  | 'Refl' ('{' Expr '}')?+  | ProofExpr+  | TacticsExpr+  | FnName+  | Idiom+  | List+  | Alt+  | Bracketed+  | Constant+  | Type+  | 'Void'+  | Quasiquote+  | NameQuote+  | Unquote+  | '_'+  ;+@+-}+simpleExpr :: SyntaxInfo -> IdrisParser PTerm+simpleExpr syn =+            try (simpleExternalExpr syn)+        <|> do (x, FC f (l, c) end) <- try (lchar '?' *> name)+               return (PMetavar (FC f (l, c-1) end) x)+        <|> do lchar '%'; fc <- getFC; reserved "instance"; return (PResolveTC fc)+        <|> do reserved "elim_for"; fc <- getFC; t <- fst <$> fnName; return (PRef fc [] (SN $ ElimN t))+        <|> proofExpr syn+        <|> tacticsExpr syn+        <|> try (do reserved "Type"; symbol "*"; return $ PUniverse AllTypes)+        <|> do reserved "AnyType"; return $ PUniverse AllTypes+        <|> PType <$> reservedFC "Type"+        <|> do reserved "UniqueType"; return $ PUniverse UniqueType+        <|> do reserved "NullType"; return $ PUniverse NullType+        <|> do (c, cfc) <- constant+               fc <- getFC+               return (modifyConst syn fc (PConstant cfc c))+        <|> do symbol "'"; fc <- getFC; str <- fst <$> name+               return (PApp fc (PRef fc [] (sUN "Symbol_"))+                          [pexp (PConstant NoFC (Str (show str)))])+        <|> do (x, fc) <- fnName+               if inPattern syn+                  then option (PRef fc [fc] x)+                              (do reservedOp "@"+                                  s <- simpleExpr syn+                                  fcIn <- getFC+                                  return (PAs fcIn x s))+                  else return (PRef fc [fc] x)+        <|> idiom syn+        <|> listExpr syn+        <|> alt syn+        <|> do reservedOp "!"+               s <- simpleExpr syn+               fc <- getFC+               return (PAppBind fc s [])+        <|> bracketed (disallowImp syn)+        <|> quasiquote syn+        <|> namequote syn+        <|> unquote syn+        <|> do lchar '_'; return Placeholder+        <?> "expression"++{- |Parses an expression in braces+@+Bracketed ::= '(' Bracketed'+@+ -}+bracketed :: SyntaxInfo -> IdrisParser PTerm+bracketed syn = do (FC fn (sl, sc) _) <- getFC+                   lchar '(' <?> "parenthesized expression"+                   bracketed' (FC fn (sl, sc) (sl, sc+1)) syn+{- |Parses the rest of an expression in braces+@+Bracketed' ::=+  ')'+  | Expr ')'+  | ExprList ')'+  | Expr '**' Expr ')'+  | Operator Expr ')'+  | Expr Operator ')'+  | Name ':' Expr '**' Expr ')'+  ;+@+-}+bracketed' :: FC -> SyntaxInfo -> IdrisParser PTerm+bracketed' open syn =+            do (FC f start (l, c)) <- getFC+               lchar ')'+               return $ PTrue (spanFC open (FC f start (l, c+1))) TypeOrTerm+        <|> try (do (ln, lnfc) <- name+                    colonFC <- lcharFC ':'+                    lty <- expr syn+                    starsFC <- reservedOpFC "**"+                    fc <- getFC+                    r <- expr syn+                    close <- lcharFC ')'+                    return (PDPair fc [open, colonFC, starsFC, close] TypeOrTerm (PRef lnfc [] ln) lty r))+        <|> try (do fc <- getFC; o <- operator; e <- expr syn; lchar ')'+                    -- No prefix operators! (bit of a hack here...)+                    if (o == "-" || o == "!")+                      then fail "minus not allowed in section"+                      else return $ PLam fc (sMN 1000 "ARG") NoFC Placeholder+                         (PApp fc (PRef fc [] (sUN o)) [pexp (PRef fc [] (sMN 1000 "ARG")),+                                                        pexp e]))+        <|> try (do l <- simpleExpr syn+                    op <- option Nothing (do o <- operator+                                             lchar ')'+                                             return (Just o))+                    fc0 <- getFC+                    case op of+                         Nothing -> bracketedExpr syn open l+                         Just o -> return $ PLam fc0 (sMN 1000 "ARG") NoFC Placeholder+                             (PApp fc0 (PRef fc0 [] (sUN o)) [pexp l,+                                                              pexp (PRef fc0 [] (sMN 1000 "ARG"))]))+        <|> do l <- expr syn+               bracketedExpr syn open l++-- | Parse the contents of parentheses, after an expression has been parsed.+bracketedExpr :: SyntaxInfo -> FC -> PTerm -> IdrisParser PTerm+bracketedExpr syn openParenFC e =+             do lchar ')'; return e+        <|>  do exprs <- many (do comma <- lcharFC ','+                                  r <- expr syn+                                  return (r, comma))+                closeParenFC <- lcharFC ')'+                let hilite = [openParenFC, closeParenFC] ++ map snd exprs+                return $ PPair openParenFC hilite TypeOrTerm e (mergePairs exprs)+        <|>  do starsFC <- reservedOpFC "**"+                r <- expr syn+                closeParenFC <- lcharFC ')'+                return (PDPair starsFC [openParenFC, starsFC, closeParenFC] TypeOrTerm e Placeholder r)+        <?> "end of bracketed expression"+  where mergePairs :: [(PTerm, FC)] -> PTerm+        mergePairs [(t, fc)]    = t+        mergePairs ((t, fc):rs) = PPair fc [] TypeOrTerm t (mergePairs rs)++-- bit of a hack here. If the integer doesn't fit in an Int, treat it as a+-- big integer, otherwise try fromInteger and the constants as alternatives.+-- a better solution would be to fix fromInteger to work with Integer, as the+-- name suggests, rather than Int+{-| Finds optimal type for integer constant -}+modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm+modifyConst syn fc (PConstant inFC (BI x))+    | not (inPattern syn)+        = PConstSugar inFC $ -- wrap in original location for highlighting+            PAlternative [] FirstSuccess+              (PApp fc (PRef fc [] (sUN "fromInteger")) [pexp (PConstant NoFC (BI (fromInteger x)))]+              : consts)+    | otherwise = PConstSugar inFC $+                    PAlternative [] FirstSuccess consts+    where+      consts = [ PConstant inFC (BI x)+               , PConstant inFC (I (fromInteger x))+               , PConstant inFC (B8 (fromInteger x))+               , PConstant inFC (B16 (fromInteger x))+               , PConstant inFC (B32 (fromInteger x))+               , PConstant inFC (B64 (fromInteger x))+               ]+modifyConst syn fc x = x++{- | Parses an alternative expression+@+  Alt ::= '(|' Expr_List '|)';++  Expr_List ::=+    Expr'+    | Expr' ',' Expr_List+  ;+@+-}+alt :: SyntaxInfo -> IdrisParser PTerm+alt syn = do symbol "(|"; alts <- sepBy1 (expr' syn) (lchar ','); symbol "|)"+             return (PAlternative [] FirstSuccess alts)++{- | Parses a possibly hidden simple expression+@+HSimpleExpr ::=+  '.' SimpleExpr+  | SimpleExpr+  ;+@+-}+hsimpleExpr :: SyntaxInfo -> IdrisParser PTerm+hsimpleExpr syn =+  do lchar '.'+     e <- simpleExpr syn+     return $ PHidden e+  <|> simpleExpr syn+  <?> "expression"++{- | Parses a unification log expression+UnifyLog ::=+  '%' 'unifyLog' SimpleExpr+  ;+-}+unifyLog :: SyntaxInfo -> IdrisParser PTerm+unifyLog syn = do (FC fn (sl, sc) kwEnd) <- try (lchar '%' *> reservedFC "unifyLog")+                  tm <- simpleExpr syn+                  highlightP (FC fn (sl, sc-1) kwEnd) AnnKeyword+                  return (PUnifyLog tm)+               <?> "unification log expression"++{- | Parses a new-style tactics expression+RunTactics ::=+  '%' 'runElab' SimpleExpr+  ;+-}+runElab :: SyntaxInfo -> IdrisParser PTerm+runElab syn = do (FC fn (sl, sc) kwEnd) <- try (lchar '%' *> reservedFC "runElab")+                 fc <- getFC+                 tm <- simpleExpr syn+                 highlightP (FC fn (sl, sc-1) kwEnd) AnnKeyword+                 return $ PRunElab fc tm (syn_namespace syn)+              <?> "new-style tactics expression"++{- | Parses a disambiguation expression+Disamb ::=+  '%' 'disamb' NameList Expr+  ;+-}+disamb :: SyntaxInfo -> IdrisParser PTerm+disamb syn = do kw <- reservedFC "with"+                ns <- sepBy1 (fst <$> name) (lchar ',')+                tm <- expr' syn+                highlightP kw AnnKeyword+                return (PDisamb (map tons ns) tm)+               <?> "namespace disambiguation expression"+  where tons (NS n s) = txt (show n) : s+        tons n = [txt (show n)]+{- | Parses a no implicits expression+@+NoImplicits ::=+  '%' 'noImplicits' SimpleExpr+  ;+@+-}+noImplicits :: SyntaxInfo -> IdrisParser PTerm+noImplicits syn = do try (lchar '%' *> reserved "noImplicits")+                     tm <- simpleExpr syn+                     return (PNoImplicits tm)+                 <?> "no implicits expression"++{- | Parses a function application expression+@+App ::=+  'mkForeign' Arg Arg*+  | MatchApp+  | SimpleExpr Arg*+  ;+MatchApp ::=+  SimpleExpr '<==' FnName+  ;+@+-}+app :: SyntaxInfo -> IdrisParser PTerm+app syn = do f <- simpleExpr syn+             (do try $ reservedOp "<=="+                 fc <- getFC+                 ff <- fst <$> fnName+                 return (PLet fc (sMN 0 "match") NoFC+                               f+                               (PMatchApp fc ff)+                               (PRef fc [] (sMN 0 "match")))+              <?> "matching application expression") <|> (do+             fc <- getFC+             i <- get+             args <- many (do notEndApp; arg syn)+             case args of+               [] -> return f+               _  -> return (flattenFromInt fc f args))+       <?> "function application"+   where+    -- bit of a hack to deal with the situation where we're applying a+    -- literal to an argument, which we may want for obscure applications+    -- of fromInteger, and this will help disambiguate better.+    -- We know, at least, it won't be one of the constants!+    flattenFromInt fc (PAlternative _ x alts) args+      | Just i <- getFromInt alts+           = PApp fc (PRef fc [] (sUN "fromInteger")) (i : args)+    flattenFromInt fc f args = PApp fc f args++    getFromInt ((PApp _ (PRef _ _ n) [a]) : _) | n == sUN "fromInteger" = Just a+    getFromInt (_ : xs) = getFromInt xs+    getFromInt _ = Nothing++{-| Parses a function argument+@+Arg ::=+  ImplicitArg+  | ConstraintArg+  | SimpleExpr+  ;+@+-}+arg :: SyntaxInfo -> IdrisParser PArg+arg syn =  implicitArg syn+       <|> constraintArg syn+       <|> do e <- simpleExpr syn+              return (pexp e)+       <?> "function argument"++{-| Parses an implicit function argument+@+ImplicitArg ::=+  '{' Name ('=' Expr)? '}'+  ;+@+-}+implicitArg :: SyntaxInfo -> IdrisParser PArg+implicitArg syn = do lchar '{'+                     (n, nfc) <- name+                     fc <- getFC+                     v <- option (PRef nfc [nfc] n) (do lchar '='+                                                        expr syn)+                     lchar '}'+                     return (pimp n v True)+                  <?> "implicit function argument"++{-| Parses a constraint argument (for selecting a named type class instance)++>    ConstraintArg ::=+>      '@{' Expr '}'+>      ;++-}+constraintArg :: SyntaxInfo -> IdrisParser PArg+constraintArg syn = do symbol "@{"+                       e <- expr syn+                       symbol "}"+                       return (pconst e)+                    <?> "constraint argument"++{-| Parses a quasiquote expression (for building reflected terms using the elaborator)++> Quasiquote ::= '`(' Expr ')'++-}+quasiquote :: SyntaxInfo -> IdrisParser PTerm+quasiquote syn = do startFC <- symbolFC "`("+                    e <- expr syn { syn_in_quasiquote = (syn_in_quasiquote syn) + 1 ,+                                    inPattern = False }+                    g <- optional $+                           do fc <- symbolFC ":"+                              ty <- expr syn { inPattern = False } -- don't allow antiquotes+                              return (ty, fc)+                    endFC <- symbolFC ")"+                    mapM_ (uncurry highlightP) [(startFC, AnnKeyword), (endFC, AnnKeyword), (spanFC startFC endFC, AnnQuasiquote)]+                    case g of+                      Just (_, fc) -> highlightP fc AnnKeyword+                      _ -> return ()+                    return $ PQuasiquote e (fst <$> g)+                 <?> "quasiquotation"++{-| Parses an unquoting inside a quasiquotation (for building reflected terms using the elaborator)++> Unquote ::= ',' Expr++-}+unquote :: SyntaxInfo -> IdrisParser PTerm+unquote syn = do guard (syn_in_quasiquote syn > 0)+                 startFC <- symbolFC "~"+                 e <- simpleExpr syn { syn_in_quasiquote = syn_in_quasiquote syn - 1 }+                 endFC <- getFC+                 highlightP startFC AnnKeyword+                 highlightP (spanFC startFC endFC) AnnAntiquote+                 return $ PUnquote e+              <?> "unquotation"++{-| Parses a quotation of a name (for using the elaborator to resolve boring details)++> NameQuote ::= '`{' Name '}'++-}+namequote :: SyntaxInfo -> IdrisParser PTerm+namequote syn = do (startFC, res) <-+                     try (do fc <- symbolFC "`{{"+                             return (fc, False)) <|>+                       (do fc <- symbolFC "`{"+                           return (fc, True))+                   (n, nfc) <- fnName+                   endFC <- if res then symbolFC "}" else symbolFC "}}"+                   mapM_ (uncurry highlightP)+                         [ (startFC, AnnKeyword)+                         , (endFC, AnnKeyword)+                         , (spanFC startFC endFC, AnnQuasiquote)+                         ]+                   return $ PQuoteName n res nfc+                <?> "quoted name"+++{-| Parses a record field setter expression+@+RecordType ::=+  'record' '{' FieldTypeList '}';+@+@+FieldTypeList ::=+  FieldType+  | FieldType ',' FieldTypeList+  ;+@+@+FieldType ::=+  FnName '=' Expr+  ;+@+-}+recordType :: SyntaxInfo -> IdrisParser PTerm+recordType syn =+      do kw <- reservedFC "record"+         lchar '{'+         fgs <- fieldGetOrSet+         lchar '}'+         fc <- getFC+         rec <- optional (simpleExpr syn)+         highlightP kw AnnKeyword+         case fgs of+              Left fields ->+                case rec of+                   Nothing ->+                       return (PLam fc (sMN 0 "fldx") NoFC Placeholder+                                   (applyAll fc fields (PRef fc [] (sMN 0 "fldx"))))+                   Just v -> return (applyAll fc fields v)+              Right fields ->+                case rec of+                   Nothing ->+                       return (PLam fc (sMN 0 "fldx") NoFC Placeholder+                                 (getAll fc (reverse fields)+                                     (PRef fc [] (sMN 0 "fldx"))))+                   Just v -> return (getAll fc (reverse fields) v)++       <?> "record setting expression"+   where fieldSet :: IdrisParser ([Name], PTerm)+         fieldSet = do ns <- fieldGet+                       lchar '='+                       e <- expr syn+                       return (ns, e)+                    <?> "field setter"++         fieldGet :: IdrisParser [Name]+         fieldGet = sepBy1 (fst <$> fnName) (symbol "->")++         fieldGetOrSet :: IdrisParser (Either [([Name], PTerm)] [Name])+         fieldGetOrSet = try (do fs <- sepBy1 fieldSet (lchar ',')+                                 return (Left fs))+                     <|> do f <- fieldGet+                            return (Right f)++         applyAll :: FC -> [([Name], PTerm)] -> PTerm -> PTerm+         applyAll fc [] x = x+         applyAll fc ((ns, e) : es) x+            = applyAll fc es (doUpdate fc ns e x)++         doUpdate fc [n] e get+              = PApp fc (PRef fc [] (mkType n)) [pexp e, pexp get]+         doUpdate fc (n : ns) e get+              = PApp fc (PRef fc [] (mkType n))+                  [pexp (doUpdate fc ns e (PApp fc (PRef fc [] n) [pexp get])),+                   pexp get]++         getAll :: FC -> [Name] -> PTerm -> PTerm+         getAll fc [n] e = PApp fc (PRef fc [] n) [pexp e]+         getAll fc (n:ns) e = PApp fc (PRef fc [] n) [pexp (getAll fc ns e)]+++-- | Creates setters for record types on necessary functions+mkType :: Name -> Name+mkType (UN n) = sUN ("set_" ++ str n)+mkType (MN 0 n) = sMN 0 ("set_" ++ str n)+mkType (NS n s) = NS (mkType n) s++{- | Parses a type signature+@+TypeSig ::=+  ':' Expr+  ;+@+@+TypeExpr ::= ConstraintList? Expr;+@+ -}+typeExpr :: SyntaxInfo -> IdrisParser PTerm+typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []+                  sc <- expr syn+                  return (bindList (PPi constraint) cs sc)+               <?> "type signature"++{- | Parses a lambda expression+@+Lambda ::=+    '\\' TypeOptDeclList LambdaTail+  | '\\' SimpleExprList  LambdaTail+  ;+@+@+SimpleExprList ::=+  SimpleExpr+  | SimpleExpr ',' SimpleExprList+  ;+@+@+LambdaTail ::=+    Impossible+  | '=>' Expr+@+-}+lambda :: SyntaxInfo -> IdrisParser PTerm+lambda syn = do lchar '\\' <?> "lambda expression"+                ((do xt <- try $ tyOptDeclList syn+                     fc <- getFC+                     sc <- lambdaTail+                     return (bindList (PLam fc) xt sc))+                 <|>+                 (do ps <- sepBy (do fc <- getFC+                                     e <- simpleExpr (syn { inPattern = True })+                                     return (fc, e))+                                 (lchar ',')+                     sc <- lambdaTail+                     return (pmList (zip [0..] ps) sc)))+                  <?> "lambda expression"+    where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm+          pmList [] sc = sc+          pmList ((i, (fc, x)) : xs) sc+                = PLam fc (sMN i "lamp") NoFC Placeholder+                        (PCase fc (PRef fc [] (sMN i "lamp"))+                                [(x, pmList xs sc)])+          lambdaTail :: IdrisParser PTerm+          lambdaTail = impossible <|> symbol "=>" *> expr syn++{- | Parses a term rewrite expression+@+RewriteTerm ::=+  'rewrite' Expr ('==>' Expr)? 'in' Expr+  ;+@+-}+rewriteTerm :: SyntaxInfo -> IdrisParser PTerm+rewriteTerm syn = do kw <- reservedFC "rewrite"+                     fc <- getFC+                     prf <- expr syn+                     giving <- optional (do symbol "==>"; expr' syn)+                     kw' <- reservedFC "in";  sc <- expr syn+                     highlightP kw AnnKeyword+                     highlightP kw' AnnKeyword+                     return (PRewrite fc+                             (PApp fc (PRef fc [] (sUN "sym")) [pexp prf]) sc+                               giving)+                  <?> "term rewrite expression"++{- |Parses a let binding+@+Let ::=+  'let' Name TypeSig'? '=' Expr  'in' Expr+| 'let' Expr'          '=' Expr' 'in' Expr++TypeSig' ::=+  ':' Expr'+  ;+@+ -}+let_ :: SyntaxInfo -> IdrisParser PTerm+let_ syn = try (do kw <- reservedFC "let"+                   ls <- indentedBlock (let_binding syn)+                   kw' <- reservedFC "in";  sc <- expr syn+                   highlightP kw AnnKeyword; highlightP kw' AnnKeyword+                   return (buildLets ls sc))+           <?> "let binding"+  where buildLets [] sc = sc+        buildLets ((fc, PRef nfc _ n, ty, v, []) : ls) sc+          = PLet fc n nfc ty v (buildLets ls sc)+        buildLets ((fc, pat, ty, v, alts) : ls) sc+          = PCase fc v ((pat, buildLets ls sc) : alts)++let_binding syn = do fc <- getFC;+                     pat <- expr' (syn { inPattern = True })+                     ty <- option Placeholder (do lchar ':'; expr' syn)+                     lchar '='+                     v <- expr syn+                     ts <- option [] (do lchar '|'+                                         sepBy1 (do_alt syn) (lchar '|'))+                     return (fc,pat,ty,v,ts)++{- | Parses a conditional expression+@+If ::= 'if' Expr 'then' Expr 'else' Expr+@++-}+if_ :: SyntaxInfo -> IdrisParser PTerm+if_ syn = (do ifFC <- reservedFC "if"+              fc <- getFC+              c <- expr syn+              thenFC <- reservedFC "then"+              t <- expr syn+              elseFC <- reservedFC "else"+              f <- expr syn+              mapM_ (flip highlightP AnnKeyword) [ifFC, thenFC, elseFC]+              return (PIfThenElse fc c t f))+          <?> "conditional expression"+++{- | Parses a quote goal++@+QuoteGoal ::=+  'quoteGoal' Name 'by' Expr 'in' Expr+  ;+@+ -}+quoteGoal :: SyntaxInfo -> IdrisParser PTerm+quoteGoal syn = do kw1 <- reservedFC "quoteGoal"; n <- fst <$> name;+                   kw2 <- reservedFC "by"+                   r <- expr syn+                   kw3 <- reservedFC "in"+                   fc <- getFC+                   sc <- expr syn+                   mapM_ (flip highlightP AnnKeyword) [kw1, kw2, kw3]+                   return (PGoal fc r n sc)+                <?> "quote goal expression"++{- | Parses a dependent type signature++@+Pi ::= PiOpts Static? Pi'+@++@+Pi' ::=+    OpExpr ('->' Pi)?+  | '(' TypeDeclList           ')'            '->' Pi+  | '{' TypeDeclList           '}'            '->' Pi+  | '{' 'auto'    TypeDeclList '}'            '->' Pi+  | '{' 'default' SimpleExpr TypeDeclList '}' '->' Pi+  ;+@+ -}++bindsymbol opts st syn+     = do symbol "->"+          return (Exp opts st False)++explicitPi opts st syn+   = do xt <- try (lchar '(' *> typeDeclList syn <* lchar ')')+        binder <- bindsymbol opts st syn+        sc <- expr syn+        return (bindList (PPi binder) xt sc)++autoImplicit opts st syn+   = do kw <- reservedFC "auto"+        when (st == Static) $ fail "auto implicits can not be static"+        xt <- typeDeclList syn+        lchar '}'+        symbol "->"+        sc <- expr syn+        highlightP kw AnnKeyword+        return (bindList (PPi+          (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing [] []]))) xt sc)++defaultImplicit opts st syn = do+   kw <- reservedFC "default"+   when (st == Static) $ fail "default implicits can not be static"+   ist <- get+   script' <- simpleExpr syn+   let script = debindApp syn . desugar syn ist $ script'+   xt <- typeDeclList syn+   lchar '}'+   symbol "->"+   sc <- expr syn+   highlightP kw AnnKeyword+   return (bindList (PPi (TacImp [] Dynamic script)) xt sc)++normalImplicit opts st syn = do+   xt <- typeDeclList syn <* lchar '}'+   symbol "->"+   cs <- constraintList syn+   sc <- expr syn+   let (im,cl)+          = if implicitAllowed syn+               then (Imp opts st False (Just (Impl False True)),+                      constraint)+               else (Imp opts st False (Just (Impl False False)),+                     Imp opts st False (Just (Impl True False)))+   return (bindList (PPi im) xt+           (bindList (PPi cl) cs sc))++implicitPi opts st syn =+      autoImplicit opts st syn+        <|> defaultImplicit opts st syn+          <|> normalImplicit opts st syn++unboundPi opts st syn = do+       x <- opExpr syn+       (do binder <- bindsymbol opts st syn+           sc <- expr syn+           return (PPi binder (sUN "__pi_arg") NoFC x sc))+              <|> 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)+            <|> unboundPi opts st syn+  <?> "dependent type signature"++{- | Parses Possible Options for Pi Expressions+@+  PiOpts ::= '.'?+@+-}+piOpts :: SyntaxInfo -> IdrisParser [ArgOpt]+piOpts syn | implicitAllowed syn =+        lchar '.' *> return [InaccessibleArg]+    <|> return []+piOpts syn = return []++{- | Parses a type constraint list++@+ConstraintList ::=+    '(' Expr_List ')' '=>'+  | Expr              '=>'+  ;+@+-}+constraintList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]+constraintList syn = try (constraintList1 syn)+                     <|> return []++constraintList1 :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]+constraintList1 syn = try (do lchar '('+                              tys <- sepBy1 nexpr (lchar ',')+                              lchar ')'+                              reservedOp "=>"+                              return tys)+                  <|> try (do t <- opExpr (disallowImp syn)+                              reservedOp "=>"+                              return [(defname, NoFC, t)])+                  <?> "type constraint list"+  where nexpr = try (do (n, fc) <- name; lchar ':'+                        e <- expr syn+                        return (n, fc, e))+                <|> do e <- expr syn+                       return (defname, NoFC, e)+        defname = sMN 0 "constraint"++{- | Parses a type declaration list+@+TypeDeclList ::=+    FunctionSignatureList+  | NameList TypeSig+  ;+@++@+FunctionSignatureList ::=+    Name TypeSig+  | Name TypeSig ',' FunctionSignatureList+  ;+@+-}+typeDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]+typeDeclList syn = try (sepBy1 (do (x, xfc) <- fnName+                                   lchar ':'+                                   t <- typeExpr (disallowImp syn)+                                   return (x, xfc, t))+                           (lchar ','))+                   <|> do ns <- sepBy1 name (lchar ',')+                          lchar ':'+                          t <- typeExpr (disallowImp syn)+                          return (map (\(x, xfc) -> (x, xfc, t)) ns)+                   <?> "type declaration list"++{- | Parses a type declaration list with optional parameters+@+TypeOptDeclList ::=+    NameOrPlaceholder TypeSig?+  | NameOrPlaceholder TypeSig? ',' TypeOptDeclList+  ;+@++@+NameOrPlaceHolder ::= Name | '_';+@+-}+tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]+tyOptDeclList syn = sepBy1 (do (x, fc) <- nameOrPlaceholder+                               t <- option Placeholder (do lchar ':'+                                                           expr syn)+                               return (x, fc, t))+                           (lchar ',')+                    <?> "type declaration list"+    where  nameOrPlaceholder :: IdrisParser (Name, FC)+           nameOrPlaceholder = fnName+                           <|> do symbol "_"+                                  return (sMN 0 "underscore", NoFC)+                           <?> "name or placeholder"++{- | Parses a list literal expression e.g. [1,2,3] or a comprehension [ (x, y) | x <- xs , y <- ys ]+@+ListExpr ::=+     '[' ']'+  | '[' Expr '|' DoList ']'+  | '[' ExprList ']'+;+@+@+DoList ::=+    Do+  | Do ',' DoList+  ;+@+@+ExprList ::=+  Expr+  | Expr ',' ExprList+  ;+@+ -}+listExpr :: SyntaxInfo -> IdrisParser PTerm+listExpr syn = do (FC f (l, c) _) <- getFC+                  lchar '['; fc <- getFC;+                  (try . token $ do (char ']' <?> "end of list expression")+                                    (FC _ _ (l', c')) <- getFC+                                    return (mkNil (FC f (l, c) (l', c'))))+                   <|> (do x <- expr syn <?> "expression"+                           (do try (lchar '|') <?> "list comprehension"+                               qs <- sepBy1 (do_ syn) (lchar ',')+                               lchar ']'+                               return (PDoBlock (map addGuard qs +++                                          [DoExp fc (PApp fc (PRef fc [] (sUN "return"))+                                                       [pexp x])]))) <|>+                            (do xs <- many (do (FC fn (sl, sc) _) <- getFC+                                               lchar ',' <?> "list element"+                                               let commaFC = FC fn (sl, sc) (sl, sc + 1)+                                               elt <- expr syn+                                               return (elt, commaFC))+                                (FC fn (sl, sc) _) <- getFC+                                lchar ']' <?> "end of list expression"+                                let rbrackFC = FC fn (sl, sc) (sl, sc+1)+                                return (mkList fc rbrackFC ((x, (FC f (l, c) (l, c+1))) : xs))))+                <?> "list expression"+  where+    mkNil :: FC -> PTerm+    mkNil fc = PRef fc [fc] (sUN "Nil")+    mkList :: FC -> FC -> [(PTerm, FC)] -> PTerm+    mkList errFC nilFC [] = PRef nilFC [nilFC] (sUN "Nil")+    mkList errFC nilFC ((x, fc) : xs) = PApp errFC (PRef fc [fc] (sUN "::")) [pexp x, pexp (mkList errFC nilFC xs)]+    addGuard :: PDo -> PDo+    addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc [] (sUN "guard"))+                                              [pexp e])+    addGuard x = x++{- | Parses a do-block+@+Do' ::= Do KeepTerminator;+@++@+DoBlock ::=+  'do' OpenBlock Do'+ CloseBlock+  ;+@+ -}+doBlock :: SyntaxInfo -> IdrisParser PTerm+doBlock syn+    = do kw <- reservedFC "do"+         ds <- indentedBlock1 (do_ syn)+         highlightP kw AnnKeyword+         return (PDoBlock ds)+      <?> "do block"++{- | Parses an expression inside a do block+@+Do ::=+    'let' Name  TypeSig'?      '=' Expr+  | 'let' Expr'                '=' Expr+  | Name  '<-' Expr+  | Expr' '<-' Expr+  | Expr+  ;+@+-}+do_ :: SyntaxInfo -> IdrisParser PDo+do_ syn+     = try (do kw <- reservedFC "let"+               (i, ifc) <- name+               ty <- option Placeholder (do lchar ':'+                                            expr' syn)+               reservedOp "="+               fc <- getFC+               e <- expr syn+               highlightP kw AnnKeyword+               return (DoLet fc i ifc ty e))+   <|> try (do kw <- reservedFC "let"+               i <- expr' syn+               reservedOp "="+               fc <- getFC+               sc <- expr syn+               highlightP kw AnnKeyword+               return (DoLetP fc i sc))+   <|> try (do (i, ifc) <- name+               symbol "<-"+               fc <- getFC+               e <- expr syn;+               option (DoBind fc i ifc e)+                      (do lchar '|'+                          ts <- sepBy1 (do_alt syn) (lchar '|')+                          return (DoBindP fc (PRef ifc [ifc] i) e ts)))+   <|> try (do i <- expr' syn+               symbol "<-"+               fc <- getFC+               e <- expr syn;+               option (DoBindP fc i e [])+                      (do lchar '|'+                          ts <- sepBy1 (do_alt syn) (lchar '|')+                          return (DoBindP fc i e ts)))+   <|> do e <- expr syn+          fc <- getFC+          return (DoExp fc e)+   <?> "do block expression"++do_alt syn = do l <- expr' syn+                option (Placeholder, l)+                       (do symbol "=>"+                           r <- expr' syn+                           return (l, r))++{- | Parses an expression in idiom brackets+@+Idiom ::= '[|' Expr '|]';+@+-}+idiom :: SyntaxInfo -> IdrisParser PTerm+idiom syn+    = do symbol "[|"+         fc <- getFC+         e <- expr syn+         symbol "|]"+         return (PIdiom fc e)+      <?> "expression in idiom brackets"++{- |Parses a constant or literal expression++@+Constant ::=+    'Integer'+  | 'Int'+  | 'Char'+  | 'Double'+  | 'String'+  | 'Bits8'+  | 'Bits16'+  | 'Bits32'+  | 'Bits64'+  | Float_t+  | Natural_t+  | VerbatimString_t+  | String_t+  | Char_t+  ;+@+-}++constants :: [(String, Idris.Core.TT.Const)]+constants =+  [ ("Integer",            AType (ATInt ITBig))+  , ("Int",                AType (ATInt ITNative))+  , ("Char",               AType (ATInt ITChar))+  , ("Double",             AType ATFloat)+  , ("String",             StrType)+  , ("prim__WorldType",    WorldType)+  , ("prim__TheWorld",     TheWorld)+  , ("Bits8",              AType (ATInt (ITFixed IT8)))+  , ("Bits16",             AType (ATInt (ITFixed IT16)))+  , ("Bits32",             AType (ATInt (ITFixed IT32)))+  , ("Bits64",             AType (ATInt (ITFixed IT64)))+  ]++-- | Parse a constant and its source span+constant :: IdrisParser (Idris.Core.TT.Const, FC)+constant = choice [ do fc <- reservedFC name; return (ty, fc)+                  | (name, ty) <- constants+                  ]+        <|> do (f, fc) <- try float; return (Fl f, fc)+        <|> do (i, fc) <- natural; return (BI i, fc)+        <|> do (s, fc) <- verbatimStringLiteral; return (Str s, fc)+        <|> do (s, fc) <- stringLiteral;  return (Str s, fc)+        <|> do (c, fc) <- try charLiteral; return (Ch c, fc) --Currently ambigous with symbols+        <?> "constant or literal"++{- | Parses a verbatim multi-line string literal (triple-quoted)++@+VerbatimString_t ::=+  '\"\"\"' ~'\"\"\"' '\"\"\"'+;+@+ -}+verbatimStringLiteral :: MonadicParsing m => m (String, FC)+verbatimStringLiteral = token $ do (FC f start _) <- getFC+                                   try $ string "\"\"\""+                                   str <- manyTill anyChar $ try (string "\"\"\"")+                                   (FC _ _ end) <- getFC+                                   return (str, FC f start end)++{- | Parses a static modifier++@+Static ::=+  '[' static ']'+;+@+-}+static :: IdrisParser Static+static =     do reserved "%static"; return Static+         <|> do reserved "[static]"+                fc <- getFC+                parserWarning fc Nothing (Msg "The use of [static] is deprecated, use %static instead.")+                return Static+         <|> return Dynamic+         <?> "static modifier"++{- | Parses a tactic script++@+Tactic ::= 'intro' NameList?+       |   'intros'+       |   'refine'      Name Imp++       |   'mrefine'     Name+       |   'rewrite'     Expr+       |   'induction'   Expr+       |   'equiv'       Expr+       |   'let'         Name ':' Expr' '=' Expr+       |   'let'         Name           '=' Expr+       |   'focus'       Name+       |   'exact'       Expr+       |   'applyTactic' Expr+       |   'reflect'     Expr+       |   'fill'        Expr+       |   'try'         Tactic '|' Tactic+       |   '{' TacticSeq '}'+       |   'compute'+       |   'trivial'+       |   'solve'+       |   'attack'+       |   'state'+       |   'term'+       |   'undo'+       |   'qed'+       |   'abandon'+       |   ':' 'q'+       ;++Imp ::= '?' | '_';++TacticSeq ::=+    Tactic ';' Tactic+  | Tactic ';' TacticSeq+  ;+@+-}++-- | A specification of the arguments that tactics can take+data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n+               | ExprTArg+               | AltsTArg+               | StringLitTArg++-- The FIXMEs are Issue #1766 in the issue tracker.+--     https://github.com/idris-lang/Idris-dev/issues/1766+-- | A list of available tactics and their argument requirements+tactics :: [([String], Maybe TacticArg, SyntaxInfo -> IdrisParser PTactic)]+tactics =+  [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name)+      do ns <- sepBy (spaced (fst <$> name)) (lchar ','); return $ Intro ns)+  , noArgs ["intros"] Intros+  , noArgs ["unfocus"] Unfocus+  , (["refine"], Just ExprTArg, const $+       do n <- spaced (fst <$> fnName)+          imps <- many imp+          return $ Refine n imps)+  , (["claim"], Nothing, \syn ->+       do n <- indentPropHolds gtProp *> (fst <$> name)+          goal <- indentPropHolds gtProp *> expr syn+          return $ Claim n goal)+  , (["mrefine"], Just ExprTArg, const $+       do n <- spaced (fst <$> fnName)+          return $ MatchRefine n)+  , expressionTactic ["rewrite"] Rewrite+  , expressionTactic ["case"] CaseTac+  , expressionTactic ["induction"] Induction+  , expressionTactic ["equiv"] Equiv+  , (["let"], Nothing, \syn -> -- FIXME syntax for let+       do n <- (indentPropHolds gtProp *> (fst <$> name))+          (do indentPropHolds gtProp *> lchar ':'+              ty <- indentPropHolds gtProp *> expr' syn+              indentPropHolds gtProp *> lchar '='+              t <- indentPropHolds gtProp *> expr syn+              i <- get+              return $ LetTacTy n (desugar syn i ty) (desugar syn i t))+            <|> (do indentPropHolds gtProp *> lchar '='+                    t <- indentPropHolds gtProp *> expr syn+                    i <- get+                    return $ LetTac n (desugar syn i t)))++  , (["focus"], Just ExprTArg, const $+       do n <- spaced (fst <$> name)+          return $ Focus n)+  , expressionTactic ["exact"] Exact+  , expressionTactic ["applyTactic"] ApplyTactic+  , expressionTactic ["byReflection"] ByReflection+  , expressionTactic ["reflect"] Reflect+  , expressionTactic ["fill"] Fill+  , (["try"], Just AltsTArg, \syn ->+        do t <- spaced (tactic syn)+           lchar '|'+           t1 <- spaced (tactic syn)+           return $ Try t t1)+  , noArgs ["compute"] Compute+  , noArgs ["trivial"] Trivial+  , noArgs ["unify"] DoUnify+  , (["search"], Nothing, const $+      do depth <- option 10 $ fst <$> natural+         return (ProofSearch True True (fromInteger depth) Nothing [] []))+  , noArgs ["instance"] TCInstance+  , noArgs ["solve"] Solve+  , noArgs ["attack"] Attack+  , noArgs ["state", ":state"] ProofState+  , noArgs ["term", ":term"] ProofTerm+  , noArgs ["undo", ":undo"] Undo+  , noArgs ["qed", ":qed"] Qed+  , noArgs ["abandon", ":q"] Abandon+  , noArgs ["skip"] Skip+  , noArgs ["sourceLocation"] SourceFC+  , expressionTactic [":e", ":eval"] TEval+  , expressionTactic [":t", ":type"] TCheck+  , expressionTactic [":search"] TSearch+  , (["fail"], Just StringLitTArg, const $+       do msg <- fst <$> stringLiteral+          return $ TFail [Idris.Core.TT.TextPart msg])+  , ([":doc"], Just ExprTArg, const $+       do whiteSpace+          doc <- (Right . fst <$> constant) <|> (Left . fst <$> fnName)+          eof+          return (TDocStr doc))+  ]+  where+  expressionTactic names tactic = (names, Just ExprTArg, \syn ->+     do t <- spaced (expr syn)+        i <- get+        return $ tactic (desugar syn i t))+  noArgs names tactic = (names, Nothing, const (return tactic))+  spaced parser = indentPropHolds gtProp *> parser+  imp :: IdrisParser Bool+  imp = do lchar '?'; return False+    <|> do lchar '_'; return True+++tactic :: SyntaxInfo -> IdrisParser PTactic+tactic syn = choice [ do choice (map reserved names); parser syn+                    | (names, _, parser) <- tactics ]+          <|> do lchar '{'+                 t <- tactic syn;+                 lchar ';';+                 ts <- sepBy1 (tactic syn) (lchar ';')+                 lchar '}'+                 return $ TSeq t (mergeSeq ts)+          <|> ((lchar ':' >> empty) <?> "prover command")+          <?> "tactic"+  where+    mergeSeq :: [PTactic] -> PTactic+    mergeSeq [t]    = t+    mergeSeq (t:ts) = TSeq t (mergeSeq ts)++-- | Parses a tactic as a whole+fullTactic :: SyntaxInfo -> IdrisParser PTactic+fullTactic syn = do t <- tactic syn+                    eof+                    return t
+ src/Idris/Parser/Helpers.hs view
@@ -0,0 +1,701 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, StandaloneDeriving #-}+#if !(MIN_VERSION_base(4,8,0))+{-# LANGUAGE OverlappingInstances #-}+#endif+module Idris.Parser.Helpers 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 qualified Text.Parser.Token as Tok+import qualified Text.Parser.Char as Chr+import qualified Text.Parser.Token.Highlight as Hi++import Idris.AbsSyntax++import Idris.Core.TT+import Idris.Core.Evaluate+import Idris.Delaborate (pprintErr)+import Idris.Docstrings+import Idris.Output (iWarn)++import qualified Util.Pretty as Pretty (text)++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict++import Data.Maybe+import qualified Data.List.Split as Spl+import Data.List+import Data.Monoid+import Data.Char+import qualified Data.Map as M+import qualified Data.HashSet as HS+import qualified Data.Text as T+import qualified Data.ByteString.UTF8 as UTF8++import System.FilePath++import Debug.Trace++-- | Idris parser with state used during parsing+type IdrisParser = StateT IState IdrisInnerParser++newtype IdrisInnerParser a = IdrisInnerParser { runInnerParser :: Parser a }+  deriving (Monad, Functor, MonadPlus, Applicative, Alternative, CharParsing, LookAheadParsing, DeltaParsing, MarkParsing Delta, Monoid, TokenParsing)++deriving instance Parsing IdrisInnerParser++#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPING #-} TokenParsing IdrisParser where+#else+instance TokenParsing IdrisParser where+#endif+  someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()+  token p = do s <- get+               (FC fn (sl, sc) _) <- getFC --TODO: Update after fixing getFC+                                           -- See Issue #1594+               r <- p+               (FC fn _ (el, ec)) <- getFC+               whiteSpace+               put (s { lastTokenSpan = Just (FC fn (sl, sc) (el, ec)) })+               return r+-- | Generalized monadic parsing constraint type+type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m)++class HasLastTokenSpan m where+  getLastTokenSpan :: m (Maybe FC)++instance HasLastTokenSpan IdrisParser where+  getLastTokenSpan = lastTokenSpan <$> get++-- | Helper to run Idris inner parser based stateT parsers+runparser :: StateT st IdrisInnerParser res -> st -> String -> String -> Result res+runparser p i inputname =+  parseString (runInnerParser (evalStateT p i))+              (Directed (UTF8.fromString inputname) 0 0 0 0)++highlightP :: FC -> OutputAnnotation -> IdrisParser ()+highlightP fc annot = do ist <- get+                         put ist { idris_parserHighlights = (fc, annot) : idris_parserHighlights ist}++noDocCommentHere :: String -> IdrisParser ()+noDocCommentHere msg =+  optional (do fc <- getFC+               docComment+               ist <- get+               put ist { parserWarnings = (fc, Msg msg) : parserWarnings ist}) *>+  pure ()++clearParserWarnings :: Idris ()+clearParserWarnings = do ist <- getIState+                         putIState ist { parserWarnings = [] }++reportParserWarnings :: Idris ()+reportParserWarnings = do ist <- getIState+                          mapM_ (uncurry iWarn)+                                (map (\ (fc, err) -> (fc, pprintErr ist err)) .+                                 reverse .+                                 nubBy (\(fc, err) (fc', err') ->+                                         FC' fc == FC' fc' && err == err') $+                                 parserWarnings ist)+                          clearParserWarnings+++parserWarning :: FC -> Maybe Opt -> Err -> IdrisParser ()+parserWarning fc warnOpt warnErr = do+  ist <- get+  let cmdline = opt_cmdline (idris_options ist)+  unless (maybe False (`elem` cmdline) warnOpt) $+    put ist { parserWarnings = (fc, warnErr) : parserWarnings ist }++{- * Space, comments and literals (token/lexing like parsers) -}++-- | Consumes any simple whitespace (any character which satisfies Char.isSpace)+simpleWhiteSpace :: MonadicParsing m => m ()+simpleWhiteSpace = satisfy isSpace *> pure ()++-- | Checks if a charcter is end of line+isEol :: Char -> Bool+isEol '\n' = True+isEol  _   = False++-- | A parser that succeeds at the end of the line+eol :: MonadicParsing m => m ()+eol = (satisfy isEol *> pure ()) <|> lookAhead eof <?> "end of line"++{- | Consumes a single-line comment++@+     SingleLineComment_t ::= '--' ~EOL_t* EOL_t ;+@+ -}+singleLineComment :: MonadicParsing m => m ()+singleLineComment = (string "--" *>+                     many (satisfy (not . isEol)) *>+                     eol *> pure ())+                    <?> ""++{- | Consumes a multi-line comment++@+  MultiLineComment_t ::=+     '{ -- }'+   | '{ -' InCommentChars_t+  ;+@++@+  InCommentChars_t ::=+   '- }'+   | MultiLineComment_t InCommentChars_t+   | ~'- }'+ InCommentChars_t+  ;+@+-}+multiLineComment :: MonadicParsing m => m ()+multiLineComment =     try (string "{-" *> (string "-}") *> pure ())+                   <|> string "{-" *> inCommentChars+                   <?> ""+  where inCommentChars :: MonadicParsing m => m ()+        inCommentChars =     string "-}" *> pure ()+                         <|> try (multiLineComment) *> inCommentChars+                         <|> string "|||" *> many (satisfy (not . isEol)) *> eol *> inCommentChars+                         <|> skipSome (noneOf startEnd) *> inCommentChars+                         <|> oneOf startEnd *> inCommentChars+                         <?> "end of comment"+        startEnd :: String+        startEnd = "{}-"++{-| Parses a documentation comment++@+  DocComment_t ::=   '|||' ~EOL_t* EOL_t+                 ;+@+ -}+docComment :: IdrisParser (Docstring (), [(Name, Docstring ())])+docComment = do dc <- pushIndent *> docCommentLine+                rest <- many (indented docCommentLine)+                args <- many $ do (name, first) <- indented argDocCommentLine+                                  rest <- many (indented docCommentLine)+                                  return (name, concat (intersperse "\n" (first:rest)))+                popIndent+                return (parseDocstring $ T.pack (concat (intersperse "\n" (dc:rest))),+                        map (\(n, d) -> (n, parseDocstring (T.pack d))) args)++  where docCommentLine :: MonadicParsing m => m String+        docCommentLine = try (do string "|||"+                                 many (satisfy (==' '))+                                 contents <- option "" (do first <- satisfy (\c -> not (isEol c || c == '@'))+                                                           res <- many (satisfy (not . isEol))+                                                           return $ first:res)+                                 eol ; someSpace+                                 return contents)-- ++ concat rest))+                        <?> ""++        argDocCommentLine = do string "|||"+                               many (satisfy isSpace)+                               char '@'+                               many (satisfy isSpace)+                               n <- fst <$> name+                               many (satisfy isSpace)+                               docs <- many (satisfy (not . isEol))+                               eol ; someSpace+                               return (n, docs)++-- | Parses some white space+whiteSpace :: MonadicParsing m => m ()+whiteSpace = Tok.whiteSpace++-- | Parses a string literal+stringLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (String, FC)+stringLiteral = do str <- Tok.stringLiteral+                   fc <- getLastTokenSpan+                   return (str, fromMaybe NoFC fc)++-- | Parses a char literal+charLiteral :: (MonadicParsing m, HasLastTokenSpan m) => m (Char, FC)+charLiteral = do ch <- Tok.charLiteral+                 fc <- getLastTokenSpan+                 return (ch, fromMaybe NoFC fc)++-- | Parses a natural number+natural :: (MonadicParsing m, HasLastTokenSpan m) => m (Integer, FC)+natural = do n <- Tok.natural+             fc <- getLastTokenSpan+             return (n, fromMaybe NoFC fc)++-- | Parses an integral number+integer :: MonadicParsing m => m Integer+integer = Tok.integer++-- | Parses a floating point number+float :: (MonadicParsing m, HasLastTokenSpan m) => m (Double, FC)+float = do f <- Tok.double+           fc <- getLastTokenSpan+           return (f, fromMaybe NoFC fc)++{- * Symbols, identifiers, names and operators -}+++-- | Idris Style for parsing identifiers/reserved keywords+idrisStyle :: MonadicParsing m => IdentifierStyle m+idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved Hi.Identifier Hi.ReservedIdentifier+  where _styleName = "Idris"+        _styleStart = satisfy isAlpha <|> oneOf "_"+        _styleLetter = satisfy isAlphaNum <|> oneOf "_'."+        _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "corecord", "Type",+                                      "do", "dsl", "import", "impossible",+                                      "case", "of", "total", "partial", "mutual",+                                      "infix", "infixl", "infixr", "rewrite",+                                      "where", "with", "syntax", "proof", "postulate",+                                      "using", "namespace", "class", "instance",+                                      "interface", "implementation", "parameters",+                                      "public", "private", "export", "abstract", "implicit",+                                      "quoteGoal", "constructor",+                                      "if", "then", "else"]++char :: MonadicParsing m => Char -> m Char+char = Chr.char++string :: MonadicParsing m => String -> m String+string = Chr.string++-- | Parses a character as a token+lchar :: MonadicParsing m => Char -> m Char+lchar = token . char++-- | Parses a character as a token, returning the source span of the character+lcharFC :: MonadicParsing m => Char -> m FC+lcharFC ch = do (FC file (l, c) _) <- getFC+                _ <- token (char ch)+                return $ FC file (l, c) (l, c+1)++-- | Parses string as a token+symbol :: MonadicParsing m => String -> m String+symbol = Tok.symbol++symbolFC :: MonadicParsing m => String -> m FC+symbolFC str = do (FC file (l, c) _) <- getFC+                  Tok.symbol str+                  return $ FC file (l, c) (l, c + length str)++-- | Parses a reserved identifier+reserved :: MonadicParsing m => String -> m ()+reserved = Tok.reserve idrisStyle++-- | Parses a reserved identifier, computing its span. Assumes that+-- reserved identifiers never contain line breaks.+reservedFC :: MonadicParsing m => String -> m FC+reservedFC str = do (FC file (l, c) _) <- getFC+                    Tok.reserve idrisStyle str+                    return $ FC file (l, c) (l, c + length str)++-- | Parse a reserved identfier, highlighting its span as a keyword+reservedHL :: String -> IdrisParser ()+reservedHL str = reservedFC str >>= flip highlightP AnnKeyword++-- Taken from Parsec (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- | Parses a reserved operator+reservedOp :: MonadicParsing m => String -> m ()+reservedOp name = token $ try $+  do string name+     notFollowedBy (operatorLetter) <?> ("end of " ++ show name)++reservedOpFC :: MonadicParsing m => String -> m FC+reservedOpFC name = token $ try $ do (FC f (l, c) _) <- getFC+                                     string name+                                     notFollowedBy (operatorLetter) <?> ("end of " ++ show name)+                                     return (FC f (l, c) (l, c + length name))++-- | Parses an identifier as a token+identifier :: (MonadicParsing m) => m (String, FC)+identifier = try(do (i, fc) <-+                      token $ do (FC f (l, c) _) <- getFC+                                 i <- Tok.ident idrisStyle+                                 return (i, FC f (l, c) (l, c + length i))+                    when (i == "_") $ unexpected "wildcard"+                    return (i, fc))++-- | Parses an identifier with possible namespace as a name+iName :: (MonadicParsing m, HasLastTokenSpan m) => [String] -> m (Name, FC)+iName bad = do (n, fc) <- maybeWithNS identifier False bad+               return (n, fc)+            <?> "name"++-- | Parses an string possibly prefixed by a namespace+maybeWithNS :: (MonadicParsing m, HasLastTokenSpan m) => m (String, FC) -> Bool -> [String] -> m (Name, FC)+maybeWithNS parser ascend bad = do+  fc <- getFC+  i <- option "" (lookAhead (fst <$> identifier))+  when (i `elem` bad) $ unexpected "reserved identifier"+  let transf = if ascend then id else reverse+  (x, xs, fc) <- choice (transf (parserNoNS parser : parsersNS parser i))+  return (mkName (x, xs), fc)+  where parserNoNS :: MonadicParsing m => m (String, FC) -> m (String, String, FC)+        parserNoNS parser = do startFC <- getFC+                               (x, nameFC) <- parser+                               return (x, "", spanFC startFC nameFC)+        parserNS   :: MonadicParsing m => m (String, FC) -> String -> m (String, String, FC)+        parserNS   parser ns = do startFC <- getFC+                                  xs <- string ns+                                  lchar '.';  (x, nameFC) <- parser+                                  return (x, xs, spanFC startFC nameFC)+        parsersNS  :: MonadicParsing m => m (String, FC) -> String -> [m (String, String, FC)]+        parsersNS parser i = [try (parserNS parser ns) | ns <- (initsEndAt (=='.') i)]++-- | Parses a name+name :: IdrisParser (Name, FC)+name = (<?> "name") $ do+    keywords <- syntax_keywords <$> get+    aliases  <- module_aliases  <$> get+    (n, fc) <- iName keywords+    return (unalias aliases n, fc)+  where+    unalias :: M.Map [T.Text] [T.Text] -> Name -> Name+    unalias aliases (NS n ns) | Just ns' <- M.lookup ns aliases = NS n ns'+    unalias aliases name = name++{- | List of all initial segments in ascending order of a list.  Every+such initial segment ends right before an element satisfying the given+condition.+-}+initsEndAt :: (a -> Bool) -> [a] -> [[a]]+initsEndAt p [] = []+initsEndAt p (x:xs) | p x = [] : x_inits_xs+                    | otherwise = x_inits_xs+  where x_inits_xs = [x : cs | cs <- initsEndAt p xs]+++{- | Create a `Name' from a pair of strings representing a base name and its+ namespace.+-}+mkName :: (String, String) -> Name+mkName (n, "") = sUN n+mkName (n, ns) = sNS (sUN n) (reverse (parseNS ns))+  where parseNS x = case span (/= '.') x of+                      (x, "")    -> [x]+                      (x, '.':y) -> x : parseNS y++opChars :: String+opChars = ":!#$%&*+./<=>?@\\^|-~"++operatorLetter :: MonadicParsing m => m Char+operatorLetter = oneOf opChars+++commentMarkers :: [String]+commentMarkers = [ "--", "|||" ]++invalidOperators :: [String]+invalidOperators = [":", "=>", "->", "<-", "=", "?=", "|", "**", "==>", "\\", "%", "~", "?", "!"]++-- | Parses an operator+operator :: MonadicParsing m => m String+operator = do op <- token . some $ operatorLetter+              when (op `elem` (invalidOperators ++ commentMarkers)) $+                   fail $ op ++ " is not a valid operator"+              return op++-- | Parses an operator+operatorFC :: MonadicParsing m => m (String, FC)+operatorFC = do (op, fc) <- token $ do (FC f (l, c) _) <- getFC+                                       op <- some operatorLetter+                                       return (op, FC f (l, c) (l, c + length op))+                when (op `elem` (invalidOperators ++ commentMarkers)) $+                     fail $ op ++ " is not a valid operator"+                return (op, fc)++{- * Position helpers -}+{- | Get filename from position (returns "(interactive)" when no source file is given)  -}+fileName :: Delta -> String+fileName (Directed fn _ _ _ _) = UTF8.toString fn+fileName _                     = "(interactive)"++{- | Get line number from position -}+lineNum :: Delta -> Int+lineNum (Lines l _ _ _)      = fromIntegral l + 1+lineNum (Directed _ l _ _ _) = fromIntegral l + 1+lineNum _ = 0++{- | Get column number from position -}+columnNum :: Delta -> Int+columnNum pos = fromIntegral (column pos) + 1+++{- | Get file position as FC -}+getFC :: MonadicParsing m => m FC+getFC = do s <- position+           let (dir, file) = splitFileName (fileName s)+           let f = if dir == addTrailingPathSeparator "." then file else fileName s+           return $ FC f (lineNum s, columnNum s) (lineNum s, columnNum s) -- TODO: Change to actual spanning+           -- Issue #1594 on the Issue Tracker.+           -- https://github.com/idris-lang/Idris-dev/issues/1594+++{-* Syntax helpers-}+-- | Bind constraints to term+bindList :: (Name -> FC -> PTerm -> PTerm -> PTerm) -> [(Name, FC, PTerm)] -> PTerm -> PTerm+bindList b []              sc = sc+bindList b ((n, fc, t):bs) sc = b n fc t (bindList b bs sc)++{- | @commaSeparated p@ parses one or more occurences of `p`,+     separated by commas and optional whitespace. -}+commaSeparated :: MonadicParsing m => m a -> m [a]+commaSeparated p = p `sepBy1` (spaces >> char ',' >> spaces)++{- * Layout helpers -}++-- | Push indentation to stack+pushIndent :: IdrisParser ()+pushIndent = do pos <- position+                ist <- get+                put (ist { indent_stack = (fromIntegral (column pos) + 1) : indent_stack ist })++-- | Pops indentation from stack+popIndent :: IdrisParser ()+popIndent = do ist <- get+               case indent_stack ist of+                 [] -> error "The impossible happened! Tried to pop an indentation level where none was pushed (underflow)."+                 (x : xs) -> put (ist { indent_stack = xs })+++-- | Gets current indentation+indent :: IdrisParser Int+indent = liftM ((+1) . fromIntegral . column) position++-- | Gets last indentation+lastIndent :: IdrisParser Int+lastIndent = do ist <- get+                case indent_stack ist of+                  (x : xs) -> return x+                  _        -> return 1++-- | Applies parser in an indented position+indented :: IdrisParser a -> IdrisParser a+indented p = notEndBlock *> p <* keepTerminator++-- | Applies parser to get a block (which has possibly indented statements)+indentedBlock :: IdrisParser a -> IdrisParser [a]+indentedBlock p = do openBlock+                     pushIndent+                     res <- many (indented p)+                     popIndent+                     closeBlock+                     return res++-- | Applies parser to get a block with at least one statement (which has possibly indented statements)+indentedBlock1 :: IdrisParser a -> IdrisParser [a]+indentedBlock1 p = do openBlock+                      pushIndent+                      res <- some (indented p)+                      popIndent+                      closeBlock+                      return res++-- | Applies parser to get a block with exactly one (possibly indented) statement+indentedBlockS :: IdrisParser a -> IdrisParser a+indentedBlockS p = do openBlock+                      pushIndent+                      res <- indented p+                      popIndent+                      closeBlock+                      return res+++-- | Checks if the following character matches provided parser+lookAheadMatches :: MonadicParsing m => m a -> m Bool+lookAheadMatches p = do match <- lookAhead (optional p)+                        return $ isJust match++-- | Parses a start of block+openBlock :: IdrisParser ()+openBlock =     do lchar '{'+                   ist <- get+                   put (ist { brace_stack = Nothing : brace_stack ist })+            <|> do ist <- get+                   lvl' <- indent+                    -- if we're not indented further, it's an empty block, so+                    -- increment lvl to ensure we get to the end+                   let lvl = case brace_stack ist of+                                   Just lvl_old : _ ->+                                       if lvl' <= lvl_old then lvl_old+1+                                                          else lvl'+                                   [] -> if lvl' == 1 then 2 else lvl'+                                   _ -> lvl'+                   put (ist { brace_stack = Just lvl : brace_stack ist })+            <?> "start of block"++-- | Parses an end of block+closeBlock :: IdrisParser ()+closeBlock = do ist <- get+                bs <- case brace_stack ist of+                        []  -> eof >> return []+                        Nothing : xs -> lchar '}' >> return xs <?> "end of block"+                        Just lvl : xs -> (do i   <- indent+                                             isParen <- lookAheadMatches (char ')')+                                             isIn <- lookAheadMatches (reserved "in")+                                             if i >= lvl && not (isParen || isIn)+                                                then fail "not end of block"+                                                else return xs)+                                          <|> (do notOpenBraces+                                                  eof+                                                  return [])+                put (ist { brace_stack = bs })++-- | Parses a terminator+terminator :: IdrisParser ()+terminator =     do lchar ';'; popIndent+             <|> do c <- indent; l <- lastIndent+                    if c <= l then popIndent else fail "not a terminator"+             <|> do isParen <- lookAheadMatches (oneOf ")}")+                    if isParen then popIndent else fail "not a terminator"+             <|> lookAhead eof++-- | Parses and keeps a terminator+keepTerminator :: IdrisParser ()+keepTerminator =  do lchar ';'; return ()+              <|> do c <- indent; l <- lastIndent+                     unless (c <= l) $ fail "not a terminator"+              <|> do isParen <- lookAheadMatches (oneOf ")}|")+                     isIn <- lookAheadMatches (reserved "in")+                     unless (isIn || isParen) $ fail "not a terminator"+              <|> lookAhead eof++-- | Checks if application expression does not end+notEndApp :: IdrisParser ()+notEndApp = do c <- indent; l <- lastIndent+               when (c <= l) (fail "terminator")++-- | Checks that it is not end of block+notEndBlock :: IdrisParser ()+notEndBlock = do ist <- get+                 case brace_stack ist of+                      Just lvl : xs -> do i <- indent+                                          isParen <- lookAheadMatches (char ')')+                                          when (i < lvl || isParen) (fail "end of block")+                      _ -> return ()++-- | Representation of an operation that can compare the current indentation with the last indentation, and an error message if it fails+data IndentProperty = IndentProperty (Int -> Int -> Bool) String++-- | Allows comparison of indent, and fails if property doesn't hold+indentPropHolds :: IndentProperty -> IdrisParser ()+indentPropHolds (IndentProperty op msg) = do+  li <- lastIndent+  i <- indent+  when (not $ op i li) $ fail ("Wrong indention: " ++ msg)++-- | Greater-than indent property+gtProp :: IndentProperty+gtProp = IndentProperty (>) "should be greater than context indentation"++-- | Greater-than or equal to indent property+gteProp :: IndentProperty+gteProp = IndentProperty (>=) "should be greater than or equal context indentation"++-- | Equal indent property+eqProp :: IndentProperty+eqProp = IndentProperty (==) "should be equal to context indentation"++-- | Less-than indent property+ltProp :: IndentProperty+ltProp = IndentProperty (<) "should be less than context indentation"++-- | Less-than or equal to indent property+lteProp :: IndentProperty+lteProp = IndentProperty (<=) "should be less than or equal to context indentation"+++-- | Checks that there are no braces that are not closed+notOpenBraces :: IdrisParser ()+notOpenBraces = do ist <- get+                   when (hasNothing $ brace_stack ist) $ fail "end of input"+  where hasNothing :: [Maybe a] -> Bool+        hasNothing = any isNothing++{- | Parses an accessibilty modifier (e.g. public, private) -}+accessibility' :: IdrisParser Accessibility+accessibility'+              = do reserved "public";+                   gotexp <- optional (reserved "export")+                   case gotexp of+                        Just _ -> return ()+                        Nothing -> do+                           ist <- get+                           fc <- getFC+                           put ist { parserWarnings =+                              (fc, Msg "'public' is deprecated. Use 'public export' instead.")+                                   : parserWarnings ist }+                   return Public+            <|> do reserved "abstract";+                   ist <- get+                   fc <- getFC+                   put ist { parserWarnings =+                      (fc, Msg "The 'abstract' keyword is deprecated. Use 'export' instead.")+                           : parserWarnings ist }+                   return Frozen+            <|> do reserved "export"; return Frozen+            <|> do reserved "private";  return Private+            <?> "accessibility modifier"++accessibility :: IdrisParser Accessibility+accessibility = do acc <- optional accessibility'+                   case acc of+                        Just a -> return a+                        Nothing -> do ist <- get+                                      return (default_access ist)++-- | Adds accessibility option for function+addAcc :: Name -> Accessibility -> IdrisParser ()+addAcc n a = do i <- get+                put (i { hide_list = addDef n a (hide_list i) })++{- | Add accessbility option for data declarations+ (works for classes too - 'abstract' means the data/class is visible but members not) -}+accData :: Accessibility -> Name -> [Name] -> IdrisParser ()+accData Frozen n ns = do addAcc n Public -- so that it can be used in public definitions+                         mapM_ (\n -> addAcc n Private) ns -- so that they are invisible+accData a n ns = do addAcc n a+                    mapM_ (`addAcc` a) ns+++{- * Error reporting helpers -}+{- | Error message with possible fixes list -}+fixErrorMsg :: String -> [String] -> String+fixErrorMsg msg fixes = msg ++ ", possible fixes:\n" ++ (concat $ intersperse "\n\nor\n\n" fixes)++-- | Collect 'PClauses' with the same function name+collect :: [PDecl] -> [PDecl]+collect (c@(PClauses _ o _ _) : ds)+    = clauses (cname c) [] (c : ds)+  where clauses :: Maybe Name -> [PClause] -> [PDecl] -> [PDecl]+        clauses j@(Just n) acc (PClauses fc _ _ [PClause fc' n' l ws r w] : ds)+           | n == n' = clauses j (PClause fc' n' l ws r (collect w) : acc) ds+        clauses j@(Just n) acc (PClauses fc _ _ [PWith fc' n' l ws r pn w] : ds)+           | n == n' = clauses j (PWith fc' n' l ws r pn (collect w) : acc) ds+        clauses (Just n) acc xs = PClauses (fcOf c) o n (reverse acc) : collect xs+        clauses Nothing acc (x:xs) = collect xs+        clauses Nothing acc [] = []++        cname :: PDecl -> Maybe Name+        cname (PClauses fc _ _ [PClause _ n _ _ _ _]) = Just n+        cname (PClauses fc _ _ [PWith   _ n _ _ _ _ _]) = Just n+        cname (PClauses fc _ _ [PClauseR _ _ _ _]) = Nothing+        cname (PClauses fc _ _ [PWithR _ _ _ _ _]) = Nothing+        fcOf :: PDecl -> FC+        fcOf (PClauses fc _ _ _) = fc+collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds+collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds+collect (PNamespace ns fc ps : ds) = PNamespace ns fc (collect ps) : collect ds+collect (PClass doc f s cs n nfc ps pdocs fds ds cn cd : ds')+    = PClass doc f s cs n nfc ps pdocs fds (collect ds) cn cd : collect ds'+collect (PInstance doc argDocs f s cs acc opts n nfc ps t en ds : ds')+    = PInstance doc argDocs f s cs acc opts n nfc ps t en (collect ds) : collect ds'+collect (d : ds) = d : collect ds+collect [] = []
+ src/Idris/Parser/Ops.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}+module Idris.Parser.Ops where++import Prelude hiding (pi)++import Text.Trifecta.Delta+import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)+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++import Idris.AbsSyntax+import Idris.Parser.Helpers++import Idris.Core.TT++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict++import Data.Maybe+import qualified Data.List.Split as Spl+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++-- | Creates table for fixity declarations to build expression parser+-- using pre-build and user-defined operator/fixity declarations+table :: [FixDecl] -> OperatorTable IdrisParser PTerm+table fixes+   = [[prefix "-" (\fc x -> PApp fc (PRef fc [fc] (sUN "negate")) [pexp x])]] +++     toTable (reverse fixes) +++     [[backtick],+      [binary "$" (\fc x y -> flatten $ PApp fc x [pexp y]) AssocRight],+      [binary "="  (\fc x y -> PApp fc (PRef fc [fc] eqTy) [pexp x, pexp y]) AssocLeft],+      [nofixityoperator]]+  where+    flatten :: PTerm -> PTerm -- flatten application+    flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))+    flatten t = t+++-- | Calculates table for fixity declarations+toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm+toTable fs = map (map toBin)+                 (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)+   where toBin (Fix (PrefixN _) op) = prefix op+                                       (\fc x -> PApp fc (PRef fc [] (sUN op)) [pexp x])+         toBin (Fix f op)+            = binary op (\fc x y -> PApp fc (PRef fc [] (sUN op)) [pexp x,pexp y]) (assoc f)+         assoc (Infixl _) = AssocLeft+         assoc (Infixr _) = AssocRight+         assoc (InfixN _) = AssocNone++-- | Binary operator+binary :: String -> (FC -> PTerm -> PTerm -> PTerm) -> Assoc -> Operator IdrisParser PTerm+binary name f = Infix (do indentPropHolds gtProp+                          fc <- reservedOpFC name+                          indentPropHolds gtProp+                          return (f fc))++-- | Prefix operator+prefix :: String -> (FC -> PTerm -> PTerm) -> Operator IdrisParser PTerm+prefix name f = Prefix (do reservedOp name+                           fc <- getFC+                           indentPropHolds gtProp+                           return (f fc))++-- | Backtick operator+backtick :: Operator IdrisParser PTerm+backtick = Infix (do indentPropHolds gtProp+                     lchar '`'; (n, fc) <- fnName+                     lchar '`'+                     indentPropHolds gtProp+                     return (\x y -> PApp fc (PRef fc [fc] n) [pexp x, pexp y])) AssocNone++-- | Operator without fixity (throws an error)+nofixityoperator :: Operator IdrisParser PTerm+nofixityoperator = Infix (do indentPropHolds gtProp+                             op <- try operator+                             unexpected $ "Operator without known fixity: " ++ op) AssocNone+++{- | Parses an operator in function position i.e. enclosed by `()', with an+ optional namespace++@+  OperatorFront ::=+    '(' '=' ')'+    | (Identifier_t '.')? '(' Operator_t ')'+    ;+@++-}+operatorFront :: IdrisParser (Name, FC)+operatorFront = try (do (FC f (l, c) _) <- getFC+                        op <- lchar '(' *> reservedOp "="  <* lchar ')'+                        return (eqTy, FC f (l, c) (l, c+3)))+            <|> maybeWithNS (do (FC f (l, c) _) <- getFC+                                op <- lchar '(' *> operator+                                (FC _ _ (l', c')) <- getFC+                                lchar ')'+                                return (op, (FC f (l, c) (l', c' + 1)))) False []++{- | Parses a function (either normal name or operator)++@+  FnName ::= Name | OperatorFront;+@+-}+fnName :: IdrisParser (Name, FC)+fnName = try operatorFront <|> name <?> "function name"++{- | Parses a fixity declaration+@+Fixity ::=+  FixityType Natural_t OperatorList Terminator+  ;+@+-}+fixity :: IdrisParser PDecl+fixity = do pushIndent+            f <- fixityType; i <- fst <$> natural;+            ops <- sepBy1 operator (lchar ',')+            terminator+            let prec = fromInteger i+            istate <- get+            let infixes = idris_infixes istate+            let fs      = map (Fix (f prec)) ops+            let redecls = map (alreadyDeclared infixes) fs+            let ill     = filter (not . checkValidity) redecls+            if null ill+               then do put (istate { idris_infixes = nub $ sort (fs ++ infixes)+                                     , ibc_write     = map IBCFix fs ++ ibc_write istate+                                   })+                       fc <- getFC+                       return (PFix fc (f prec) ops)+               else fail $ concatMap (\(f, (x:xs)) -> "Illegal redeclaration of fixity:\n\t\""+                                                ++ show f ++ "\" overrides \"" ++ show x ++ "\"") ill+         <?> "fixity declaration"+             where alreadyDeclared :: [FixDecl] -> FixDecl -> (FixDecl, [FixDecl])+                   alreadyDeclared fs f = (f, filter ((extractName f ==) . extractName) fs)++                   checkValidity :: (FixDecl, [FixDecl]) -> Bool+                   checkValidity (f, fs) = all (== f) fs++                   extractName :: FixDecl -> String+                   extractName (Fix _ n) = n++{- | Parses a fixity declaration type (i.e. infix or prefix, associtavity)+@+    FixityType ::=+      'infixl'+      | 'infixr'+      | 'infix'+      | 'prefix'+      ;+@+ -}+fixityType :: IdrisParser (Int -> Fixity)+fixityType = do reserved "infixl"; return Infixl+         <|> do reserved "infixr"; return Infixr+         <|> do reserved "infix";  return InfixN+         <|> do reserved "prefix"; return PrefixN+         <?> "fixity type"
src/Idris/ProofSearch.hs view
@@ -48,13 +48,13 @@                    then try' (elab (PRef (fileFC "prf") [] x))                              (tryAll xs) True                    else tryAll xs-        +         holesOK hs ap@(App _ _ _)            | (P _ n _, args) <- unApply ap                 = holeArgsOK hs n 0 args         holesOK hs (App _ f a) = holesOK hs f && holesOK hs a         holesOK hs (P _ n _) = not (n `elem` hs)-        holesOK hs (Bind n b sc) = holesOK hs (binderTy b) && +        holesOK hs (Bind n b sc) = holesOK hs (binderTy b) &&                                    holesOK hs sc         holesOK hs _ = True @@ -85,8 +85,8 @@                    then try' (elab (PRef (fileFC "prf") [] x))                              (tryAll xs) True                    else tryAll xs-       -        tcArg env ty ++        tcArg env ty            | (P _ n _, args) <- unApply (getRetTy (normalise (tt_ctxt ist) env ty))                  = case lookupCtxtExact n (idris_classes ist) of                         Just _ -> True@@ -98,7 +98,7 @@                 = holeArgsOK hs n 0 args         holesOK hs (App _ f a) = holesOK hs f && holesOK hs a         holesOK hs (P _ n _) = not (n `elem` hs)-        holesOK hs (Bind n b sc) = holesOK hs (binderTy b) && +        holesOK hs (Bind n b sc) = holesOK hs (binderTy b) &&                                    holesOK hs sc         holesOK hs _ = True @@ -111,16 +111,16 @@ cantSolveGoal = do g <- goal                    env <- get_env                    lift $ tfail $-                      CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env) +                      CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env) -proofSearch :: Bool -> -- recursive search (False for 'refine') +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 -> +               (PTerm -> ElabD ()) -> Maybe Name -> Name ->                [Name] ->                [Name] ->                IState -> ElabD ()@@ -131,7 +131,7 @@             tryAllFns all_imps   where     -- if nothing worked, make a new metavariable-    tryAllFns [] | fromProver = cantSolveGoal  +    tryAllFns [] | fromProver = cantSolveGoal     tryAllFns [] = do attack; defer [] nroot; solve     tryAllFns (f : fs) = try' (tryFn f) (tryAllFns fs) True @@ -142,20 +142,20 @@                                                   (match_apply (Var f) imps) True                          ps' <- get_probs --                          when (length ps < length ps') $ fail "Can't apply constructor"-                         -- Make metavariables for new holes +                         -- Make metavariables for new holes                          hs' <- get_holes                          ptm <- get_term                          if fromProver then cantSolveGoal                            else do                              mapM_ (\ h -> do focus h-                                              attack; defer [] nroot; solve) +                                              attack; defer [] nroot; solve)                                  (hs' \\ hs) --                                  (filter (\ (x, y) -> not x) (zip (map fst imps) args))                              solve      isImp (PImp p _ _ _ _) = (True, p)     isImp arg = (True, priority arg) -- try to get all of them by unification-proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hints ist +proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hints ist        = do compute             ty <- goal             hs <- get_holes@@ -172,7 +172,7 @@                                       (autoArg (sUN "auto"))                else autoArg (sUN "auto") -- not enough info in the type yet   where-    findInferredTy (t : _) = elab (delab ist (toUN t)) +    findInferredTy (t : _) = elab (delab ist (toUN t))      cantsolve (InternalMsg _) = True     cantsolve (CantSolveGoal _ _) = True@@ -185,12 +185,12 @@     conArgsOK ty        = let (f, as) = unApply ty in            case f of-              P _ n _ -> +              P _ n _ ->                 let autohints = case lookupCtxtExact n (idris_autohints ist) of                                      Nothing -> []                                      Just hs -> hs in                     case lookupCtxtExact n (idris_datatypes ist) of-                              Just t -> do rs <- mapM (conReady as) +                              Just t -> do rs <- mapM (conReady as)                                                       (autohints ++ con_names t)                                            return (and rs)                               Nothing -> -- local variable, go for it@@ -199,7 +199,7 @@               _ -> typeNotSearchable ty      conReady :: [Term] -> Name -> ElabD Bool-    conReady as n +    conReady as n        = case lookupTyExact n (tt_ctxt ist) of               Just ty -> do let (_, cs) = unApply (getRetTy ty)                             -- if any metavariables in 'as' correspond to@@ -223,7 +223,7 @@     inHS hs (P _ n _) = n `elem` hs     isHS _ _ = False -    toUN t@(P nt (MN i n) ty) +    toUN t@(P nt (MN i n) ty)        | ('_':xs) <- str n = t        | otherwise = P nt (UN n) ty     toUN (App s f a) = App s (toUN f) (toUN a)@@ -239,7 +239,7 @@     psRec :: Bool -> Int -> [Name] -> S.Set Type -> ElabD ()     psRec _ 0 locs tys | fromProver = cantSolveGoal     psRec rec 0 locs tys = do attack; defer [] nroot; solve --fail "Maximum depth reached"-    psRec False d locs tys = tryCons d locs tys hints +    psRec False d locs tys = tryCons d locs tys hints     psRec True d locs tys                  = do compute                       ty <- goal@@ -248,11 +248,11 @@                       try' (try' (trivialHoles psnames [] elab ist)                                  (resolveTC False False 20 ty nroot elab ist)                                  True)-                           (try' (try' (resolveByCon (d - 1) locs tys') +                           (try' (try' (resolveByCon (d - 1) locs tys')                                        (resolveByLocals (d - 1) locs tys')                                  True)              -- if all else fails, make a new metavariable-                         (if fromProver +                         (if fromProver                              then fail "cantSolveGoal"                              else do attack; defer [] nroot; solve) True) True @@ -269,18 +269,13 @@         = do t <- goal              let (f, _) = unApply t              case f of-                P _ n _ -> +                P _ n _ ->                    do let autohints = case lookupCtxtExact n (idris_autohints ist) of                                            Nothing -> []                                            Just hs -> hs                       case lookupCtxtExact n (idris_datatypes ist) of                           Just t -> do                              let others = hints ++ con_names t ++ autohints-                             when (not fromProver && length (con_names t) > 1)-                                   -- in interactive mode,-                                   -- don't just guess (fine for 'auto',-                                   -- since that's part of the point...)-                                   $ checkConstructor ist others                              tryCons d locs tys (others ++ getFn d fn)                           Nothing -> typeNotSearchable t                 _ -> typeNotSearchable t@@ -292,26 +287,26 @@              tryLocals d locs tys env      tryLocals d locs tys [] = fail "Locals failed"-    tryLocals d locs tys ((x, t) : xs) +    tryLocals d locs tys ((x, t) : xs)        | x `elem` locs || x `notElem` psnames = tryLocals d locs tys xs-       | otherwise = try' (tryLocal d (x : locs) tys x t) +       | otherwise = try' (tryLocal d (x : locs) tys x t)                           (tryLocals d locs tys xs) True      tryCons d locs tys [] = fail "Constructors failed"-    tryCons d locs tys (c : cs) +    tryCons d locs tys (c : cs)         = try' (tryCon d locs tys c) (tryCons d locs tys cs) True -    tryLocal d locs tys n t +    tryLocal d locs tys n t           = do let a = getPArity (delab ist (binderTy t))                tryLocalArg d locs tys n a      tryLocalArg d locs tys n 0 = elab (PRef (fileFC "prf") [] n)-    tryLocalArg d locs tys n i +    tryLocalArg d locs tys n i         = simple_app False (tryLocalArg d locs tys n (i - 1))                 (psRec True d locs tys) "proof search local apply"      -- Like type class resolution, but searching with constructors-    tryCon d locs tys n = +    tryCon d locs tys n =          do ty <- goal             let imps = case lookupCtxtExact n (idris_implicits ist) of                             Nothing -> []@@ -341,23 +336,6 @@          (Bind _ (Pi _ _ _) _) -> [TextPart "In particular, function types are not supported."]          _ -> [] --- In interactive mode, only search for things if there is some --- index to help pick a relevant constructor-checkConstructor :: IState -> [Name] -> ElabD ()-checkConstructor ist [] = return ()-checkConstructor ist (n : ns) =-    case lookupTyExact n (tt_ctxt ist) of-         Just t -> if not (conIndexed t)-                      then fail "Overlapping constructor types"-                      else checkConstructor ist ns-  where-    conIndexed t = let (_, args) = unApply (getRetTy t) in-                       any conHead args-    conHead t | (P _ n _, _) <- unApply t = case lookupDefExact n (tt_ctxt ist) of-                                                 Just _ -> True-                                                 _ -> False-              | otherwise = False- -- | Resolve type classes. This will only pick up 'normal' instances, never -- named instances (which is enforced by 'findInstances'). resolveTC :: Bool -- ^ using default Int@@ -383,8 +361,10 @@        let (argsok, okholePos) = case tcArgsOK g topholes of                                     Nothing -> (False, [])                                     Just hs -> (True, hs)+       env <- get_env+       probs <- get_probs        if not argsok -- && not mvok)-         then lift $ tfail $ CantResolve True topg+         then lift $ tfail $ CantResolve True topg (probErr probs)          else do            ptm <- get_term            ulog <- getUnifyLog@@ -397,7 +377,7 @@                               _ -> []             traceWhen ulog ("Resolving class " ++ show g ++ "\nin" ++ show env ++ "\n" ++ show okholes) $-            try' (trivialTCs okholes elab ist) +            try' (trivialTCs okholes elab ist)                 (do addDefault t tc ttypes                     let stk = map fst (filter snd $ elab_stack ist)                     let insts = findInstances ist t@@ -431,8 +411,11 @@                               _ -> Just rs     tcDetArgsOK _ _ _ [] = Just [] +    probErr [] = Msg ""+    probErr ((_,_,_,_,err,_,_) : _) = err+     isMeta :: [Name] -> Term -> Bool-    isMeta ns (P _ n _) = n `elem` ns +    isMeta ns (P _ n _) = n `elem` ns     isMeta _ _ = False      notHole hs (P _ n _, c)@@ -449,7 +432,7 @@     chaser (NS n _) = chaser n     chaser _ = False -    numclass = sNS (sUN "Num") ["Classes","Prelude"]+    numclass = sNS (sUN "Num") ["Interfaces","Prelude"]      addDefault t num@(P _ nc _) [P Bound a _] | nc == numclass && defaultOn         = do focus a@@ -462,12 +445,13 @@     boundVar (P Bound _ _) = True     boundVar _ = False -    blunderbuss t d stk [] = lift $ tfail $ CantResolve False topg+    blunderbuss t d stk [] = do ps <- get_probs+                                lift $ tfail $ CantResolve False topg (probErr ps)     blunderbuss t d stk (n:ns)         | n /= fn -- && (n `elem` stk)               = tryCatch (resolve n d)                     (\e -> case e of-                             CantResolve True _ -> lift $ tfail e+                             CantResolve True _ _ -> lift $ tfail e                              _ -> blunderbuss t d stk ns)         | otherwise = blunderbuss t d stk ns @@ -529,6 +513,5 @@     | otherwise = []   where accessible n = case lookupDefAccExact n False (tt_ctxt ist) of                             Just (_, Hidden) -> False+                            Just (_, Private) -> False                             _ -> True--
src/Idris/Prover.hs view
@@ -124,7 +124,7 @@                                 [([], P Ref n ty, ptm')] ty                                 ctxt          setContext ctxt'-         solveDeferred n+         solveDeferred emptyFC n          case idris_outputmode i of            IdeMode n h ->              runIO . hPutStrLn h $ IdeMode.convSExp "return" (IdeMode.SymbolAtom "ok", "") n@@ -271,6 +271,21 @@ undoElab prf env st (h:hs) = do (prf', env', st') <- undoStep prf env st h                                 return (prf', env', st', hs) +runWithInterrupt+  :: ElabState EState+  -> Idris a -- ^ run with SIGINT handler+  -> Idris b -- ^ run if mTry finished+  -> Idris b -- ^ run if mTry was interrupted+  -> Idris b+runWithInterrupt elabState mTry mSuccess mFailure = do+  ist <- getIState+  case idris_outputmode ist of+    RawOutput _ -> do+      success <- runInputT (proverSettings elabState) $+                   handleInterrupt (return False) $+                   withInterrupt (lift mTry >> return True)+      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@@ -283,7 +298,7 @@                do case h of                     Just history -> putHistory history                     Nothing -> return ()-                  l <- getInputLine (prompt ++ "> ")+                  l <- handleInterrupt (return $ Just "") $ withInterrupt $ getInputLine (prompt ++ "> ")                   h' <- getHistory                   return (l, Just h')            IdeMode _ handle ->@@ -375,8 +390,9 @@          Right ok ->            if done then do (tm, _) <- elabStep st get_term                            return (tm, prf')-                   else do ok-                           elabloop fn d prompt prf' st prev' h' env'+                   else runWithInterrupt e ok+                           (elabloop fn d prompt prf' st prev' h' env')+                           (elabloop fn d prompt prf e prev h' env)    where     -- A bit of a hack: wrap the value up in a let binding, which will@@ -401,7 +417,7 @@                  do case h of                       Just history -> putHistory history                       Nothing -> return ()-                    l <- getInputLine (prompt ++ "> ")+                    l <- handleInterrupt (return $ Just "") $ withInterrupt $ getInputLine (prompt ++ "> ")                     h' <- getHistory                     return (l, Just h')              IdeMode _ handle ->@@ -445,8 +461,9 @@            Right ok ->              if done then do (tm, _) <- elabStep st get_term                              return (tm, prf')-                     else do ok-                             ploop fn d prompt prf' st h'+                     else runWithInterrupt e ok+                             (ploop fn d prompt prf' st h')+                             (ploop fn d prompt prf e h')   envCtxt env ctxt = foldl (\c (n, b) -> addTyDecl n Bound (binderTy b) c) ctxt env
src/Idris/REPL.hs view
@@ -8,10 +8,10 @@ import Idris.AbsSyntax import Idris.ASTUtils import Idris.Apropos (apropos, aproposModules)-import Idris.REPLParser-import Idris.ElabDecls+import Idris.REPL.Parser import Idris.Erasure import Idris.Error+import Idris.IBC import Idris.ErrReverse import Idris.Delaborate import Idris.Docstrings (Docstring, overview, renderDocstring, renderDocTerm)@@ -38,6 +38,7 @@  import Idris.REPL.Browse (namesInNS, namespacesInNS) +import Idris.ElabDecls import Idris.Elab.Type import Idris.Elab.Clause import Idris.Elab.Data@@ -121,13 +122,13 @@                              (if colour && not isWindows                                 then colourisePrompt theme str                                 else str) ++ " "-        x <- H.catch (getInputLine prompt)-                     (ctrlC (return Nothing))+        x <- H.catch (H.withInterrupt $ getInputLine prompt)+                     (ctrlC (return $ Just ""))         case x of             Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")                           return ()             Just input -> -- H.catch-                do ms <- H.catch (lift $ processInput input orig mods efile)+                do ms <- H.catch (H.withInterrupt $ lift $ processInput input orig mods efile)                                  (ctrlC (return (Just mods)))                    case ms of                         Just mods -> let efile' = fromMaybe efile (listToMaybe mods)@@ -690,9 +691,9 @@  watch :: IState -> [FilePath] -> Idris (Maybe [FilePath]) watch orig inputs = do-  let inputSet = S.fromList inputs-  let dirs = nub $ map takeDirectory inputs   resp <- runIO $ do+    let dirs = nub $ map takeDirectory inputs+    inputSet <- fmap S.fromList $ mapM canonicalizePath inputs     signal <- newEmptyMVar     withManager $ \mgr -> do       forM_ dirs $ \dir ->@@ -735,7 +736,7 @@                    return (Just mod)             Success (Right (ModImport f)) ->                 do clearErr-                   fmod <- loadModule f+                   fmod <- loadModule f (IBC_REPL True)                    return (Just (inputs ++ maybe [] (:[]) fmod))             Success (Right Edit) -> do -- takeMVar stvar                                edit efile orig@@ -817,7 +818,7 @@ process fn (ChangeDirectory f)                  = do runIO $ setCurrentDirectory f                       return ()-process fn (ModImport f) = do fmod <- loadModule f+process fn (ModImport f) = do fmod <- loadModule f (IBC_REPL True)                               case fmod of                                 Just pr -> isetPrompt pr                                 Nothing -> iPrintError $ "Can't find import " ++ f@@ -901,8 +902,8 @@   fixClauses :: PDecl' t -> PDecl' t   fixClauses (PClauses fc opts _ css@(clause:cs)) =     PClauses fc opts (getClauseName clause) css-  fixClauses (PInstance doc argDocs syn fc constraints cls nfc parms ty instName decls) =-    PInstance doc argDocs syn fc constraints cls nfc parms ty instName (map fixClauses decls)+  fixClauses (PInstance doc argDocs syn fc constraints acc opts cls nfc parms ty instName decls) =+    PInstance doc argDocs syn fc constraints acc opts cls nfc parms ty instName (map fixClauses decls)   fixClauses decl = decl  process fn (Undefine names) = undefine names@@ -958,8 +959,8 @@         case lookupNames n ctxt of           ts@(t:_) ->             case lookup t (idris_metavars ist) of-                Just (_, i, _, _) -> iRenderResult . fmap (fancifyAnnots ist True) $-                                     showMetavarInfo ppo ist n i+                Just (_, i, _, _, _) -> iRenderResult . fmap (fancifyAnnots ist True) $+                                        showMetavarInfo ppo ist n i                 Nothing -> iPrintFunTypes [] n (map (\n -> (n, pprintDelabTy ist n)) ts)           [] -> iPrintError $ "No such variable " ++ show n   where@@ -1089,7 +1090,7 @@         when (not (null di)) $ iputStrLn (show di)         let imps = lookupCtxt n (idris_implicits i)         when (not (null imps)) $ iputStrLn (show imps)-        let d = lookupDef n (tt_ctxt i)+        let d = lookupDefAcc n False (tt_ctxt i)         when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))         let cg = lookupCtxtName n (idris_callgraph i)         i <- getIState@@ -1138,7 +1139,7 @@                             insertMetavar n =                               do i <- getIState                                  let ms = idris_metavars i-                                 putIState $ i { idris_metavars = (n, (Nothing, 0, [], False)) : ms }+                                 putIState $ i { idris_metavars = (n, (Nothing, 0, [], False, False)) : ms }  process fn' (AddProof prf)   = do fn <- do@@ -1191,8 +1192,9 @@           let metavars = mapMaybe (\n -> do c <- lookup n (idris_metavars ist); return (n, c)) ns           n <- case metavars of               [] -> ierror (Msg $ "Cannot find metavariable " ++ show n')-              [(n, (_,_,_,False))] -> return n-              [(_, (_,_,_,True))]  -> ierror (Msg $ "Declarations not solvable using prover")+              [(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")               ns -> ierror (CantResolveAlts (map fst ns))           prover mode (lit fn) n           -- recheck totality@@ -1238,12 +1240,15 @@           iPrintError $ "Invalid filename for compiler output \"" ++ f ++"\""       | otherwise = do opts <- getCmdLine                        let iface = Interface `elem` opts+                       let mainname = sNS (sUN "main") ["Main"]+                        m <- if iface then return Nothing else                             do (m', _) <- elabVal recinfo ERHS                                             (PApp fc (PRef fc [] (sUN "run__IO"))-                                            [pexp $ PRef fc [] (sNS (sUN "main") ["Main"])])+                                            [pexp $ PRef fc [] mainname])                                return (Just m')                        ir <- compile codegen f m+                        i <- getIState                        runIO $ generate codegen (fst (head (idris_imported i))) ir   where fc = fileFC "main"@@ -1559,7 +1564,7 @@                    logParser 1 ("MODULE TREE : " ++ show modTree)                    logParser 1 ("RELOAD: " ++ show ifiles)                    when (not (all ibc ifiles) || loadCode) $-                        tryLoad False (filter (not . ibc) ifiles)+                        tryLoad False IBC_Building (filter (not . ibc) ifiles)                    -- return the files that need rechecking                    return (input, ifiles))                       ninputs@@ -1570,7 +1575,8 @@               Nothing ->                 do putIState $!! ist { idris_tyinfodata = tidata }                    ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles)))-                   tryLoad True (mapMaybe id ibcfiles)+--                    logLvl 0 $ "Loading from " ++ show ibcfiles+                   tryLoad True (IBC_REPL True) (mapMaybe id ibcfiles)               _ -> return ()            exports <- findExports @@ -1590,9 +1596,9 @@                             iWarn emptyFC $ pprintErr i e                   return [])    where -- load all files, stop if any fail-         tryLoad :: Bool -> [IFileType] -> Idris ()-         tryLoad keepstate [] = warnTotality >> return ()-         tryLoad keepstate (f : fs)+         tryLoad :: Bool -> IBCPhase -> [IFileType] -> Idris ()+         tryLoad keepstate phase [] = warnTotality >> return ()+         tryLoad keepstate phase (f : fs)                  = do ist <- getIState                       let maxline                             = case toline of@@ -1605,7 +1611,7 @@                                                           then Just l                                                           else Nothing                                             _ -> Nothing-                      loadFromIFile True f maxline+                      loadFromIFile True phase f maxline                       inew <- getIState                       -- FIXME: Save these in IBC to avoid this hack! Need to                       -- preserve it all from source inputs@@ -1615,15 +1621,16 @@                       let tidata = idris_tyinfodata inew                       let patdefs = idris_patdefs inew                       ok <- noErrors-                      when ok $-                        -- The $!! here prevents a space leak on reloading.-                        -- This isn't a solution - but it's a temporary stopgap.-                        -- See issue #2386-                        do when (not keepstate) $ putIState $!! ist-                           ist <- getIState-                           putIState $!! ist { idris_tyinfodata = tidata,-                                               idris_patdefs = patdefs }-                           tryLoad keepstate fs+                      if ok then+                            -- The $!! here prevents a space leak on reloading.+                            -- This isn't a solution - but it's a temporary stopgap.+                            -- See issue #2386+                            do when (not keepstate) $ putIState $!! ist+                               ist <- getIState+                               putIState $!! ist { idris_tyinfodata = tidata,+                                                   idris_patdefs = patdefs }+                               tryLoad keepstate phase fs+                          else warnTotality           ibc (IBC _ _) = True          ibc _ = False@@ -1727,13 +1734,12 @@            addPkgDir "base"        mapM_ addPkgDir pkgdirs        elabPrims-       when (not (NoBuiltins `elem` opts)) $ do x <- loadModule "Builtins"+       when (not (NoBuiltins `elem` opts)) $ do x <- loadModule "Builtins" (IBC_REPL True)                                                 addAutoImport "Builtins"                                                 return ()-       when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude"+       when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude" (IBC_REPL True)                                                addAutoImport "Prelude"                                                return ()-        when (runrepl && not idesl) initScript         nobanner <- getNoBanner@@ -1794,7 +1800,7 @@        when (runrepl && not idesl) $ do --          clearOrigPats          startServer port orig mods-         runInputT (replSettings (Just historyFile)) $ repl orig mods efile+         runInputT (replSettings (Just historyFile)) $ repl (force orig) mods efile        let idesock = IdemodeSocket `elem` opts        when (idesl) $ idemodeStart idesock orig inputs        ok <- noErrors
src/Idris/REPL/Browse.hs view
@@ -8,7 +8,7 @@ import Data.Maybe (mapMaybe) import qualified Data.Text as T (unpack) -import Idris.Core.Evaluate (ctxtAlist, Accessibility(Hidden), lookupDefAccExact)+import Idris.Core.Evaluate (ctxtAlist, Accessibility(Private, Hidden), lookupDefAccExact) import Idris.Core.TT (Name(..))  import Idris.AbsSyntaxTree (Idris)@@ -41,4 +41,5 @@         accessible n = do ctxt <- getContext                           case lookupDefAccExact n False ctxt of                             Just (_, Hidden ) -> return False+                            Just (_, Private ) -> return False                             _ -> return True
+ src/Idris/REPL/Parser.hs view
@@ -0,0 +1,526 @@++module Idris.REPL.Parser (parseCmd, help, allHelp, setOptions) where++import System.FilePath ((</>))+import System.Console.ANSI (Color(..))++import Idris.Colours+import Idris.AbsSyntax+import Idris.Core.TT+import Idris.Help+import qualified Idris.Parser as P++import Control.Applicative+import Control.Monad.State.Strict++import Text.Parser.Combinators+import Text.Parser.Char(anyChar,oneOf)+import Text.Trifecta(Result, parseString)+import Text.Trifecta.Delta++import Debug.Trace+import Data.List+import Data.List.Split(splitOn)+import Data.Char(isSpace, toLower)+import qualified Data.ByteString.UTF8 as UTF8++parseCmd :: IState -> String -> String -> Result (Either String Command)+parseCmd i inputname = P.runparser pCmd i inputname . trim+    where trim = f . f+              where f = reverse . dropWhile isSpace++type CommandTable = [ ( [String], CmdArg, String+                    , String -> P.IdrisParser (Either String Command) ) ]++setOptions :: [(String, Opt)]+setOptions = [("errorcontext", ErrContext),+              ("showimplicits", ShowImpl),+              ("originalerrors", ShowOrigErr),+              ("autosolve", AutoSolve),+              ("nobanner", NoBanner),+              ("warnreach", WarnReach),+              ("evaltypes", EvalTypes),+              ("desugarnats", DesugarNats)]++help :: [([String], CmdArg, String)]+help = (["<expr>"], NoArg, "Evaluate an expression") :+  [ (map (':' :) names, args, text) | (names, args, text, _) <- parserCommandsForHelp ]++allHelp :: [([String], CmdArg, String)]+allHelp = [ (map (':' :) names, args, text)+          | (names, args, text, _) <- parserCommandsForHelp ++ parserCommands ]++parserCommandsForHelp :: CommandTable+parserCommandsForHelp =+  [ exprArgCmd ["t", "type"] Check "Check the type of an expression"+  , exprArgCmd ["core"] Core "View the core language representation of a term"+  , nameArgCmd ["miss", "missing"] Missing "Show missing clauses"+  , (["doc"], NameArg, "Show internal documentation", cmd_doc)+  , (["mkdoc"], NamespaceArg, "Generate IdrisDoc for namespace(s) and dependencies"+    , genArg "namespace" (many anyChar) MakeDoc)+  , (["apropos"], SeqArgs (OptionalArg PkgArgs) NameArg, " Search names, types, and documentation"+    , cmd_apropos)+  , (["s", "search"], SeqArgs (OptionalArg PkgArgs) ExprArg+    , " Search for values by type", cmd_search)+  , nameArgCmd ["wc", "whocalls"] WhoCalls "List the callers of some name"+  , nameArgCmd ["cw", "callswho"] CallsWho "List the callees of some name"+  , namespaceArgCmd ["browse"] Browse "List the contents of some namespace"+  , nameArgCmd ["total"] TotCheck "Check the totality of a name"+  , noArgCmd ["r", "reload"] Reload "Reload current file"+  , noArgCmd ["w", "watch"] Watch "Watch the current file for changes"+  , (["l", "load"], FileArg, "Load a new file"+    , strArg (\f -> Load f Nothing))+  , (["cd"], FileArg, "Change working directory"+    , strArg ChangeDirectory)+  , (["module"], ModuleArg, "Import an extra module", moduleArg ModImport) -- NOTE: dragons+  , noArgCmd ["e", "edit"] Edit "Edit current file using $EDITOR or $VISUAL"+  , noArgCmd ["m", "metavars"] Metavars "Show remaining proof obligations (metavariables or holes)"+  , (["p", "prove"], MetaVarArg, "Prove a metavariable"+    , nameArg (Prove False))+  , (["elab"], MetaVarArg, "Build a metavariable using the elaboration shell"+    , nameArg (Prove True))+  , (["a", "addproof"], NameArg, "Add proof to source file", cmd_addproof)+  , (["rmproof"], NameArg, "Remove proof from proof stack"+    , nameArg RmProof)+  , (["showproof"], NameArg, "Show proof"+    , nameArg ShowProof)+  , noArgCmd ["proofs"] Proofs "Show available proofs"+  , exprArgCmd ["x"] ExecVal "Execute IO actions resulting from an expression using the interpreter"+  , (["c", "compile"], FileArg, "Compile to an executable [codegen] <filename>", cmd_compile)+  , (["exec", "execute"], OptionalArg ExprArg, "Compile to an executable and run", cmd_execute)+  , (["dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)", cmd_dynamic)+  , (["dynamic"], NoArg, "List dynamically loaded C libraries", cmd_dynamic)+  , noArgCmd ["?", "h", "help"] Help "Display this help text"+  , optArgCmd ["set"] SetOpt $ "Set an option (" ++ optionsList ++ ")"+  , optArgCmd ["unset"] UnsetOpt "Unset an option"+  , (["color", "colour"], ColourArg+    , "Turn REPL colours on or off; set a specific colour"+    , cmd_colour)+  , (["consolewidth"], ConsoleWidthArg, "Set the width of the console", cmd_consolewidth)+  , (["printerdepth"], OptionalArg NumberArg, "Set the maximum pretty-printer depth (no arg for infinite)", cmd_printdepth)+  , noArgCmd ["q", "quit"] Quit "Exit the Idris system"+  , noArgCmd ["warranty"] Warranty "Displays warranty information"+  , (["let"], ManyArgs DeclArg+    , "Evaluate a declaration, such as a function definition, instance implementation, or fixity declaration"+    , cmd_let)+  , (["unlet", "undefine"], ManyArgs NameArg+    , "Remove the listed repl definitions, or all repl definitions if no names given"+    , cmd_unlet)+  , nameArgCmd ["printdef"] PrintDef "Show the definition of a function"+  , (["pp", "pprint"], (SeqArgs OptionArg (SeqArgs NumberArg NameArg))+    , "Pretty prints an Idris function in either LaTeX or HTML and for a specified width."+    , cmd_pprint)+  ]+  where optionsList = intercalate ", " $ map fst setOptions++parserCommands =+  [ noArgCmd ["u", "universes"] Universes "Display universe constraints"+  , noArgCmd ["errorhandlers"] ListErrorHandlers "List registered error handlers"++  , nameArgCmd ["d", "def"] Defn "Display a name's internal definitions"+  , nameArgCmd ["transinfo"] TransformInfo "Show relevant transformation rules for a name"+  , nameArgCmd ["di", "dbginfo"] DebugInfo "Show debugging information for a name"++  , exprArgCmd ["patt"] Pattelab "(Debugging) Elaborate pattern expression"+  , exprArgCmd ["spec"] Spec "?"+  , exprArgCmd ["whnf"] WHNF "(Debugging) Show weak head normal form of an expression"+  , exprArgCmd ["inline"] TestInline "?"+  , proofArgCmd ["cs", "casesplit"] CaseSplitAt+      ":cs <line> <name> splits the pattern variable on the line"+  , proofArgCmd ["apc", "addproofclause"] AddProofClauseFrom+      ":apc <line> <name> adds a pattern-matching proof clause to name on line"+  , proofArgCmd ["ac", "addclause"] AddClauseFrom+      ":ac <line> <name> adds a clause for the definition of the name on the line"+  , proofArgCmd ["am", "addmissing"] AddMissing+      ":am <line> <name> adds all missing pattern matches for the name on the line"+  , proofArgCmd ["mw", "makewith"] MakeWith+      ":mw <line> <name> adds a with clause for the definition of the name on the line"+  , proofArgCmd ["mc", "makecase"] MakeCase+      ":mc <line> <name> adds a case block for the definition of the metavariable on the line"+  , proofArgCmd ["ml", "makelemma"] MakeLemma "?"+  , (["log"], NumberArg, "Set logging verbosity level", cmd_log)+  , ( ["logcats"]+    , ManyArgs NameArg+    , "Set logging categories"+    , cmd_cats)+  , (["lto", "loadto"], SeqArgs NumberArg FileArg+    , "Load file up to line number", cmd_loadto)+  , (["ps", "proofsearch"], NoArg+    , ":ps <line> <name> <names> does proof search for name on line, with names as hints"+    , cmd_proofsearch)+  , (["ref", "refine"], NoArg+    , ":ref <line> <name> <name'> attempts to partially solve name on line, with name' as hint, introducing metavariables for arguments that aren't inferrable"+    , cmd_refine)+  , (["debugunify"], SeqArgs ExprArg ExprArg+    , "(Debugging) Try to unify two expressions", const $ do+       l <- P.simpleExpr defaultSyntax+       r <- P.simpleExpr defaultSyntax+       eof+       return (Right (DebugUnify l r))+    )+  ]++noArgCmd names command doc =+  (names, NoArg, doc, noArgs command)+nameArgCmd names command doc =+  (names, NameArg, doc, fnNameArg command)+namespaceArgCmd names command doc =+  (names, NamespaceArg, doc, namespaceArg command)+exprArgCmd names command doc =+  (names, ExprArg, doc, exprArg command)+metavarArgCmd names command doc =+  (names, MetaVarArg, doc, fnNameArg command)+optArgCmd names command doc =+  (names, OptionArg, doc, optArg command)+proofArgCmd names command doc =+  (names, NoArg, doc, proofArg command)++pCmd :: P.IdrisParser (Either String Command)+pCmd = choice [ do c <- cmd names; parser c+              | (names, _, _, parser) <- parserCommandsForHelp ++ parserCommands ]+     <|> unrecognized+     <|> nop+     <|> eval+    where nop = do eof; return (Right NOP)+          unrecognized = do+              P.lchar ':'+              cmd <- many anyChar+              let cmd' = takeWhile (/=' ') cmd+              return (Left $ "Unrecognized command: " ++ cmd')++cmd :: [String] -> P.IdrisParser String+cmd xs = try $ do+    P.lchar ':'+    docmd sorted_xs++    where docmd [] = fail "Could not parse command"+          docmd (x:xs) = try (P.reserved x >> return x) <|> docmd xs++          sorted_xs = sortBy (\x y -> compare (length y) (length x)) xs+++noArgs :: Command -> String -> P.IdrisParser (Either String Command)+noArgs cmd name = do+    let emptyArgs = do+        eof+        return (Right cmd)++    let failure = return (Left $ ":" ++ name ++ " takes no arguments")++    emptyArgs <|> failure++eval :: P.IdrisParser (Either String Command)+eval = do+  t <- P.fullExpr defaultSyntax+  return $ Right (Eval t)++exprArg :: (PTerm -> Command) -> String -> P.IdrisParser (Either String Command)+exprArg cmd name = do+    let noArg = do+        eof+        return $ Left ("Usage is :" ++ name ++ " <expression>")++    let justOperator = do+        (op, fc) <- P.operatorFC+        eof+        return $ Right $ cmd (PRef fc [] (sUN op))++    let properArg = do+        t <- P.fullExpr defaultSyntax+        return $ Right (cmd t)+    try noArg <|> try justOperator <|> properArg++++genArg :: String -> P.IdrisParser a -> (a -> Command)+           -> String -> P.IdrisParser (Either String Command)+genArg argName argParser cmd name = do+    let emptyArgs = do eof; failure+        oneArg = do arg <- argParser+                    eof+                    return (Right (cmd arg))+    try emptyArgs <|> oneArg <|> failure+    where+    failure = return $ Left ("Usage is :" ++ name ++ " <" ++ argName ++ ">")++nameArg, fnNameArg :: (Name -> Command) -> String -> P.IdrisParser (Either String Command)+nameArg = genArg "name" $ fst <$> P.name+fnNameArg = genArg "functionname" $ fst <$> P.fnName++strArg :: (String -> Command) -> String -> P.IdrisParser (Either String Command)+strArg = genArg "string" (many anyChar)++moduleArg :: (FilePath -> Command) -> String -> P.IdrisParser (Either String Command)+moduleArg = genArg "module" (fmap (toPath . fst) P.identifier)+  where+    toPath n = foldl1' (</>) $ splitOn "." n++namespaceArg :: ([String] -> Command) -> String -> P.IdrisParser (Either String Command)+namespaceArg = genArg "namespace" (fmap (toNS . fst) P.identifier)+  where+    toNS  = splitOn "."++optArg :: (Opt -> Command) -> String -> P.IdrisParser (Either String Command)+optArg cmd name = do+    let emptyArgs = do+            eof+            return $ Left ("Usage is :" ++ name ++ " <option>")++    let oneArg = do+        o <- pOption+        P.whiteSpace+        eof+        return (Right (cmd o))++    let failure = return $ Left "Unrecognized setting"++    try emptyArgs <|> oneArg <|> failure++    where+        pOption :: P.IdrisParser Opt+        pOption = foldl (<|>) empty $ map (\(a, b) -> do discard (P.symbol a); return b) setOptions++proofArg :: (Bool -> Int -> Name -> Command) -> String -> P.IdrisParser (Either String Command)+proofArg cmd name = do+    upd <- option False $ do+        P.lchar '!'+        return True+    l <- fst <$> P.natural+    n <- fst <$> P.name;+    return (Right (cmd upd (fromInteger l) n))++cmd_doc :: String -> P.IdrisParser (Either String Command)+cmd_doc name = do+    let constant = do+        c <- fmap fst P.constant+        eof+        return $ Right (DocStr (Right c) FullDocs)++    let pType = do+        P.reserved "Type"+        eof+        return $ Right (DocStr (Left $ P.mkName ("Type", "")) FullDocs)++    let fnName = fnNameArg (\n -> DocStr (Left n) FullDocs) name++    try constant <|> pType <|> fnName++cmd_consolewidth :: String -> P.IdrisParser (Either String Command)+cmd_consolewidth name = do+    w <- pConsoleWidth+    return (Right (SetConsoleWidth w))++    where+        pConsoleWidth :: P.IdrisParser ConsoleWidth+        pConsoleWidth = do discard (P.symbol "auto"); return AutomaticWidth+                    <|> do discard (P.symbol "infinite"); return InfinitelyWide+                    <|> do n <- fmap (fromInteger . fst) P.natural+                           return (ColsWide n)++cmd_printdepth :: String -> P.IdrisParser (Either String Command)+cmd_printdepth _ = do d <- optional (fmap (fromInteger . fst) P.natural)+                      return (Right $ SetPrinterDepth d)++cmd_execute :: String -> P.IdrisParser (Either String Command)+cmd_execute name = do+    tm <- option maintm (P.fullExpr defaultSyntax)+    return (Right (Execute tm))+  where+    maintm = PRef (fileFC "(repl)") [] (sNS (sUN "main") ["Main"])+++cmd_dynamic :: String -> P.IdrisParser (Either String Command)+cmd_dynamic name = do+    let optArg = do l <- many anyChar+                    if (l /= "")+                        then return $ Right (DynamicLink l)+                        else return $ Right ListDynamic++    let failure = return $ Left $ "Usage is :" ++ name ++ " [<library>]"++    try optArg <|> failure++cmd_pprint :: String -> P.IdrisParser (Either String Command)+cmd_pprint name = do+     fmt <- ppFormat+     P.whiteSpace+     n <- fmap (fromInteger . fst) P.natural+     P.whiteSpace+     t <- P.fullExpr defaultSyntax+     return (Right (PPrint fmt n t))++    where+        ppFormat :: P.IdrisParser OutputFmt+        ppFormat = (discard (P.symbol "html") >> return HTMLOutput)+               <|> (discard (P.symbol "latex") >> return LaTeXOutput)++++cmd_compile :: String -> P.IdrisParser (Either String Command)+cmd_compile name = do+    let defaultCodegen = Via "c"++    let codegenOption :: P.IdrisParser Codegen+        codegenOption = do+            let bytecodeCodegen = discard (P.symbol "bytecode") *> return Bytecode+                viaCodegen = do x <- fst <$> P.identifier+                                return (Via (map toLower x))+            bytecodeCodegen <|> viaCodegen++    let hasOneArg = do+        i <- get+        f <- fst <$> P.identifier+        eof+        return $ Right (Compile defaultCodegen f)++    let hasTwoArgs = do+        i <- get+        codegen <- codegenOption+        f <- fst <$> P.identifier+        eof+        return $ Right (Compile codegen f)++    let failure = return $ Left $ "Usage is :" ++ name ++ " [<codegen>] <filename>"+    try hasTwoArgs <|> try hasOneArg <|> failure++cmd_addproof :: String -> P.IdrisParser (Either String Command)+cmd_addproof name = do+    n <- option Nothing $ do+        x <- fst <$> P.name+        return (Just x)+    eof+    return (Right (AddProof n))++cmd_log :: String -> P.IdrisParser (Either String Command)+cmd_log name = do+    i <- fmap (fromIntegral . fst) P.natural+    eof+    return (Right (LogLvl i))++cmd_cats :: String -> P.IdrisParser (Either String Command)+cmd_cats name = do+    cs <- sepBy pLogCats (P.whiteSpace)+    eof+    return $ Right $ LogCategory (concat cs)+  where+    badCat = do+      c <- fst <$> P.identifier+      fail $ "Category: " ++ c ++ " is not recognised."++    pLogCats :: P.IdrisParser [LogCat]+    pLogCats = try (P.symbol (strLogCat IParse)    >> return parserCats)+           <|> try (P.symbol (strLogCat IElab)     >> return elabCats)+           <|> try (P.symbol (strLogCat ICodeGen)  >> return codegenCats)+           <|> try (P.symbol (strLogCat ICoverage) >> return [ICoverage])+           <|> try (P.symbol (strLogCat IIBC)      >> return [IIBC])+           <|> try (P.symbol (strLogCat IErasure)  >> return [IErasure])+           <|> badCat++cmd_let :: String -> P.IdrisParser (Either String Command)+cmd_let name = do+    defn <- concat <$> many (P.decl defaultSyntax)+    return (Right (NewDefn defn))++cmd_unlet :: String -> P.IdrisParser (Either String Command)+cmd_unlet name = (Right . Undefine) `fmap` many (fst <$> P.name)++cmd_loadto :: String -> P.IdrisParser (Either String Command)+cmd_loadto name = do+    toline <- fmap (fromInteger . fst) P.natural+    f <- many anyChar;+    return (Right (Load f (Just toline)))++cmd_colour :: String -> P.IdrisParser (Either String Command)+cmd_colour name = fmap Right pSetColourCmd++    where+        colours :: [(String, Maybe Color)]+        colours = [ ("black", Just Black)+                  , ("red", Just Red)+                  , ("green", Just Green)+                  , ("yellow", Just Yellow)+                  , ("blue", Just Blue)+                  , ("magenta", Just Magenta)+                  , ("cyan", Just Cyan)+                  , ("white", Just White)+                  , ("default", Nothing)+                  ]++        pSetColourCmd :: P.IdrisParser Command+        pSetColourCmd = (do c <- pColourType+                            let defaultColour = IdrisColour Nothing True False False False+                            opts <- sepBy pColourMod (P.whiteSpace)+                            let colour = foldr ($) defaultColour $ reverse opts+                            return $ SetColour c colour)+                    <|> try (P.symbol "on" >> return ColourOn)+                    <|> try (P.symbol "off" >> return ColourOff)++        pColour :: P.IdrisParser (Maybe Color)+        pColour = doColour colours+            where doColour [] = fail "Unknown colour"+                  doColour ((s, c):cs) = (try (P.symbol s) >> return c) <|> doColour cs++        pColourMod :: P.IdrisParser (IdrisColour -> IdrisColour)+        pColourMod = try (P.symbol "vivid" >> return doVivid)+                 <|> try (P.symbol "dull" >> return doDull)+                 <|> try (P.symbol "underline" >> return doUnderline)+                 <|> try (P.symbol "nounderline" >> return doNoUnderline)+                 <|> try (P.symbol "bold" >> return doBold)+                 <|> try (P.symbol "nobold" >> return doNoBold)+                 <|> try (P.symbol "italic" >> return doItalic)+                 <|> try (P.symbol "noitalic" >> return doNoItalic)+                 <|> try (pColour >>= return . doSetColour)+            where doVivid i       = i { vivid = True }+                  doDull i        = i { vivid = False }+                  doUnderline i   = i { underline = True }+                  doNoUnderline i = i { underline = False }+                  doBold i        = i { bold = True }+                  doNoBold i      = i { bold = False }+                  doItalic i      = i { italic = True }+                  doNoItalic i    = i { italic = False }+                  doSetColour c i = i { colour = c }++        -- | Generate the colour type names using the default Show instance.+        colourTypes :: [(String, ColourType)]+        colourTypes = map (\x -> ((map toLower . reverse . drop 6 . reverse . show) x, x)) $+                      enumFromTo minBound maxBound++        pColourType :: P.IdrisParser ColourType+        pColourType = doColourType colourTypes+            where doColourType [] = fail $ "Unknown colour category. Options: " +++                                           (concat . intersperse ", " . map fst) colourTypes+                  doColourType ((s,ct):cts) = (try (P.symbol s) >> return ct) <|> doColourType cts++idChar = oneOf (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_'])++cmd_apropos :: String -> P.IdrisParser (Either String Command)+cmd_apropos = packageBasedCmd (some idChar) Apropos++packageBasedCmd :: P.IdrisParser a -> ([String] -> a -> Command)+                -> String -> P.IdrisParser (Either String Command)+packageBasedCmd valParser cmd name =+  try (do P.lchar '('+          pkgs <- sepBy (some idChar) (P.lchar ',')+          P.lchar ')'+          val <- valParser+          return (Right (cmd pkgs val)))+   <|> do val <- valParser+          return (Right (cmd [] val))++cmd_search :: String -> P.IdrisParser (Either String Command)+cmd_search = packageBasedCmd+  (P.typeExpr (defaultSyntax { implicitAllowed = True })) Search++cmd_proofsearch :: String -> P.IdrisParser (Either String Command)+cmd_proofsearch name = do+    upd <- option False (do P.lchar '!'; return True)+    l <- fmap (fromInteger . fst) P.natural; n <- fst <$> P.name+    hints <- many (fst <$> P.fnName)+    return (Right (DoProofSearch upd True l n hints))++cmd_refine :: String -> P.IdrisParser (Either String Command)+cmd_refine name = do+   upd <- option False (do P.lchar '!'; return True)+   l <- fmap (fromInteger . fst) P.natural; n <- fst <$> P.name+   hint <- fst <$> P.fnName+   return (Right (DoProofSearch upd False l n [hint]))
− src/Idris/REPLParser.hs 
@@ -1,526 +0,0 @@--module Idris.REPLParser (parseCmd, help, allHelp, setOptions) where--import System.FilePath ((</>))-import System.Console.ANSI (Color(..))--import Idris.Colours-import Idris.AbsSyntax-import Idris.Core.TT-import Idris.Help-import qualified Idris.Parser as P--import Control.Applicative-import Control.Monad.State.Strict--import Text.Parser.Combinators-import Text.Parser.Char(anyChar,oneOf)-import Text.Trifecta(Result, parseString)-import Text.Trifecta.Delta--import Debug.Trace-import Data.List-import Data.List.Split(splitOn)-import Data.Char(isSpace, toLower)-import qualified Data.ByteString.UTF8 as UTF8--parseCmd :: IState -> String -> String -> Result (Either String Command)-parseCmd i inputname = P.runparser pCmd i inputname . trim-    where trim = f . f-              where f = reverse . dropWhile isSpace--type CommandTable = [ ( [String], CmdArg, String-                    , String -> P.IdrisParser (Either String Command) ) ]--setOptions :: [(String, Opt)]-setOptions = [("errorcontext", ErrContext),-              ("showimplicits", ShowImpl),-              ("originalerrors", ShowOrigErr),-              ("autosolve", AutoSolve),-              ("nobanner", NoBanner),-              ("warnreach", WarnReach),-              ("evaltypes", EvalTypes),-              ("desugarnats", DesugarNats)]--help :: [([String], CmdArg, String)]-help = (["<expr>"], NoArg, "Evaluate an expression") :-  [ (map (':' :) names, args, text) | (names, args, text, _) <- parserCommandsForHelp ]--allHelp :: [([String], CmdArg, String)]-allHelp = [ (map (':' :) names, args, text)-          | (names, args, text, _) <- parserCommandsForHelp ++ parserCommands ]--parserCommandsForHelp :: CommandTable-parserCommandsForHelp =-  [ exprArgCmd ["t", "type"] Check "Check the type of an expression"-  , exprArgCmd ["core"] Core "View the core language representation of a term"-  , nameArgCmd ["miss", "missing"] Missing "Show missing clauses"-  , (["doc"], NameArg, "Show internal documentation", cmd_doc)-  , (["mkdoc"], NamespaceArg, "Generate IdrisDoc for namespace(s) and dependencies"-    , genArg "namespace" (many anyChar) MakeDoc)-  , (["apropos"], SeqArgs (OptionalArg PkgArgs) NameArg, " Search names, types, and documentation"-    , cmd_apropos)-  , (["s", "search"], SeqArgs (OptionalArg PkgArgs) ExprArg-    , " Search for values by type", cmd_search)-  , nameArgCmd ["wc", "whocalls"] WhoCalls "List the callers of some name"-  , nameArgCmd ["cw", "callswho"] CallsWho "List the callees of some name"-  , namespaceArgCmd ["browse"] Browse "List the contents of some namespace"-  , nameArgCmd ["total"] TotCheck "Check the totality of a name"-  , noArgCmd ["r", "reload"] Reload "Reload current file"-  , noArgCmd ["w", "watch"] Watch "Watch the current file for changes"-  , (["l", "load"], FileArg, "Load a new file"-    , strArg (\f -> Load f Nothing))-  , (["cd"], FileArg, "Change working directory"-    , strArg ChangeDirectory)-  , (["module"], ModuleArg, "Import an extra module", moduleArg ModImport) -- NOTE: dragons-  , noArgCmd ["e", "edit"] Edit "Edit current file using $EDITOR or $VISUAL"-  , noArgCmd ["m", "metavars"] Metavars "Show remaining proof obligations (metavariables or holes)"-  , (["p", "prove"], MetaVarArg, "Prove a metavariable"-    , nameArg (Prove False))-  , (["elab"], MetaVarArg, "Build a metavariable using the elaboration shell"-    , nameArg (Prove True))-  , (["a", "addproof"], NameArg, "Add proof to source file", cmd_addproof)-  , (["rmproof"], NameArg, "Remove proof from proof stack"-    , nameArg RmProof)-  , (["showproof"], NameArg, "Show proof"-    , nameArg ShowProof)-  , noArgCmd ["proofs"] Proofs "Show available proofs"-  , exprArgCmd ["x"] ExecVal "Execute IO actions resulting from an expression using the interpreter"-  , (["c", "compile"], FileArg, "Compile to an executable [codegen] <filename>", cmd_compile)-  , (["exec", "execute"], OptionalArg ExprArg, "Compile to an executable and run", cmd_execute)-  , (["dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)", cmd_dynamic)-  , (["dynamic"], NoArg, "List dynamically loaded C libraries", cmd_dynamic)-  , noArgCmd ["?", "h", "help"] Help "Display this help text"-  , optArgCmd ["set"] SetOpt $ "Set an option (" ++ optionsList ++ ")"-  , optArgCmd ["unset"] UnsetOpt "Unset an option"-  , (["color", "colour"], ColourArg-    , "Turn REPL colours on or off; set a specific colour"-    , cmd_colour)-  , (["consolewidth"], ConsoleWidthArg, "Set the width of the console", cmd_consolewidth)-  , (["printerdepth"], OptionalArg NumberArg, "Set the maximum pretty-printer depth (no arg for infinite)", cmd_printdepth)-  , noArgCmd ["q", "quit"] Quit "Exit the Idris system"-  , noArgCmd ["warranty"] Warranty "Displays warranty information"-  , (["let"], ManyArgs DeclArg-    , "Evaluate a declaration, such as a function definition, instance implementation, or fixity declaration"-    , cmd_let)-  , (["unlet", "undefine"], ManyArgs NameArg-    , "Remove the listed repl definitions, or all repl definitions if no names given"-    , cmd_unlet)-  , nameArgCmd ["printdef"] PrintDef "Show the definition of a function"-  , (["pp", "pprint"], (SeqArgs OptionArg (SeqArgs NumberArg NameArg))-    , "Pretty prints an Idris function in either LaTeX or HTML and for a specified width."-    , cmd_pprint)-  ]-  where optionsList = intercalate ", " $ map fst setOptions--parserCommands =-  [ noArgCmd ["u", "universes"] Universes "Display universe constraints"-  , noArgCmd ["errorhandlers"] ListErrorHandlers "List registered error handlers"--  , nameArgCmd ["d", "def"] Defn "Display a name's internal definitions"-  , nameArgCmd ["transinfo"] TransformInfo "Show relevant transformation rules for a name"-  , nameArgCmd ["di", "dbginfo"] DebugInfo "Show debugging information for a name"--  , exprArgCmd ["patt"] Pattelab "(Debugging) Elaborate pattern expression"-  , exprArgCmd ["spec"] Spec "?"-  , exprArgCmd ["whnf"] WHNF "(Debugging) Show weak head normal form of an expression"-  , exprArgCmd ["inline"] TestInline "?"-  , proofArgCmd ["cs", "casesplit"] CaseSplitAt-      ":cs <line> <name> splits the pattern variable on the line"-  , proofArgCmd ["apc", "addproofclause"] AddProofClauseFrom-      ":apc <line> <name> adds a pattern-matching proof clause to name on line"-  , proofArgCmd ["ac", "addclause"] AddClauseFrom-      ":ac <line> <name> adds a clause for the definition of the name on the line"-  , proofArgCmd ["am", "addmissing"] AddMissing-      ":am <line> <name> adds all missing pattern matches for the name on the line"-  , proofArgCmd ["mw", "makewith"] MakeWith-      ":mw <line> <name> adds a with clause for the definition of the name on the line"-  , proofArgCmd ["mc", "makecase"] MakeCase-      ":mc <line> <name> adds a case block for the definition of the metavariable on the line"-  , proofArgCmd ["ml", "makelemma"] MakeLemma "?"-  , (["log"], NumberArg, "Set logging verbosity level", cmd_log)-  , ( ["logcats"]-    , ManyArgs NameArg-    , "Set logging categories"-    , cmd_cats)-  , (["lto", "loadto"], SeqArgs NumberArg FileArg-    , "Load file up to line number", cmd_loadto)-  , (["ps", "proofsearch"], NoArg-    , ":ps <line> <name> <names> does proof search for name on line, with names as hints"-    , cmd_proofsearch)-  , (["ref", "refine"], NoArg-    , ":ref <line> <name> <name'> attempts to partially solve name on line, with name' as hint, introducing metavariables for arguments that aren't inferrable"-    , cmd_refine)-  , (["debugunify"], SeqArgs ExprArg ExprArg-    , "(Debugging) Try to unify two expressions", const $ do-       l <- P.simpleExpr defaultSyntax-       r <- P.simpleExpr defaultSyntax-       eof-       return (Right (DebugUnify l r))-    )-  ]--noArgCmd names command doc =-  (names, NoArg, doc, noArgs command)-nameArgCmd names command doc =-  (names, NameArg, doc, fnNameArg command)-namespaceArgCmd names command doc =-  (names, NamespaceArg, doc, namespaceArg command)-exprArgCmd names command doc =-  (names, ExprArg, doc, exprArg command)-metavarArgCmd names command doc =-  (names, MetaVarArg, doc, fnNameArg command)-optArgCmd names command doc =-  (names, OptionArg, doc, optArg command)-proofArgCmd names command doc =-  (names, NoArg, doc, proofArg command)--pCmd :: P.IdrisParser (Either String Command)-pCmd = choice [ do c <- cmd names; parser c-              | (names, _, _, parser) <- parserCommandsForHelp ++ parserCommands ]-     <|> unrecognized-     <|> nop-     <|> eval-    where nop = do eof; return (Right NOP)-          unrecognized = do-              P.lchar ':'-              cmd <- many anyChar-              let cmd' = takeWhile (/=' ') cmd-              return (Left $ "Unrecognized command: " ++ cmd')--cmd :: [String] -> P.IdrisParser String-cmd xs = try $ do-    P.lchar ':'-    docmd sorted_xs--    where docmd [] = fail "Could not parse command"-          docmd (x:xs) = try (P.reserved x >> return x) <|> docmd xs--          sorted_xs = sortBy (\x y -> compare (length y) (length x)) xs---noArgs :: Command -> String -> P.IdrisParser (Either String Command)-noArgs cmd name = do-    let emptyArgs = do-        eof-        return (Right cmd)--    let failure = return (Left $ ":" ++ name ++ " takes no arguments")--    emptyArgs <|> failure--eval :: P.IdrisParser (Either String Command)-eval = do-  t <- P.fullExpr defaultSyntax-  return $ Right (Eval t)--exprArg :: (PTerm -> Command) -> String -> P.IdrisParser (Either String Command)-exprArg cmd name = do-    let noArg = do-        eof-        return $ Left ("Usage is :" ++ name ++ " <expression>")--    let justOperator = do-        (op, fc) <- P.operatorFC-        eof-        return $ Right $ cmd (PRef fc [] (sUN op))--    let properArg = do-        t <- P.fullExpr defaultSyntax-        return $ Right (cmd t)-    try noArg <|> try justOperator <|> properArg----genArg :: String -> P.IdrisParser a -> (a -> Command)-           -> String -> P.IdrisParser (Either String Command)-genArg argName argParser cmd name = do-    let emptyArgs = do eof; failure-        oneArg = do arg <- argParser-                    eof-                    return (Right (cmd arg))-    try emptyArgs <|> oneArg <|> failure-    where-    failure = return $ Left ("Usage is :" ++ name ++ " <" ++ argName ++ ">")--nameArg, fnNameArg :: (Name -> Command) -> String -> P.IdrisParser (Either String Command)-nameArg = genArg "name" $ fst <$> P.name-fnNameArg = genArg "functionname" $ fst <$> P.fnName--strArg :: (String -> Command) -> String -> P.IdrisParser (Either String Command)-strArg = genArg "string" (many anyChar)--moduleArg :: (FilePath -> Command) -> String -> P.IdrisParser (Either String Command)-moduleArg = genArg "module" (fmap (toPath . fst) P.identifier)-  where-    toPath n = foldl1' (</>) $ splitOn "." n--namespaceArg :: ([String] -> Command) -> String -> P.IdrisParser (Either String Command)-namespaceArg = genArg "namespace" (fmap (toNS . fst) P.identifier)-  where-    toNS  = splitOn "."--optArg :: (Opt -> Command) -> String -> P.IdrisParser (Either String Command)-optArg cmd name = do-    let emptyArgs = do-            eof-            return $ Left ("Usage is :" ++ name ++ " <option>")--    let oneArg = do-        o <- pOption-        P.whiteSpace-        eof-        return (Right (cmd o))--    let failure = return $ Left "Unrecognized setting"--    try emptyArgs <|> oneArg <|> failure--    where-        pOption :: P.IdrisParser Opt-        pOption = foldl (<|>) empty $ map (\(a, b) -> do discard (P.symbol a); return b) setOptions--proofArg :: (Bool -> Int -> Name -> Command) -> String -> P.IdrisParser (Either String Command)-proofArg cmd name = do-    upd <- option False $ do-        P.lchar '!'-        return True-    l <- fst <$> P.natural-    n <- fst <$> P.name;-    return (Right (cmd upd (fromInteger l) n))--cmd_doc :: String -> P.IdrisParser (Either String Command)-cmd_doc name = do-    let constant = do-        c <- fmap fst P.constant-        eof-        return $ Right (DocStr (Right c) FullDocs)--    let pType = do-        P.reserved "Type"-        eof-        return $ Right (DocStr (Left $ P.mkName ("Type", "")) FullDocs)--    let fnName = fnNameArg (\n -> DocStr (Left n) FullDocs) name--    try constant <|> pType <|> fnName--cmd_consolewidth :: String -> P.IdrisParser (Either String Command)-cmd_consolewidth name = do-    w <- pConsoleWidth-    return (Right (SetConsoleWidth w))--    where-        pConsoleWidth :: P.IdrisParser ConsoleWidth-        pConsoleWidth = do discard (P.symbol "auto"); return AutomaticWidth-                    <|> do discard (P.symbol "infinite"); return InfinitelyWide-                    <|> do n <- fmap (fromInteger . fst) P.natural-                           return (ColsWide n)--cmd_printdepth :: String -> P.IdrisParser (Either String Command)-cmd_printdepth _ = do d <- optional (fmap (fromInteger . fst) P.natural)-                      return (Right $ SetPrinterDepth d)--cmd_execute :: String -> P.IdrisParser (Either String Command)-cmd_execute name = do-    tm <- option maintm (P.fullExpr defaultSyntax)-    return (Right (Execute tm))-  where-    maintm = PRef (fileFC "(repl)") [] (sNS (sUN "main") ["Main"])---cmd_dynamic :: String -> P.IdrisParser (Either String Command)-cmd_dynamic name = do-    let optArg = do l <- many anyChar-                    if (l /= "")-                        then return $ Right (DynamicLink l)-                        else return $ Right ListDynamic--    let failure = return $ Left $ "Usage is :" ++ name ++ " [<library>]"--    try optArg <|> failure--cmd_pprint :: String -> P.IdrisParser (Either String Command)-cmd_pprint name = do-     fmt <- ppFormat-     P.whiteSpace-     n <- fmap (fromInteger . fst) P.natural-     P.whiteSpace-     t <- P.fullExpr defaultSyntax-     return (Right (PPrint fmt n t))--    where-        ppFormat :: P.IdrisParser OutputFmt-        ppFormat = (discard (P.symbol "html") >> return HTMLOutput)-               <|> (discard (P.symbol "latex") >> return LaTeXOutput)----cmd_compile :: String -> P.IdrisParser (Either String Command)-cmd_compile name = do-    let defaultCodegen = Via "c"--    let codegenOption :: P.IdrisParser Codegen-        codegenOption = do-            let bytecodeCodegen = discard (P.symbol "bytecode") *> return Bytecode-                viaCodegen = do x <- fst <$> P.identifier-                                return (Via (map toLower x))-            bytecodeCodegen <|> viaCodegen--    let hasOneArg = do-        i <- get-        f <- fst <$> P.identifier-        eof-        return $ Right (Compile defaultCodegen f)--    let hasTwoArgs = do-        i <- get-        codegen <- codegenOption-        f <- fst <$> P.identifier-        eof-        return $ Right (Compile codegen f)--    let failure = return $ Left $ "Usage is :" ++ name ++ " [<codegen>] <filename>"-    try hasTwoArgs <|> try hasOneArg <|> failure--cmd_addproof :: String -> P.IdrisParser (Either String Command)-cmd_addproof name = do-    n <- option Nothing $ do-        x <- fst <$> P.name-        return (Just x)-    eof-    return (Right (AddProof n))--cmd_log :: String -> P.IdrisParser (Either String Command)-cmd_log name = do-    i <- fmap (fromIntegral . fst) P.natural-    eof-    return (Right (LogLvl i))--cmd_cats :: String -> P.IdrisParser (Either String Command)-cmd_cats name = do-    cs <- sepBy pLogCats (P.whiteSpace)-    eof-    return $ Right $ LogCategory (concat cs)-  where-    badCat = do-      c <- fst <$> P.identifier-      fail $ "Category: " ++ c ++ " is not recognised."--    pLogCats :: P.IdrisParser [LogCat]-    pLogCats = try (P.symbol (strLogCat IParse)    >> return parserCats)-           <|> try (P.symbol (strLogCat IElab)     >> return elabCats)-           <|> try (P.symbol (strLogCat ICodeGen)  >> return codegenCats)-           <|> try (P.symbol (strLogCat ICoverage) >> return [ICoverage])-           <|> try (P.symbol (strLogCat IIBC)      >> return [IIBC])-           <|> try (P.symbol (strLogCat IErasure)  >> return [IErasure])-           <|> badCat--cmd_let :: String -> P.IdrisParser (Either String Command)-cmd_let name = do-    defn <- concat <$> many (P.decl defaultSyntax)-    return (Right (NewDefn defn))--cmd_unlet :: String -> P.IdrisParser (Either String Command)-cmd_unlet name = (Right . Undefine) `fmap` many (fst <$> P.name)--cmd_loadto :: String -> P.IdrisParser (Either String Command)-cmd_loadto name = do-    toline <- fmap (fromInteger . fst) P.natural-    f <- many anyChar;-    return (Right (Load f (Just toline)))--cmd_colour :: String -> P.IdrisParser (Either String Command)-cmd_colour name = fmap Right pSetColourCmd--    where-        colours :: [(String, Maybe Color)]-        colours = [ ("black", Just Black)-                  , ("red", Just Red)-                  , ("green", Just Green)-                  , ("yellow", Just Yellow)-                  , ("blue", Just Blue)-                  , ("magenta", Just Magenta)-                  , ("cyan", Just Cyan)-                  , ("white", Just White)-                  , ("default", Nothing)-                  ]--        pSetColourCmd :: P.IdrisParser Command-        pSetColourCmd = (do c <- pColourType-                            let defaultColour = IdrisColour Nothing True False False False-                            opts <- sepBy pColourMod (P.whiteSpace)-                            let colour = foldr ($) defaultColour $ reverse opts-                            return $ SetColour c colour)-                    <|> try (P.symbol "on" >> return ColourOn)-                    <|> try (P.symbol "off" >> return ColourOff)--        pColour :: P.IdrisParser (Maybe Color)-        pColour = doColour colours-            where doColour [] = fail "Unknown colour"-                  doColour ((s, c):cs) = (try (P.symbol s) >> return c) <|> doColour cs--        pColourMod :: P.IdrisParser (IdrisColour -> IdrisColour)-        pColourMod = try (P.symbol "vivid" >> return doVivid)-                 <|> try (P.symbol "dull" >> return doDull)-                 <|> try (P.symbol "underline" >> return doUnderline)-                 <|> try (P.symbol "nounderline" >> return doNoUnderline)-                 <|> try (P.symbol "bold" >> return doBold)-                 <|> try (P.symbol "nobold" >> return doNoBold)-                 <|> try (P.symbol "italic" >> return doItalic)-                 <|> try (P.symbol "noitalic" >> return doNoItalic)-                 <|> try (pColour >>= return . doSetColour)-            where doVivid i       = i { vivid = True }-                  doDull i        = i { vivid = False }-                  doUnderline i   = i { underline = True }-                  doNoUnderline i = i { underline = False }-                  doBold i        = i { bold = True }-                  doNoBold i      = i { bold = False }-                  doItalic i      = i { italic = True }-                  doNoItalic i    = i { italic = False }-                  doSetColour c i = i { colour = c }--        -- | Generate the colour type names using the default Show instance.-        colourTypes :: [(String, ColourType)]-        colourTypes = map (\x -> ((map toLower . reverse . drop 6 . reverse . show) x, x)) $-                      enumFromTo minBound maxBound--        pColourType :: P.IdrisParser ColourType-        pColourType = doColourType colourTypes-            where doColourType [] = fail $ "Unknown colour category. Options: " ++-                                           (concat . intersperse ", " . map fst) colourTypes-                  doColourType ((s,ct):cts) = (try (P.symbol s) >> return ct) <|> doColourType cts--idChar = oneOf (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_'])--cmd_apropos :: String -> P.IdrisParser (Either String Command)-cmd_apropos = packageBasedCmd (some idChar) Apropos--packageBasedCmd :: P.IdrisParser a -> ([String] -> a -> Command)-                -> String -> P.IdrisParser (Either String Command)-packageBasedCmd valParser cmd name =-  try (do P.lchar '('-          pkgs <- sepBy (some idChar) (P.lchar ',')-          P.lchar ')'-          val <- valParser-          return (Right (cmd pkgs val)))-   <|> do val <- valParser-          return (Right (cmd [] val))--cmd_search :: String -> P.IdrisParser (Either String Command)-cmd_search = packageBasedCmd-  (P.typeExpr (defaultSyntax { implicitAllowed = True })) Search--cmd_proofsearch :: String -> P.IdrisParser (Either String Command)-cmd_proofsearch name = do-    upd <- option False (do P.lchar '!'; return True)-    l <- fmap (fromInteger . fst) P.natural; n <- fst <$> P.name-    hints <- many (fst <$> P.fnName)-    return (Right (DoProofSearch upd True l n hints))--cmd_refine :: String -> P.IdrisParser (Either String Command)-cmd_refine name = do-   upd <- option False (do P.lchar '!'; return True)-   l <- fmap (fromInteger . fst) P.natural; n <- fst <$> P.name-   hint <- fst <$> P.fnName-   return (Right (DoProofSearch upd False l n [hint]))
src/Idris/Reflection.hs view
@@ -364,10 +364,10 @@ reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)  reifyNativeTy :: Term -> ElabD NativeTy-reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8-reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8-reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8-reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8+reifyNativeTy (P _ n _) | n == reflm "IT8"  = return IT8+reifyNativeTy (P _ n _) | n == reflm "IT16" = return IT16+reifyNativeTy (P _ n _) | n == reflm "IT32" = return IT32+reifyNativeTy (P _ n _) | n == reflm "IT64" = return IT64 reifyNativeTy x = fail $ "Couldn't reify reflected NativeTy " ++ show x  reifyIntTy :: Term -> ElabD IntTy@@ -896,7 +896,8 @@             , reflect t2             , reflect t3             ]-reflectErr (CantResolve _ t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]+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) =   raw_apply (Var $ reflErrName "CantResolveAlts")
src/Pkg/PParser.hs view
@@ -5,11 +5,11 @@ module Pkg.PParser where  import Text.Trifecta hiding (span, charLiteral, natural, symbol, char, string, whiteSpace)-+import qualified Text.PrettyPrint.ANSI.Leijen as PP import Idris.Core.TT import Idris.REPL import Idris.AbsSyntaxTree-import Idris.ParseHelpers hiding (stringLiteral)+import Idris.Parser.Helpers hiding (stringLiteral) import Idris.CmdOptions  import Control.Monad.State.Strict@@ -51,7 +51,7 @@ parseDesc fp = do     p <- readFile fp     case runparser pPkg defaultPkg fp p of-      Failure err -> fail (show err)+      Failure err -> fail (show $ PP.plain err)       Success x -> return x  pPkg :: PParser PkgDesc
src/Pkg/Package.hs view
@@ -142,7 +142,7 @@      setCurrentDirectory pkgDir      let run l       = runExceptT . execStateT l          load []     = return ()-         load (f:fs) = do loadModule f; load fs+         load (f:fs) = do loadModule f IBC_Building; load fs          loader      = do idrisMain opts; addImportDir (sourcedir pkgdesc); load fs      idrisInstance  <- run loader idrisInit      setCurrentDirectory cd
src/Util/ScreenSize.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} module Util.ScreenSize(getScreenWidth) where -import Debug.Trace- #ifndef CURSES  getScreenWidth :: IO Int@@ -11,11 +9,16 @@ #else  import UI.HSCurses.Curses+import System.IO (hIsTerminalDevice, stdout)  getScreenWidth :: IO Int-getScreenWidth = do initScr-                    refresh-                    size <- scrSize-                    endWin-                    return (snd size)+getScreenWidth = do term <- hIsTerminalDevice stdout+                    if term+                       then do+                         initScr+                         refresh+                         size <- scrSize+                         endWin+                         return (snd size)+                       else return 80 #endif
src/Util/System.hs view
@@ -2,7 +2,6 @@ module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows,                    writeSource, writeSourceText, readSource,                    setupBundledCC, isATTY) where- -- System helper functions.  import Control.Exception as CE@@ -31,9 +30,6 @@  catchIO :: IO a -> (IOError -> IO a) -> IO a catchIO = CE.catch--throwIO :: IOError -> IO a-throwIO = CE.throw  isWindows :: Bool isWindows = os `elem` ["win32", "mingw32", "cygwin32"]
stack.yaml view
@@ -1,4 +1,4 @@-resolver: lts-3.16+resolver: lts-4.2 packages: - '.' flags:@@ -11,3 +11,6 @@ - cheapskate-0.1.0.4 - hscurses-1.4.2.0 - libffi-0.1+nix:+   enable: false+   shell-file: stack-shell.nix
test/Makefile view
@@ -1,24 +1,34 @@-.PHONY: test test_java test_js time update diff distclean $(TESTS)+.PHONY: test test_js time update diff distclean $(TESTS)  TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))  test: $(TESTS) -%.test:-	@perl ./runtest.pl $(patsubst %.test,%,$@) -test_js:-	@perl ./runtest.pl without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 --codegen node+info: runtest+	@./runtest all -update:-	/usr/bin/env perl ./runtest.pl all -u+%.test: runtest+	@./runtest $(patsubst %.test,%,$@) -q -diff:-	/usr/bin/env perl ./runtest.pl all -d+test_js: runtest+	@./runtest without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 ffi007 primitives005 opts --codegen node -time:-	/usr/bin/env perl ./runtest.pl all -t+update: runtest+	@./runtest all -u +diff: runtest+	@./runtest all -d++time: runtest+	@./runtest all -t+ distclean:-	rm -f *~-	rm -f */output+	@rm runtest+	@rm -f *~+	@rm -f */output+++runtest:+	@ghc --make runtest.hs+	@rm runtest.o runtest.hi
test/basic001/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris $@ reg005.idr -o reg005-idris $@ basic001a.idr -o basic001a+${IDRIS:-idris} $@ reg005.idr -o reg005+${IDRIS:-idris} $@ basic001a.idr -o basic001a ./reg005 ./basic001a rm -f reg005 basic001a *.ibc
test/basic002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ --nocolour --consolewidth 80 test006.idr -o test006+${IDRIS:-idris} $@ --nocolour test006.idr -o test006 ./test006 rm -f test006 test006.ibc
test/basic003/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test027.idr -o test027+${IDRIS:-idris} $@ test027.idr -o test027 ./test027 rm -f test027 *.ibc
test/basic004/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test016.idr -o test016+${IDRIS:-idris} $@ test016.idr -o test016 ./test016 rm -f test016 *.ibc
test/basic005/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test019.lidr -o test019+${IDRIS:-idris} $@ test019.lidr -o test019 ./test019 rm -f test019 *.ibc
test/basic006/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -idris --consolewidth 80 $@ test020.idr -o test020-idris --consolewidth 80 $@ test020a.idr --check --nocolor+${IDRIS:-idris} $@ test020.idr -o test020+${IDRIS:-idris} $@ test020a.idr --check --nocolor ./test020 rm -f test020 *.ibc
test/basic007/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ -o test033 test033.idr+${IDRIS:-idris} $@ -o test033 test033.idr ./test033 rm -f *.ibc test033
test/basic008/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test036.idr -o test036+${IDRIS:-idris} $@ test036.idr -o test036 ./test036 rm -f test036 *.ibc
test/basic009/A.idr view
@@ -1,4 +1,5 @@ module A +public export num : Nat num = 0
test/basic009/B/C.idr view
@@ -1,4 +1,5 @@ module B.C +public export num : Nat num = 1
test/basic009/run view
@@ -1,8 +1,8 @@ #!/usr/bin/env bash -idris --consolewidth 80 $@ Main.idr --nocolour --check && echo MAIN-PASS-idris --consolewidth 80 $@ Faulty.idr --nocolour --check && echo FAULTY-PASS-idris --consolewidth 80 $@ Multiple.idr --nocolour --check && echo MULTIPLE-PASS+${IDRIS:-idris} $@ Main.idr --nocolour --check && echo MAIN-PASS+${IDRIS:-idris} $@ Faulty.idr --nocolour --check && echo FAULTY-PASS+${IDRIS:-idris} $@ Multiple.idr --nocolour --check && echo MULTIPLE-PASS   rm -f *.ibc B/*.ibc
test/basic011/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ basic011.idr -p contrib -o basic011+${IDRIS:-idris} $@ basic011.idr -p contrib -o basic011 ./basic011 rm -f basic011 *.ibc
test/basic012/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ basic012.idr -o basic012+${IDRIS:-idris} $@ basic012.idr -o basic012 ./basic012 rm -f basic012 *.ibc
test/basic013/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ basic013.idr -o basic013+${IDRIS:-idris} $@ basic013.idr -o basic013 ./basic013 rm -f basic013 *.ibc
test/basic014/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ basic014.idr --check+${IDRIS:-idris} $@ basic014.idr --check rm -f *.ibc
test/basic015/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ basic015.idr -o basic015+${IDRIS:-idris} $@ basic015.idr -o basic015 ./basic015 rm -f basic015 *.ibc
test/basic016/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ CycleA.idr --consolewidth 80 --nocolour --check+${IDRIS:-idris} $@ CycleA.idr --nocolour --check rm -f *.ibc
+ test/basic017/basic017.idr view
@@ -0,0 +1,25 @@+%auto_implicits off++data Vect : Nat -> Type -> Type where+     Nil  : {a : _} -> Vect Z a+     (::) : {a, k : _} -> a -> Vect k a -> Vect (S k) a++data Elem  : {a, n : _} -> a -> Vect n a -> Type where+     Here  : {x, xs : _} -> Elem x (x :: xs)+     There : {x, y, xs : _} -> Elem x xs -> Elem x (y :: xs)++using (xs : Vect _ _)+  data Elem2  : {a, n : _} -> a -> Vect n a -> Type where+       Here2  : {x : _} -> Elem2 x (x :: xs)+       There2 : {x, y : _} -> Elem2 x xs -> Elem2 x (y :: xs)++append : {n, m, a : _} -> Vect n a -> Vect m a -> Vect (n + m) a+append [] ys = ys+append (x :: xs) ys = x :: append xs ys++%auto_implicits on++append2 : Vect n a -> Vect m a -> Vect (n + m) a+append2 [] ys = ys+append2 (x :: xs) ys = x :: append2 xs ys+
+ test/basic017/basic017a.idr view
@@ -0,0 +1,15 @@+%auto_implicits off++data Vect : Nat -> Type -> Type where+     Nil  : {a : _} -> Vect Z a+     (::) : {a, k : _} -> a -> Vect k a -> Vect (S k) a++data Elem  : {a, n : _} -> a -> Vect n a -> Type where+     Here  : {x, xs : _} -> Elem x (x :: xs)+     There : {x, y, xs : _} -> Elem x xs -> Elem x (y :: xs)++append : Vect n a -> Vect m a -> Vect (n + m) a+append [] ys = ys+append (x :: xs) ys = x :: append xs ys++
+ test/basic017/expected view
@@ -0,0 +1,3 @@+basic017a.idr:11:8:When checking type of Main.append:+When checking an application of Main.Vect:+        No such variable n
+ test/basic017/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ basic017.idr --check --nocolor+${IDRIS:-idris} $@ basic017a.idr --check --nocolor+rm -f *.ibc
test/bignum001/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ bignum001.idr -o bignum001+${IDRIS:-idris} $@ bignum001.idr -o bignum001 ./bignum001 rm -f bignum001 *.ibc
test/bignum002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ bignum002.idr -o bignum002+${IDRIS:-idris} $@ bignum002.idr -o bignum002 ./bignum002 rm -f bignum002 *.ibc
test/classes001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --quiet --nocolour --consolewidth 70 ClassName.idr < input+${IDRIS:-idris} $@ --quiet --nocolour --consolewidth 70 ClassName.idr < input rm -f bounded001 *.ibc
test/corecords001/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ corecords001.idr -o corecords001+${IDRIS:-idris} $@ corecords001.idr -o corecords001 ./corecords001 rm -f corecords001 corecords001.ibc
test/corecords002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ corecords002.idr -o corecords002+${IDRIS:-idris} $@ corecords002.idr -o corecords002 ./corecords002 rm -f corecords002 corecords002.ibc
test/delab001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --quiet --nocolor delab001.idr < input+${IDRIS:-idris} $@ --quiet --nocolor delab001.idr < input rm -f *.ibc
test/disambig002/disambig002.idr view
@@ -6,7 +6,7 @@ Dec0 = Dec  Dec1 : {A : Type} -> (P : A -> Type) -> Type-Dec1 {A} P = (a : A) -> Dec0 (P a) +Dec1 {A} P = (a : A) -> Dec0 (P a)  Unique : Type -> Type Unique t = (p : t) -> (q : t) -> p = q@@ -53,8 +53,8 @@ filterTag : {A : Type} ->             {P : A -> Type} ->             Dec1 P ->-            Vect n A -> -            Sigma Nat (\ m => Vect m (Sigma A P))+            Vect n A ->+            DPair Nat (\ m => Vect m (DPair A P)) filterTag d1P Nil = (_ ** Nil) filterTag d1P (a :: as) with (filterTag d1P as)   | (_ ** tail) with (d1P a)@@ -66,7 +66,7 @@          {P : A -> Type} ->          Finite A ->          Dec1 P ->-         (n : Nat ** Vect n (Sigma A P))+         (n : Nat ** Vect n (DPair A P)) toVect fA d1P = filterTag d1P (toVect fA)  sigmaUniqueLemma1 : {A   : Type} ->@@ -74,16 +74,14 @@                     Unique1 {t0 = A} P ->                     (a : A) ->                     (p : P a) ->-                    (ss : Vect n (Sigma A P)) ->-                    Elem a (map getWitness ss) -> +                    (ss : Vect n (DPair A P)) ->+                    Elem a (map fst ss) ->                     Elem (a ** p) ss  toVectComplete : {A   : Type} ->                  {P   : A -> Type} ->-                 (fA  : Finite A) -> -                 (d1P : Dec1 P) -> +                 (fA  : Finite A) ->+                 (d1P : Dec1 P) ->                  Unique1 {t0 = A} P ->-                 (s   : Sigma A P) -> -                 Elem s (getProof (toVect fA d1P))--+                 (s   : DPair A P) ->+                 Elem s (snd (toVect fA d1P))
test/disambig002/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ disambig002.idr --check+${IDRIS:-idris} $@ disambig002.idr --check rm -f *.ibc
test/docs001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet --nocolor --consolewidth 80 docs001.idr < input+${IDRIS:-idris} --quiet --nocolor docs001.idr < input rm *.ibc
test/docs002/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 --nobanner --nocolor --quiet docs002.idr < input+${IDRIS:-idris} --nobanner --nocolor --quiet docs002.idr < input rm *.ibc
test/docs003/expected view
@@ -5,7 +5,7 @@     f   -- a parameterised type  Methods:-    map : Functor f => (m : a -> b) -> f a -> f b+    map : Functor f => (func : a -> b) -> f a -> f b         Apply a function across everything of type 'a' in a         parameterised type
test/docs003/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 --quiet --nocolor docs003.idr < input+${IDRIS:-idris} --quiet --nocolor docs003.idr < input rm *.ibc
test/dsl001/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test001.idr -o test001+${IDRIS:-idris} $@ test001.idr -o test001 ./test001 rm -f test001 test001.ibc
test/dsl001/test001.idr view
@@ -45,7 +45,7 @@       index_next = Pop    total-  interp : Env G -> [static] (e : Expr G t) -> interpTy t+  interp : Env G -> %static (e : Expr G t) -> interpTy t   interp env (Var i)     = lookup i env   interp env (Val x)     = x   interp env (Lam sc)    = \x => interp (x :: env) sc
test/dsl002/Resimp.idr view
@@ -3,6 +3,8 @@ import public Data.Vect import public Data.Fin +%access public export+ -- IO operations which read a resource data Reader : Type -> Type where     MkReader : IO a -> Reader a@@ -122,7 +124,7 @@   ioret : a -> IO a   ioret = return -  interp : Env gam -> [static] (e : Res gam gam' t) ->+  interp : Env gam -> %static (e : Res gam gam' t) ->            (Env gam' -> interpTy t -> IO u) -> IO u    interp env (Let val scope) k
test/dsl002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test014.idr -o test014+${IDRIS:-idris} $@ test014.idr -o test014 ./test014 rm -f test014 Resimp.ibc test014.ibc
test/dsl003/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --nocolour --check DSLPi.idr -e test1 -e test2+${IDRIS:-idris} $@ --nocolour --check DSLPi.idr -e test1 -e test2 rm -f *.ibc
test/dsl004/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris $@ Door0.idr --check-idris $@ Door1.idr --check-idris $@ Door2.idr --check+${IDRIS:-idris} $@ Door0.idr --check+${IDRIS:-idris} $@ Door1.idr --check+${IDRIS:-idris} $@ Door2.idr --check rm -f *.ibc
test/effects001/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris -p effects $@ test021.idr -o test021-idris -p effects $@ test021a.idr -o test021a+${IDRIS:-idris} -p effects $@ test021.idr -o test021+${IDRIS:-idris} -p effects $@ test021a.idr -o test021a ./test021 ./test021a rm -f test021 test021a *.ibc
test/effects002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris -p effects $@ test025.idr -o test025+${IDRIS:-idris} -p effects $@ test025.idr -o test025 ./test025 rm -f test025 *.ibc
test/effects003/VectMissing.idr view
@@ -3,9 +3,7 @@ import Data.Fin import Data.Vect -implementation Uninhabited (Elem x []) where-    uninhabited Here impossible-+export shrink : (xs : Vect (S n) a) -> Elem x xs -> Vect n a shrink (x :: ys) Here = ys shrink (y :: []) (There p) = absurd p
test/effects003/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ hangman.idr --consolewidth 80 --nocolour -p effects -o hangman+${IDRIS:-idris} $@ hangman.idr --nocolour -p effects -o hangman ./hangman < input rm -f hangman *.ibc
test/effects004/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ effects004.idr -o effects004 -p effects+${IDRIS:-idris} $@ effects004.idr -o effects004 -p effects ./effects004 < input rm -f effects004 *.ibc
test/effects005/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris $@ defaultLogger.idr -o default -p effects+${IDRIS:-idris} $@ defaultLogger.idr -o default -p effects ./default-idris $@ categoryLogger.idr -o category -p effects+${IDRIS:-idris} $@ categoryLogger.idr -o category -p effects ./category rm -f default category *.ibc
test/error001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ test002.idr --check --noprelude --consolewidth 70+${IDRIS:-idris} $@ test002.idr --check --noprelude --consolewidth 70 rm -f *.ibc
test/error002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test031.idr -o test031+${IDRIS:-idris} $@ test031.idr -o test031 ./test031 rm -f test031 *.ibc
test/error003/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ ErrorReflection.idr --nocolour --check+${IDRIS:-idris} $@ ErrorReflection.idr --nocolour --check rm -f *.ibc
test/error004/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ FunErrTest.idr --nocolour --check+${IDRIS:-idris} $@ FunErrTest.idr --nocolour --check rm -f *.ibc
test/error005/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ --check --nocolour error005.idr+${IDRIS:-idris} $@ --check --nocolour error005.idr rm -f *.ibc
test/ffi001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet --nocolour test022.idr --exec main+${IDRIS:-idris} --quiet --nocolour test022.idr --exec main rm -f *.ibc
test/ffi002/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 --quiet test023.idr -o test023+${IDRIS:-idris} --quiet test023.idr -o test023 rm -f test023 *.ibc
test/ffi003/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet --nocolour test024.idr --exec main < input+${IDRIS:-idris} --quiet --nocolour test024.idr --exec main < input rm -f *.ibc
test/ffi004/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet --nocolour --check test026.idr+${IDRIS:-idris} --quiet --nocolour --check test026.idr rm -f *.ibc
test/ffi005/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash -idris $@ Postulate.idr -o postulate+${IDRIS:-idris} $@ Postulate.idr -o postulate ./postulate rm -f postulate *.ibc
test/ffi006/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris $@ ffi006.idr --interface -o ffi006.o+${IDRIS:-idris} $@ ffi006.idr --interface -o ffi006.o ${CC:=cc} ffi006.c ffi006.o `idris --include` `idris --link` -o ffi006 ./ffi006 rm -f ffi006 *.ibc *.o *.h
+ test/ffi007/expected view
@@ -0,0 +1,8 @@+8+5+Before calling callback+In an Idris callback+After calling callback+00000377+I'm dynamic 3+6
+ test/ffi007/ffi007.c view
@@ -0,0 +1,30 @@+#include <stdio.h>++typedef int (*callback)(int);+typedef int (*cb2)(char *);++void test_ffi(callback cb)+{+    printf("%d\n", cb(3));+}++void test_ffi2(cb2 cb)+{+    printf("%d\n", cb("hello"));+}++void test_ffi3(void (*cb)(void))+{+    printf("Before calling callback\n");+    cb();+    printf("After calling callback\n");+}++int dynamic_fn(int i) {+    printf("I'm dynamic %d\n", i);+    return i*2;+}++callback test_ffi6(void) {+    return &dynamic_fn;+}
+ test/ffi007/ffi007.h view
@@ -0,0 +1,11 @@+#include <stdint.h>+typedef int (*callback)(int);++int32_t testvar = 887;++void test_ffi(int (*cb)(int));++void test_ffi2(int (*cb)(char*));+void test_ffi3(void (*cb)(void));++callback test_ffi6(void);
+ test/ffi007/ffi007.idr view
@@ -0,0 +1,49 @@+module Main++%include c "ffi007.h"++getInt : Int -> Int+getInt _ = 8++test : IO ()+test = foreign FFI_C "test_ffi" (CFnPtr (Int -> Int) -> IO ()) (MkCFnPtr getInt)++strLen : String -> Int+strLen s = cast $ length s++test2 : IO ()+test2 = foreign FFI_C "test_ffi2" (CFnPtr (String -> Int) -> IO ()) (MkCFnPtr strLen)++-- Do IO+printIt : () -> ()+printIt _ = unsafePerformIO $ do+    putStrLn "In an Idris callback"++test3 : IO ()+test3 = foreign FFI_C "test_ffi3" (CFnPtr (() -> ()) -> IO ()) (MkCFnPtr printIt)++test4 : IO Ptr+test4 = foreign FFI_C "%wrapper" (CFnPtr (() -> ()) -> IO Ptr) (MkCFnPtr printIt)++test5 : IO Ptr+test5 = foreign FFI_C "&testvar" (IO Ptr)++test6 : IO Ptr+test6 = foreign FFI_C "test_ffi6" (IO Ptr)++test7 : Ptr -> Int -> IO Int+test7 fnptr i = foreign FFI_C "%dynamic" (Ptr -> Int -> IO Int) fnptr i++main : IO ()+main = do+            test+            test2+            test3+            ptr <- test4+            tv <- test5+            val <- prim_peek32 tv 0+            printLn val+            fptr <- test6+            i <- test7 fptr 3+            printLn i+            return ()
+ test/ffi007/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ ffi007.idr -o ffi007 --cg-opt "ffi007.c"+./ffi007+rm -f ffi007 *.ibc
test/folding001/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ folding001.idr -o folding001+${IDRIS:-idris} $@ folding001.idr -o folding001 ./folding001 rm -f folding001 *.ibc
test/idrisdoc001/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash # Tests that no documentation is built for empty and/or private-only namespaces-idris --mkdoc test_empty.ipkg+${IDRIS:-idris} --mkdoc test_empty.ipkg rm -rf *.ibc *_doc
test/idrisdoc002/TestFunctions.idr view
@@ -1,5 +1,6 @@ module TestFunctions  ||| Test function+public export test : () test = ()
test/idrisdoc002/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash # Tests that documentation is generated for functions-idris --mkdoc test_functions.ipkg+${IDRIS:-idris} --mkdoc test_functions.ipkg [ -d test_functions_doc ] && echo "Functions are documented" rm -rf *.ibc *_doc
test/idrisdoc003/TestDatatypes.idr view
@@ -1,6 +1,7 @@ module TestDatatypes  ||| This is another test+public export data Test : Type where   ||| Test constructor   ATest : Test
test/idrisdoc003/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash # Tests that documentation is generated for data types-idris --mkdoc test_datatypes.ipkg+${IDRIS:-idris} --mkdoc test_datatypes.ipkg [ -d test_datatypes_doc ] && echo "Data types are documented" rm -rf *.ibc *_doc
test/idrisdoc004/TestTypeclasses.idr view
@@ -3,6 +3,7 @@ ||| This is a test ||| ||| @ a Test arg+public export interface Test a where   ||| Test function   test : a -> Int
test/idrisdoc004/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash # Tests that documentation is generated for typeclasses-idris --mkdoc test_typeclasses.ipkg+${IDRIS:-idris} --mkdoc test_typeclasses.ipkg [ -d test_typeclasses_doc ] && echo "Typeclasses are documented" rm -rf *.ibc *_doc
test/idrisdoc005/TestTracing.idr view
@@ -1,4 +1,5 @@ module TestTracing +public export test : Bool test = True
test/idrisdoc005/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash # Tests that references to other namespaces are traced-idris --mkdoc test_tracing.ipkg+${IDRIS:-idris} --mkdoc test_tracing.ipkg [ -f test_tracing_doc/docs/TestTracing.html ] && echo "TestTracing: Check" [ -f test_tracing_doc/docs/Prelude.Bool.html ] && echo "Prelude.Bool: Check" rm -rf *.ibc *_doc
test/idrisdoc006/A/fully/Qualified/NAME.idr view
@@ -1,6 +1,6 @@ module A.fully.Qualified.NAME  ||| This is another test-data Test : Type where+public export data Test : Type where   ||| Test constructor   ATest : Test
test/idrisdoc006/B.idr view
@@ -1,5 +1,6 @@ module B  ||| Test function+public export test : () test = ()
test/idrisdoc006/run view
@@ -1,8 +1,8 @@ #!/usr/bin/env bash # Tests that documentation properly is merged with existent.-idris --mkdoc package_a.ipkg+${IDRIS:-idris} --mkdoc package_a.ipkg [ -f test_merge_doc/IdrisDoc ] && echo "IdrisDoc file written"-idris --mkdoc package_b.ipkg+${IDRIS:-idris} --mkdoc package_b.ipkg ls -1p test_merge_doc/docs if grep -q "href\\=\"docs/A.fully.Qualified.NAME\\.html\"" test_merge_doc/index.html; then   echo A.fully.Qualified.NAME is in the index
test/idrisdoc007/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash # Tests that documentation only is written when safe mkdir do_not_delete_doc-idris --mkdoc package.ipkg > nowhere+${IDRIS:-idris} --mkdoc package.ipkg > nowhere echo Exit status \(expects 1\): $? rm -rf do_not_delete_doc *.ibc nowhere
test/idrisdoc008/Abstract.idr view
@@ -1,5 +1,5 @@ module Abstract -abstract+export frozen : () frozen = ()
test/idrisdoc008/Visible.idr view
@@ -1,5 +1,5 @@ module Visible -public+public export visible : () visible = ()
test/idrisdoc008/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash # Tests that documentation is generated for both public and abstract members.-idris --mkdoc visibility.ipkg+${IDRIS:-idris} --mkdoc visibility.ipkg [ -f visibility_doc/docs/Abstract.html ] && echo "Abstract members are documented" [ -f visibility_doc/docs/Visible.html ] && echo "Public members are documented" rm -rf *.ibc *_doc
test/idrisdoc009/Test.idr view
@@ -23,6 +23,8 @@ module Test import Data.Complex +%access public export+ myplus : Nat -> Nat -> Nat myplus Z j = j myplus (S k) j = S (myplus k j)
test/idrisdoc009/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --nocolour --quiet Test.idr < input+${IDRIS:-idris} $@ --nocolour --quiet Test.idr < input rm -f *.ibc
test/interactive001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet test032.idr < input+${IDRIS:-idris} --quiet test032.idr < input rm -f *.ibc
test/interactive002/expected view
@@ -5,6 +5,6 @@ Vect (n + m) a Nat Nat-S n+(S n) String ()
test/interactive002/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet interactive002.idr < input+${IDRIS:-idris} --quiet interactive002.idr < input rm -f *.ibc
test/interactive003/expected view
@@ -2,4 +2,4 @@ x :: app xs ys [] f x y :: vzipWith f xs ys-?word_length_rhs_3 :: word_length xs+0 :: word_length xs
test/interactive003/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet interactive003.idr < input+${IDRIS:-idris} --quiet interactive003.idr < input rm -f *.ibc
test/interactive004/expected view
@@ -1,2 +1,2 @@ plus ?foo_rhs2 ?foo_rhs3-append k m ?append_rhs2 ?append_rhs3+(append k m ?append_rhs2 ?append_rhs3)
test/interactive004/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet interactive004.idr < input+${IDRIS:-idris} --quiet interactive004.idr < input rm -f *.ibc
test/interactive005/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris --nocolour --quiet interactive005.idr --consolewidth 70 < input+${IDRIS:-idris} --nocolour --quiet interactive005.idr --consolewidth 70 < input rm -f *.ibc rm -f hello.bytecode rm -f hello
test/interactive006/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet --port 5000 interactive006.idr < input+${IDRIS:-idris} --quiet --port 5000 interactive006.idr < input rm -f *.ibc
test/interactive007/run view
@@ -1,2 +1,2 @@ #!/usr/bin/env bash-idris -p contrib --nobanner --nocolor < input+${IDRIS:-idris} -p contrib --nobanner --nocolor < input
test/interactive008/run view
@@ -1,2 +1,2 @@ #!/usr/bin/env bash-idris --nobanner --nocolor < input+${IDRIS:-idris} --nobanner --nocolor < input
test/interactive009/expected view
@@ -1,1 +1,1 @@-IsSetCons pf prfRec+(IsSetCons pf prfRec)
test/interactive009/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet interactive009.idr < input+${IDRIS:-idris} --quiet interactive009.idr < input rm -f *.ibc
test/interactive010/expected view
@@ -1,12 +1,12 @@ Prelude.List.(++) : List a -> List a -> List a Prelude.Strings.(++) : String -> String -> String-a is not an implicit argument of Prelude.Classes./+a is not an implicit argument of Prelude.Interfaces./ Usage is :doc <functionname> Usage is :wc <functionname> Usage is :printdef <functionname>-pat {ty504} : Type u. pat {__class505} : Prelude.Classes.Fractional {ty504}. Prelude.Classes./ {ty504} {__class505}+pat {ty504} : Type u. pat {__class505} : Prelude.Interfaces.Fractional {ty504}. Prelude.Interfaces./ {ty504} {__class505} - : pty {ty504} : Type u. pty {__class505} : Prelude.Classes.Fractional {ty504}. {ty504} -> {ty504} -> {ty504}+ : pty {ty504} : Type u. pty {__class505} : Prelude.Interfaces.Fractional {ty504}. {ty504} -> {ty504} -> {ty504} (input):1:1: error: expected: ":",     dependent type signature,     end of input
test/interactive010/run view
@@ -1,2 +1,2 @@ #!/usr/bin/env bash-idris --quiet --nobanner --nocolor  --consolewidth 80 < input+${IDRIS:-idris} --quiet --nobanner --nocolor  < input
test/interactive011/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --quiet interactive011.idr < input+${IDRIS:-idris} --quiet interactive011.idr < input rm -f *.ibc
test/interactive012/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --nocolour --consolewidth 70 --quiet interactive012.idr < input+${IDRIS:-idris} --nocolour --consolewidth 70 --quiet interactive012.idr < input rm -f *.ibc
test/io001/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test004.idr -o test004+${IDRIS:-idris} $@ test004.idr -o test004 ./test004 rm -f test004 test004.ibc testfile
test/io001/test004.idr view
@@ -17,7 +17,7 @@                    closeFile h }  main : IO ()-main = do { Right h <- openFile "testfile" Write+main = do { Right h <- openFile "testfile" WriteTruncate             fPutStr h "Hello!\nWorld!\n...\n3\n4\nLast line\n"             closeFile h             putStrLn "Reading testfile"
test/io002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test008.idr -o test008+${IDRIS:-idris} $@ test008.idr -o test008 ./test008 rm -f test008 test008.ibc
test/io003/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris $@ test018.idr -p contrib -o test018-idris $@ test018a.idr -p contrib -o test018a+${IDRIS:-idris} $@ test018.idr -p contrib -o test018+${IDRIS:-idris} $@ test018a.idr -p contrib -o test018a ./test018 #./test018a rm -f test018 test018a *.ibc
test/literate001/Lit.lidr view
@@ -2,12 +2,12 @@  Test some string primitives while we're at it -> st : String+> export st : String > st = "abcdefg"  Literate main program -> main : IO ()+> export main : IO () > main = do { putStrLn (show (strHead st)) >             putStrLn (show (strIndex st 3)) >             putStrLn (strCons 'z' st)
test/literate001/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ test003a.lidr --check-idris --consolewidth 80 $@ test003.lidr -o test003+${IDRIS:-idris} $@ test003a.lidr --check+${IDRIS:-idris} $@ test003.lidr -o test003 ./test003 rm -f test003 test003.ibc Lit.ibc
test/meta001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --check --nocolour --consolewidth 70 Finite.idr+${IDRIS:-idris} $@ --check --nocolour --consolewidth 70 Finite.idr rm -f *.ibc
test/meta002/AgdaStyleReflection.idr view
@@ -2,6 +2,10 @@ ||| Idris's reflected elaboration. Requires handling type class ||| resolution and implicit arguments - some of the same features as ||| the Idris elaborator itself.+|||+||| Since this test was put together, Agda has adopted an Idris-style+||| elaborator reflection mechanism. The module name is preserved for+||| historical interest. module AgdaStyleReflection  @@ -11,6 +15,7 @@ %default total  + ||| Function arguments as provided at the application site record Arg a where   constructor MkArg@@ -20,6 +25,10 @@ implementation Functor Arg where   map f (MkArg plic x) = MkArg plic (f x) +implementation Show a => Show (Arg a) where+  showPrec d (MkArg plic x) = showCon d "MkArg" $ showArg plic ++ showArg x++ ||| Reflected terms, in the tradition of Agda's reflection library data Term   = Var Nat (List (Arg Term))@@ -37,6 +46,41 @@         unApply' (RApp f x) xs = unApply' f (x::xs)         unApply' notApp xs = (notApp, xs) ++implementation Quotable Plicity Raw where+  quotedTy = `(Plicity)+  quote Explicit = `(Explicit)+  quote Implicit = `(Implicit)+  quote Constraint = `(Constraint)++implementation (Quotable a Raw) => Quotable (Arg a) Raw where+  quotedTy = `(Arg ~(quotedTy {a=a}))+  quote (MkArg plicity argValue) =+    `(MkArg {a=~(quotedTy {a=a})} ~(quote plicity) ~(quote argValue))+++implementation Quotable Term Raw where+  quotedTy = `(Term)+  quote (Var k xs) = `(AgdaStyleReflection.Var ~(quote k) ~(assert_total $ quote xs))+  quote (Ctor n xs) = `(AgdaStyleReflection.Ctor ~(quote n) ~(assert_total $ quote xs))+  quote (TyCtor n xs) = `(AgdaStyleReflection.TyCtor ~(quote n) ~(assert_total $ quote xs))+  quote (Def n xs) = `(Def ~(quote n) ~(assert_total $ quote xs))+  quote (Lam x) = `(AgdaStyleReflection.Lam ~(quote x))+  quote (Pi x y) = `(AgdaStyleReflection.Pi ~(quote x) ~(quote y))+  quote (Constant c) = `(Constant ~(quote c))+  quote Ty = `(Ty)+++partial implementation Show Term where+  showPrec d (Var k xs) = showCon d "Var" $ showArg k ++ showArg xs+  showPrec d (Ctor n xs) = showCon d "Ctor" $ showArg n ++ showArg xs+  showPrec d (TyCtor n xs) = showCon d "TyCtor" $ showArg n ++ showArg xs+  showPrec d (Def n xs) = showCon d "Def" $ showArg n ++ showArg xs+  showPrec d (Lam x) = showCon d "Lam" $ showArg x+  showPrec d (Pi x y) = showCon d "Pi" $ showArg x ++ showArg y+  showPrec d (Constant c) = showCon d "Constant" $ showArg c+  showPrec d Ty = "Ty"+ ||| Quote a reflected Idris term to a Term in some induced local context covering quoteTerm' : List TTName -> Raw -> Elab Term@@ -183,18 +227,41 @@ spliceTerm : Term -> Elab () spliceTerm = spliceTerm' [] -||| Lift an Agda-style tactic into an Idris-style tactic+syntax "splice" [tm] = %runElab (spliceTerm tm)+ covering-quoteGoalImpl : (Term -> Term) -> Elab ()-quoteGoalImpl f = do compute-                     g <- goalType >>= quoteTerm-                     spliceTerm (f g)+quoteGoalImpl : TTName -> Elab ()+quoteGoalImpl f =+    do g <- goalType >>= quoteTerm+       fill (RApp (Var f) (quote g))+       solve -syntax "quoteGoal" {x} "in" [expr] = %runElab (quoteGoalImpl (\x => expr))+syntax "quoteGoal" {g} "in" [e] =+  let f = \g : Term => e in %runElab (quoteGoalImpl `{f}) -syntax "tactic" [expr] = %runElab (quoteGoalImpl expr) +-- Note: this definition would seem to be the right thing, but it's not:+--   syntax "tactic" [tac] = quoteGoal g in splice tac g+-- This is because it would make+--   tactic foo+-- expand to+--   let f = \g : Term => %runElab (spliceTerm (tac g))+--   in %runElab (quoteGoalImpl `{f})+-- which confuses the meta-level at which the body of the lambda should be+-- run. It must be sequenced into the same monadic action as quoting the goal,+-- yielding the following implementation: +covering+tacticImpl : (tac : Term -> Term) -> Elab ()+tacticImpl tac = do g <- goalType >>= quoteTerm+                    AgdaStyleReflection.spliceTerm (tac g)++syntax "tactic" [tacticCode] =+    %runElab (tacticImpl tacticCode)++++   @@ -231,12 +298,30 @@ trivial : (goal : Term) -> Term trivial = perhaps . trivial' -foo : (Nat, (), Nat, Either (() -> ()) Void)-foo = quoteGoal x in trivial x+-- DOESN'T WORK because reflection operations are not pure - they have+-- side effects in the elaborator! Also due to metalevel confusion in+-- underlying syntax+--foo : (Nat, (), Either Void Nat, Nat -> ())+--foo = quoteGoal g in splice (trivial g) ++-- WORKS because "tactic" takes care of the sequencing of operations bar : (Nat, (), Either Void Nat, Nat -> ()) bar = tactic trivial +someTerm : Term+someTerm = quoteGoal g in g++ok : AgdaStyleReflection.someTerm = TyCtor (NS (UN "Term") ["AgdaStyleReflection"]) []+ok = Refl++-- assert_total needed due to partial Show implementations+stringly : String -> String+stringly = quoteGoal g in \x => assert_total $ show g++ok2 : stringly "fnord" = "Pi (Constant StrType) (Constant StrType)"+ok2 = Refl+ --     When checking right hand side of baz: --     PROOF SEARCH FAILURE is not defined. baz : (Nat, Void)@@ -245,3 +330,4 @@ -- Local Variables: -- idris-load-packages: ("pruviloj") -- End:+
test/meta002/Tacs.idr view
@@ -208,7 +208,7 @@           -- Now we put this hole variable into our sigma constructor          -- prior to elaboration, so it doesn't disappear too soon-         fill `(MkSigma ~(Var tH) ~(Var tmH) : Sigma Ty (Tm []))+         fill `(MkDPair ~(Var tH) ~(Var tmH) : DPair Ty (Tm []))          solve          focus tmH          mkTerm [] tm@@ -287,18 +287,17 @@                                      apply `(UnitCon {env=~(Var envH)})                                            []                                      solve-    testElab : Sigma Ty (Tm [])+    testElab : DPair Ty (Tm [])     testElab = %runElab (elaborateSTLC (App (Lam "x" UnitCon) UnitCon)) -    testElab2 : Sigma Ty (Tm [])+    testElab2 : DPair Ty (Tm [])     testElab2 = %runElab (elaborateSTLC (App (Lam "x" (Var 0)) UnitCon))      -- Doesn't work! :-)-    testElab3 : Sigma Ty (Tm [])+    testElab3 : DPair Ty (Tm [])     testElab3 = %runElab (elaborateSTLC (App (Lam "x" (App (Var 0) (Var 0)))                                              (Lam "x" (App (Var 0) (Var 0)))))     -- Error is:     -- Tacs.idr line 247 col 14:     --     When elaborating right hand side of testElab3:     --     Unifying ty and Tacs.STLC.ARR ty t would lead to infinite value-
test/meta002/expected view
@@ -1,9 +1,9 @@ Tacs.idr:298:15: When checking right hand side of testElab3 with expected type-        Sigma Ty (Tm [])+        DPair Ty (Tm [])  Unifying ty and ARR ty t would lead to infinite value-AgdaStyleReflection.idr:243:5:+AgdaStyleReflection.idr:328:5: When checking right hand side of baz with expected type         (Nat, Void)
test/meta002/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris $@ -p pruviloj --nocolour --check --consolewidth 70 Tacs.idr-idris $@ -p pruviloj --nocolour --check --consolewidth 70 AgdaStyleReflection.idr+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 Tacs.idr+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 AgdaStyleReflection.idr # Disabled due to excess memory consumption # idris $@ -p pruviloj --nocolour --check --consolewidth 70 Deriving.idr rm -f *.ibc
test/meta004/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ -p pruviloj --nocolour --check --consolewidth 70 meta004.idr+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 meta004.idr rm -f *.ibc
test/pkg001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --build test.ipkg+${IDRIS:-idris} $@ --build test.ipkg rm -f  *.ibc
test/primitives001/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris $@ test005.idr -o test005+${IDRIS:-idris} $@ test005.idr -o test005 ./test005-idris $@ substring.idr -o substring+${IDRIS:-idris} $@ substring.idr -o substring ./substring < input rm -f test005 substring *.ibc
test/primitives003/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris $@ -o test038 test038.idr --nocolour+${IDRIS:-idris} $@ -o test038 test038.idr --nocolour ./test038 rm -f test038 *.ibc
+ test/primitives005/expected view
@@ -0,0 +1,2 @@+04030201+000000000000FFFF
+ test/primitives005/primitives005.idr view
@@ -0,0 +1,24 @@+module Main++%include C "memory.h"++-- use calloc to ensure zeroed out memory+malloc : Int -> IO Ptr+malloc size = foreign FFI_C "calloc" (Int -> Int -> IO Ptr) size 1++free : Ptr -> IO ()+free ptr = foreign FFI_C "free" (Ptr -> IO ()) ptr++main : IO ()+main = do+    p <- malloc 1000+    prim_poke16 p 0 0xffff+    prim_poke8 p 8 1+    prim_poke8 p 9 2+    prim_poke8 p 10 3+    prim_poke8 p 11 4+    a <- prim_peek32 p 8+    b <- prim_peek64 p 0+    printLn a+    printLn b+    free p
+ test/primitives005/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ -o p005 primitives005.idr --nocolour+./p005+rm -f p005 *.ibc+
test/proof001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ test029.idr --consolewidth 80 --nocolour --check test029+${IDRIS:-idris} $@ test029.idr --nocolour --check test029 rm -f *.ibc
test/proof002/Reflect.idr view
@@ -2,6 +2,7 @@  import Decidable.Equality +%access public export %default total  using (xs : List a, ys : List a, G : List (List a))@@ -43,7 +44,7 @@                        let (yl ** (yr, yprf)) = expr_r ey in                                appRExpr _ _ xr yr xprf yprf     where-      appRExpr : (xs', ys' : List a) -> +      appRExpr : (xs', ys' : List a) ->                  {G : List (List a)} -> {xs, ys : List a} ->                  RExpr G xs -> RExpr G ys -> (xs' = xs) -> (ys' = ys) ->                  (ws' ** (RExpr G ws', xs' ++ ys' = ws'))@@ -205,6 +206,4 @@ -- prover.  syntax AssocProof [ty] = quoteGoal x by reflectEq ty [] in-                             getJust (prove (getProof x)) ItIsJust--+                             getJust (prove (snd x)) ItIsJust
test/proof002/expected view
@@ -1,8 +1,8 @@-Reflect.idr:173:21-26:+Reflect.idr:174:21-26: This style of tactic proof is deprecated. See %runElab for the replacement.-Reflect.idr:182:21-26:+Reflect.idr:183:21-26: This style of tactic proof is deprecated. See %runElab for the replacement.-Reflect.idr:190:15-20:+Reflect.idr:191:15-20: This style of tactic proof is deprecated. See %runElab for the replacement. test030a.idr:12:26-14:1: When checking right hand side of testReflect1 with expected type@@ -12,7 +12,7 @@         Type mismatch between                 IsJust (Just x1) (Type of ItIsJust)         and-                IsJust (prove (getProof x)) (Expected type)+                IsJust (prove (snd x)) (Expected type)                  Specifically:                 Type mismatch between
test/proof002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ test030.idr --check --nocolour-idris --consolewidth 80 $@ test030a.idr --check --nocolour+${IDRIS:-idris} $@ test030.idr --check --nocolour+${IDRIS:-idris} $@ test030a.idr --check --nocolour rm -f *.ibc
test/proof002/test030.idr view
@@ -10,4 +10,3 @@ testReflect1 : (xs, ys : List a) ->                ((xs ++ (x :: ys ++ xs)) = ((xs ++ [x]) ++ (ys ++ xs))) testReflect1 {a} xs ys = AssocProof a-
test/proof003/Parity.idr view
@@ -1,5 +1,7 @@ module Parity +%access public export+ data Parity : Nat -> Type where     Even : {n : Nat} -> Parity (n + n)     Odd  : {n : Nat} -> Parity (S (n + n))
test/proof003/expected view
@@ -1,6 +1,6 @@-Parity.idr:15:18-23:+Parity.idr:17:18-23: This style of tactic proof is deprecated. See %runElab for the replacement.-Parity.idr:22:18-23:+Parity.idr:24:18-23: This style of tactic proof is deprecated. See %runElab for the replacement. test015.idr:88:15-20: This style of tactic proof is deprecated. See %runElab for the replacement.
test/proof003/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test015.idr --nocolour --consolewidth 80 -o test015+${IDRIS:-idris} $@ test015.idr --nocolour -o test015 ./test015 rm -f test015 Parity.ibc test015.ibc
test/proof004/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --check $@ test035.idr+${IDRIS:-idris} --check $@ test035.idr rm -f *.ibc
test/proof005/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --check $@ DefaultArgSubstitutionSuccess.idr+${IDRIS:-idris} --check $@ DefaultArgSubstitutionSuccess.idr rm -f *.ibc
test/proof006/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --check $@ DefaultArgSubstitutionSyntax.idr+${IDRIS:-idris} --check $@ DefaultArgSubstitutionSyntax.idr rm -f *.ibc
test/proof007/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --nocolour --consolewidth 80 --check $@ DefaultArgUnknownName.idr+${IDRIS:-idris} --nocolour --check $@ DefaultArgUnknownName.idr rm -f *.ibc
test/proof008/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --nocolour --consolewidth 80 --check $@ ClaimAndUnfocus.idr+${IDRIS:-idris} --nocolour --check $@ ClaimAndUnfocus.idr rm -f *.ibc
test/proof009/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --consolewidth 70 --quiet proof009.idr < input+${IDRIS:-idris} $@ --consolewidth 70 --quiet proof009.idr < input rm -f *.ibc
test/proof010/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ proof010.idr -o proof010+${IDRIS:-idris} $@ proof010.idr -o proof010 ./proof010 rm -f proof010 *.ibc
test/proofsearch001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --check proofsearch001.idr+${IDRIS:-idris} $@ --check proofsearch001.idr rm -f *.ibc
test/proofsearch002/Process.idr view
@@ -3,7 +3,7 @@ import System.Concurrency.Raw import public Data.List -- public, to get proof search machinery -%access public+%access public export  -- Process IDs are parameterised by their interface. A request of type -- 'iface t' will get a response of type 't'
test/proofsearch002/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --check proofsearch002.idr+${IDRIS:-idris} $@ --check proofsearch002.idr rm -f *.ibc
test/proofsearch003/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --check proofsearch003.idr +${IDRIS:-idris} --check proofsearch003.idr  rm -f *.ibc
test/pruviloj001/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ -p pruviloj --check --nocolour --consolewidth 70 pruviloj001.idr+${IDRIS:-idris} $@ -p pruviloj --check --nocolour --consolewidth 70 pruviloj001.idr rm -f *.ibc
test/quasiquote001/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ QuasiquoteBasics.idr -o quasiquote001+${IDRIS:-idris} $@ QuasiquoteBasics.idr -o quasiquote001 ./quasiquote001 rm -f quasiquote001 *.ibc
test/quasiquote002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ GoalQQuote.idr -o quasiquote002+${IDRIS:-idris} $@ GoalQQuote.idr -o quasiquote002 ./quasiquote002 rm -f quasiquote002 *.ibc
test/quasiquote003/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ --check NoInfer.idr+${IDRIS:-idris} $@ --check NoInfer.idr rm -f *.ibc
test/quasiquote004/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ --check --nocolour Quasiquote004.idr+${IDRIS:-idris} $@ --check --nocolour Quasiquote004.idr rm -f *.ibc
test/quasiquote005/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --check --nocolour Quasiquote005.idr+${IDRIS:-idris} $@ --check --nocolour Quasiquote005.idr rm -f *.ibc
test/quasiquote006/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --check --nocolour --quiet --consolewidth 70 quasiquote006.idr+${IDRIS:-idris} $@ --check --nocolour --quiet --consolewidth 70 quasiquote006.idr rm -f *.ibc
test/records001/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test011.idr -o test011+${IDRIS:-idris} $@ test011.idr -o test011 ./test011 rm -f test011 test011.ibc
test/records002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ record002.idr -o record002+${IDRIS:-idris} $@ record002.idr -o record002 ./record002 rm -f record002 *.ibc
test/records003/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ records003.idr -o records003+${IDRIS:-idris} $@ records003.idr -o records003 ./records003 rm -f records003 *.ibc
test/reg001/reg001.idr view
@@ -37,7 +37,7 @@              **              ((a ** believe_me Oh)               ::-              (fst (getProof (filterTagP p as (believe_me Oh)))),+              (fst (snd (filterTagP p as (believe_me Oh)))),               Oh              )             )@@ -95,7 +95,7 @@  using (A : Type, B : A->Type, C : Type)   foo2 : ((x:A) -> B x -> C) -> ((x:A ** B x) -> C)-  foo2 f p = f (getWitness p) (getProof p)+  foo2 f p = f (fst p) (snd p)   m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) ->@@ -144,7 +144,7 @@ X t = (c : Nat ** So (c < 5))  column : X t -> Nat-column = getWitness+column = fst  data Action = Left | Ahead | Right @@ -161,31 +161,31 @@ isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)  interface Set univ => HasPower univ where-  Powerset : (a : univ) -> -             Sigma univ (\Pa => (c : univ) ->+  Powerset : (a : univ) ->+             DPair univ (\Pa => (c : univ) ->                                  (isSubsetOf c a) -> member c Pa)  powerset : HasPower univ => univ -> univ-powerset {univ} a = getWitness (Powerset a)+powerset {univ} a = fst (Powerset a)  mapFilter : (alpha -> beta) ->-           (alpha -> Bool) -> -           Vect n alpha -> +           (alpha -> Bool) ->+           Vect n alpha ->            (n : Nat ** Vect n beta) mapFilter f p Nil = (_ ** Nil) mapFilter f p (a :: as) with (p a)- | True  = (_  ** (f a) :: (getProof (mapFilter f p as)))+ | 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 -  +foom = pure+ bar : IO () bar = case foom 5 of            Nothing => print 42@@ -193,7 +193,7 @@  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 @@ -207,4 +207,3 @@ kappa : Kappa (rho r) -> Kappa (rho r) kappa {r} k = k' where -- k' : Kappa (rho r)                        k' = k-
test/reg001/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris reg001.idr --check+${IDRIS:-idris} reg001.idr --check rm -rf reg001.ibc
test/reg002/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris reg012.idr -o reg012+${IDRIS:-idris} reg012.idr -o reg012 ./reg012 rm -f reg012 *.ibc
test/reg003/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris --consolewidth 80 --check reg003.idr-idris --consolewidth 80 --check reg003a.idr+${IDRIS:-idris} --check reg003.idr+${IDRIS:-idris} --check reg003a.idr rm -f *.ibc
test/reg004/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg004.idr -o reg004+${IDRIS:-idris} $@ reg004.idr -o reg004 ./reg004 rm -f reg004 *.ibc
+ test/reg005/expected view
@@ -0,0 +1,3 @@+hey+you+[(), ()]
+ test/reg005/reg005.idr view
@@ -0,0 +1,9 @@+module UPIO++foo : List (IO ())+foo = [putStrLn "hey", putStrLn "you"]++namespace Main+  main : IO ()+  main = let stuff = map unsafePerformIO foo in putStrLn (show stuff)+
+ test/reg005/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+${IDRIS:-idris} $@ reg005.idr -o reg005+./reg005+rm -f reg005 *.ibc
test/reg006/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ reg006.idr --check+${IDRIS:-idris} $@ reg006.idr --check rm -f *.ibc
test/reg007/A.lidr view
@@ -1,5 +1,5 @@ > module A -> n : Nat+> public export n : Nat > n = ?lala
test/reg007/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 --nocolour --check $@ reg007.lidr+${IDRIS:-idris} --nocolour --check $@ reg007.lidr rm -f *.ibc
test/reg010/run view
@@ -1,2 +1,2 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ reg010.idr --check --nocolour+${IDRIS:-idris} $@ reg010.idr --check --nocolour
test/reg013/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg013.idr -o reg013+${IDRIS:-idris} $@ reg013.idr -o reg013 ./reg013 rm -f reg013 *.ibc
test/reg016/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg016.idr -o reg016+${IDRIS:-idris} $@ reg016.idr -o reg016 ./reg016 rm -f reg016 *.ibc
test/reg017/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ --nocolour --consolewidth 80 reg017.idr -o reg017+${IDRIS:-idris} $@ --nocolour reg017.idr -o reg017 ./reg017 rm -f reg017 *.ibc
test/reg018/expected view
@@ -4,6 +4,8 @@ conat.loopForever is possibly not total due to: conat.minusCoNat reg018b.idr:8:1: A.showB is possibly not total due to recursive path A.showB+reg018b.idr:11:1:+A.B implementation of Prelude.Show.Show is possibly not total due to: A.showB reg018c.idr:21:1: CodataTest.inf is possibly not total due to: with block in CodataTest.inf reg018d.idr:8:1:
test/reg018/reg018b.idr view
@@ -8,7 +8,7 @@ showB (I x) = "I" ++ showB x showB (Z x) = "Z" ++ showB x -implementation Show B where show = showB+Show B where show = showB  os : B os = Z os
test/reg018/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ reg018a.idr --check-idris --consolewidth 80 $@ reg018b.idr --check-idris --consolewidth 80 $@ reg018c.idr --check-idris --consolewidth 80 $@ reg018d.idr --check+${IDRIS:-idris} $@ reg018a.idr --check+${IDRIS:-idris} $@ reg018b.idr --check+${IDRIS:-idris} $@ reg018c.idr --check+${IDRIS:-idris} $@ reg018d.idr --check rm *.ibc
test/reg020/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg020.idr -o reg020+${IDRIS:-idris} $@ reg020.idr -o reg020 ./reg020 rm -f reg020 *.ibc
test/reg023/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --nocolour --consolewidth 80 $@ reg023.idr --check+${IDRIS:-idris} --nocolour $@ reg023.idr --check rm -f *.ibc
test/reg024/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg024.idr -o reg024+${IDRIS:-idris} $@ reg024.idr -o reg024 ./reg024 rm -f reg024 *.ibc
test/reg025/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg025.idr -o reg025+${IDRIS:-idris} $@ reg025.idr -o reg025 ./reg025 rm -f reg025 *.ibc
test/reg027/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ reg027.idr -o reg027+${IDRIS:-idris} $@ reg027.idr -o reg027 ./reg027-idris --consolewidth 80 $@ reg027a.idr --check+${IDRIS:-idris} $@ reg027a.idr --check rm -f reg027 *.ibc
test/reg028/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ reg028.idr --check-idris --consolewidth 80 $@ reg028a.idr --check+${IDRIS:-idris} $@ reg028.idr --check+${IDRIS:-idris} $@ reg028a.idr --check rm -f *.ibc
test/reg029/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -idris $@ reg029.idr -o reg029+${IDRIS:-idris} $@ reg029.idr -o reg029 unset IDRIS_REG029_NONEXISTENT_VAR export IDRIS_REG029_EXISTENT_VAR='exists!' @@ -12,6 +12,6 @@   javac -cp reg029:. Reg029Wrapper.java   java -cp reg029:. Reg029Wrapper fi-idris $@ reg029.idr --execute+${IDRIS:-idris} $@ reg029.idr --execute rm -f reg029 *.ibc *.class
test/reg031/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg031.idr -o reg031+${IDRIS:-idris} $@ reg031.idr -o reg031 ./reg031 rm -f *.ibc reg031
test/reg032/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ test028.idr -o test028+${IDRIS:-idris} $@ test028.idr -o test028 ./test028 rm -f test028 test028.ibc
test/reg034/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --nocolour --consolewidth 80 --check reg034.idr+${IDRIS:-idris} --nocolour --check reg034.idr rm -f reg034 *.ibc
test/reg035/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris --nocolour --consolewidth 80 --check reg035.idr-idris --nocolour --consolewidth 80 --check reg035a.lidr-idris --nocolour --consolewidth 80 --check reg035b.idr+${IDRIS:-idris} --nocolour --check reg035.idr+${IDRIS:-idris} --nocolour --check reg035a.lidr+${IDRIS:-idris} --nocolour --check reg035b.idr rm -f *.ibc
test/reg036/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --check reg036.idr+${IDRIS:-idris} --check reg036.idr rm -f reg036 *.ibc
test/reg037/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --check reg037.idr+${IDRIS:-idris} --check reg037.idr rm -f reg037 *.ibc
test/reg038/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --check reg038.idr+${IDRIS:-idris} --check reg038.idr rm -f *.ibc
test/reg040/run view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -idris --warnreach reg040.idr -o reg040+${IDRIS:-idris} --warnreach reg040.idr -o reg040 ./reg040  rm -f reg040 *.ibc
test/reg041/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris $@ --quiet ott.idr -e example-idris $@ showu.idr -o reg040+${IDRIS:-idris} $@ --quiet ott.idr -e example+${IDRIS:-idris} $@ showu.idr -o reg040 ./reg040 rm -f reg040 *.ibc
test/reg042/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg042 -o reg042 --warnreach+${IDRIS:-idris} $@ reg042 -o reg042 --warnreach ./reg042 rm -f reg042 *.ibc
test/reg044/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --nocolour --consolewidth 80 reg044.idr --check+${IDRIS:-idris} --nocolour reg044.idr --check rm -f *.ibc
test/reg045/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg045.idr -o reg045+${IDRIS:-idris} $@ reg045.idr -o reg045 ./reg045 rm -f reg045 *.ibc
test/reg046/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg046.idr --check+${IDRIS:-idris} $@ reg046.idr --check rm -f reg046 *.ibc
test/reg047/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg047.idr --check --nobuiltins-idris $@ reg047a.idr --check+${IDRIS:-idris} $@ reg047.idr --check --nobuiltins+${IDRIS:-idris} $@ reg047a.idr --check rm -f *.ibc
test/reg048/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg048.idr -p contrib -o reg048+${IDRIS:-idris} $@ reg048.idr -p contrib -o reg048 ./reg048 rm -f reg048 *.ibc
test/reg049/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 --nocolour --check $@ reg049.idr+${IDRIS:-idris} --nocolour --check $@ reg049.idr rm -f *.ibc
test/reg050/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris --nocolour --check $@ working.idr-idris --nocolour --check $@ badbangop.idr-idris --nocolour --check $@ baddoublebang.idr+${IDRIS:-idris} --nocolour --check $@ working.idr+${IDRIS:-idris} --nocolour --check $@ badbangop.idr+${IDRIS:-idris} --nocolour --check $@ baddoublebang.idr rm -f *.ibc
test/reg051-disabled/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg051.idr --check+${IDRIS:-idris} $@ reg051.idr --check rm -f *.ibc
test/reg052/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ -o reg052 reg052.idr+${IDRIS:-idris} $@ -o reg052 reg052.idr ./reg052 rm -f reg052 *.ibc
test/reg053/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ --check four.idr +${IDRIS:-idris} $@ --check four.idr  rm -f *.ibc
test/reg054/run view
@@ -1,2 +1,2 @@ #!/usr/bin/env bash-idris --nocolour --consolewidth 80 $@ reg054.idr --check+${IDRIS:-idris} --nocolour $@ reg054.idr --check
test/reg055/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris --nocolour --consolewidth 80 $@ reg055.idr --check-idris --nocolour --consolewidth 80 $@ reg055a.idr --check+${IDRIS:-idris} --nocolour $@ reg055.idr --check+${IDRIS:-idris} --nocolour $@ reg055a.idr --check rm -f *.ibc
test/reg056/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris --consolewidth 80 $@ reg056.idr -o reg056+${IDRIS:-idris} $@ reg056.idr -o reg056 rm -f *.ibc
test/reg057/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg057.idr --check+${IDRIS:-idris} $@ reg057.idr --check rm -f *.ibc
test/reg058/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-idris $@ implicits.idr --check-idris $@ implicits2.idr --check+${IDRIS:-idris} $@ implicits.idr --check+${IDRIS:-idris} $@ implicits2.idr --check  rm -f *.ibc
test/reg059/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg059.idr --check+${IDRIS:-idris} $@ reg059.idr --check rm -f *.ibc
test/reg060/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg060.idr --check+${IDRIS:-idris} $@ reg060.idr --check rm -f *.ibc
test/reg061/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ Capture.idr --check+${IDRIS:-idris} $@ Capture.idr --check rm -f *.ibc
test/reg062/run view
@@ -1,4 +1,4 @@ #!/usr/bin/env bash-idris $@ reg062.idr --check --nocolour-idris $@ reg062.lidr --check --nocolour+${IDRIS:-idris} $@ reg062.idr --check --nocolour+${IDRIS:-idris} $@ reg062.lidr --check --nocolour rm -f *.ibc
test/reg063/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ Cmp.idr --check --nocolour --quiet+${IDRIS:-idris} $@ Cmp.idr --check --nocolour --quiet rm *.ibc
test/reg064/reg064.idr view
@@ -1,9 +1,8 @@-sigmaEq2 : {A : Type} -> -           {P : A -> Type} -> -           {s1: Sigma A P} -> -           {s2: Sigma A P} ->-           getWitness s1 = getWitness s2 ->-           getProof s1 = getProof s2 ->+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 view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg064.idr --check+${IDRIS:-idris} $@ reg064.idr --check rm -f *.ibc
test/reg065/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg065.idr --check+${IDRIS:-idris} $@ reg065.idr --check rm -f *.ibc
test/reg066/run view
@@ -1,3 +1,3 @@ #!/usr/bin/env bash-idris $@ reg066.idr --check --nocolor+${IDRIS:-idris} $@ reg066.idr --check --nocolor rm -f *.ibc
test/reg067/run view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash rm -f *.ibc reg067-idris $@ reg067.idr -o reg067 --warnreach+${IDRIS:-idris} $@ reg067.idr -o reg067 --warnreach ./reg067 rm -f *.ibc reg067
+ test/reg068/expected view
@@ -0,0 +1,7 @@+reg068.idr:1:6:+Main.nat has a name which may be implicitly bound.+This is likely to lead to problems!+reg068.idr:2:6:Main.ze has a name which may be implicitly bound.+This is likely to lead to problems!+reg068.idr:2:6:When checking constructor Main.ze:+Type level variable nat is not Main.nat
+ test/reg068/reg068.idr view

file too large to diff

+ test/reg068/run view

file too large to diff

+ test/reg069/Mod.idr view

file too large to diff

+ test/reg069/expected view

file too large to diff

+ test/reg069/reg069.idr view

file too large to diff

+ test/reg069/run view

file too large to diff

+ test/reg070/expected view

file too large to diff

+ test/reg070/reg070.idr view

file too large to diff

+ test/reg070/run view

file too large to diff

+ test/runtest.hs view

file too large to diff

− test/runtest.pl

file too large to diff

test/sourceLocation001/run view

file too large to diff

test/sugar001/run view

file too large to diff

test/sugar002/run view

file too large to diff

test/sugar003/run view

file too large to diff

test/sugar004/run view

file too large to diff

test/sugar005/run view

file too large to diff

test/syntax001/expected view

file too large to diff

test/syntax001/run view

file too large to diff

test/syntax002/run view

file too large to diff

test/tactics001/run view

file too large to diff

test/totality001/run view

file too large to diff

test/totality002/run view

file too large to diff

test/totality003/run view

file too large to diff

test/totality004/run view

file too large to diff

test/totality005/run view

file too large to diff

test/totality006/run view

file too large to diff

test/totality007/run view

file too large to diff

test/totality008/run view

file too large to diff

test/totality009/run view

file too large to diff

test/totality010/run view

file too large to diff

+ test/totality011/expected view

file too large to diff

+ test/totality011/run view

file too large to diff

+ test/totality011/totality011.lidr view

file too large to diff

test/tutorial001/run view

file too large to diff

test/tutorial002/run view

file too large to diff

test/tutorial003/run view

file too large to diff

test/tutorial004/run view

file too large to diff

test/tutorial005/run view

file too large to diff

test/tutorial006/expected view

file too large to diff

test/tutorial006/run view

file too large to diff

test/unique001/run view

file too large to diff

test/unique001/unique001c.idr view

file too large to diff

test/unique002/run view

file too large to diff

test/unique003/run view

file too large to diff