packages feed

idris 0.9.20.2 → 0.10

raw patch · 185 files changed

+1728/−1505 lines, 185 filesdep +asyncdep +fsnotifydep ~optparse-applicativesetup-changed

Dependencies added: async, fsnotify

Dependency ranges changed: optparse-applicative

Files

CHANGELOG view
@@ -1,3 +1,18 @@+New in 0.10:+============++* 'class' and 'instance' are now deprecated keywords. They have been+  replaced by 'interface' and 'implementation' respectively. This is to+  properly reflect their purpose.+* (/) operator moved into new Fractional interface.+* Idris' logging infrastructure has been categorised. Command line and repl+  are available. For command line the option `--logging-categories CATS`+  is used to pass in the categories. Here `CATS` is a colon separated quoted+  string containing the categories to log. The REPL command is `logcats CATS`.+  Where `CATS` is a whitespace separated list of categoriese. Default is for+  all categories to be logged.+* New flag `--listlogcats` to list logging categories.`+ New in 0.9.20: ============== @@ -19,7 +34,7 @@ * Name binding in patterns follows the same rule as name binding for implicits   in types: names which begin with lower case letters, not applied to any   arguments, are treated as bound pattern variables.-* Added %deprecate directive, which gives a warning and a message when a +* Added %deprecate directive, which gives a warning and a message when a   deprecated name is referenced.  Library updates@@ -39,7 +54,7 @@   from Effectful programs. * Some constructors that never actually occurred have been removed from   the TT and Raw reflection datatypes in Language.Reflection.-* File IO operations (for example openFile/fread/fwrite) now return +* File IO operations (for example openFile/fread/fwrite) now return   'Either FileError ty' where the return type was previously 'ty' to indicate   that they may fail.
CONTRIBUTORS view
@@ -11,6 +11,7 @@ Alyssa Carter David Raymond Christiansen Carter Charbonneau+Aaron Craelius Jason Dagit Guglielmo Fachini Simon Fowler
Makefile view
@@ -36,6 +36,9 @@ 	$(MAKE) test_llvm 	$(MAKE) test_java +test_timed:+	$(MAKE) -C test IDRIS=../dist/build/idris time+ lib_clean: 	$(MAKE) -C libs IDRIS=../../dist/build/idris/idris RTS=../../dist/build/rts/libidris_rts clean
Setup.hs view
@@ -53,7 +53,7 @@   case lookup (FlagName "gmp") (S.configConfigurationsFlags flags) of     Just True -> True     Just False -> False-    Nothing -> True+    Nothing -> False  execOnly :: S.ConfigFlags -> Bool execOnly flags =
benchmarks/fasta/fasta.idr view
@@ -1,7 +1,6 @@ module Main  import System-import Data.Floats  alu : String alu = "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG\@@ -9,12 +8,12 @@     \CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC\     \GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA" -iub : List (Char, Float)+iub : List (Char, Double) iub = [('a',0.27),('c',0.12),('g',0.12),('t',0.27),('B',0.02)       ,('D',0.02),('H',0.02),('K',0.02),('M',0.02),('N',0.02)       ,('R',0.02),('S',0.02),('V',0.02),('W',0.02),('Y',0.02)] -homosapiens : List (Char, Float)+homosapiens : List (Char, Double) homosapiens = [('a',0.3029549426680),('c',0.1979883004921)               ,('g',0.1975473066391),('t',0.3015094502008)] @@ -30,10 +29,10 @@ splitAt' n s = let s' = unpack s in (pack $ take n s', pack $ drop n s')  writeAlu : String -> String -> IO ()-writeAlu name s0 = putStrLn name $> go s0+writeAlu name s0 = putStrLn name *> go s0   where     go "" = return ()-    go s  = let (h,t) = splitAt' 60 s in putStrLn h $> go t+    go s  = let (h,t) = splitAt' 60 s in putStrLn h *> go t  replicate : Int -> Char -> String replicate 0 c = ""@@ -44,10 +43,10 @@                         []    => []                         x::xs => scanl f (f q x) xs) -accum : (Char,Float) -> (Char,Float) -> (Char,Float)+accum : (Char,Double) -> (Char,Double) -> (Char,Double) accum (_,p) (c,q) = (c,p+q) -make : String -> Int -> List (Char, Float) -> Int -> IO Int+make : String -> Int -> List (Char, Double) -> Int -> IO Int make name n0 tbl seed0 = do     putStrLn name     make' n0 0 seed0 ""@@ -55,7 +54,7 @@     modulus : Int     modulus = 139968 -    fill : List (Char,Float) -> Int -> List String+    fill : List (Char,Double) -> Int -> List String     fill ((c,p) :: cps) j =       let k = min modulus (cast (cast modulus * p + 1))       in replicate (k - j) c :: fill cps k@@ -65,13 +64,13 @@     lookupTable = Foldable.concat (fill (scanl accum ('a',0) tbl) 0)      make' : Int -> Int -> Int -> String -> IO Int-    make' 0 col seed buf = when (col > 0) (putStrLn buf) $> return seed+    make' 0 col seed buf = when (col > 0) (putStrLn buf) *> return seed     make' n col seed buf = do       let newseed  = modInt (seed * 3877 + 29573) modulus       let nextchar = strIndex lookupTable newseed       let newbuf   = buf <+> singleton nextchar       if col+1 >= 60-        then putStrLn newbuf $> make' (n-1) 0 newseed ""+        then putStrLn newbuf *> make' (n-1) 0 newseed ""         else make' (n-1) (col+1) newseed newbuf
benchmarks/pidigits/pidigits.idr view
@@ -1,18 +1,19 @@ import System+import Data.Vect  {- Toy program that outputs the n first digits of Pi. -   Inspired from http://www.haskell.org/haskellwiki/Shootout/Pidigits. +   Inspired from http://www.haskell.org/haskellwiki/Shootout/Pidigits.    The original ns and str lazy lists have been replaced by strict functions. -   Memory usage seems to be excessive. One of the branches of str is tail recursive, and +   Memory usage seems to be excessive. One of the branches of str is tail recursive, and    the other one only needs to cons an extra Integer. -   For reference, the Haskell version runs in 0m0.230s when printing to /dev/null. +   For reference, the Haskell version runs in 0m0.230s when printing to /dev/null.    It almost runs in constant space. -} -data F = mkF Integer Integer Integer+data F = MkF Integer Integer Integer  -- Prints the list of digits by groups of 10 loop : Nat -> Nat -> List Integer -> IO()@@ -23,19 +24,19 @@                            loop k (S k') xs  fn : Integer -> F-fn k = mkF k (4*k+2) (2*k+1)+fn k = MkF k (4*k+2) (2*k+1)  flr : Integer -> F -> Integer-flr x (mkF q r t) = (q*x + r) `div` t+flr x (MkF q r t) = (q*x + r) `div` t  comp : F -> F -> F-comp (mkF q r t) (mkF u v x) = mkF (q*u) (q*v+r*x) (t*x)+comp (MkF q r t) (MkF u v x) = MkF (q*u) (q*v+r*x) (t*x)  -- Returns the list of digits of pi. Memory hungry. str : F -> Integer -> Nat -> List Integer str _ _ Z     = Nil str z k (S n) = if(y == flr 4 z)-                   then y :: str (comp (mkF 10 (-10*y) 1) z    ) k     n+                   then y :: str (comp (MkF 10 (-10*y) 1) z    ) k     n                    else      str (comp z                 (fn k)) (k+1) (S n)   where y = flr 3 z @@ -43,10 +44,9 @@ pidigit = do   [_,a] <- getArgs   let n = fromIntegerNat (the Integer (cast a))-  let l = str (mkF 1 0 1) 1 n+  let l = str (MkF 1 0 1) 1 n   loop 10 0 l   return ()  main : IO () main = pidigit-
benchmarks/quasigroups/Main.idr view
@@ -10,15 +10,18 @@   case args of     [_, path] => do       f <- readFile path-      case parse f of-        Left err => putStrLn err-        Right (_ ** (board ** legal)) => do-          putStrLn "Got board:"-          printLn board-          putStrLn "Solving..."-          case fillBoard board legal of-            Nothing => putStrLn "No solution found"-            Just (solved ** _) => do-              putStrLn "Solution found:"-              printLn solved+      case f of+        Left _err => putStrLn $ "Error reading file: " ++ path+        Right f' =>+          case parse f' of+            Left err => putStrLn err+            Right (_ ** (board ** legal)) => do+              putStrLn "Got board:"+              printLn board+              putStrLn "Solving..."+              case fillBoard board legal of+                Nothing => putStrLn "No solution found"+                Just (solved ** _) => do+                  putStrLn "Solution found:"+                  printLn solved     [self] => putStrLn ("Usage: " ++ self ++ " <board file>")
benchmarks/quasigroups/Parser.idr view
@@ -1,6 +1,7 @@ module Parser  import Decidable.Equality+import Data.Vect  import Solver @@ -61,9 +62,9 @@     step : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k)     step i l =       let cs = fromList (words (index i rs)) in-      case decEq (length cs) (S k) of+      case decEq (Parser.length cs) (S k) of         No _  => Left "Row length not equal to column height"-        Yes prf => let foo = (replace {P=\n => Vect n String} prf cs) in parseCols i l foo -- TODO: foo shouldn't be needed+        Yes prf => parseCols i l (replace {P=\n => Vect n String} prf cs)      helper : {b : Board (S k)} -> Fin (S k) -> LegalBoard b -> Parser (S k)     helper FZ l = step FZ l
benchmarks/quasigroups/Solver.idr view
@@ -2,6 +2,7 @@  import Decidable.Equality import Control.Monad.State+import Data.Vect import Data.Vect.Quantifiers  %default total@@ -95,7 +96,7 @@       case colSafe b x v of         No prf' => No (\(_, cf, _) => prf' cf)         Yes prf' =>-          case empty (getCell b (x, y)) of+          case Solver.empty (getCell b (x, y)) of             No prf'' => No (\(ef, _, _) => prf'' ef)             Yes prf'' => Yes (prf'', prf', prf) @@ -194,7 +195,7 @@      %assert_total     recurse : Fin (S n) -> Maybe (b' : Board (S n) ** CompleteBoard b')-    recurse start = +    recurse start =       case tryAll start of         (_, Nothing) => Nothing         (FZ, Just (b' ** l')) => fillBoard b' l'
benchmarks/trivial/sortvec.idr view
@@ -1,7 +1,9 @@ module Main  import System+import Effects import Effect.Random+import Data.Vect  total insert : Ord a => a -> Vect n a -> Vect (S n) a@@ -12,13 +14,12 @@ vsort [] = [] vsort (x :: xs) = insert x (vsort xs) -mkSortVec : (n : Nat) -> Eff m [RND] (Vect n Int)+mkSortVec : (n : Nat) -> Eff (Vect n Int) [RND] mkSortVec Z = return [] mkSortVec (S k) = return (fromInteger !(rndInt 0 10000) :: !(mkSortVec k))  main : IO () main = do (_ :: arg :: _) <- getArgs---           let arg = "2000"-          let vec = runPure [123456789] (mkSortVec (fromInteger (cast arg)))+          let vec = runPure $ (srand 123456789 *> mkSortVec (fromInteger (cast arg)))           putStrLn "Made vector"           printLn (vsort vec)
config.mk view
@@ -20,28 +20,20 @@ MACHINE         := $(shell $(CC) -dumpmachine) ifneq (, $(findstring darwin, $(MACHINE))) 	OS      :=darwin-else-ifneq (, $(findstring cygwin, $(MACHINE)))+else ifneq (, $(findstring cygwin, $(MACHINE))) 	OS      :=windows-else-ifneq (, $(findstring mingw, $(MACHINE)))+else ifneq (, $(findstring mingw, $(MACHINE))) 	OS      :=windows-else-ifneq (, $(findstring windows, $(MACHINE)))+else ifneq (, $(findstring windows, $(MACHINE))) 	OS      :=windows else 	OS      :=unix endif-endif-endif-endif  ifeq ($(OS),darwin) 	SHLIB_SUFFIX    :=.dylib-else-ifeq ($(OS),windows)+else ifeq ($(OS),windows) 	SHLIB_SUFFIX    :=.DLL else 	SHLIB_SUFFIX    :=.so-endif endif
idris.cabal view
@@ -1,5 +1,5 @@ Name:           idris-Version:        0.9.20.2+Version:        0.10 License:        BSD3 License-file:   LICENSE Author:         Edwin Brady@@ -18,12 +18,12 @@                 <http://www.idris-lang.org/documentation>.                 Features include:                 .-                * Full dependent types with dependent pattern matching+                * Full, first class, dependent types with dependent pattern matching                 .-                * where clauses, with rule, simple case expressions,+                * where clauses, with rule, case expressions,                   pattern matching let and lambda bindings                 .-                * Type classes, monad comprehensions+                * Interfaces (similar to type classes), monad comprehensions                 .                 * do notation, idiom brackets, syntactic conveniences for lists,                   tuples, dependent pairs@@ -34,8 +34,6 @@                 .                 * Indentation significant syntax, extensible syntax                 .-                * Tactic based theorem proving (influenced by Coq)-                .                 * Cumulative universes                 .                 * Simple foreign function interface (to C)@@ -962,7 +960,7 @@                 , haskeline >= 0.7 && < 0.8                 , mtl >= 2.1 && < 2.3                 , network < 2.7-                , optparse-applicative >= 0.11 && < 0.12+                , optparse-applicative >= 0.11 && < 0.13                 , parsers >= 0.9 && < 0.13                 , pretty < 1.2                 , process < 1.3@@ -979,6 +977,8 @@                 , vector-binary-instances < 0.3                 , zip-archive > 0.2.3.5 && < 0.2.4                 , safe+                , fsnotify < 2.2+                , async < 2.1   -- zlib >= 0.6.1 is broken with GHC < 7.10.3   if impl(ghc < 7.10.3)      build-depends: zlib < 0.6.1
libs/base/Control/Arrow.idr view
@@ -11,7 +11,7 @@ infixr 2 +++ infixr 2 \|/ -class Category arr => Arrow (arr : Type -> Type -> Type) where+interface Category arr => Arrow (arr : Type -> Type -> Type) where   arrow  : (a -> b) -> arr a b   first  : arr a b -> arr (a, c) (b, c) @@ -26,14 +26,14 @@     dup : x -> (x,x)     dup x = (x,x) -instance Arrow Morphism where+implementation Arrow Morphism where   arrow  f            = Mor f   first  (Mor f)      = Mor $ \(a, b) => (f a, b)   second (Mor f)      = Mor $ \(a, b) => (a, f b)   (Mor f) *** (Mor g) = Mor $ \(a, b) => (f a, g b)   (Mor f) &&& (Mor g) = Mor $ \a => (f a, g a) -instance Monad m => Arrow (Kleislimorphism m) where+implementation Monad m => Arrow (Kleislimorphism m) where   arrow f = Kleisli (return . f)   first (Kleisli f) =  Kleisli $ \(a, b) => do x <- f a                                                return (x, b)@@ -49,13 +49,13 @@                                                    y <- g a                                                    return (x, y) -class Arrow arr => ArrowZero (arr : Type -> Type -> Type) where+interface Arrow arr => ArrowZero (arr : Type -> Type -> Type) where   zeroArrow : arr a b -class ArrowZero arr => ArrowPlus (arr : Type -> Type -> Type) where+interface ArrowZero arr => ArrowPlus (arr : Type -> Type -> Type) where   (<++>) : arr a b -> arr a b -> arr a b -class Arrow arr => ArrowChoice (arr : Type -> Type -> Type) where+interface Arrow arr => ArrowChoice (arr : Type -> Type -> Type) where   left  : arr a b -> arr (Either a c) (Either b c)    right : arr a b -> arr (Either c a) (Either c b)@@ -67,16 +67,16 @@   (\|/) : arr a b -> arr c b -> arr (Either a c) b   f \|/ g = f +++ g >>> arrow fromEither -instance Monad m => ArrowChoice (Kleislimorphism m) where+implementation Monad m => ArrowChoice (Kleislimorphism m) where   left f                      = f          +++ (arrow id)   right f                     = (arrow id) +++ f   f           +++ g           = (f >>> (arrow Left)) \|/ (g >>> (arrow Right))   (Kleisli f) \|/ (Kleisli g) = Kleisli (either f g) -class Arrow arr => ArrowApply (arr : Type -> Type -> Type) where+interface Arrow arr => ArrowApply (arr : Type -> Type -> Type) where   app : arr (arr a b, a) b -instance Monad m => ArrowApply (Kleislimorphism m) where+implementation Monad m => ArrowApply (Kleislimorphism m) where   app = Kleisli $ \(Kleisli f, x) => f x  data ArrowMonad : (Type -> Type -> Type) -> Type -> Type where@@ -85,16 +85,16 @@ runArrowMonad : ArrowMonad arr a -> arr (the Type ()) a runArrowMonad (MkArrowMonad a) = a -instance Arrow a => Functor (ArrowMonad a) where+implementation Arrow a => Functor (ArrowMonad a) where   map f (MkArrowMonad m) = MkArrowMonad $ m >>> arrow f -instance Arrow a => Applicative (ArrowMonad a) where+implementation Arrow a => Applicative (ArrowMonad a) where   pure x = MkArrowMonad $ arrow $ \_ => x   (MkArrowMonad f) <*> (MkArrowMonad x) = MkArrowMonad $ f &&& x >>> arrow (uncurry id) -instance ArrowApply a => Monad (ArrowMonad a) where+implementation ArrowApply a => Monad (ArrowMonad a) where   (MkArrowMonad m) >>= f =     MkArrowMonad $ m >>> (arrow $ \x => (runArrowMonad (f x), ())) >>> app -class Arrow arr => ArrowLoop (arr : Type -> Type -> Type) where+interface Arrow arr => ArrowLoop (arr : Type -> Type -> Type) where   loop : arr (Pair a c) (Pair b c) -> arr a b
libs/base/Control/Catchable.idr view
@@ -2,30 +2,30 @@  import Control.IOExcept -class Catchable (m : Type -> Type) t where+interface Catchable (m : Type -> Type) t where     throw : t -> m a     catch : m a -> (t -> m a) -> m a -instance Catchable Maybe () where+implementation Catchable Maybe () where     catch Nothing  h = h ()     catch (Just x) h = Just x      throw () = Nothing -instance Catchable (Either a) a where+implementation Catchable (Either a) a where     catch (Left err) h = h err     catch (Right x)  h = (Right x)      throw = Left -instance Catchable (IOExcept err) err where+implementation Catchable (IOExcept err) err where     catch (IOM prog) h = IOM (do p' <- prog                                  case p' of                                       Left e => let IOM he = h e in he                                       Right val => return (Right val))     throw = ioe_fail -instance Catchable List () where+implementation Catchable List () where     catch [] h = h ()     catch xs h = xs
libs/base/Control/Category.idr view
@@ -4,17 +4,17 @@  %access public -class Category (cat : Type -> Type -> Type) where+interface Category (cat : Type -> Type -> Type) where   id  : cat a a   (.) : cat b c -> cat a b -> cat a c -instance Category Morphism where+implementation Category Morphism where   id                = Mor id   -- disambiguation needed below, because unification can now get further-  -- here with Category.(.) and it's only type class resolution that fails!+  -- here with Category.(.) and it's only interface resolution that fails!   (Mor f) . (Mor g) = with Basics (Mor (f . g)) -instance Monad m => Category (Kleislimorphism m) where+implementation Monad m => Category (Kleislimorphism m) where   id                        = Kleisli (return . id)   (Kleisli f) . (Kleisli g) = Kleisli $ \a => g a >>= f
libs/base/Control/IOExcept.idr view
@@ -2,25 +2,28 @@  -- An IO monad with exception handling -record IOExcept err a where+record IOExcept' (f:FFI) err a where      constructor IOM-     runIOExcept : IO (Either err a)+     runIOExcept : IO' f (Either err a) -instance Functor (IOExcept e) where+Functor (IOExcept' f e) where      map f (IOM fn) = IOM (map (map f) fn) -instance Applicative (IOExcept e) where+Applicative (IOExcept' f e) where      pure x = IOM (pure (pure x))      (IOM f) <*> (IOM a) = IOM [| f <*> a |] -instance Monad (IOExcept e) where+Monad (IOExcept' f e) where      (IOM x) >>= f = IOM $ x >>= either (pure . Left) (runIOExcept . f) -ioe_lift : IO a -> IOExcept err a+ioe_lift : IO' f a -> IOExcept' f err a ioe_lift op = IOM $ map Right op -ioe_fail : err -> IOExcept err a+ioe_fail : err -> IOExcept' f err a ioe_fail e = IOM $ pure (Left e) -ioe_run : IOExcept err a -> (err -> IO b) -> (a -> IO b) -> IO b+ioe_run : IOExcept' f err a -> (err -> IO' f b) -> (a -> IO' f b) -> IO' f b ioe_run (IOM act) err ok = either err ok !act++IOExcept : Type -> Type -> Type+IOExcept = IOExcept' FFI_C
libs/base/Control/Monad/Identity.idr view
@@ -4,13 +4,13 @@   constructor Id   runIdentity : a -instance Functor Identity where+implementation Functor Identity where     map fn (Id a) = Id (fn a) -instance Applicative Identity where+implementation Applicative Identity where     pure x = Id x      (Id f) <*> (Id g) = Id (f g) -instance Monad Identity where+implementation Monad Identity where     (Id x) >>= k = k x
libs/base/Control/Monad/RWS.idr view
@@ -8,46 +8,46 @@ %access public  ||| A combination of the Reader, Writer, and State monads-class (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m) => MonadRWS r w s (m : Type -> Type) where {}+interface (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m) => MonadRWS r w s (m : Type -> Type) where {}  ||| The transformer on which the RWS monad is based record RWST (r : Type) (w : Type) (s : Type) (m : Type -> Type) (a : Type) where   constructor MkRWST   runRWST : r -> s -> m (a, s, w)   -instance Monad m => Functor (RWST r w s m) where+implementation Monad m => Functor (RWST r w s m) where     map f (MkRWST m) = MkRWST $ \r,s => do  (a, s', w) <- m r s                                             return (f a, s', w) -instance (Monoid w, Monad m) => Applicative (RWST r w s m) where+implementation (Monoid w, Monad m) => Applicative (RWST r w s m) where     pure a = MkRWST $ \_,s => return (a, s, neutral)     (MkRWST f) <*> (MkRWST v) = MkRWST $ \r,s => do (a, s', w)   <- v r s                                                     (fn, ss, w') <- f r s                                                     return (fn a, ss, w <+> w') -instance (Monoid w, Monad m) => Monad (RWST r w s m) where+implementation (Monoid w, Monad m) => Monad (RWST r w s m) where     (MkRWST m) >>= k = MkRWST $ \r,s => do  (a, s', w) <- m r s                                             let MkRWST ka = k a                                             (b, ss, w') <- ka r s'                                             return (b, ss, w <+> w') -instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where+implementation (Monoid w, Monad m) => MonadReader r (RWST r w s m) where     ask                = MkRWST $ \r,s => return (r, s, neutral)     local f (MkRWST m) = MkRWST $ \r,s => m (f r) s -instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where+implementation (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where     tell w            = MkRWST $ \_,s => return ((), s, w)     listen (MkRWST m) = MkRWST $ \r,s => do (a, s', w) <- m r s                                             return ((a, w), s', w)     pass (MkRWST m)   = MkRWST $ \r,s => do ((a, f), s', w) <- m r s                                             return (a, s', f w) -instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where+implementation (Monoid w, Monad m) => MonadState s (RWST r w s m) where     get   = MkRWST $ \_,s => return (s,  s, neutral)     put s = MkRWST $ \_,_ => return ((), s, neutral) -instance (Monoid w, Monad m) => MonadRWS r w s (RWST r w s m) where {}+implementation (Monoid w, Monad m) => MonadRWS r w s (RWST r w s m) where {} -||| The RWS monad. See the MonadRWS class+||| The RWS monad. See the MonadRWS interface RWS : Type -> Type -> Type -> Type -> Type RWS r w s a = RWST r w s Identity a
libs/base/Control/Monad/Reader.idr view
@@ -7,7 +7,7 @@ %access public  ||| A monad representing a computation that runs in an immutable context-class Monad m => MonadReader r (m : Type -> Type) where+interface Monad m => MonadReader r (m : Type -> Type) where     ||| Return the context     ask   : m r     ||| Temprorarily modify the input and run an action in the new context@@ -22,27 +22,27 @@ liftReaderT : {m : Type -> Type} -> m a -> ReaderT r m a liftReaderT m = RD $ const m -instance Functor f => Functor (ReaderT r f) where+implementation Functor f => Functor (ReaderT r f) where     map f (RD g) = RD $ (map f) . g -instance Applicative m => Applicative (ReaderT r m) where+implementation Applicative m => Applicative (ReaderT r m) where     pure              = liftReaderT . pure     (RD f) <*> (RD v) = RD $ \r => f r <*> v r -instance Alternative m => Alternative (ReaderT r m) where+implementation Alternative m => Alternative (ReaderT r m) where     empty             = liftReaderT empty     (RD m) <|> (RD n) = RD $ \r => m r <|> n r -instance Monad m => Monad (ReaderT r m) where+implementation Monad m => Monad (ReaderT r m) where     (RD f) >>= k = RD $ \r => do a <- f r                                  let RD ka = k a                                  ka r -instance Monad m => MonadReader r (ReaderT r m) where+implementation Monad m => MonadReader r (ReaderT r m) where     ask            = RD return     local f (RD m) = RD $ m . f -instance MonadTrans (ReaderT r) where+implementation MonadTrans (ReaderT r) where     lift x = RD (const x)  ||| Evaluate a function in the context of a Reader monad
libs/base/Control/Monad/State.idr view
@@ -6,7 +6,7 @@ %access public  ||| A computation which runs in a context and produces an output-class Monad m => MonadState s (m : Type -> Type) | m where+interface Monad m => MonadState s (m : Type -> Type) | m where     ||| Get the context     get : m s     ||| Write a new context/output@@ -17,28 +17,28 @@   constructor ST   runStateT : s -> m (a, s) -instance Functor f => Functor (StateT s f) where+implementation Functor f => Functor (StateT s f) where     map f (ST g) = ST (\st => map (mapFst f) (g st)) where        mapFst : (a -> x) -> (a, s) -> (x, s)        mapFst fn (a, b) = (fn a, b) -instance Monad f => Applicative (StateT s f) where+implementation Monad f => Applicative (StateT s f) where     pure x = ST (\st => pure (x, st))      (ST f) <*> (ST a) = ST (\st => do (g, r) <- f st                                       (b, t) <- a r                                       return (g b, t)) -instance Monad m => Monad (StateT s m) where+implementation Monad m => Monad (StateT s m) where     (ST f) >>= k = ST (\st => do (v, st') <- f st                                  let ST kv = k v                                  kv st') -instance Monad m => MonadState s (StateT s m) where+implementation Monad m => MonadState s (StateT s m) where     get   = ST (\x => return (x, x))     put x = ST (\y => return ((), x)) -instance MonadTrans (StateT s) where+implementation MonadTrans (StateT s) where     lift x = ST (\st => do r <- x                            return (r, st)) @@ -52,7 +52,7 @@ gets f = do s <- get             return (f s) -||| The State monad. See the MonadState class+||| The State monad. See the MonadState interface State : Type -> Type -> Type State s a = StateT s Identity a
libs/base/Control/Monad/Trans.idr view
@@ -1,4 +1,4 @@ module Control.Monad.Trans -class MonadTrans (t : (Type -> Type) -> Type -> Type) where+interface MonadTrans (t : (Type -> Type) -> Type -> Type) where     lift : Monad m => m a -> t m a
libs/base/Control/Monad/Writer.idr view
@@ -7,7 +7,7 @@ %access public  ||| A monad representing a computation that produces a stream of output-class (Monoid w, Monad m) => MonadWriter w (m : Type -> Type) where+interface (Monoid w, Monad m) => MonadWriter w (m : Type -> Type) where     ||| tell w produces the output w     tell   : w -> m ()     ||| Execute an action and add it's output to the value of the computation@@ -20,32 +20,32 @@   constructor WR   runWriterT : m (a, w) -instance Functor f => Functor (WriterT w f) where+implementation Functor f => Functor (WriterT w f) where     map f (WR g) = WR $ map (\w => (f . fst $ w, snd w)) g -instance (Monoid w, Applicative m) => Applicative (WriterT w m) where+implementation (Monoid w, Applicative m) => Applicative (WriterT w m) where     pure a            = WR $ pure (a, neutral)     (WR f) <*> (WR v) = WR $ liftA2 merge f v where         merge (fn, w) (a, w') = (fn a, w <+> w') -instance (Monoid w, Alternative m) => Alternative (WriterT w m) where+implementation (Monoid w, Alternative m) => Alternative (WriterT w m) where     empty             = WR empty     (WR m) <|> (WR n) = WR $ m <|> n -instance (Monoid w, Monad m) => Monad (WriterT w m) where+implementation (Monoid w, Monad m) => Monad (WriterT w m) where     (WR m) >>= k = WR $ do (a, w) <- m                            let WR ka = k a                            (b, w') <- ka                            return (b, w <+> w') -instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where+implementation (Monoid w, Monad m) => MonadWriter w (WriterT w m) where     tell w        = WR $ return ((), w)     listen (WR m) = WR $ do (a, w) <- m                             return ((a, w), w)     pass (WR m)   = WR $ do ((a, f), w) <- m                             return (a, f w) -instance Monoid w => MonadTrans (WriterT w) where+implementation Monoid w => MonadTrans (WriterT w) where     lift x = WR $ do r <- x                      return (r, neutral) @@ -61,6 +61,6 @@ censor f m = pass $ do a <- m                        return (a, f) -||| The Writer monad itself. See the MonadWriter class+||| The Writer monad itself. See the MonadWriter interface Writer : Type -> Type -> Type Writer w a = WriterT w Identity a
libs/base/Data/Bits.idr view
@@ -4,6 +4,7 @@  %default total +public nextPow2 : Nat -> Nat nextPow2 Z = Z nextPow2 (S x) = if (S x) == (2 `power` l2x)@@ -12,9 +13,11 @@     where       l2x = log2NZ (S x) SIsNotZ +public nextBytes : Nat -> Nat nextBytes bits = (nextPow2 (divCeilNZ bits 8 SIsNotZ)) +public machineTy : Nat -> Type machineTy Z = Bits8 machineTy (S Z) = Bits16@@ -273,10 +276,10 @@     | S (S Z) = prim__gtB32 x y     | S (S (S _)) = prim__gtB64 x y -instance Eq (Bits n) where+implementation Eq (Bits n) where     (MkBits x) == (MkBits y) = boolOp eq x y -instance Ord (Bits n) where+implementation Ord (Bits n) where     (MkBits x) < (MkBits y) = boolOp lt x y     (MkBits x) <= (MkBits y) = boolOp lte x y     (MkBits x) >= (MkBits y) = boolOp gte x y@@ -338,7 +341,7 @@ intToBits : Integer -> Bits n intToBits n = MkBits (intToBits' n) -instance Cast Integer (Bits n) where+implementation Cast Integer (Bits n) where     cast = intToBits  bitsToInt' : machineTy (nextBytes n) -> Integer@@ -356,7 +359,7 @@ zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n) zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0) ---instance Cast Nat (Bits n) where+--implementation Cast Nat (Bits n) where --    cast x = MkBits (zeroUnused (natToBits n))  -- TODO: Prove@@ -437,6 +440,6 @@       helper FZ _ = []       helper (FS x) b = (if getBit x b then '1' else '0') :: helper (weaken x) b -instance Show (Bits n) where+implementation Show (Bits n) where     show = bitsToStr
libs/base/Data/Complex.idr view
@@ -16,10 +16,10 @@ imagPart : Complex a -> a imagPart (r:+i) = i -instance Eq a => Eq (Complex a) where+implementation Eq a => Eq (Complex a) where     (==) a b = realPart a == realPart b && imagPart a == imagPart b -instance Show a => Show (Complex a) where+implementation Show a => Show (Complex a) where     showPrec d (r :+ i) = showParens (d >= plus_i) $ showPrec plus_i r ++ " :+ " ++ showPrec plus_i i       where plus_i : Prec             plus_i = User 6@@ -28,7 +28,7 @@ -- when we have a type class 'Fractional' (which contains Double), -- we can do: {--instance Fractional a => Fractional (Complex a) where+implementation Fractional a => Fractional (Complex a) where     (/) (a:+b) (c:+d) = let                           real = (a*c+b*d)/(c*c+d*d)                           imag = (b*c-a*d)/(c*c+d*d)@@ -58,17 +58,17 @@ conjugate : Neg a => Complex a -> Complex a conjugate (r:+i) = (r :+ (0-i)) -instance Functor Complex where+implementation Functor Complex where     map f (r :+ i) = f r :+ f i --- We can't do "instance Num a => Num (Complex a)" because+-- We can't do "implementation Num a => Num (Complex a)" because -- we need "abs" which needs "magnitude" which needs "sqrt" which needs Double-instance Num (Complex Double) where+implementation Num (Complex Double) where     (+) (a:+b) (c:+d) = ((a+c):+(b+d))     (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d))     fromInteger x = (fromInteger x:+0) -instance Neg (Complex Double) where+implementation Neg (Complex Double) where     negate = map negate     (-) (a:+b) (c:+d) = ((a-c):+(b-d))     abs (a:+b) = (magnitude (a:+b):+0)
libs/base/Data/Erased.idr view
@@ -11,14 +11,14 @@     ||| Construct an erased value from any value.     Erase : .(x : a) -> Erased a -instance Functor Erased where+implementation Functor Erased where   map f (Erase x) = Erase (f x) -instance Applicative Erased where+implementation Applicative Erased where   pure = Erase   (<*>) (Erase f) (Erase x) = Erase (f x) -instance Monad Erased where+implementation Monad Erased where   (>>=) (Erase x) f = f x  ||| Project the erased value out of the monad.
libs/base/Data/Fin.idr view
@@ -12,14 +12,14 @@     FZ : Fin (S k)     FS : Fin k -> Fin (S k) -instance Uninhabited (Fin Z) where+implementation Uninhabited (Fin Z) where   uninhabited FZ impossible   uninhabited (FS f) impossible  FSInjective : (m : Fin k) -> (n : Fin k) -> FS m = FS n -> m = n FSInjective left _ Refl = Refl -instance Eq (Fin n) where+implementation Eq (Fin n) where     (==) FZ FZ = True     (==) (FS k) (FS k') = k == k'     (==) _ _ = False@@ -44,7 +44,7 @@ finToNatInjective (FS m) (FS n) prf  =   cong (finToNatInjective m n (succInjective (finToNat m) (finToNat n) prf)) -instance Cast (Fin n) Nat where+implementation Cast (Fin n) Nat where     cast x = finToNat x  ||| Convert a Fin to an Integer@@ -52,7 +52,7 @@ finToInteger FZ     = 0 finToInteger (FS k) = 1 + finToInteger k -instance Cast (Fin n) Integer where+implementation Cast (Fin n) Integer where     cast x = finToInteger x  ||| Weaken the bound on a Fin by 1@@ -89,16 +89,16 @@ total FSinjective : {f : Fin n} -> {f' : Fin n} -> (FS f = FS f') -> f = f' FSinjective Refl = Refl -instance Ord (Fin n) where+implementation Ord (Fin n) where   compare  FZ     FZ    = EQ   compare  FZ    (FS _) = LT   compare (FS _)  FZ    = GT   compare (FS x) (FS y) = compare x y -instance MinBound (Fin (S n)) where+implementation MinBound (Fin (S n)) where   minBound = FZ -instance MaxBound (Fin (S n)) where+implementation MaxBound (Fin (S n)) where   maxBound = last  @@ -174,7 +174,7 @@  %error_handlers Data.Fin.fromInteger prf finFromIntegerErrors -instance Enum (Fin (S n)) where+implementation Enum (Fin (S n)) where   pred FZ = FZ   pred (FS n) = weaken n   succ n = case strengthen (FS n) of@@ -192,7 +192,7 @@ total FZNotFS : {f : Fin n} -> FZ {k = n} = FS f -> Void FZNotFS Refl impossible -instance DecEq (Fin n) where+implementation DecEq (Fin n) where   decEq FZ FZ = Yes Refl   decEq FZ (FS f) = No FZNotFS   decEq (FS f) FZ = No $ negEqSym FZNotFS
libs/base/Data/HVect.idr view
@@ -35,10 +35,10 @@ (++) [] ys = ys (++) (x::xs) ys = x :: (xs ++ ys) -instance Eq (HVect []) where+implementation Eq (HVect []) where   [] == [] = True -instance (Eq t, Eq (HVect ts)) => Eq (HVect (t::ts)) where+implementation (Eq t, Eq (HVect ts)) => Eq (HVect (t::ts)) where   (x::xs) == (y::ys) = x == y && xs == ys  total@@ -49,26 +49,26 @@ hvectInjective2 : {xs, ys: HVect ts} -> {x, y:a} -> x :: xs = y :: ys -> xs = ys hvectInjective2 Refl = Refl -instance DecEq (HVect []) where+implementation DecEq (HVect []) where   decEq [] [] = Yes Refl -instance (DecEq t, DecEq (HVect ts)) => DecEq (HVect (t::ts)) where+implementation (DecEq t, DecEq (HVect ts)) => DecEq (HVect (t::ts)) where   decEq (x::xs) (y::ys) with (decEq x y)     decEq (z::xs) (z::ys) | Yes Refl with (decEq xs ys)       decEq (z::zs) (z::zs) | Yes Refl | Yes Refl = Yes Refl       decEq (z::xs) (z::ys) | Yes Refl | No ctr = No (ctr . hvectInjective2)     decEq (x::xs) (y::ys) | No ctr = No (ctr . hvectInjective1) -class Shows (k : Nat) (ts : Vect k Type) where+interface Shows (k : Nat) (ts : Vect k Type) where   shows : HVect ts -> Vect k String -instance Shows Z [] where+implementation Shows Z [] where   shows [] = [] -instance (Show t, Shows k ts) => Shows (S k) (t::ts) where+implementation (Show t, Shows k ts) => Shows (S k) (t::ts) where   shows (x::xs) = show x :: shows xs -instance (Shows k ts) => Show (HVect ts) where+implementation (Shows k ts) => Show (HVect ts) where   show xs = "[" ++ (pack . intercalate [','] . map unpack . toList $ shows xs) ++ "]"  ||| Extract an arbitrary element of the correct type.
libs/base/Data/List.idr view
@@ -15,7 +15,7 @@      ||| Example: `the (Elem "b" ["a", "b"]) (There Here)`      There : Elem x xs -> Elem x (y :: xs) -instance Uninhabited (Elem {a} x []) where+implementation Uninhabited (Elem {a} x []) where      uninhabited Here impossible      uninhabited (There p) impossible @@ -49,7 +49,7 @@ intersectBy : (a -> a -> Bool) -> List a -> List a -> List a intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] -||| Compute the intersection of two lists according to their `Eq` instance.+||| Compute the intersection of two lists according to their `Eq` implementation. ||| ||| ```idris example ||| intersect [1, 2, 3, 4] [2, 4, 6, 8]
libs/base/Data/List/Quantifiers.idr view
@@ -16,7 +16,7 @@ anyNilAbsurd (Here _) impossible anyNilAbsurd (There _) impossible -instance Uninhabited (Any p Nil) where+implementation Uninhabited (Any p Nil) where   uninhabited = anyNilAbsurd  ||| Eliminator for `Any`
libs/base/Data/Mod2.idr view
@@ -28,25 +28,25 @@ intToMod : {n : Nat} -> Integer -> Mod2 n intToMod {n=n} x = MkMod2 (intToBits x) -instance Eq (Mod2 n) where+implementation Eq (Mod2 n) where     (==) = modComp (==) -instance Ord (Mod2 n) where+implementation Ord (Mod2 n) where     (<) = modComp (<)     (<=) = modComp (<=)     (>=) = modComp (>=)     (>) = modComp (>)     compare = modComp compare -instance Num (Mod2 n) where+implementation Num (Mod2 n) where     (+) = modBin plus     (*) = modBin times     fromInteger = intToMod -instance Cast (Mod2 n) (Bits n) where+implementation Cast (Mod2 n) (Bits n) where     cast (MkMod2 x) = x -instance Cast (Bits n) (Mod2 n) where+implementation Cast (Bits n) (Mod2 n) where     cast x = MkMod2 x  modToStr : Mod2 n -> String@@ -58,5 +58,5 @@                  :: (if x < 10 then [] else helper (x `div` 10))  -instance Show (Mod2 n) where+implementation Show (Mod2 n) where     show = modToStr
libs/base/Data/Morphisms.idr view
@@ -20,20 +20,20 @@ applyEndo : Endomorphism a -> a -> a applyEndo (Endo f) a = f a -instance Functor (Morphism r) where+implementation Functor (Morphism r) where   map f (Mor a) = Mor (f . a) -instance Applicative (Morphism r) where+implementation Applicative (Morphism r) where   pure a                = Mor $ const a   (Mor f) <*> (Mor a) = Mor $ \r => f r $ a r -instance Monad (Morphism r) where+implementation Monad (Morphism r) where   (Mor h) >>= f = Mor $ \r => applyMor (f $ h r) r -instance Semigroup (Endomorphism a) where+implementation Semigroup (Endomorphism a) where   (Endo f) <+> (Endo g) = Endo $ g . f -instance Monoid (Endomorphism a) where+implementation Monoid (Endomorphism a) where   neutral = Endo id  infixr 1 ~>
libs/base/Data/So.idr view
@@ -14,7 +14,7 @@ data So : Bool -> Type where    Oh : So True -instance Uninhabited (So False) where+implementation Uninhabited (So False) where   uninhabited Oh impossible  ||| Perform a case analysis on a Boolean, providing clients with a `So` proof
libs/base/Data/String.idr view
@@ -1,4 +1,5 @@ module Data.String+%access public  private parseNumWithoutSign : List Char -> Integer -> Maybe Integer
libs/base/Data/Vect.idr view
@@ -232,7 +232,7 @@ -- Equality -------------------------------------------------------------------------------- -instance (Eq a) => Eq (Vect n a) where+implementation (Eq a) => Eq (Vect n a) where   (==) []      []      = True   (==) (x::xs) (y::ys) = x == y && xs == ys @@ -241,7 +241,7 @@ -- Order -------------------------------------------------------------------------------- -instance Ord a => Ord (Vect n a) where+implementation Ord a => Ord (Vect n a) where   compare []      []      = EQ   compare (x::xs) (y::ys) = compare x y `thenCompare` compare xs ys @@ -250,7 +250,7 @@ -- Maps -------------------------------------------------------------------------------- -instance Functor (Vect n) where+implementation Functor (Vect n) where   map f []        = []   map f (x::xs) = f x :: map f xs @@ -281,7 +281,7 @@ foldrImpl f e go [] = go e foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs -instance Foldable (Vect n) where+implementation Foldable (Vect n) where   foldr f e xs = foldrImpl f e id xs  --------------------------------------------------------------------------------@@ -501,17 +501,17 @@ -- Applicative/Monad/Traversable -------------------------------------------------------------------------------- -instance Applicative (Vect k) where+implementation Applicative (Vect k) where     pure = replicate _      fs <*> vs = zipWith apply fs vs  ||| This monad is different from the List monad, (>>=) ||| uses the diagonal.-instance Monad (Vect n) where+implementation Monad (Vect n) where     m >>= f = diag (map f m) -instance Traversable (Vect n) where+implementation Traversable (Vect n) where     traverse f [] = pure Vect.Nil     traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |] @@ -519,7 +519,7 @@ -- Show -------------------------------------------------------------------------------- -instance Show a => Show (Vect n a) where+implementation Show a => Show (Vect n a) where     show = show . toList  --------------------------------------------------------------------------------@@ -549,7 +549,7 @@ vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl -instance DecEq a => DecEq (Vect n a) where+implementation DecEq a => DecEq (Vect n a) where   decEq [] [] = Yes Refl   decEq (x :: xs) (y :: ys) with (decEq x y)     decEq (x :: xs) (x :: ys)   | Yes Refl with (decEq xs ys)@@ -558,7 +558,7 @@     decEq (x :: xs) (y :: ys)   | No  neq             = No (neq . vectInjective1)  {- The following definition is elaborated in a wrong case-tree. Examination pending.-instance DecEq a => DecEq (Vect n a) where+implementation DecEq a => DecEq (Vect n a) where   decEq [] [] = Yes Refl   decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)     decEq (x :: xs) (x :: xs) | (Yes Refl, Yes Refl) = Yes Refl
libs/base/Data/Vect/Quantifiers.idr view
@@ -16,7 +16,7 @@ anyNilAbsurd (Here _) impossible anyNilAbsurd (There _) impossible -instance Uninhabited (Any p Nil) where+implementation Uninhabited (Any p Nil) where   uninhabited = anyNilAbsurd  ||| Eliminator for `Any`
libs/base/Language/Reflection/Utils.idr view
@@ -61,14 +61,14 @@ binderTy (PVar t)      = t binderTy (PVTy t)      = t -instance Show SourceLocation where+implementation Show SourceLocation where   showPrec d (FileLoc filename line col) = showCon d "FileLoc" $ showArg filename ++ showArg line ++ showArg col -instance Eq SourceLocation where+implementation Eq SourceLocation where   (FileLoc fn s e) == (FileLoc fn' s' e') = fn == fn' && s == s' && e == e'  mutual-  instance Show SpecialName where+  implementation Show SpecialName where     showPrec d (WhereN i n1 n2) = showCon d "WhereN" $ showArg i ++                             showArg n1 ++ showArg n2     showPrec d (WithN i n) = showCon d "WithN" $ showArg i ++ showArg n@@ -80,21 +80,21 @@     showPrec d (InstanceCtorN n) = showCon d "InstanceCtorN" $ showArg n     showPrec d (MetaN parent meta) = showCon d "MetaN" $ showArg parent ++ showArg meta -  instance Show TTName where+  implementation Show TTName where     showPrec d (UN str)   = showCon d "UN" $ showArg str     showPrec d (NS n ns)  = showCon d "NS" $ showArg n ++ showArg ns     showPrec d (MN i str) = showCon d "MN" $ showArg i ++ showArg str     showPrec d (SN sn)    = showCon d "SN" $ assert_total (showArg sn)  mutual-  instance Eq TTName where+  implementation Eq TTName where     (UN str1)  == (UN str2)     = str1 == str2     (NS n ns)  == (NS n' ns')   = n == n' && ns == ns'     (MN i str) == (MN i' str')  = i == i' && str == str'     (SN sn)    == (SN sn')      = assert_total $ sn == sn'     x          == y             = False -  instance Eq SpecialName where+  implementation Eq SpecialName where     (WhereN i n1 n2)    == (WhereN i' n1' n2')   = i == i' && n1 == n1' && n2 == n2'     (WithN i n)         == (WithN i' n')         = i == i' && n == n'     (InstanceN i ss)    == (InstanceN i' ss')    = i == i' && ss == ss'@@ -106,32 +106,32 @@     (MetaN parent meta) == (MetaN parent' meta') = parent == parent' && meta == meta'     _                   == _                     = False -instance Show TTUExp where+implementation Show TTUExp where   showPrec d (UVar i) = showCon d "UVar" $ showArg i   showPrec d (UVal i) = showCon d "UVal" $ showArg i -instance Eq TTUExp where+implementation Eq TTUExp where   (UVar i) == (UVar j) = i == j   (UVal i) == (UVal j) = i == j   x        == y        = False -instance Show NativeTy where+implementation Show NativeTy where   show IT8  = "IT8"   show IT16 = "IT16"   show IT32 = "IT32"   show IT64 = "IT64" -instance Show IntTy where+implementation Show IntTy where   showPrec d (ITFixed t) = showCon d "ITFixed" $ showArg t   showPrec d ITNative    = "ITNative"   showPrec d ITBig       = "ITBig"   showPrec d ITChar      = "ITChar" -instance Show ArithTy where+implementation Show ArithTy where   showPrec d (ATInt t) = showCon d "ATInt" $ showArg t   showPrec d ATDouble   = "ATDouble" -instance Show Const where+implementation Show Const where   showPrec d (I i)      = showCon d "I" $ showArg i   showPrec d (BI n)     = showCon d "BI" $ showArg n   showPrec d (Fl f)     = showCon d "Fl" $ showArg f@@ -146,26 +146,26 @@   showPrec d VoidType   = "VoidType"   showPrec d Forgot     = "Forgot" -instance Eq NativeTy where+implementation Eq NativeTy where   IT8  == IT8  = True   IT16 == IT16 = True   IT32 == IT32 = True   IT64 == IT64 = True   _    == _    = False -instance Eq Reflection.IntTy where+implementation Eq Reflection.IntTy where   (ITFixed x) == (ITFixed y) = x == y   ITNative    == ITNative    = True   ITBig       == ITBig       = True   ITChar      == ITChar      = True   _           == _           = False -instance Eq ArithTy where+implementation Eq ArithTy where   (ATInt x) == (ATInt y) = x == y   ATDouble  == ATDouble   = True   _         == _         = False -instance Eq Const where+implementation Eq Const where   (I x)          == (I y)           = x == y   (BI x)         == (BI y)          = x == y   (Fl x)         == (Fl y)          = x == y@@ -182,20 +182,20 @@   _              == _               = False  -instance Show NameType where+implementation Show NameType where   showPrec d Bound = "Bound"   showPrec d Ref = "Ref"   showPrec d (DCon t ar) = showCon d "DCon" $ showArg t ++ showArg ar   showPrec d (TCon t ar) = showCon d "TCon" $ showArg t ++ showArg ar -instance Eq NameType where+implementation Eq NameType where   Bound       == Bound          = True   Ref         == Ref            = True   (DCon t ar) == (DCon t' ar')  = t == t' && ar == ar'   (TCon t ar) == (TCon t' ar')  = t == t' && ar == ar'   x           == y              = False -instance (Show a) => Show (Binder a) where+implementation (Show a) => Show (Binder a) where   showPrec d (Lam t) = showCon d "Lam" $ showArg t   showPrec d (Pi t1 t2) = showCon d "Pi" $ showArg t1 ++ showArg t2   showPrec d (Let t1 t2) = showCon d "Let" $ showArg t1 ++ showArg t2@@ -205,7 +205,7 @@   showPrec d (PVar t) = showCon d "PVar" $ showArg t   showPrec d (PVTy t) = showCon d "PVTy" $ showArg t -instance (Eq a) => Eq (Binder a) where+implementation (Eq a) => Eq (Binder a) where   (Lam t)       == (Lam t')         = t == t'   (Pi t k)      == (Pi t' k')       = t == t' && k == k'   (Let t1 t2)   == (Let t1' t2')    = t1 == t1' && t2 == t2'@@ -216,7 +216,7 @@   (PVTy t)      == (PVTy t')        = t == t'   x             == y                = False -instance Show TT where+implementation Show TT where   showPrec = my_show     where %assert_total my_show : Prec -> TT -> String           my_show d (P nt n t) = showCon d "P" $ showArg nt ++ showArg n ++ showArg t@@ -227,7 +227,7 @@           my_show d Erased = "Erased"           my_show d (TType u) = showCon d "TType" $ showArg u -instance Eq TT where+implementation Eq TT where   a == b = equalp a b     where %assert_total equalp : TT -> TT -> Bool           equalp (P nt n t)   (P nt' n' t')    = nt == nt' && n == n' && t == t'@@ -239,7 +239,7 @@           equalp (TType u)    (TType u')       = u == u'           equalp x            y                = False -instance Eq Universe where+implementation Eq Universe where   Reflection.NullType   == Reflection.NullType   = True   Reflection.UniqueType == Reflection.UniqueType = True   Reflection.AllTypes   == Reflection.AllTypes   = True@@ -269,7 +269,7 @@     fe env (UType uni)   = Just (RUType uni)     fe env Erased        = Just $ RConstant Forgot -instance Show Raw where+implementation Show Raw where   showPrec = my_show     where %assert_total my_show : Prec -> Raw -> String           my_show d (Var n) = showCon d "Var" $ showArg n@@ -279,7 +279,7 @@           my_show d (RConstant c) = showCon d "RConstant" $ showArg c  -instance Show Err where+implementation Show Err where   showPrec d (Msg x) = showCon d "Msg" $ showArg x   showPrec d (InternalMsg x) = showCon d "InternalMsg" $ showArg x   showPrec d (CantUnify x tm tm' err xs y) = showCon d "CantUnify" $ showArg x ++@@ -329,28 +329,28 @@ -------------------------------------- -- Instances for definition reflection ---------------------------------------instance Show Erasure where+implementation Show Erasure where   show Erased    = "Erased"   show NotErased = "NotErased" -instance Show Plicity where+implementation Show Plicity where   show Explicit = "Explicit"   show Implicit = "Implicit"   show Constraint = "Constraint" -instance Show FunArg where+implementation Show FunArg where   showPrec d (MkFunArg n ty plic era) = showCon d "MkFunArg" $ showArg n ++                                         showArg ty ++ showArg plic ++ showArg era -instance Show CtorArg where+implementation Show CtorArg where   showPrec d (CtorParameter fa) = showCon d "CtorParameter" $ showArg fa   showPrec d (CtorField fa) = showCon d "CtorField" $ showArg fa -instance Show TyDecl where+implementation Show TyDecl where   showPrec d (Declare fn args ret) = showCon d "Declare" $ showArg fn ++                                      showArg args ++ showArg ret -instance Show tm => Show (FunClause tm) where+implementation Show tm => Show (FunClause tm) where   showPrec d (MkFunClause lhs rhs) =       showCon d "MkFunClause" $ showArg lhs ++ showArg rhs   showPrec d (MkImpossibleClause lhs) =
libs/base/System.idr view
@@ -56,7 +56,7 @@ exit : Int -> IO () exit code = foreign FFI_C "exit" (Int -> IO ()) code -||| Get the numbers of sections since 1st January 1970, 00:00 UTC +||| Get the numbers of seconds since 1st January 1970, 00:00 UTC  time : IO Integer time = do MkRaw t <- foreign FFI_C "idris_time" (IO (Raw Integer))           return t
libs/contrib/Classes/Verified.idr view
@@ -6,18 +6,18 @@  -- 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 instances, and we get those+-- be implemented for a number of implementations, and we get those -- implementations, then some of them can move back to base (or even -- prelude, in the cases of Functor, Applicative, Monad, Semigroup, -- and Monoid). -class Functor f => VerifiedFunctor (f : Type -> Type) where+interface Functor f => VerifiedFunctor (f : Type -> Type) where   functorIdentity : {a : Type} -> (x : f a) -> map id x = id x   functorComposition : {a : Type} -> {b : Type} -> (x : f a) ->                        (g1 : a -> b) -> (g2 : b -> c) ->                        map (g2 . g1) x = (map g2 . map g1) x -class (Applicative f, VerifiedFunctor f) => VerifiedApplicative (f : Type -> Type) where+interface (Applicative f, VerifiedFunctor f) => VerifiedApplicative (f : Type -> Type) where   applicativeMap : (x : f a) -> (g : a -> b) ->                    map g x = pure g <*> x   applicativeIdentity : (x : f a) -> pure Basics.id <*> x = x@@ -28,7 +28,7 @@   applicativeInterchange : (x : a) -> (g : f (a -> b)) ->                            g <*> pure x = pure (\g' : a -> b => g' x) <*> g -class (Monad m, VerifiedApplicative m) => VerifiedMonad (m : Type -> Type) where+interface (Monad m, VerifiedApplicative m) => VerifiedMonad (m : Type -> Type) where   monadApplicative : (mf : m (a -> b)) -> (mx : m a) ->                      mf <*> mx = mf >>= \f =>                                  mx >>= \x =>@@ -39,76 +39,76 @@                        (mx >>= f) >>= g = mx >>= (\x => f x >>= g)  -class Semigroup a => VerifiedSemigroup a where+interface Semigroup a => VerifiedSemigroup a where   total semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r -instance VerifiedSemigroup (List a) where+implementation VerifiedSemigroup (List a) where   semigroupOpIsAssociative = appendAssociative ---instance VerifiedSemigroup Nat where+--implementation VerifiedSemigroup Nat where --  semigroupOpIsAssociative = plusAssociative  -class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where+interface (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where   total monoidNeutralIsNeutralL : (l : a) -> l <+> Algebra.neutral = l   total monoidNeutralIsNeutralR : (r : a) -> Algebra.neutral <+> r = r --- instance VerifiedMonoid Nat where+-- implementation VerifiedMonoid Nat where --   monoidNeutralIsNeutralL = plusZeroRightNeutral --   monoidNeutralIsNeutralR = plusZeroLeftNeutral -instance VerifiedMonoid (List a) where+implementation VerifiedMonoid (List a) where   monoidNeutralIsNeutralL = appendNilRightNeutral   monoidNeutralIsNeutralR xs = Refl -class (VerifiedMonoid a, Group a) => VerifiedGroup a where+interface (VerifiedMonoid a, Group a) => VerifiedGroup a where   total groupInverseIsInverseL : (l : a) -> l <+> inverse l = Algebra.neutral   total groupInverseIsInverseR : (r : a) -> inverse r <+> r = Algebra.neutral -class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where+interface (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where   total abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l -class (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where+interface (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where   total ringOpIsAssociative   : (l, c, r : a) -> l <.> (c <.> r) = (l <.> c) <.> r   total ringOpIsDistributiveL : (l, c, r : a) -> l <.> (c <+> r) = (l <.> c) <+> (l <.> r)   total ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <.> r = (l <.> r) <+> (c <.> r) -class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where+interface (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where   total ringWithUnityIsUnityL : (l : a) -> l <.> Algebra.unity = l   total ringWithUnityIsUnityR : (r : a) -> Algebra.unity <.> r = r ---class (VerifiedRingWithUnity a, Field a) => VerifiedField a where+--interface (VerifiedRingWithUnity a, Field a) => VerifiedField a where --  total fieldInverseIsInverseL : (l : a) -> (notId : Not (l = neutral)) -> l <.> (inverseM l notId) = Algebra.unity --  total fieldInverseIsInverseR : (r : a) -> (notId : Not (r = neutral)) -> (inverseM r notId) <.> r = Algebra.unity  -class JoinSemilattice a => VerifiedJoinSemilattice a where+interface JoinSemilattice a => VerifiedJoinSemilattice a where   total joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r   total joinSemilatticeJoinIsCommutative : (l, r : a)    -> join l r = join r l   total joinSemilatticeJoinIsIdempotent  : (e : a)       -> join e e = e -class MeetSemilattice a => VerifiedMeetSemilattice a where+interface MeetSemilattice a => VerifiedMeetSemilattice a where   total meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r   total meetSemilatticeMeetIsCommutative : (l, r : a)    -> meet l r = meet r l   total meetSemilatticeMeetIsIdempotent  : (e : a)       -> meet e e = e -class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where+interface (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where   total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e Algebra.bottom = e -class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where+interface (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where   total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e Algebra.top = e -class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where+interface (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where   total latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l   total latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l -class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }+interface (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }  ---class (VerifiedRingWithUnity a, VerifiedAbelianGroup b, Module a b) => VerifiedModule a b where+--interface (VerifiedRingWithUnity a, VerifiedAbelianGroup b, Module a b) => VerifiedModule a b where --  total moduleScalarMultiplyComposition : (x,y : a) -> (v : b) -> x <#> (y <#> v) = (x <.> y) <#> v --  total moduleScalarUnityIsUnity : (v : b) -> Algebra.unity {a} <#> v = v --  total moduleScalarMultDistributiveWRTVectorAddition : (s : a) -> (v, w : b) -> s <#> (v <+> w) = (s <#> v) <+> (s <#> w) --  total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v) ---class (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}+--interface (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}
libs/contrib/Control/Algebra.idr view
@@ -15,7 +15,7 @@ ||| + Inverse for `<+>`: |||     forall a,     a <+> inverse a == neutral |||     forall a,     inverse a <+> a == neutral-class Monoid a => Group a where+interface Monoid a => Group a where   inverse : a -> a  (<->) : Group a => a -> a -> a@@ -35,7 +35,7 @@ ||| + Inverse for `<+>`: |||     forall a,     a <+> inverse a == neutral |||     forall a,     inverse a <+> a == neutral-class Group a => AbelianGroup a where { }+interface Group a => AbelianGroup a where { }  ||| Sets equipped with two binary operations, one associative and commutative ||| supplied with a neutral element, and the other associative, with@@ -57,7 +57,7 @@ ||| + Distributivity of `<.>` and `<+>`: |||     forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c) |||     forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)-class AbelianGroup a => Ring a where+interface AbelianGroup a => Ring a where   (<.>) : a -> a -> a  ||| Sets equipped with two binary operations, one associative and commutative@@ -83,7 +83,7 @@ ||| + Distributivity of `<.>` and `<+>`: |||     forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c) |||     forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)-class Ring a => RingWithUnity a where+interface Ring a => RingWithUnity a where   unity : a  ||| Sets equipped with two binary operations – both associative, commutative and@@ -112,7 +112,7 @@ ||| + Distributivity of `<.>` and `<+>`: |||     forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c) |||     forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)-class RingWithUnity a => Field a where+interface RingWithUnity a => Field a where   inverseM : (x : a) -> Not (x = Algebra.neutral) -> a  sum' : (Foldable t, Monoid a) => t a -> a
libs/contrib/Control/Algebra/Lattice.idr view
@@ -15,13 +15,13 @@ |||     forall a,     join a a          == a ||| ||| Join semilattices capture the notion of sets with a "least upper bound".-class JoinSemilattice a where+interface JoinSemilattice a where   join : a -> a -> a -instance JoinSemilattice Nat where+implementation JoinSemilattice Nat where   join = maximum -instance Ord a => JoinSemilattice (MaxiphobicHeap a) where+implementation Ord a => JoinSemilattice (MaxiphobicHeap a) where   join = merge  ||| Sets equipped with a binary operation that is commutative, associative and@@ -35,10 +35,10 @@ |||     forall a,     meet a a          == a ||| ||| Meet semilattices capture the notion of sets with a "greatest lower bound".-class MeetSemilattice a where+interface MeetSemilattice a where   meet : a -> a -> a -instance MeetSemilattice Nat where+implementation MeetSemilattice Nat where   meet = minimum  ||| Sets equipped with a binary operation that is commutative, associative and@@ -56,10 +56,10 @@ ||| |||  Join semilattices capture the notion of sets with a "least upper bound" |||  equipped with a "bottom" element.-class JoinSemilattice a => BoundedJoinSemilattice a where+interface JoinSemilattice a => BoundedJoinSemilattice a where   bottom  : a -instance BoundedJoinSemilattice Nat where+implementation BoundedJoinSemilattice Nat where   bottom = Z  ||| Sets equipped with a binary operation that is commutative, associative and@@ -77,7 +77,7 @@ ||| ||| Meet semilattices capture the notion of sets with a "greatest lower bound" ||| equipped with a "top" element.-class MeetSemilattice a => BoundedMeetSemilattice a where+interface MeetSemilattice a => BoundedMeetSemilattice a where   top : a  ||| Sets equipped with two binary operations that are both commutative,@@ -96,9 +96,9 @@ ||| + Absorbtion laws for meet and join: |||     forall a b,   meet a (join a b) == a |||     forall a b,   join a (meet a b) == a-class (JoinSemilattice a, MeetSemilattice a) => Lattice a where { }+interface (JoinSemilattice a, MeetSemilattice a) => Lattice a where { } -instance Lattice Nat where { }+implementation Lattice Nat where { }  ||| Sets equipped with two binary operations that are both commutative, ||| associative and idempotent and supplied with neutral elements, along with@@ -120,4 +120,4 @@ ||| + Neutral for meet and join: |||     forall a,     meet a top        == top |||     forall a,     join a bottom     == bottom-class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }+interface (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }
libs/contrib/Control/Algebra/NumericInstances.idr view
@@ -8,106 +8,106 @@ import Data.ZZ  -instance Semigroup Integer where+Semigroup Integer where   (<+>) = (+) -instance Monoid Integer where+Monoid Integer where   neutral = 0 -instance Group Integer where+Group Integer where   inverse = (* -1) -instance AbelianGroup Integer+AbelianGroup Integer where  -instance Ring Integer where+Ring Integer where   (<.>) = (*) -instance RingWithUnity Integer where+RingWithUnity Integer where   unity = 1  -instance Semigroup Int where+Semigroup Int where   (<+>) = (+) -instance Monoid Int where+Monoid Int where   neutral = 0 -instance Group Int where+Group Int where   inverse = (* -1) -instance AbelianGroup Int+AbelianGroup Int where -instance Ring Int where+Ring Int where   (<.>) = (*) -instance RingWithUnity Int where+RingWithUnity Int where   unity = 1  -instance Semigroup Double where+Semigroup Double where   (<+>) = (+) -instance Monoid Double where+Monoid Double where   neutral = 0 -instance Group Double where+Group Double where   inverse = (* -1) -instance AbelianGroup Double+AbelianGroup Double where -instance Ring Double where+Ring Double where   (<.>) = (*) -instance RingWithUnity Double where+RingWithUnity Double where   unity = 1 -instance Field Double where+Field Double where   inverseM f _ = 1 / f  -instance Semigroup Nat where+Semigroup Nat where   (<+>) = (+) -instance Monoid Nat where+Monoid Nat where   neutral = 0 -instance Semigroup ZZ where+Semigroup ZZ where   (<+>) = (+) -instance Monoid ZZ where+Monoid ZZ where   neutral = 0 -instance Group ZZ where+Group ZZ where   inverse = (* -1) -instance AbelianGroup ZZ+AbelianGroup ZZ where -instance Ring ZZ where+Ring ZZ where   (<.>) = (*) -instance RingWithUnity ZZ where+RingWithUnity ZZ where   unity = 1  -instance Semigroup a => Semigroup (Complex a) where+Semigroup a => Semigroup (Complex a) where   (<+>) (a :+ b) (c :+ d) = (a <+> c) :+ (b <+> d) -instance Monoid a => Monoid (Complex a) where+Monoid a => Monoid (Complex a) where   neutral = (neutral :+ neutral) -instance Group a => Group (Complex a) where+Group a => Group (Complex a) where   inverse (r :+ i) = (inverse r :+ inverse i) -instance Ring a => AbelianGroup (Complex a) where {}+Ring a => AbelianGroup (Complex a) where {} -instance Ring a => Ring (Complex a) where+Ring a => Ring (Complex a) where   (<.>) (a :+ b) (c :+ d) = (a <.> c <-> b <.> d) :+ (a <.> d <+> b <.> c) -instance RingWithUnity a => RingWithUnity (Complex a) where+RingWithUnity a => RingWithUnity (Complex a) where   unity = (unity :+ neutral) -instance RingWithUnity a => Module a (Complex a) where+RingWithUnity a => Module a (Complex a) where   (<#>) x = map (x <.>) -instance RingWithUnity a => InnerProductSpace a (Complex a) where+RingWithUnity a => InnerProductSpace a (Complex a) where   (x :+ y) <||> z = realPart $ (x :+ inverse y) <.> z
libs/contrib/Control/Algebra/VectorSpace.idr view
@@ -18,13 +18,13 @@ ||| + Distributivity of `<#>` and `<+>`: |||     forall a v w,  a <#> (v <+> w) == (a <#> v) <+> (a <#> w) |||     forall a b v,  (a <+> b) <#> v == (a <#> v) <+> (b <#> v)-class (RingWithUnity a, AbelianGroup b) => Module a b where+interface (RingWithUnity a, AbelianGroup b) => Module a b where   (<#>) : a -> b -> b  ||| A vector space is a module over a ring that is also a field-class (Field a, Module a b) => VectorSpace a b where {}+interface (Field a, Module a b) => VectorSpace a b where {}  ||| An inner product space is a module – or vector space – over a ring, with a binary function ||| associating a ring value to each pair of vectors.-class Module a b => InnerProductSpace a b where+interface Module a b => InnerProductSpace a b where   (<||>) : b -> b -> a
libs/contrib/Control/WellFounded.idr view
@@ -26,7 +26,7 @@ ||| acessible. ||| ||| @ rel the well-founded relation-class WellFounded (rel : a -> a -> Type) where+interface WellFounded (rel : a -> a -> Type) where   wellFounded : (x : _) -> Accessible rel x
libs/contrib/Data/BoundedList.idr view
@@ -62,7 +62,7 @@ -- Folds -------------------------------------------------------------------------------- -instance Foldable (BoundedList n) where+implementation Foldable (BoundedList n) where   foldr f e []      = e   foldr f e (x::xs) = f x (foldr f e xs)   foldl f e []      = e@@ -72,7 +72,7 @@ -- Maps -------------------------------------------------------------------------------- -instance Functor (BoundedList n) where+implementation Functor (BoundedList n) where   map f [] = []   map f (x :: xs) = f x :: map f xs
libs/contrib/Data/CoList.idr view
@@ -13,17 +13,17 @@ (++) []      right = right (++) (x::xs) right = x :: (xs ++ right) -instance Semigroup (CoList a) where+implementation Semigroup (CoList a) where   (<+>) = (++) -instance Monoid (CoList a) where+implementation Monoid (CoList a) where   neutral = [] -instance Functor CoList where+implementation Functor CoList where   map f []      = []   map f (x::xs) = f x :: map f xs -instance Show a => Show (CoList a) where+implementation Show a => Show (CoList a) where   show xs = "[" ++ show' "" 20 xs ++ "]" where     show' : String -> (n : Nat) -> (xs : CoList a) -> String     show' acc Z _             = acc ++ "..."
libs/contrib/Data/Hash.idr view
@@ -15,7 +15,7 @@ -}  ||| A type that can be hashed-class Hashable a where+interface Hashable a where   saltedHash64 : a -> Bits64 -> Bits64 -- value to hash, salt, hash  ||| Computes a non cryptographic hash@@ -40,48 +40,48 @@ mod64 : Integer -> Bits64 mod64 i = assert_total $ prim__truncBigInt_B64 (abs i `mod` 0xffffffffffffffff) -instance Hashable Bits64 where+implementation Hashable Bits64 where   saltedHash64 w salt = foldr (\b,acc => (acc `prim__shlB64` 10) + acc + b)                               salt                               [byte (fromInteger n) w | n <- [7,6..0]] -- djb2 hash function. Not meant for crypto -instance Hashable Integer where+implementation Hashable Integer where   saltedHash64 i = saltedHash64 (mod64 i) -instance Hashable () where+implementation Hashable () where   saltedHash64 _ salt = salt -instance Hashable Bool where+implementation Hashable Bool where   saltedHash64 True  = saltedHash64 (the Bits64 1)   saltedHash64 False = saltedHash64 (the Bits64 0) -instance Hashable Int where+implementation Hashable Int where   saltedHash64 w = saltedHash64 (prim__zextInt_B64 w) -instance Hashable Char where+implementation Hashable Char where   saltedHash64 w = saltedHash64 (the Int (cast w)) -instance Hashable Bits8 where+implementation Hashable Bits8 where   saltedHash64 w = saltedHash64 (prim__zextB8_B64 w) -instance Hashable Bits16 where+implementation Hashable Bits16 where   saltedHash64 w = saltedHash64 (prim__zextB16_B64 w) -instance Hashable Bits32 where+implementation Hashable Bits32 where   saltedHash64 w = saltedHash64 (prim__zextB32_B64 w) -instance Hashable a => Hashable (Maybe a) where+implementation Hashable a => Hashable (Maybe a) where   saltedHash64 Nothing  salt = salt   saltedHash64 (Just k) salt = saltedHash64 k salt -instance (Hashable a, Hashable b) => Hashable (a, b) where+implementation (Hashable a, Hashable b) => Hashable (a, b) where   saltedHash64 (a,b) salt = saltedHash64 b (saltedHash64 a salt) -instance Hashable a => Hashable (List a) where+implementation Hashable a => Hashable (List a) where   saltedHash64 l salt = foldr (\c,acc => saltedHash64 c acc) salt l -instance Hashable a => Hashable (Vect n a) where+implementation Hashable a => Hashable (Vect n a) where   saltedHash64 l salt = foldr (\c,acc => saltedHash64 c acc) salt l -instance Hashable String where+implementation Hashable String where   saltedHash64 s = saltedHash64 (unpack s)
libs/contrib/Data/Heap.idr view
@@ -110,23 +110,23 @@ sort = Heap.toList . Heap.fromList  ----------------------------------------------------------------------------------- Class instances+-- Interface implementations -------------------------------------------------------------------------------- -instance Show a => Show (MaxiphobicHeap a) where+implementation Show a => Show (MaxiphobicHeap a) where   showPrec d Empty = "Empty"   showPrec d (Node s l e r) = showCon d "Node" $ " _" ++ showArg l ++ showArg e ++ showArg r -instance Eq a => Eq (MaxiphobicHeap a) where+implementation Eq a => Eq (MaxiphobicHeap a) where   Empty              == Empty              = True   (Node ls ll le lr) == (Node rs rl re rr) =     ls == rs && ll == rl && le == re && lr == rr   _                  == _                  = False -instance Ord a => Semigroup (MaxiphobicHeap a) where+implementation Ord a => Semigroup (MaxiphobicHeap a) where   (<+>) = merge -instance Ord a => Monoid (MaxiphobicHeap a) where+implementation Ord a => Monoid (MaxiphobicHeap a) where   neutral = empty  --------------------------------------------------------------------------------
libs/contrib/Data/Matrix/Algebraic.idr view
@@ -26,29 +26,29 @@ --               Vectors as members of algebraic classes ----------------------------------------------------------------------- -instance Semigroup a => Semigroup (Vect n a) where+implementation Semigroup a => Semigroup (Vect n a) where   (<+>)= zipWith (<+>) -instance Monoid a => Monoid (Vect n a) where+implementation Monoid a => Monoid (Vect n a) where   neutral {n} = replicate n neutral -instance Group a => Group (Vect n a) where+implementation Group a => Group (Vect n a) where   inverse = map inverse -instance AbelianGroup a => AbelianGroup (Vect n a) where {}+implementation AbelianGroup a => AbelianGroup (Vect n a) where {} -instance Ring a => Ring (Vect n a) where+implementation Ring a => Ring (Vect n a) where   (<.>) = zipWith (<.>) -instance RingWithUnity a => RingWithUnity (Vect n a) where+implementation RingWithUnity a => RingWithUnity (Vect n a) where   unity {n} = replicate n unity -instance RingWithUnity a => Module a (Vect n a) where+implementation RingWithUnity a => Module a (Vect n a) where   (<#>) r = map (r <.>) -instance RingWithUnity a => Module a (Vect n (Vect l a)) where+implementation RingWithUnity a => Module a (Vect n (Vect l a)) where   (<#>) r = map (r <#>)--- should be Module a b => Module a (Vect n b), but results in 'overlapping instance'+-- should be Module a b => Module a (Vect n b), but results in 'overlapping implementation'  ----------------------------------------------------------------------- --                        (Ring) Vector functions
libs/contrib/Data/Matrix/Numeric.idr view
@@ -22,12 +22,12 @@ --                   Vectors as members of Num ----------------------------------------------------------------------- -instance Num a => Num (Vect n a) where+implementation Num a => Num (Vect n a) where   (+) = zipWith (+)   (*) = zipWith (*)   fromInteger n = replicate _ (fromInteger n) -instance Neg a => Neg (Vect n a) where+implementation Neg a => Neg (Vect n a) where   (-) = zipWith (-)   abs = map abs   negate = map negate
libs/contrib/Data/Nat/DivMod/IteratedSubtraction.idr view
@@ -23,7 +23,7 @@ %name LT' lt, lt'  ||| Nothing is strictly less than zero-instance Uninhabited (LT' n 0) where+implementation Uninhabited (LT' n 0) where   uninhabited LTSucc impossible  ||| Zero is less than any non-zero number.@@ -56,7 +56,7 @@ ||| zero (because there's nothing less than zero). This can't be done ||| for LTE, because that one doesn't stop at zero (because `LTE 0 0` ||| is inhabited).-instance WellFounded LT' where+implementation WellFounded LT' where   wellFounded x = Access (acc x)     where       ||| Show accessibility by induction on the structure of the LT' witness
libs/contrib/Data/Sign.idr view
@@ -4,5 +4,5 @@ data Sign = Plus | Zero | Minus  ||| Discover the sign of some type-class Signed t where+interface Signed t where   total sign : t -> Sign
libs/contrib/Data/SortedMap.idr view
@@ -242,7 +242,7 @@ treeMap f (Branch3 t1 k1 t2 k2 t3)      = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3) -instance Functor (SortedMap k) where+implementation Functor (SortedMap k) where   map _ Empty = Empty   map f (M n t) = M _ (treeMap f t)
libs/contrib/Data/SortedSet.idr view
@@ -31,5 +31,5 @@ toList : SortedSet k -> List k toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m) -instance Foldable SortedSet where+implementation Foldable SortedSet where   foldr f e xs = foldr f e (Data.SortedSet.toList xs)
libs/contrib/Data/ZZ.idr view
@@ -14,7 +14,7 @@ ||| data ZZ = Pos Nat | NegS Nat -instance Signed ZZ where+implementation Signed ZZ where   sign (Pos Z) = Zero   sign (Pos _) = Plus   sign (NegS _) = Minus@@ -24,7 +24,7 @@ absZ (Pos n) = n absZ (NegS n) = S n -instance Show ZZ where+implementation Show ZZ where   show (Pos n) = show n   show (NegS n) = "-" ++ show (S n) @@ -46,13 +46,13 @@ plusZ (Pos n) (NegS m) = minusNatZ n (S m) plusZ (NegS n) (Pos m) = minusNatZ m (S n) -instance Eq ZZ where+implementation Eq ZZ where   (Pos n) == (Pos m) = n == m   (NegS n) == (NegS m) = n == m   _ == _ = False  -instance Ord ZZ where+implementation Ord ZZ where   compare (Pos n) (Pos m) = compare n m   compare (NegS n) (NegS m) = compare m n   compare (Pos _) (NegS _) = GT@@ -68,19 +68,19 @@ ||| Convert an `Integer` to an inductive representation. fromInt : Integer -> ZZ fromInt n = if n < 0-            then NegS $ fromInteger {a=Nat} ((-n) - 1)-            else Pos $ fromInteger {a=Nat} n+            then NegS $ fromInteger ((-n) - 1)+            else Pos $ fromInteger n -instance Cast Nat ZZ where+implementation Cast Nat ZZ where   cast n = Pos n -instance Num ZZ where+implementation Num ZZ where   (+) = plusZ   (*) = multZ   fromInteger = fromInt  mutual-  instance Neg ZZ where+  implementation Neg ZZ where     negate (Pos Z)     = Pos Z     negate (Pos (S n)) = NegS n     negate (NegS n)    = Pos (S n)@@ -93,11 +93,11 @@   subZ n m = plusZ n (negate m)  -instance Cast ZZ Integer where+implementation Cast ZZ Integer where   cast (Pos n) = cast n   cast (NegS n) = (-1) * (cast n + 1) -instance Cast Integer ZZ where+implementation Cast Integer ZZ where   cast = fromInteger  @@ -130,7 +130,7 @@ posNotNeg Refl impossible  -- Decidable equality-instance DecEq ZZ where+implementation DecEq ZZ where   decEq (Pos n) (NegS m) = No posNotNeg   decEq (NegS n) (Pos m) = No $ negEqSym posNotNeg   decEq (Pos n) (Pos m) with (decEq n m)
libs/contrib/Decidable/Decidable.idr view
@@ -6,12 +6,12 @@ %access public  ----------------------------------------------------------------------------------- Typeclass for decidable n-ary Relations+-- Interface for decidable n-ary Relations --------------------------------------------------------------------------------  --  Note: Instance resolution for Decidable is likely to not work in the REPL --        at the moment.-class Decidable (ts : Vect k Type) (p : Rel ts) where+interface Decidable (ts : Vect k Type) (p : Rel ts) where   total decide : liftRel ts p Dec  -- 'No such variable {k506}'
libs/contrib/Decidable/Order.idr view
@@ -16,20 +16,20 @@ -- Preorders, Posets, total Orders, Equivalencies, Congruencies -------------------------------------------------------------------------------- -class Preorder t (po : t -> t -> Type) where+interface Preorder t (po : t -> t -> Type) where   total transitive : (a : t) -> (b : t) -> (c : t) -> po a b -> po b c -> po a c   total reflexive : (a : t) -> po a a -class (Preorder t po) => Poset t (po : t -> t -> Type) where+interface (Preorder t po) => Poset t (po : t -> t -> Type) where   total antisymmetric : (a : t) -> (b : t) -> po a b -> po b a -> a = b -class (Poset t to) => Ordered t (to : t -> t -> Type) where+interface (Poset t to) => Ordered t (to : t -> t -> Type) where   total order : (a : t) -> (b : t) -> Either (to a b) (to b a) -class (Preorder t eq) => Equivalence t (eq : t -> t -> Type) where+interface (Preorder t eq) => Equivalence t (eq : t -> t -> Type) where   total symmetric : (a : t) -> (b : t) -> eq a b -> eq b a -class (Equivalence t eq) => Congruence t (f : t -> t) (eq : t -> t -> Type) where+interface (Equivalence t eq) => Congruence t (f : t -> t) (eq : t -> t -> Type) where   total congruent : (a : t) ->                      (b : t) ->                      eq a b -> @@ -49,14 +49,14 @@ -- Syntactic equivalence (=) -------------------------------------------------------------------------------- -instance Preorder t ((=) {A = t} {B = t}) where+implementation Preorder t ((=) {A = t} {B = t}) where   transitive a b c = trans {a = a} {b = b} {c = c}   reflexive a = Refl -instance Equivalence t ((=) {A = t} {B = t}) where+implementation Equivalence t ((=) {A = t} {B = t}) where   symmetric a b prf = sym prf -instance Congruence t f ((=) {A = t} {B = t}) where+implementation Congruence t f ((=) {A = t} {B = t}) where   congruent a b = cong {a = a} {b = b} {f = f}  --------------------------------------------------------------------------------@@ -73,7 +73,7 @@ LTEIsReflexive Z      = LTEZero LTEIsReflexive (S n)  = LTESucc (LTEIsReflexive n) -instance Preorder Nat LTE where+implementation Preorder Nat LTE where   transitive = LTEIsTransitive   reflexive  = LTEIsReflexive @@ -84,7 +84,7 @@    LTEIsAntisymmetric (S n) (S n) (LTESucc mLTEn) (LTESucc nLTEm)    | Refl = Refl             -instance Poset Nat LTE where+implementation Poset Nat LTE where   antisymmetric = LTEIsAntisymmetric  total zeroNeverGreater : {n : Nat} -> LTE (S n) Z -> Void@@ -108,7 +108,7 @@     | Yes nLTEm = Yes (LTESucc nLTEm)     | No  nGTm  = No (ltesuccinjective nGTm) -instance Decidable [Nat,Nat] LTE where+implementation Decidable [Nat,Nat] LTE where   decide = decideLTE  total@@ -119,7 +119,7 @@ shift : (m : Nat) -> (n : Nat) -> LTE m n -> LTE (S m) (S n) shift m n mLTEn = LTESucc mLTEn       -instance Ordered Nat LTE where+implementation Ordered Nat LTE where   order Z      n = Left LTEZero   order m      Z = Right LTEZero   order (S k) (S j) with (order {to=LTE} k j)@@ -134,21 +134,21 @@   data FinLTE : Fin k -> Fin k -> Type where     FromNatPrf : {m : Fin k} -> {n : Fin k} -> LTE (finToNat m) (finToNat n) -> FinLTE m n -  instance Preorder (Fin k) FinLTE where+  implementation Preorder (Fin k) FinLTE where     transitive m n o (FromNatPrf p1) (FromNatPrf p2) =        FromNatPrf (LTEIsTransitive (finToNat m) (finToNat n) (finToNat o) p1 p2)     reflexive n = FromNatPrf (LTEIsReflexive (finToNat n)) -  instance Poset (Fin k) FinLTE where+  implementation Poset (Fin k) FinLTE where     antisymmetric m n (FromNatPrf p1) (FromNatPrf p2) =       finToNatInjective m n (LTEIsAntisymmetric (finToNat m) (finToNat n) p1 p2)   -  instance Decidable [Fin k, Fin k] FinLTE where+  implementation Decidable [Fin k, Fin k] FinLTE where     decide m n with (decideLTE (finToNat m) (finToNat n))       | Yes prf    = Yes (FromNatPrf prf)       | No  disprf = No (\ (FromNatPrf prf) => disprf prf) -  instance Ordered (Fin k) FinLTE where+  implementation Ordered (Fin k) FinLTE where     order m n =       either (Left . FromNatPrf)               (Right . FromNatPrf)
libs/contrib/Network/Cgi.idr view
@@ -30,21 +30,20 @@ getAction : CGI a -> CGIInfo -> IO (a, CGIInfo) getAction (MkCGI act) = act -instance Functor CGI where+implementation Functor CGI where     map f (MkCGI c) = MkCGI (\s => do (a, i) <- c s                                       return (f a, i)) -instance Applicative CGI where+implementation Applicative CGI where     pure v = MkCGI (\s => return (v, s))      (MkCGI a) <*> (MkCGI b) = MkCGI (\s => do (f, i) <- a s                                               (c, j) <- b i                                               return (f c, j)) -instance Monad CGI where {+implementation Monad CGI where     (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s                                         getAction (k (fst v)) (snd v))-}  setInfo : CGIInfo -> CGI () setInfo i = MkCGI (\s => return ((), i))
libs/contrib/Network/Socket.idr view
@@ -13,7 +13,7 @@ ByteLength : Type ByteLength = Int -class ToCode a where+interface ToCode a where   toCode : a -> Int  ||| Socket Families@@ -28,12 +28,12 @@   |||  IP / UDP etc. IPv6   AF_INET6 -instance Show SocketFamily where+implementation Show SocketFamily where   show AF_UNSPEC = "AF_UNSPEC"   show AF_INET   = "AF_INET"   show AF_INET6  = "AF_INET6" -instance ToCode SocketFamily where+implementation ToCode SocketFamily where   toCode AF_UNSPEC = 0   toCode AF_INET   = 2   toCode AF_INET6  = 10@@ -52,13 +52,13 @@   ||| Raw sockets   RawSocket -instance Show SocketType where+implementation Show SocketType where   show NotASocket = "Not a socket"   show Stream     = "Stream"   show Datagram   = "Datagram"   show RawSocket  = "Raw" -instance ToCode SocketType where+implementation ToCode SocketType where   toCode NotASocket = 0   toCode Stream     = 1   toCode Datagram   = 2@@ -89,7 +89,7 @@                    | Hostname String                    | InvalidAddress -- Used when there's a parse error -instance Show SocketAddress where+implementation Show SocketAddress where   show (IPv4Addr i1 i2 i3 i4) = concat $ Prelude.List.intersperse "." (map show [i1, i2, i3, i4])   show IPv6Addr = "NOT IMPLEMENTED YET"   show (Hostname host) = host
libs/contrib/System/Concurrency/Process.idr view
@@ -14,14 +14,14 @@ data Process : (msgType : Type) -> Type -> Type where      Lift : IO a -> Process msg a -instance Functor (Process msg) where+implementation Functor (Process msg) where      map f (Lift a) = Lift (map f a) -instance Applicative (Process msg) where+implementation Applicative (Process msg) where      pure = Lift . return      (Lift f) <*> (Lift a) = Lift (f <*> a) -instance Monad (Process msg) where+implementation Monad (Process msg) where      (Lift io) >>= k = Lift (do x <- io                                 case k x of                                      Lift v => v)
libs/effects/Effect/Default.idr view
@@ -1,46 +1,45 @@-module Default+module Effect.Default  import Data.Vect -class Default a where+interface Default a where     default : a -instance Default Int where+implementation Default Int where     default = 0 -instance Default Integer where+implementation Default Integer where     default = 0 -instance Default Double where+implementation Default Double where     default = 0 -instance Default Nat where+implementation Default Nat where     default = 0 -instance Default Char where+implementation Default Char where     default = '\0' -instance Default String where+implementation Default String where     default = "" -instance Default Bool where+implementation Default Bool where     default = False -instance Default () where+implementation Default () where     default = () -instance (Default a, Default b) => Default (a, b) where+implementation (Default a, Default b) => Default (a, b) where     default = (default, default) -instance Default (Maybe a) where+implementation Default (Maybe a) where     default = Nothing -instance Default (List a) where+implementation Default (List a) where     default = [] -instance Default a => Default (Vect n a) where+implementation Default a => Default (Vect n a) where     default = mkDef _ where       mkDef : (n : Nat) -> Vect n a       mkDef Z = []       mkDef (S k) = default :: mkDef k-
libs/effects/Effect/Exception.idr view
@@ -7,20 +7,20 @@ data Exception : Type -> Effect where      Raise : a -> sig (Exception a) b -instance Handler (Exception a) Maybe where+implementation Handler (Exception a) Maybe where      handle _ (Raise e) k = Nothing -instance Handler (Exception a) List where+implementation Handler (Exception a) List where      handle _ (Raise e) k = [] -instance Show a => Handler (Exception a) IO where+implementation Show a => Handler (Exception a) IO where      handle _ (Raise e) k = do printLn e                                believe_me (exit 1) -instance Handler (Exception a) (IOExcept a) where+implementation Handler (Exception a) (IOExcept a) where      handle _ (Raise e) k = ioe_fail e -instance Handler (Exception a) (Either a) where+implementation Handler (Exception a) (Either a) where      handle _ (Raise e) k = Left e  EXCEPTION : Type -> EFFECT
libs/effects/Effect/File.idr view
@@ -73,7 +73,7 @@ -- ------------------------------------------------------------ [ The Handlers ]  --- An implementation of the resource access protocol for the IO Context.-instance Handler FileIO IO where+implementation Handler FileIO IO where     handle () (Open fname m) k = do Right h <- openFile fname m                                         | Left err => k False ()                                     k True (FH h)@@ -89,7 +89,7 @@     handle (FH h) EOF             k = do e <- fEOF h                                          k e (FH h) -instance Handler FileIO (IOExcept a) where+implementation Handler FileIO (IOExcept a) where     handle () (Open fname m) k = do Right h <- ioe_lift $ openFile fname m                                         | Left err => k False ()                                     k True (FH h)
libs/effects/Effect/Logging/Category.idr view
@@ -25,7 +25,7 @@   getLevel      : LogLevel n   getCategories : List a -instance Default (LogRes a) where+implementation Default (LogRes a) where   default = MkLogRes OFF Nil  -- ------------------------------------------------------- [ Effect Definition ]@@ -68,7 +68,7 @@  -- -------------------------------------------------------------- [ IO Handler ] -instance Handler Logging IO where+implementation Handler Logging IO where     handle st (SetLogLvl  nlvl)  k = do         let newSt = record {getLevel = nlvl}  st         k () newSt
libs/effects/Effect/Logging/Default.idr view
@@ -24,7 +24,7 @@   constructor MkLogRes   getLevel : LogLevel n -instance Default LogRes where+implementation Default LogRes where   default = MkLogRes OFF  -- ------------------------------------------------------ [ The Logging Effect ]@@ -49,7 +49,7 @@ -- -------------------------------------------------------------- [ IO Handler ]  -- For logging in the IO context-instance Handler Logging IO where+implementation Handler Logging IO where     handle st (SetLvl newLvl) k = k () (MkLogRes newLvl)     handle st (Log lvl msg) k = do       case cmpLevel lvl (getLevel st)  of
libs/effects/Effect/Logging/Level.idr view
@@ -54,10 +54,10 @@   ||| User defined logging level.   CUSTOM : (n : Nat) -> {auto prf : LTE n 70} -> LogLevel n -instance Cast (LogLevel n) Nat where+implementation Cast (LogLevel n) Nat where   cast {n} _ = n -instance Show (LogLevel n) where+implementation Show (LogLevel n) where   show OFF        = "OFF"   show TRACE      = "TRACE"   show DEBUG      = "DEBUG"@@ -68,7 +68,7 @@   show ALL        = "ALL"   show (CUSTOM n) = unwords ["CUSTOM", show n] -instance Eq (LogLevel n) where+implementation Eq (LogLevel n) where   (==) x y = lvlEq x y     where       lvlEq : LogLevel a -> LogLevel b -> Bool
libs/effects/Effect/Memory.idr view
@@ -79,7 +79,7 @@   = do foreign FFI_C "idris_poke" (Ptr -> Int -> Bits8 -> IO ()) ptr (fromInteger $ cast offset) b        do_poke ptr (S offset) bs -instance Handler RawMemory (IOExcept String) where+implementation Handler RawMemory (IOExcept String) where   handle () (Allocate n) k     = do ptr <- do_malloc n          k () (CH ptr)
libs/effects/Effect/Monad.idr view
@@ -5,18 +5,18 @@ data MonadEffT : List EFFECT -> (Type -> Type) -> Type -> Type where      MkMonadEffT : EffM m a xs (\v => xs) -> MonadEffT xs m a -instance Functor (MonadEffT xs f) where+implementation Functor (MonadEffT xs f) where     map f (MkMonadEffT x) = MkMonadEffT (do x' <- x                                             pure (f x')) -instance Applicative (MonadEffT xs f) where+implementation Applicative (MonadEffT xs f) where     pure x = MkMonadEffT (pure x)     (<*>) (MkMonadEffT f) (MkMonadEffT x)            = MkMonadEffT (do f' <- f                             x' <- x                             pure (f' x')) -instance Monad (MonadEffT xs f) where+implementation Monad (MonadEffT xs f) where     (>>=) (MkMonadEffT x) f = MkMonadEffT (do x' <- x                                               let MkMonadEffT fx = f x'                                               fx)
libs/effects/Effect/Perf.idr view
@@ -57,7 +57,7 @@   stamps   : List (String, Integer)  -instance Default PMetrics where+implementation Default PMetrics where   default = MkPMetrics False False Nil Nil 0 Nil  displayPerfMetrics : PMetrics -> String@@ -121,7 +121,7 @@  -- ---------------------------------------------------------- [ Handler for IO ] -instance Handler Perf IO where+implementation Handler Perf IO where   handle res (TurnOn b) k = do       v <- time       let res' = record {canPerf = True, livePerf = b, stime = v} res
libs/effects/Effect/Random.idr view
@@ -7,7 +7,7 @@      GetRandom : sig Random Integer Integer      SetSeed   : Integer -> sig Random () Integer -instance Handler Random m where+implementation Handler Random m where   handle seed GetRandom k            = let seed' = assert_total ((1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32)) in                  k seed' seed'
libs/effects/Effect/Select.idr view
@@ -5,14 +5,14 @@ data Selection : Effect where      Select : List a -> sig Selection a () -instance Handler Selection Maybe where+implementation Handler Selection Maybe where      handle _ (Select xs) k = tryAll xs where          tryAll [] = Nothing          tryAll (x :: xs) = case k x () of                                  Nothing => tryAll xs                                  Just v => Just v -instance Handler Selection List where+implementation Handler Selection List where      handle r (Select xs) k = concatMap (\x => k x r) xs  SELECT : EFFECT
libs/effects/Effect/State.idr view
@@ -9,7 +9,7 @@   Put : b -> sig State () a b  -- using (m : Type -> Type)-instance Handler State m where+implementation Handler State m where      handle st Get     k = k st st      handle st (Put n) k = k () n
libs/effects/Effect/StdIO.idr view
@@ -19,13 +19,13 @@ -- IO effects handlers ------------------------------------------------------------- -instance Handler StdIO IO where+implementation Handler StdIO IO where     handle () (PutStr s) k = do putStr s; k () ()     handle () GetStr     k = do x <- getLine; k x ()     handle () (PutCh c)  k = do putChar c; k () ()     handle () GetCh      k = do x <- getChar; k x () -instance Handler StdIO (IOExcept a) where+implementation Handler StdIO (IOExcept a) where     handle () (PutStr s) k = do ioe_lift $ putStr s; k () ()     handle () GetStr     k = do x <- ioe_lift $ getLine; k x ()     handle () (PutCh c)  k = do ioe_lift $ putChar c; k () ()
libs/effects/Effect/System.idr view
@@ -13,13 +13,13 @@      GetEnv : String -> sig System (Maybe String)      CSystem : String -> sig System Int -instance Handler System IO where+implementation Handler System IO where     handle () Args k = do x <- getArgs; k x ()     handle () Time k = do x <- time; k x ()     handle () (GetEnv s) k = do x <- getEnv s; k x ()     handle () (CSystem s) k = do x <- system s; k x () -instance Handler System (IOExcept a) where+implementation Handler System (IOExcept a) where     handle () Args k = do x <- ioe_lift getArgs; k x ()     handle () Time k = do x <- ioe_lift time; k x ()     handle () (GetEnv s) k = do x <- ioe_lift $ getEnv s; k x ()
libs/effects/Effect/Trans.idr view
@@ -8,7 +8,7 @@   Lift : m a -> sig (Trans m) a  -- using (m : Type -> Type)-instance Monad m => Handler (Trans m) m where+implementation Monad m => Handler (Trans m) m where      handle st (Lift op) k = do x <- op                                 k x ()
libs/effects/Effects.idr view
@@ -46,9 +46,9 @@         (ret : Type) -> (res_in : Type) -> (res_out : ret -> Type) -> Type   sig e r e_in e_out = e r e_in e_out -||| Handler classes describe how an effect `e` is translated to the+||| Handler interfaces describe how an effect `e` is translated to the ||| underlying computation context `m` for execution.-class Handler (e : Effect) (m : Type -> Type) where+interface Handler (e : Effect) (m : Type -> Type) where   ||| How to handle the effect.   |||   ||| @ r The resource being handled.@@ -138,7 +138,7 @@ (:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e  using (lbl : Type)-  instance Default a => Default (LRes lbl a) where+  implementation Default a => Default (LRes lbl a) where     default = lbl := default  private@@ -285,7 +285,7 @@    = let env' = unlabel env in          eff env' prog (\p', envk => k p' (relabel l envk)) --- yuck :) Haven't got type class instances working nicely in tactic+-- yuck :) Haven't got interface instances working nicely in tactic -- proofs yet, and 'search' can't be told about any hints yet, -- so just brute force it. syntax MkDefaultEnv = with Env
libs/prelude/Decidable/Equality.idr view
@@ -23,7 +23,7 @@ --------------------------------------------------------------------------------  ||| Decision procedures for propositional equality-class DecEq t where+interface DecEq t where   ||| Decide whether two elements of `t` are propositionally equal   total decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2) @@ -31,7 +31,7 @@ --- Unit -------------------------------------------------------------------------------- -instance DecEq () where+implementation DecEq () where   decEq () () = Yes Refl  --------------------------------------------------------------------------------@@ -40,7 +40,7 @@ total trueNotFalse : True = False -> Void trueNotFalse Refl impossible -instance DecEq Bool where+implementation DecEq Bool where   decEq True  True  = Yes Refl   decEq False False = Yes Refl   decEq True  False = No trueNotFalse@@ -53,7 +53,7 @@ total ZnotS : Z = S n -> Void ZnotS Refl impossible -instance DecEq Nat where+implementation DecEq Nat where   decEq Z     Z     = Yes Refl   decEq Z     (S _) = No ZnotS   decEq (S _) Z     = No (negEqSym ZnotS)@@ -68,7 +68,7 @@ total nothingNotJust : {x : t} -> (Nothing {a = t} = Just x) -> Void nothingNotJust Refl impossible -instance (DecEq t) => DecEq (Maybe t) where+implementation (DecEq t) => DecEq (Maybe t) where   decEq Nothing Nothing = Yes Refl   decEq (Just x') (Just y') with (decEq x' y')     | Yes p = Yes $ cong p@@ -83,7 +83,7 @@ total leftNotRight : {x : a} -> {y : b} -> Left {b = b} x = Right {a = a} y -> Void leftNotRight Refl impossible -instance (DecEq a, DecEq b) => DecEq (Either a b) where+implementation (DecEq a, DecEq b) => DecEq (Either a b) where   decEq (Left x') (Left y') with (decEq x' y')     | Yes p = Yes $ cong p     | No p = No $ \h : Left x' = Left y' => p $ leftInjective {b = b} h@@ -109,7 +109,7 @@                        ((x, y) = (x', y) -> Void) lemma_fst_neq_snd_eq p_x_not_x' Refl Refl = p_x_not_x' Refl -instance (DecEq a, DecEq b) => DecEq (a, b) where+implementation (DecEq a, DecEq b) => DecEq (a, b) where   decEq (a, b) (a', b')     with (decEq a a')     decEq (a, b) (a, b')    | (Yes Refl) with (decEq b b')       decEq (a, b) (a, b)   | (Yes Refl) | (Yes Refl) = Yes Refl@@ -135,7 +135,7 @@ lemma_x_neq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> Void) -> (xs = ys -> Void) -> ((x :: xs) = (y :: ys) -> Void) lemma_x_neq_xs_neq p p' Refl = p Refl -instance DecEq a => DecEq (List a) where+implementation DecEq a => DecEq (List a) where   decEq [] [] = Yes Refl   decEq (x :: xs) [] = No lemma_val_not_nil   decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil)@@ -155,7 +155,7 @@ -- Int -------------------------------------------------------------------------------- -instance DecEq Int where+implementation DecEq Int where     decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq        where primitiveEq : x = y              primitiveEq = believe_me (Refl {x})@@ -165,7 +165,7 @@ -- Char -------------------------------------------------------------------------------- -instance DecEq Char where+implementation DecEq Char where     decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq        where primitiveEq : x = y              primitiveEq = believe_me (Refl {x})@@ -175,7 +175,7 @@ -- Integer -------------------------------------------------------------------------------- -instance DecEq Integer where+implementation DecEq Integer where     decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq        where primitiveEq : x = y              primitiveEq = really_believe_me (Refl {x})@@ -186,7 +186,7 @@ -- String -------------------------------------------------------------------------------- -instance DecEq String where+implementation DecEq String where     decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq        where primitiveEq : x = y              primitiveEq = believe_me (Refl {x})@@ -196,7 +196,7 @@ -- Ptr -------------------------------------------------------------------------------- -instance DecEq Ptr where+implementation DecEq Ptr where     decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq        where primitiveEq : x = y              primitiveEq = believe_me (Refl {x})@@ -206,7 +206,7 @@ -- ManagedPtr -------------------------------------------------------------------------------- -instance DecEq ManagedPtr where+implementation DecEq ManagedPtr where     decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq        where primitiveEq : x = y              primitiveEq = believe_me (Refl {x})
libs/prelude/Language/Reflection.idr view
@@ -80,34 +80,34 @@            | WorldType | TheWorld %name Const c, c' -abstract class ReflConst (a : Type) where+abstract interface ReflConst (a : Type) where    toConst : a -> Const -instance ReflConst Int where+implementation ReflConst Int where    toConst x = I x -instance ReflConst Integer where+implementation ReflConst Integer where    toConst = BI -instance ReflConst Double where+implementation ReflConst Double where    toConst = Fl -instance ReflConst Char where+implementation ReflConst Char where    toConst = Ch -instance ReflConst String where+implementation ReflConst String where    toConst = Str -instance ReflConst Bits8 where+implementation ReflConst Bits8 where    toConst = B8 -instance ReflConst Bits16 where+implementation ReflConst Bits16 where    toConst = B16 -instance ReflConst Bits32 where+implementation ReflConst Bits32 where    toConst = B32 -instance ReflConst Bits64 where+implementation ReflConst Bits64 where    toConst = B64  implicit@@ -182,7 +182,7 @@  %name Binder b, b' -instance Functor Binder where+implementation Functor Binder where   map f (Lam x) = Lam (f x)   map f (Pi x k) = Pi (f x) (f k)   map f (Let x y) = Let (f x) (f y)@@ -192,7 +192,7 @@   map f (PVar x) = PVar (f x)   map f (PVTy x) = PVTy (f x) -instance Foldable Binder where+implementation Foldable Binder where   foldr f z (Lam x) = f x z   foldr f z (Pi x k) = f x (f k z)   foldr f z (Let x y) = f x (f y z)@@ -202,7 +202,7 @@   foldr f z (PVar x) = f x z   foldr f z (PVTy x) = f x z -instance Traversable Binder where+implementation Traversable Binder where   traverse f (Lam x) = [| Lam (f x) |]   traverse f (Pi x k) = [| Pi (f x) (f k) |]   traverse f (Let x y) = [| Let (f x) (f y) |]@@ -285,7 +285,7 @@             Trivial |             ||| Build a proof by applying contructors up to a maximum depth             Search Int |-            ||| Resolve a type class+            ||| Resolve an interface             Instance |             ||| Infer the proof target from the context             Solve |@@ -330,12 +330,12 @@  ||| Things with a canonical representation as a reflected term. |||-||| This type class is intended to be used during proof automation and the+||| This interface is intended to be used during proof automation and the ||| construction of custom tactics. ||| ||| @ a the type to be quoted ||| @ t the type to quote it to (typically `TT` or `Raw`)-class Quotable a t where+interface Quotable a t where   ||| A representation of the type `a`.   |||   ||| This is to enable quoting polymorphic datatypes@@ -346,122 +346,122 @@   ||| Each equation should look something like ```quote (Foo x y) = `(Foo ~(quote x) ~(quote y))```   quote : a -> t -instance Quotable Nat TT where+implementation Quotable Nat TT where   quotedTy = `(Nat)    quote Z     = `(Z)   quote (S k) = `(S ~(quote k)) -instance Quotable Nat Raw where+implementation Quotable Nat Raw where   quotedTy = `(Nat)    quote Z     = `(Z)   quote (S k) = `(S ~(quote k)) -instance Quotable Int TT where+implementation Quotable Int TT where   quotedTy = `(Int)   quote x = TConst (I x) -instance Quotable Int Raw where+implementation Quotable Int Raw where   quotedTy = `(Int)   quote x = RConstant (I x) -instance Quotable Double TT where+implementation Quotable Double TT where   quotedTy = `(Double)   quote x = TConst (Fl x) -instance Quotable Double Raw where+implementation Quotable Double Raw where   quotedTy = `(Double)   quote x = RConstant (Fl x) -instance Quotable Char TT where+implementation Quotable Char TT where   quotedTy = `(Char)   quote x = TConst (Ch x) -instance Quotable Char Raw where+implementation Quotable Char Raw where   quotedTy = `(Char)   quote x = RConstant (Ch x) -instance Quotable Bits8 TT where+implementation Quotable Bits8 TT where   quotedTy = `(Bits8)   quote x = TConst (B8 x) -instance Quotable Bits8 Raw where+implementation Quotable Bits8 Raw where   quotedTy = `(Bits8)   quote x = RConstant (B8 x) -instance Quotable Bits16 TT where+implementation Quotable Bits16 TT where   quotedTy = `(Bits16)   quote x = TConst (B16 x) -instance Quotable Bits16 Raw where+implementation Quotable Bits16 Raw where   quotedTy = `(Bits16)   quote x = RConstant (B16 x) -instance Quotable Bits32 TT where+implementation Quotable Bits32 TT where   quotedTy = `(Bits32)   quote x = TConst (B32 x) -instance Quotable Bits32 Raw where+implementation Quotable Bits32 Raw where   quotedTy = `(Bits32)   quote x = RConstant (B32 x) -instance Quotable Bits64 TT where+implementation Quotable Bits64 TT where   quotedTy = `(Bits64)   quote x = TConst (B64 x) -instance Quotable Bits64 Raw where+implementation Quotable Bits64 Raw where   quotedTy = `(Bits64)   quote x = RConstant (B64 x) -instance Quotable Integer TT where+implementation Quotable Integer TT where   quotedTy = `(Integer)   quote x = TConst (BI x) -instance Quotable Integer Raw where+implementation Quotable Integer Raw where   quotedTy = `(Integer)   quote x = RConstant (BI x) -instance Quotable String TT where+implementation Quotable String TT where   quotedTy = `(String)   quote x = TConst (Str x) -instance Quotable String Raw where+implementation Quotable String Raw where   quotedTy = `(String)   quote x = RConstant (Str x) -instance Quotable NameType TT where+implementation Quotable NameType TT where   quotedTy = `(NameType)   quote Bound = `(Bound)   quote Ref = `(Ref)   quote (DCon x y) = `(DCon ~(quote x) ~(quote y))   quote (TCon x y) = `(TCon ~(quote x) ~(quote y)) -instance Quotable NameType Raw where+implementation Quotable NameType Raw where   quotedTy = `(NameType)   quote Bound = `(Bound)   quote Ref = `(Ref)   quote (DCon x y) = `(DCon ~(quote {t=Raw} x) ~(quote {t=Raw} y))   quote (TCon x y) = `(TCon ~(quote {t=Raw} x) ~(quote {t=Raw} y)) -instance Quotable a TT => Quotable (List a) TT where+implementation Quotable a TT => Quotable (List a) TT where   quotedTy = `(List ~(quotedTy {a}))   quote [] = `(List.Nil {elem=~(quotedTy {a})})   quote (x :: xs) = `(List.(::) {elem=~(quotedTy {a})} ~(quote x) ~(quote xs)) -instance Quotable a Raw => Quotable (List a) Raw where+implementation Quotable a Raw => Quotable (List a) Raw where   quotedTy = `(List ~(quotedTy {a}))   quote [] = `(List.Nil {elem=~(quotedTy {a})})   quote (x :: xs) = `(List.(::) {elem=~(quotedTy {a})} ~(quote x) ~(quote xs)) -instance Quotable SourceLocation TT where+implementation Quotable SourceLocation TT where   quotedTy = `(SourceLocation)   quote (FileLoc fn (sl, sc) (el, ec)) =     `(FileLoc ~(quote fn)               (~(quote sl), ~(quote sc))               (~(quote el), ~(quote ec))) -instance Quotable SourceLocation Raw where+implementation Quotable SourceLocation Raw where   quotedTy = `(SourceLocation)   quote (FileLoc fn (sl, sc) (el, ec)) =     `(FileLoc ~(quote {t=Raw} fn)@@ -470,14 +470,14 @@   mutual-  instance Quotable TTName TT where+  implementation Quotable TTName TT where     quotedTy = `(TTName)     quote (UN x) = `(UN ~(quote x))     quote (NS n xs) = `(NS ~(quote n) ~(quote xs))     quote (MN x y) = `(MN ~(quote x) ~(quote y))     quote (SN sn) = `(SN ~(assert_total $ quote sn)) -  instance Quotable SpecialName TT where+  implementation Quotable SpecialName TT where     quotedTy = `(SpecialName)     quote (WhereN i n1 n2) = `(WhereN ~(quote i) ~(quote n1) ~(quote n2))     quote (WithN i n) = `(WithN ~(quote i) ~(quote n))@@ -490,14 +490,14 @@     quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta))  mutual-  instance Quotable TTName Raw where+  implementation Quotable TTName Raw where     quotedTy = `(TTName)     quote (UN x) = `(UN ~(quote {t=Raw} x))     quote (NS n xs) = `(NS ~(quote {t=Raw} n) ~(quote {t=Raw} xs))     quote (MN x y) = `(MN ~(quote {t=Raw} x) ~(quote {t=Raw} y))     quote (SN sn) = `(SN ~(assert_total $ quote sn)) -  instance Quotable SpecialName Raw where+  implementation Quotable SpecialName Raw where     quotedTy = `(SpecialName)     quote (WhereN i n1 n2) = `(WhereN ~(quote i) ~(quote n1) ~(quote n2))     quote (WithN i n) = `(WithN ~(quote i) ~(quote n))@@ -510,45 +510,45 @@     quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta))  -instance Quotable NativeTy TT where+implementation Quotable NativeTy TT where     quotedTy = `(NativeTy)     quote IT8 = `(Reflection.IT8)     quote IT16 = `(Reflection.IT16)     quote IT32 = `(Reflection.IT32)     quote IT64 = `(Reflection.IT64) -instance Quotable NativeTy Raw where+implementation Quotable NativeTy Raw where     quotedTy = `(NativeTy)     quote IT8 = `(Reflection.IT8)     quote IT16 = `(Reflection.IT16)     quote IT32 = `(Reflection.IT32)     quote IT64 = `(Reflection.IT64) -instance Quotable Reflection.IntTy TT where+implementation Quotable Reflection.IntTy TT where   quotedTy = `(Reflection.IntTy)   quote (ITFixed x) = `(ITFixed ~(quote x))   quote ITNative = `(Reflection.ITNative)   quote ITBig = `(ITBig)   quote ITChar = `(Reflection.ITChar) -instance Quotable Reflection.IntTy Raw where+implementation Quotable Reflection.IntTy Raw where   quotedTy = `(Reflection.IntTy)   quote (ITFixed x) = `(ITFixed ~(quote {t=Raw} x))   quote ITNative = `(Reflection.ITNative)   quote ITBig = `(ITBig)   quote ITChar = `(Reflection.ITChar) -instance Quotable ArithTy TT where+implementation Quotable ArithTy TT where   quotedTy = `(ArithTy)   quote (ATInt x) = `(ATInt ~(quote x))   quote ATDouble = `(ATDouble) -instance Quotable ArithTy Raw where+implementation Quotable ArithTy Raw where   quotedTy = `(ArithTy)   quote (ATInt x) = `(ATInt ~(quote {t=Raw} x))   quote ATDouble = `(ATDouble) -instance Quotable Const TT where+implementation Quotable Const TT where   quotedTy = `(Const)   quote (I x) = `(I ~(quote x))   quote (BI x) = `(BI ~(quote x))@@ -566,7 +566,7 @@   quote WorldType = `(WorldType)   quote TheWorld = `(TheWorld) -instance Quotable Const Raw where+implementation Quotable Const Raw where   quotedTy = `(Const)   quote (I x) = `(I ~(quote {t=Raw} x))   quote (BI x) = `(BI ~(quote {t=Raw} x))@@ -584,30 +584,30 @@   quote WorldType = `(WorldType)   quote TheWorld = `(TheWorld) -instance Quotable TTUExp TT where+implementation Quotable TTUExp TT where   quotedTy = `(TTUExp)   quote (UVar x) = `(UVar ~(quote x))   quote (UVal x) = `(UVal ~(quote x)) -instance Quotable TTUExp Raw where+implementation Quotable TTUExp Raw where   quotedTy = `(TTUExp)   quote (UVar x) = `(UVar ~(quote {t=Raw} x))   quote (UVal x) = `(UVal ~(quote {t=Raw} x)) -instance Quotable Universe TT where+implementation Quotable Universe TT where   quotedTy = `(Universe)   quote Reflection.NullType = `(NullType)   quote Reflection.UniqueType = `(UniqueType)   quote Reflection.AllTypes = `(AllTypes) -instance Quotable Universe Raw where+implementation Quotable Universe Raw where   quotedTy = `(Universe)   quote Reflection.NullType = `(NullType)   quote Reflection.UniqueType = `(UniqueType)   quote Reflection.AllTypes = `(AllTypes)  mutual-  instance Quotable TT TT where+  implementation Quotable TT TT where     quotedTy = `(TT)     quote (P nt n tm) = `(P ~(quote nt) ~(quote n) ~(quote tm))     quote (V x) = `(V ~(quote x))@@ -618,7 +618,7 @@     quote (TType uexp) = `(TType ~(quote uexp))     quote (UType u) = `(UType ~(quote u)) -  instance Quotable (Binder TT) TT where+  implementation Quotable (Binder TT) TT where     quotedTy = `(Binder TT)     quote (Lam x) = `(Lam {a=TT} ~(assert_total (quote x)))     quote (Pi x k) = `(Pi {a=TT} ~(assert_total (quote x))@@ -651,11 +651,11 @@   quoteRawBinderTT (PVar x) = `(PVar {a=Raw} ~(quoteRawTT x))   quoteRawBinderTT (PVTy x) = `(PVTy {a=Raw} ~(quoteRawTT x)) -instance Quotable Raw TT where+implementation Quotable Raw TT where   quotedTy = `(Raw)   quote = quoteRawTT -instance Quotable (Binder Raw) TT where+implementation Quotable (Binder Raw) TT where   quotedTy = `(Binder Raw)   quote = quoteRawBinderTT @@ -678,15 +678,15 @@   quoteRawBinderRaw (PVar x) = `(PVar {a=Raw} ~(quoteRawRaw x))   quoteRawBinderRaw (PVTy x) = `(PVTy {a=Raw} ~(quoteRawRaw x)) -instance Quotable Raw Raw where+implementation Quotable Raw Raw where   quotedTy = `(Raw)   quote = quoteRawRaw -instance Quotable (Binder Raw) Raw where+implementation Quotable (Binder Raw) Raw where   quotedTy = `(Binder Raw)   quote = quoteRawBinderRaw -instance Quotable ErrorReportPart TT where+implementation Quotable ErrorReportPart TT where   quotedTy = `(ErrorReportPart)   quote (TextPart x) = `(TextPart ~(quote x))   quote (NamePart n) = `(NamePart ~(quote n))@@ -694,7 +694,7 @@   quote (RawPart tm) = `(RawPart ~(quote tm))   quote (SubReport xs) = `(SubReport ~(assert_total $ quote xs)) -instance Quotable Tactic TT where+implementation Quotable Tactic TT where   quotedTy = `(Tactic)   quote (Try tac tac') = `(Try ~(quote tac) ~(quote tac'))   quote (GoalType x tac) = `(GoalType ~(quote x) ~(quote tac))
libs/prelude/Language/Reflection/Elab.idr view
@@ -28,7 +28,7 @@   Explicit |   ||| The argument is found by Idris at the application site   Implicit |-  ||| The argument is solved using type class resolution+  ||| The argument is solved using interface resolution   Constraint  ||| Function arguments@@ -166,23 +166,23 @@ ------------- %access public namespace Tactics-  instance Functor Elab where+  implementation Functor Elab where     map f t = Prim__BindElab t (\x => Prim__PureElab (f x)) -  instance Applicative Elab where+  implementation Applicative Elab where     pure x  = Prim__PureElab x     f <*> x = Prim__BindElab f $ \g =>               Prim__BindElab x $ \y =>               Prim__PureElab   $ g y -  ||| The Alternative instance on Elab represents left-biased error+  ||| The Alternative implementation on Elab represents left-biased error   ||| handling. In other words, `t <|> t'` will run `t`, and if it   ||| fails, roll back the elaboration state and run `t'`.-  instance Alternative Elab where+  implementation Alternative Elab where     empty   = Prim__Fail [TextPart "empty"]     x <|> y = Prim__Try x y -  instance Monad Elab where+  implementation Monad Elab where     x >>= f = Prim__BindElab x f    ||| Halt elaboration with an error@@ -468,20 +468,20 @@   defineFunction : FunDefn Raw -> Elab ()   defineFunction defun = Prim__DefineFunction defun -  ||| Register a new instance for type class resolution.+  ||| Register a new implementation for interface resolution.   |||-  ||| @ className the name of the class for which an instance is being registered-  ||| @ instName the name of the definition to use in instance search-  addInstance : (className, instName : TTName) -> Elab ()-  addInstance className instName = Prim__AddInstance className instName+  ||| @ ifaceName the name of the interface for which an implementation is being registered+  ||| @ instName the name of the definition to use in implementation search+  addInstance : (ifaceName, instName : TTName) -> Elab ()+  addInstance ifaceName instName = Prim__AddInstance ifaceName instName -  ||| Determine whether a name denotes a class.+  ||| Determine whether a name denotes an interface.   |||-  ||| @ name a name that might denote a class.+  ||| @ name a name that might denote an interface.   isTCName : (name : TTName) -> Elab Bool   isTCName name = Prim__IsTCName name -  ||| Attempt to solve the current goal with a type class dictionary+  ||| Attempt to solve the current goal with an interface dictionary   |||   ||| @ fn the name of the definition being elaborated (to prevent Idris   ||| from looping)
libs/prelude/Prelude.idr view
@@ -46,80 +46,80 @@ decAsBool (No _)  = False  ----- Functor instances+---- Functor implementations -instance Functor PrimIO where+Functor PrimIO where     map f io = prim_io_bind io (prim_io_return . f) -instance Functor Maybe where+Functor Maybe where     map f (Just x) = Just (f x)     map f Nothing  = Nothing -instance Functor (Either e) where+Functor (Either e) where     map f (Left l) = Left l     map f (Right r) = Right (f r) ----- Applicative instances+---- Applicative implementations -instance Applicative PrimIO where+Applicative PrimIO where     pure = prim_io_return      am <*> bm = prim_io_bind am (\f => prim_io_bind bm (prim_io_return . f)) -instance Applicative Maybe where+Applicative Maybe where     pure = Just      (Just f) <*> (Just a) = Just (f a)     _        <*> _        = Nothing -instance Applicative (Either e) where+Applicative (Either e) where     pure = Right      (Left a) <*> _          = Left a     (Right f) <*> (Right r) = Right (f r)     (Right _) <*> (Left l)  = Left l -instance Applicative List where+Applicative List where     pure x = [x]      fs <*> vs = concatMap (\f => map f vs) fs ----- Alternative instances+---- Alternative implementations -instance Alternative Maybe where+Alternative Maybe where     empty = Nothing      (Just x) <|> _ = Just x     Nothing  <|> v = v -instance Alternative List where+Alternative List where     empty = []      (<|>) = (++) ----- Monad instances+---- Monad implementations -instance Monad PrimIO where+Monad PrimIO where     b >>= k = prim_io_bind b k -instance Monad Maybe where+Monad Maybe where     Nothing  >>= k = Nothing     (Just x) >>= k = k x -instance Monad (Either e) where+Monad (Either e) where     (Left n) >>= _ = Left n     (Right r) >>= f = f r -instance Monad List where+Monad List where     m >>= f = concatMap f m ----- Traversable instances+---- Traversable implementations -instance Traversable Maybe where+Traversable Maybe where     traverse f Nothing = pure Nothing     traverse f (Just x) = [| Just (f x) |] -instance Traversable List where+Traversable List where     traverse f [] = pure List.Nil     traverse f (x::xs) = [| List.(::) (f x) (traverse f xs) |] @@ -145,7 +145,7 @@ natEnumFromThenTo _ Z       _ = [] natEnumFromThenTo n (S inc) m = map (plus n . (* (S inc))) (natRange (S (divNatNZ (minus m n) (S inc) SIsNotZ))) -class Enum a where+interface Enum a where   total pred : a -> a   total succ : a -> a   succ e = fromNat (S (toNat e))@@ -160,7 +160,7 @@   total enumFromThenTo : a -> a -> a -> List a   enumFromThenTo x1 x2 y = map fromNat (natEnumFromThenTo (toNat x1) (toNat x2) (toNat y)) -instance Enum Nat where+Enum Nat where   pred n = Nat.pred n   succ n = S n   toNat x = id x@@ -169,7 +169,7 @@   enumFromThenTo x y z = natEnumFromThenTo x y z   enumFromTo x y = natEnumFromTo x y -instance Enum Integer where+Enum Integer where   pred n = n - 1   succ n = n + 1   toNat n = cast n@@ -187,7 +187,7 @@           go [] = []           go (x :: xs) = n + (cast x * inc) :: go xs -instance Enum Int where+Enum Int where   pred n = n - 1   succ n = n + 1   toNat n = cast n@@ -207,7 +207,7 @@           go [] = []           go (x :: xs) = n + (cast x * inc) :: go xs -instance Enum Char where+Enum Char where   toNat c   = toNat (ord c)   fromNat n = chr (fromNat n)
libs/prelude/Prelude/Algebra.idr view
@@ -7,7 +7,7 @@ %access public  ----------------------------------------------------------------------------------- A modest class hierarchy+-- A modest interface hierarchy --------------------------------------------------------------------------------  ||| Sets equipped with a single binary operation that is associative.  Must@@ -15,8 +15,8 @@ ||| ||| + Associativity of `<+>`: |||     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c-class Semigroup a where-  (<+>) : a -> a -> a+interface Semigroup ty where+  (<+>) : ty -> ty -> ty   ||| Sets equipped with a single binary operation that is associative, along with@@ -28,6 +28,6 @@ ||| + Neutral for `<+>`: |||     forall a,     a <+> neutral   == a |||     forall a,     neutral <+> a   == a-class Semigroup a => Monoid a where-  neutral : a+interface Semigroup ty => Monoid ty where+  neutral : ty
libs/prelude/Prelude/Applicative.idr view
@@ -12,7 +12,7 @@  infixl 2 <*> -class Functor f => Applicative (f : Type -> Type) where+interface Functor f => Applicative (f : Type -> Type) where     pure  : a -> f a     (<*>) : f (a -> b) -> f a -> f b @@ -37,7 +37,7 @@ liftA3 f a b c = (map f a) <*> b <*> c  infixl 3 <|>-class Applicative f => Alternative (f : Type -> Type) where+interface Applicative f => Alternative (f : Type -> Type) where     empty : f a     (<|>) : f a -> f a -> f a
libs/prelude/Prelude/Cast.idr view
@@ -3,8 +3,8 @@ import Prelude.Bool import public Builtins -||| Type class for transforming an instance of a data type to another type.-class Cast from to where+||| Interface for transforming an instance of a data type to another type.+interface Cast from to where     ||| Perform a cast operation.     |||     ||| @orig The original type.@@ -12,46 +12,46 @@  -- String casts -instance Cast String Int where+Cast String Int where     cast = prim__fromStrInt -instance Cast String Double where+Cast String Double where     cast = prim__strToFloat -instance Cast String Integer where+Cast String Integer where     cast = prim__fromStrBigInt  -- Int casts -instance Cast Int String where+Cast Int String where     cast = prim__toStrInt -instance Cast Int Double where+Cast Int Double where     cast = prim__toFloatInt -instance Cast Int Integer where+Cast Int Integer where     cast = prim__sextInt_BigInt  -- Double casts -instance Cast Double String where+Cast Double String where     cast = prim__floatToStr -instance Cast Double Int where+Cast Double Int where     cast = prim__fromFloatInt -instance Cast Double Integer where+Cast Double Integer where     cast = prim__fromFloatBigInt  -- Integer casts -instance Cast Integer String where+Cast Integer String where     cast = prim__toStrBigInt -instance Cast Integer Double where+Cast Integer Double where     cast = prim__toFloatBigInt  -- Char casts -instance Cast Char Int where+Cast Char Int where     cast = prim__charToInt
libs/prelude/Prelude/Chars.idr view
@@ -13,7 +13,7 @@                 then assert_total (prim__intToChar x)                 else '\0' -instance Cast Int Char where+Cast Int Char where     cast = chr  ||| Return the ASCII representation of the character.
libs/prelude/Prelude/Classes.idr view
@@ -19,53 +19,53 @@ boolOp : (a -> a -> Int) -> a -> a -> Bool boolOp op x y = intToBool (op x y) --- ---------------------------------------------------------- [ Equality Class ]-||| The Eq class defines inequality and equality.-class Eq a where-    (==) : a -> a -> Bool-    (/=) : a -> a -> Bool+-- ---------------------------------------------------------- [ 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) -instance Eq () where+Eq () where   () == () = True -instance Eq Int where+Eq Int where     (==) = boolOp prim__eqInt -instance Eq Integer where+Eq Integer where     (==) = boolOp prim__eqBigInt -instance Eq Double where+Eq Double where     (==) = boolOp prim__eqFloat -instance Eq Char where+Eq Char where     (==) = boolOp prim__eqChar -instance Eq String where+Eq String where     (==) = boolOp prim__eqString -instance Eq Ptr where+Eq Ptr where     (==) = boolOp prim__eqPtr -instance Eq ManagedPtr where+Eq ManagedPtr where     (==) = boolOp prim__eqManagedPtr -instance Eq Bool where+Eq Bool where     True  == True  = True     True  == False = False     False == True  = False     False == False = True     -instance (Eq a, Eq b) => Eq (a, b) where+(Eq a, Eq b) => Eq (a, b) where   (==) (a, c) (b, d) = (a == b) && (c == d)  --- ---------------------------------------------------------- [ Ordering Class ]+-- ---------------------------------------------------------- [ Ordering Interface ] %elim data Ordering = LT | EQ | GT -instance Eq Ordering where+Eq Ordering where     LT == LT = True     EQ == EQ = True     GT == GT = True@@ -77,163 +77,163 @@ thenCompare EQ y = y thenCompare GT y = GT -||| The Ord class defines comparison operations on ordered data types.-class Eq a => Ord a where-    compare : a -> a -> Ordering+||| The Ord interface defines comparison operations on ordered data types.+interface Eq ty => Ord ty where+    compare : ty -> ty -> Ordering -    (<) : a -> a -> Bool+    (<) : ty -> ty -> Bool     (<) x y with (compare x y)         (<) x y | LT = True         (<) x y | _  = False -    (>) : a -> a -> Bool+    (>) : ty -> ty -> Bool     (>) x y with (compare x y)         (>) x y | GT = True         (>) x y | _  = False -    (<=) : a -> a -> Bool+    (<=) : ty -> ty -> Bool     (<=) x y = x < y || x == y -    (>=) : a -> a -> Bool+    (>=) : ty -> ty -> Bool     (>=) x y = x > y || x == y -    max : a -> a -> a+    max : ty -> ty -> ty     max x y = if x > y then x else y -    min : a -> a -> a+    min : ty -> ty -> ty     min x y = if (x < y) then x else y -instance Ord () where+Ord () where     compare () () = EQ -instance Ord Int where+Ord Int where     compare x y = if (x == y) then EQ else                   if (boolOp prim__sltInt x y) then LT else                   GT  -instance Ord Integer where+Ord Integer where     compare x y = if (x == y) then EQ else                   if (boolOp prim__sltBigInt x y) then LT else                   GT  -instance Ord Double where+Ord Double where     compare x y = if (x == y) then EQ else                   if (boolOp prim__sltFloat x y) then LT else                   GT  -instance Ord Char where+Ord Char where     compare x y = if (x == y) then EQ else                   if (boolOp prim__sltChar x y) then LT else                   GT  -instance Ord String where+Ord String where     compare x y = if (x == y) then EQ else                   if (boolOp prim__ltString x y) then LT else                   GT  -instance Ord Bool where+Ord Bool where     compare True True = EQ     compare False False = EQ     compare False True = LT     compare True False = GT  -instance (Ord a, Ord b) => Ord (a, b) where+(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 Class ]-||| The Num class defines basic numerical arithmetic.-class Num a where-    (+) : a -> a -> a-    (*) : a -> a -> a+-- --------------------------------------------------------- [ Numerical Interface ]+||| The Num interface defines basic numerical arithmetic.+interface Num ty where+    (+) : ty -> ty -> ty+    (*) : ty -> ty -> ty     ||| Conversion from Integer.-    fromInteger : Integer -> a+    fromInteger : Integer -> ty -instance Num Integer where+Num Integer where     (+) = prim__addBigInt     (*) = prim__mulBigInt      fromInteger = id -instance Num Int where+Num Int where     (+) = prim__addInt     (*) = prim__mulInt      fromInteger = prim__truncBigInt_Int  -instance Num Double where+Num Double where     (+) = prim__addFloat     (*) = prim__mulFloat      fromInteger = prim__toFloatBigInt -instance Num Bits8 where+Num Bits8 where   (+) = prim__addB8   (*) = prim__mulB8   fromInteger = prim__truncBigInt_B8 -instance Num Bits16 where+Num Bits16 where   (+) = prim__addB16   (*) = prim__mulB16   fromInteger = prim__truncBigInt_B16 -instance Num Bits32 where+Num Bits32 where   (+) = prim__addB32   (*) = prim__mulB32   fromInteger = prim__truncBigInt_B32 -instance Num Bits64 where+Num Bits64 where   (+) = prim__addB64   (*) = prim__mulB64   fromInteger = prim__truncBigInt_B64 --- --------------------------------------------------------- [ Negatable Class ]-||| The `Neg` class defines operations on numbers which can be negative.-class Num a => Neg a where-    ||| The underlying implementation of unary minus. `-5` desugars to `negate (fromInteger 5)`.-    negate : a -> a-    (-) : a -> a -> a+-- --------------------------------------------------------- [ 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 : a -> a+    abs : ty -> ty -instance Neg Integer where+Neg Integer where     negate x = prim__subBigInt 0 x     (-) = prim__subBigInt     abs x = if x < 0 then -x else x -instance Neg Int where+Neg Int where     negate x = prim__subInt 0 x     (-) = prim__subInt     abs x = if x < (prim__truncBigInt_Int 0) then -x else x -instance Neg Double where+Neg Double where     negate x = prim__negFloat x     (-) = prim__subFloat     abs x = if x < (prim__toFloatBigInt 0) then -x else x  -- -------------------------------------------------------------instance Eq Bits8 where+Eq Bits8 where   x == y = intToBool (prim__eqB8 x y) -instance Eq Bits16 where+Eq Bits16 where   x == y = intToBool (prim__eqB16 x y) -instance Eq Bits32 where+Eq Bits32 where   x == y = intToBool (prim__eqB32 x y) -instance Eq Bits64 where+Eq Bits64 where   x == y = intToBool (prim__eqB64 x y) -instance Ord Bits8 where+Ord Bits8 where   (<) = boolOp prim__ltB8   (>) = boolOp prim__gtB8   (<=) = boolOp prim__lteB8@@ -242,7 +242,7 @@                 else if l > r then GT                      else EQ -instance Ord Bits16 where+Ord Bits16 where   (<) = boolOp prim__ltB16   (>) = boolOp prim__gtB16   (<=) = boolOp prim__lteB16@@ -251,7 +251,7 @@                 else if l > r then GT                      else EQ -instance Ord Bits32 where+Ord Bits32 where   (<) = boolOp prim__ltB32   (>) = boolOp prim__gtB32   (<=) = boolOp prim__lteB32@@ -260,7 +260,7 @@                 else if l > r then GT                      else EQ -instance Ord Bits64 where+Ord Bits64 where   (<) = boolOp prim__ltB64   (>) = boolOp prim__gtB64   (<=) = boolOp prim__lteB64@@ -271,52 +271,56 @@  -- ------------------------------------------------------------- [ Bounded ] -class Ord b => MinBound b where+interface Ord b => MinBound b where   ||| The lower bound for the type   minBound : b -class Ord b => MaxBound b where+interface Ord b => MaxBound b where   ||| The upper bound for the type   maxBound : b -instance MinBound Bits8 where+MinBound Bits8 where   minBound = 0x0 -instance MaxBound Bits8 where+MaxBound Bits8 where   maxBound = 0xff -instance MinBound Bits16 where+MinBound Bits16 where   minBound = 0x0 -instance MaxBound Bits16 where+MaxBound Bits16 where   maxBound = 0xffff -instance MinBound Bits32 where+MinBound Bits32 where   minBound = 0x0 -instance MaxBound Bits32 where+MaxBound Bits32 where   maxBound = 0xffffffff -instance MinBound Bits64 where+MinBound Bits64 where   minBound = 0x0 -instance MaxBound Bits64 where+MaxBound Bits64 where   maxBound = 0xffffffffffffffff   -- ------------------------------------------------------------- [ Fractionals ] -||| Fractional division of two Doubles.-(/) : Double -> Double -> Double-(/) = prim__divFloat+interface Num ty => Fractional ty where+  (/) : ty -> ty -> ty+  recip : ty -> ty +  recip x = 1 / x +Fractional Double where+  (/) = prim__divFloat+ -- --------------------------------------------------------------- [ Integrals ] %default partial -class Integral a where-   div : a -> a -> a-   mod : a -> a -> a+interface Num ty => Integral ty where+   div : ty -> ty -> ty+   mod : ty -> ty -> ty  -- ---------------------------------------------------------------- [ Integers ] divBigInt : Integer -> Integer -> Integer@@ -327,7 +331,7 @@ modBigInt x y = case y == 0 of   False => prim__sremBigInt x y -instance Integral Integer where+Integral Integer where   div = divBigInt   mod = modBigInt @@ -341,7 +345,7 @@ modInt x y = case y == 0 of   False => prim__sremInt x y -instance Integral Int where+Integral Int where   div = divInt   mod = modInt @@ -354,7 +358,7 @@ modB8 x y = case y == 0 of   False => prim__sremB8 x y   -instance Integral Bits8 where+Integral Bits8 where   div = divB8   mod = modB8 @@ -367,7 +371,7 @@ modB16 x y = case y == 0 of   False => prim__sremB16 x y -instance Integral Bits16 where+Integral Bits16 where   div = divB16    mod = modB16  @@ -380,7 +384,7 @@ modB32 x y = case y == 0 of   False => prim__sremB32 x y -instance Integral Bits32 where+Integral Bits32 where   div = divB32    mod = modB32  @@ -393,7 +397,7 @@ modB64 x y = case y == 0 of   False => prim__sremB64 x y -instance Integral Bits64 where+Integral Bits64 where   div = divB64    mod = modB64
libs/prelude/Prelude/Either.idr view
@@ -90,7 +90,7 @@ -- Instances -------------------------------------------------------------------------------- -instance (Eq a, Eq b) => Eq (Either a b) where+(Eq a, Eq b) => Eq (Either a b) where   (==) (Left x)  (Left y)  = x == y   (==) (Right x) (Right y) = x == y   (==) _         _         = False
libs/prelude/Prelude/File.idr view
@@ -43,7 +43,7 @@                                     (Ptr -> IO (Raw FileError)) prim__vm                   return err -instance Show FileError where+Show FileError where   show FileNotFound = "File Not Found"   show PermissionDenied = "Permission Denied"   show (GenericFileError errno) = strError errno
libs/prelude/Prelude/Foldable.idr view
@@ -9,7 +9,7 @@ %access public %default total -class Foldable (t : Type -> Type) where+interface Foldable (t : Type -> Type) where   foldr : (elt -> acc -> acc) -> acc -> t elt -> acc   foldl : (acc -> elt -> acc) -> acc -> t elt -> acc   foldl f z t = foldr (flip (.) . flip f) id t z
libs/prelude/Prelude/Functor.idr view
@@ -4,7 +4,7 @@  ||| Functors allow a uniform action over a parameterised type. ||| @ f a parameterised type -class Functor (f : Type -> Type) where+interface Functor (f : Type -> Type) where     ||| Apply a function across everything of type 'a' in a      ||| parameterised type     ||| @ f the parameterised type
libs/prelude/Prelude/Interactive.idr view
@@ -46,20 +46,20 @@  ||| Output something showable to stdout, without a trailing newline, for any FFI ||| descriptor-print' : Show a => a -> IO' ffi ()+print' : Show ty => ty -> IO' ffi () print' x = putStr' (show x)  ||| Output something showable to stdout, without a trailing newline-print : Show a => a -> IO ()+print : Show ty => ty -> IO () print = print'  ||| Output something showable to stdout, with a trailing newline, for any FFI ||| descriptor-printLn' : Show a => a -> IO' ffi ()+printLn' : Show ty => ty -> IO' ffi () printLn' x = putStrLn' (show x)  ||| Output something showable to stdout, with a trailing newline-printLn : Show a => a -> IO ()+printLn : Show ty => ty -> IO () printLn = printLn'  ||| Read one line of input from stdin, without the trailing newline, for any FFI
libs/prelude/Prelude/List.idr view
@@ -56,7 +56,7 @@     ||| The proof that a cons cell is non-empty     IsNonEmpty : NonEmpty (x :: xs) -instance Uninhabited (NonEmpty []) where+Uninhabited (NonEmpty []) where   uninhabited IsNonEmpty impossible  ||| Decide whether a list is non-empty@@ -74,7 +74,7 @@     ||| Valid indices can be extended     InLater : InBounds k xs -> InBounds (S k) (x :: xs) -instance Uninhabited (InBounds k []) where+Uninhabited (InBounds k []) where     uninhabited InFirst impossible  ||| Decide whether `k` is a valid index into `xs`@@ -252,7 +252,7 @@ -- Instances -------------------------------------------------------------------------------- -instance (Eq a) => Eq (List a) where+(Eq a) => Eq (List a) where   (==) []      []      = True   (==) (x::xs) (y::ys) =     if x == y then@@ -262,7 +262,7 @@   (==) _ _ = False  -instance Ord a => Ord (List a) where+Ord a => Ord (List a) where   compare [] [] = EQ   compare [] _ = LT   compare _ [] = GT@@ -272,13 +272,13 @@     else       compare xs ys -instance Semigroup (List a) where+Semigroup (List a) where   (<+>) = (++) -instance Monoid (List a) where+Monoid (List a) where   neutral = [] -instance Functor List where+Functor List where   map f []      = []   map f (x::xs) = f x :: map f xs @@ -349,7 +349,7 @@ -- Folds -------------------------------------------------------------------------------- -instance Foldable List where+Foldable List where   foldr c n [] = n   foldr c n (x::xs) = c x (foldr c n xs) @@ -590,7 +590,7 @@ unionBy : (a -> a -> Bool) -> List a -> List a -> List a unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs -||| Compute the union of two lists according to their `Eq` instance.+||| Compute the union of two lists according to their `Eq` implementation. ||| ||| ```idris example ||| union ['d', 'o', 'g'] ['c', 'o', 'w']
libs/prelude/Prelude/Maybe.idr view
@@ -72,25 +72,25 @@ raiseToMaybe x = if x == neutral then Nothing else Just x  ----------------------------------------------------------------------------------- Class instances+-- Interface implementations --------------------------------------------------------------------------------  maybe_bind : Maybe a -> (a -> Maybe b) -> Maybe b maybe_bind Nothing  k = Nothing maybe_bind (Just x) k = k x -instance (Eq a) => Eq (Maybe a) where+(Eq a) => Eq (Maybe a) where   Nothing  == Nothing  = True   Nothing  == (Just _) = False   (Just _) == Nothing  = False   (Just a) == (Just b) = a == b -||| Prioritised choice. Just like the `Alternative` instance, the+||| Prioritised choice. Just like the `Alternative` implementation, the ||| `Semigroup` for `Maybe a` keeps the first succeeding computation. ||| ||| **NB**: This is a different choice than in the Haskell libraries. ||| Use `collectJust` to get the Haskell behaviour.-instance Semigroup (Maybe a) where+Semigroup (Maybe a) where   Nothing   <+> m = m   (Just x)  <+> _ = Just x @@ -98,20 +98,20 @@ ||| designated neutral element and collecting the contents of the ||| `Just` constructors using a semigroup structure on `a`. This is ||| the behaviour in the Haskell libraries.-instance [collectJust] Semigroup a => Semigroup (Maybe a) where+[collectJust] Semigroup a => Semigroup (Maybe a) where   Nothing   <+> m       = m   m         <+> Nothing = m   (Just m1) <+> (Just m2) = Just (m1 <+> m2) -instance  Monoid (Maybe a) where+ Monoid (Maybe a) where   neutral = Nothing -instance (Monoid a, Eq a) => Cast a (Maybe a) where+(Monoid a, Eq a) => Cast a (Maybe a) where   cast = raiseToMaybe -instance (Monoid a) => Cast (Maybe a) a where+(Monoid a) => Cast (Maybe a) a where   cast = lowerMaybe -instance Foldable Maybe where+Foldable Maybe where   foldr _ z Nothing  = z   foldr f z (Just x) = f x z
libs/prelude/Prelude/Monad.idr view
@@ -12,7 +12,7 @@  infixl 5 >>= -class Applicative m => Monad (m : Type -> Type) where+interface Applicative m => Monad (m : Type -> Type) where     (>>=)  : m a -> ((result : a) -> m b) -> m b  ||| Also called `join` or mu@@ -27,16 +27,16 @@ -- Annoyingly, these need to be here, so that we can use them in other -- Prelude modules other than the top level. -instance Functor (IO' ffi) where+Functor (IO' ffi) where     map f io = io_bind io (\b => io_return (f b)) -instance Applicative (IO' ffi) where+Applicative (IO' ffi) where     pure x = io_return x     f <*> a = io_bind f (\f' =>                 io_bind a (\a' =>                   io_return (f' a')))  -instance Monad (IO' ffi) where+Monad (IO' ffi) where     b >>= k = io_bind b k
libs/prelude/Prelude/Nat.idr view
@@ -23,7 +23,7 @@ -- name hints for interactive editing %name Nat k,j,i,n,m -instance Uninhabited (Z = S n) where+Uninhabited (Z = S n) where   uninhabited Refl impossible  --------------------------------------------------------------------------------@@ -100,7 +100,7 @@   ||| If n <= m, then n + 1 <= m + 1   LTESucc : LTE left right -> LTE (S left) (S right) -instance Uninhabited (LTE (S n) Z) where+Uninhabited (LTE (S n) Z) where   uninhabited LTEZero impossible  ||| Greater than or equal to@@ -184,50 +184,50 @@ (-) m n {smaller} = minus m n  ----------------------------------------------------------------------------------- Type class instances+-- Type class implementations -------------------------------------------------------------------------------- -instance Eq Nat where+Eq Nat where   Z == Z         = True   (S l) == (S r) = l == r   _ == _         = False -instance Cast Nat Integer where+Cast Nat Integer where   cast = toIntegerNat -instance Ord Nat where+Ord Nat where   compare Z Z         = EQ   compare Z (S k)     = LT   compare (S k) Z     = GT   compare (S x) (S y) = compare x y -instance Num Nat where+Num Nat where   (+) = plus   (*) = mult    fromInteger = fromIntegerNat -instance MinBound Nat where+MinBound Nat where   minBound = Z  ||| Casts negative `Integers` to 0.-instance Cast Integer Nat where+Cast Integer Nat where   cast = fromInteger -instance Cast String Nat where+Cast String Nat where     cast str = cast (the Integer (cast str)) -||| A wrapper for Nat that specifies the semigroup and monad instances that use (*)+||| A wrapper for Nat that specifies the semigroup and monad implementations that use (*) record Multiplicative where   constructor GetMultiplicative   _ : Nat -||| A wrapper for Nat that specifies the semigroup and monad instances that use (+)+||| A wrapper for Nat that specifies the semigroup and monad implementations that use (+) record Additive where   constructor GetAdditive     _ : Nat   -instance Semigroup Multiplicative where+Semigroup Multiplicative where   (<+>) left right = GetMultiplicative $ left' * right'     where       left'  : Nat@@ -240,7 +240,7 @@         case right of           GetMultiplicative m => m -instance Semigroup Additive where+Semigroup Additive where   left <+> right = GetAdditive $ left' + right'     where       left'  : Nat@@ -253,20 +253,20 @@         case right of           GetAdditive m => m -instance Monoid Multiplicative where+Monoid Multiplicative where   neutral = GetMultiplicative $ S Z -instance Monoid Additive where+Monoid Additive where   neutral = GetAdditive Z  ||| Casts negative `Ints` to 0.-instance Cast Int Nat where+Cast Int Nat where   cast i = fromInteger (cast i) -instance Cast Nat Int where+Cast Nat Int where   cast = toIntNat -instance Cast Nat Double where+Cast Nat Double where   cast = cast . toIntegerNat  --------------------------------------------------------------------------------@@ -341,7 +341,7 @@ divCeil : Nat -> Nat -> Nat divCeil x (S y) = divCeilNZ x (S y) SIsNotZ -instance Integral Nat where+Integral Nat where   div = divNat   mod = modNat
libs/prelude/Prelude/Providers.idr view
@@ -15,17 +15,16 @@   ||| @ msg the error message   Error : (msg : String) -> Provider a --- instances-instance Functor Provider where+Functor Provider where   map f (Provide a) = Provide (f a)   map f (Error err) = Error err -instance Applicative Provider where+Applicative Provider where   (Provide f) <*> (Provide x) = Provide (f x)   (Provide f) <*> (Error err) = Error err   (Error err) <*> _           = Error err   pure = Provide -instance Monad Provider where+Monad Provider where   (Provide x) >>= f = f x   (Error err) >>= _ = Error err
libs/prelude/Prelude/Show.idr view
@@ -19,7 +19,7 @@ ||| The precedence of an Idris operator or syntactic context. data Prec = Open | Eq | Dollar | Backtick | User Nat | PrefixMinus | App -||| Gives the constructor index of the Prec as a helper for writing instances.+||| Gives the constructor index of the Prec as a helper for writing implementations. precCon : Prec -> Integer precCon Open        = 0 precCon Eq          = 1@@ -29,21 +29,21 @@ precCon PrefixMinus = 5 precCon App         = 6 -instance Eq Prec where+Eq Prec where   (==) (User m) (User n) = m == n   (==) x        y        = precCon x == precCon y -instance Ord Prec where+Ord Prec where   compare (User m) (User n) = compare m n   compare x        y        = compare (precCon x) (precCon y)  ||| Things that have a canonical `String` representation.-class Show a where+interface Show ty where   ||| Convert a value to its `String` representation.   |||-  ||| @ a the value to convert+  ||| @ x the value to convert   partial-  show : (x : a) -> String+  show : (x : ty) -> String   show = showPrec Open    ||| Convert a value to its `String` representation in a certain precedence@@ -58,9 +58,9 @@   ||| their own bracketing, like `Pair` and `List`.   |||   ||| @ d the precedence context.-  ||| @ a the value to convert+  ||| @ x the value to convert   partial-  showPrec : (d : Prec) -> (x : a) -> String+  showPrec : (d : Prec) -> (x : ty) -> String   showPrec _ = show  ||| Surround a `String` with parentheses depending on a condition.@@ -78,7 +78,7 @@ ||| ``` ||| data Ann a = MkAnn String a |||-||| instance Show a => Show (Ann a) where+||| Show a => Show (Ann a) where |||   showPrec d (MkAnn s x) = showCon d "MkAnn" $ showArg s ++ showArg x ||| ``` showCon : (d : Prec) -> (conName : String) -> (shownArgs : String) -> String@@ -100,13 +100,13 @@ primNumShow : (a -> String) -> Prec -> a -> String primNumShow f d x = let str = f x in showParens (d >= PrefixMinus && firstCharIs (== '-') str) str -instance Show Int where+Show Int where   showPrec = primNumShow prim__toStrInt -instance Show Integer where+Show Integer where   showPrec = primNumShow prim__toStrBigInt -instance Show Double where+Show Double where   showPrec = primNumShow prim__floatToStr  protectEsc : (Char -> Bool) -> String -> String -> String@@ -144,52 +144,52 @@ showLitString ('"'::cs) = ("\\\"" ++) . showLitString cs showLitString (c  ::cs) = showLitChar c . showLitString cs -instance Show Char where+Show Char where   show '\'' = "'\\''"   show c    = strCons '\'' (showLitChar c "'") -instance Show String where+Show String where   show cs = strCons '"' (showLitString (cast cs) "\"") -instance Show Nat where+Show Nat where     show n = show (the Integer (cast n)) -instance Show Bool where+Show Bool where     show True = "True"     show False = "False" -instance Show () where+Show () where   show () = "()" -instance Show Bits8 where+Show Bits8 where   show b = b8ToString b -instance Show Bits16 where+Show Bits16 where   show b = b16ToString b -instance Show Bits32 where+Show Bits32 where   show b = b32ToString b -instance Show Bits64 where+Show Bits64 where   show b = b64ToString b -instance (Show a, Show b) => Show (a, b) where+(Show a, Show b) => Show (a, b) where     show (x, y) = "(" ++ show x ++ ", " ++ show y ++ ")" -instance Show a => Show (List a) where+Show a => Show (List a) where     show xs = "[" ++ show' "" xs ++ "]" where         show' acc []        = acc         show' acc [x]       = acc ++ show x         show' acc (x :: xs) = show' (acc ++ show x ++ ", ") xs -instance Show a => Show (Maybe a) where+Show a => Show (Maybe a) where   showPrec d Nothing  = "Nothing"   showPrec d (Just x) = showCon d "Just" $ showArg x -instance (Show a, Show b) => Show (Either a b) where+(Show a, Show b) => Show (Either a b) where   showPrec d (Left x)  = showCon d "Left" $ showArg x   showPrec d (Right x) = showCon d "Right" $ showArg x -instance (Show a, {y : a} -> Show (p y)) => Show (Sigma a p) where+(Show a, {y : a} -> Show (p y)) => Show (Sigma a p) where     show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"
libs/prelude/Prelude/Stream.idr view
@@ -22,7 +22,7 @@ -- Usage hints for erasure analysis %used Stream.(::) e -instance Functor Stream where+Functor Stream where     map f (x::xs) = f x :: map f xs  ||| The first element of an infinite stream@@ -90,13 +90,6 @@ diag : Stream (Stream a) -> Stream a diag ((x::xs)::xss) = x :: diag (map tail xss) -||| Fold a Stream corecursively. Since there is no Nil, no initial value is used.-||| @ f the combining function-||| @ xs the Stream to fold up-partial -- the recursive call isn't guarded!-foldr : (f : a -> Inf b -> b) -> (xs : Stream a) -> b-foldr f (x :: xs) = f x (foldr f xs)- ||| Produce a Stream of left folds of prefixes of the given Stream ||| @ f the combining function ||| @ acc the initial value@@ -104,14 +97,6 @@ scanl : (f : a -> b -> a) -> (acc : a) -> (xs : Stream b) -> Stream a scanl f acc (x :: xs) = acc :: scanl f (f acc x) xs -||| Produce a Stream of (corecursive) right folds of tails of the given Stream-||| @ f the combining function-||| @ xs the Stream to fold up--- Reusing the head of the corecursion in the obvious way doesn't productivity check-partial -- and the call to foldr isn't guarded anyway!-scanr : (f : a -> Inf b -> b) -> (xs : Stream a) -> Stream b-scanr f (x :: xs) = f x (foldr f xs) :: scanr f xs- ||| Produce a Stream repeating a sequence ||| @ xs the sequence to repeat ||| @ ok proof that the list is non-empty@@ -121,10 +106,10 @@         cycle' []        = x :: cycle' xs         cycle' (y :: ys) = y :: cycle' ys -instance Applicative Stream where+Applicative Stream where   pure = repeat   (<*>) = zipWith apply -instance Monad Stream where+Monad Stream where   s >>= f = diag (map f s)
libs/prelude/Prelude/Strings.idr view
@@ -143,19 +143,19 @@ singleton : Char -> String singleton c = strCons c "" -instance Cast String (List Char) where+Cast String (List Char) where   cast = unpack -instance Cast (List Char) String where+Cast (List Char) String where   cast = pack -instance Cast Char String where+Cast Char String where   cast = singleton -instance Semigroup String where+Semigroup String where   (<+>) = (++) -instance Monoid String where+Monoid String where   neutral = ""  ||| Splits the string into a part before the predicate
libs/prelude/Prelude/Traversable.idr view
@@ -16,7 +16,7 @@ for_ : (Foldable t, Applicative f) => t a -> (a -> f b) -> f () for_ = flip traverse_ -class (Functor t, Foldable t) => Traversable (t : Type -> Type) where+interface (Functor t, Foldable t) => Traversable (t : Type -> Type) where   traverse : Applicative f => (a -> f b) -> t a -> f (t b)  sequence : (Traversable t, Applicative f) => t (f a) -> f (t a)
libs/prelude/Prelude/Uninhabited.idr view
@@ -6,12 +6,12 @@ import Builtins  ||| A canonical proof that some type is empty-class Uninhabited t where+interface Uninhabited t where   ||| If I have a t, I've had a contradiction   ||| @ t the uninhabited type   total uninhabited : t -> Void -instance Uninhabited Void where+Uninhabited Void where   uninhabited a = a  ||| Use an absurd assumption to discharge a proof obligation
libs/pruviloj/Pruviloj/Derive/Eliminators.idr view
@@ -129,7 +129,7 @@  data ElimArg = IHArgument TTName | NormalArgument TTName -instance Show ElimArg where+implementation Show ElimArg where   show (IHArgument x) = "IHArgument " ++ show x   show (NormalArgument x) = "NormalArgument " ++ show x
main/Main.hs view
@@ -45,6 +45,7 @@ runIdris :: [Opt] -> Idris () runIdris opts = do        runIO setupBundledCC+       when (ShowLoggingCats `elem` opts) $ runIO showLoggingCats        when (ShowIncs `elem` opts) $ runIO showIncs        when (ShowLibs `elem` opts) $ runIO showLibs        when (ShowLibdir `elem` opts) $ runIO showLibdir@@ -101,3 +102,8 @@ showPkgs :: IO b showPkgs = do mapM putStrLn =<< installedPackages               exitWith ExitSuccess++showLoggingCats :: IO b+showLoggingCats = do+    putStrLn loggingCatsStr+    exitWith ExitSuccess
rts/idris_rts.c view
@@ -95,7 +95,7 @@ }  void init_signals() {-#if (__linux__ || __APPLE__ || __FreeBSD__)+#if (__linux__ || __APPLE__ || __FreeBSD__ || __DragonFly__)     signal(SIGPIPE, SIG_IGN); #endif }
rts/idris_rts.h view
@@ -9,7 +9,7 @@ #include <pthread.h> #endif #include <stdint.h>-#if (__linux__ || __APPLE__ || __FreeBSD__)+#if (__linux__ || __APPLE__ || __FreeBSD__ || __DragonFly__) #include <signal.h> #endif
src/IRTS/Compiler.hs view
@@ -54,12 +54,12 @@                              Nothing -> []                              Just t -> freeNames t -        reachableNames <- performUsageAnalysis +        reachableNames <- performUsageAnalysis                               (rootNames ++ getExpNames exports)         maindef <- case mtm of                         Nothing -> return []                         Just tm -> do md <- irMain tm-                                      logLvl 1 $ "MAIN: " ++ show md+                                      logCodeGen 1 $ "MAIN: " ++ show md                                       return [(sMN 0 "runMain", md)]         objs <- getObjectFiles codegen         libs <- getLibs codegen@@ -82,13 +82,13 @@         let (nexttag, tagged) = addTags 65536 (liftAll defsUniq)         let ctxtIn = addAlist tagged emptyContext -        logLvl 1 "Defunctionalising"+        logCodeGen 1 "Defunctionalising"         let defuns_in = defunctionalise nexttag ctxtIn-        logLvl 5 $ show defuns_in-        logLvl 1 "Inlining"+        logCodeGen 5 $ show defuns_in+        logCodeGen 1 "Inlining"         let defuns = inline defuns_in-        logLvl 5 $ show defuns-        logLvl 1 "Resolving variables for CG"+        logCodeGen 5 $ show defuns+        logCodeGen 1 "Resolving variables for CG"          let checked = simplifyDefs defuns (toAlist defuns)         outty <- outputTy@@ -102,7 +102,7 @@             Just f -> runIO $ writeFile f (dumpDefuns defuns)         triple <- Idris.AbsSyntax.targetTriple         cpu <- Idris.AbsSyntax.targetCPU-        logLvl 1 "Building output"+        logCodeGen 1 "Building output"         case checked of             OK c -> do return $ CodegenInfo f outty triple cpu                                             hdrs impdirs objs libs flags@@ -184,10 +184,10 @@                       return (n, (LFun [] n (take ar args)                                          (LOp op (map (LV . Glob) (take ar args)))))               _ -> do def <- mkLDecl n d-                      logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def+                      logCodeGen 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def                       return (n, def)-   where getPrim n i -             | Just (ar, op) <- lookup n (idris_scprims i) +   where getPrim n i+             | Just (ar, op) <- lookup n (idris_scprims i)                   = Just (ar, op)              | Just ar <- lookup n (S.toList (idris_externs i))                   = Just (ar, LExternal n)@@ -224,7 +224,7 @@ type Vars = M.Map Name VarInfo  irTerm :: Vars -> [Name] -> Term -> Idris LExp-irTerm vs env tm@(App _ f a) = do +irTerm vs env tm@(App _ f a) = do   ist <- getIState   case unApply tm of     (P _ (UN m) _, args)@@ -454,19 +454,19 @@ doForeign :: Vars -> [Name] -> [Term] -> Idris LExp doForeign vs env (ret : fname : world : args)      = do args' <- mapM splitArg args-          let fname' = toFDesc fname +          let fname' = toFDesc fname           let ret' = toFDesc ret           return $ LForeign ret' fname' args'   where     splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits-        = do let l' = toFDesc l +        = do let l' = toFDesc l              r' <- irTerm vs env r              return (l', r')     splitArg _ = ifail "Badly formed foreign function call" -    toFDesc (Constant (Str str)) = FStr str -    toFDesc tm -       | (P _ n _, []) <- unApply tm = FCon (deNS n) +    toFDesc (Constant (Str str)) = FStr str+    toFDesc tm+       | (P _ n _, []) <- unApply tm = FCon (deNS n)        | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDesc as)     toFDesc _ = FUnknown @@ -476,7 +476,7 @@  irTree :: [Name] -> SC -> Idris LExp irTree args tree = do-    logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree+    logCodeGen 3 $ "Compiling " ++ show args ++ "\n" ++ show tree     LLam args <$> irSC M.empty tree  irSC :: Vars -> SC -> Idris LExp
src/IRTS/Exports.hs view
@@ -13,7 +13,7 @@ findExports :: Idris [ExportIFace] findExports = do exps <- getExports                  es <- mapM toIFace exps-                 logLvl 2 $ "Exporting " ++ show es+                 logCodeGen 2 $ "Exporting " ++ show es                  return es  getExpNames :: [ExportIFace] -> [Name]@@ -39,7 +39,7 @@     getExpList _ = ifail "Badly formed export list"  toIFaceTyVal :: Type -> Term -> Idris ExportIFace-toIFaceTyVal ty tm +toIFaceTyVal ty tm    | (P _ exp _, [P _ ffi _, Constant (Str hdr), _]) <- unApply ty          = do tm' <- toIFaceVal tm               return $ Export ffi hdr tm'@@ -51,7 +51,7 @@    | (P _ fun _, [_,_,_,_,(P _ fn _),extnm,prf,rest]) <- unApply tm,      fun == sNS (sUN "Fun") ["FFI_Export"]        = do rest' <- toIFaceVal rest-            return $ +            return $               ExportFun fn (toFDesc extnm) (toFDescRet prf) (toFDescArgs prf)                   : rest'    | (P _ dat _, [_,_,_,_,d,rest]) <- unApply tm,@@ -63,7 +63,7 @@ toFDesc :: Term -> FDesc toFDesc (Constant (Str str)) = FStr str toFDesc tm-   | (P _ n _, []) <- unApply tm = FCon (deNS n) +   | (P _ n _, []) <- unApply tm = FCon (deNS n)    | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDesc as) toFDesc _ = FUnknown @@ -91,20 +91,17 @@    | otherwise = error "Badly formed export type"  toFDescArgs :: Term -> [FDesc]-toFDescArgs tm +toFDescArgs tm    | (P _ fun _, [_,_,_,_,b,t]) <- unApply tm,      fun == sNS (sUN "FFI_Fun") ["FFI_Export"]        = toFDescBase b : toFDescArgs t    | otherwise = [] -toFDescPrim (Constant (Str str)) = FStr str -toFDescPrim tm -   | (P _ n _, []) <- unApply tm = FCon (deNS n) +toFDescPrim (Constant (Str str)) = FStr str+toFDescPrim tm+   | (P _ n _, []) <- unApply tm = FCon (deNS n)    | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDescPrim as) toFDescPrim _ = FUnknown  deNS (NS n _) = n deNS n = n---
src/IRTS/System.hs view
@@ -21,10 +21,7 @@ getCC = fromMaybe "gcc" <$> environment "IDRIS_CC"  getEnvFlags :: IO [String]-getEnvFlags = do flags <- environment "IDRIS_CFLAGS"-                 case flags of-                     Nothing -> return $ []-                     Just s -> return $ splitOn " " s+getEnvFlags = maybe [] (splitOn " ") <$> environment "IDRIS_CFLAGS"  mvnCommand :: String #ifdef mingw32_HOST_OS@@ -37,9 +34,8 @@ getMvn = fromMaybe mvnCommand <$> environment "IDRIS_MVN"  environment :: String -> IO (Maybe String)-environment x = catchIO (do e <- getEnv x-                            return (Just e))-                      (\_ -> return Nothing)+environment x = catchIO (Just <$> getEnv x)+                        (\_ -> return Nothing)  getTargetDir :: IO String getTargetDir = environment "TARGET" >>= maybe getDataDir return
src/Idris/AbsSyntax.hs view
@@ -699,6 +699,13 @@                    let opt' = opts { opt_logLevel = l }                    putIState $ i { idris_options = opt' } +setLogCats :: [LogCat] -> Idris ()+setLogCats cs = do+  i <- getIState+  let opts = idris_options i+  let opt' = opts { opt_logcats = cs }+  putIState $ i { idris_options = opt' }+ setCmdLine :: [Opt] -> Idris () setCmdLine opts = do i <- getIState                      let iopts = idris_options i@@ -969,16 +976,56 @@           setColour' PromptColour    c t = t { promptColour = c }           setColour' PostulateColour c t = t { postulateColour = c } + logLvl :: Int -> String -> Idris ()-logLvl l str = do i <- getIState-                  let lvl = opt_logLevel (idris_options i)-                  when (lvl >= l) $-                    case idris_outputmode i of-                      RawOutput h -> do runIO $ hPutStrLn h str-                      IdeMode n h ->-                        do let good = SexpList [IntegerAtom (toInteger l), toSExp str]-                           runIO . hPutStrLn h $ convSExp "log" good n+logLvl = logLvlCats [] +logCoverage :: Int -> String -> Idris ()+logCoverage = logLvlCats [ICoverage]++logErasure :: Int -> String -> Idris ()+logErasure = logLvlCats [IErasure]++-- | Log an action of the parser+logParser :: Int -> String -> Idris ()+logParser = logLvlCats parserCats++-- | Log an action of the elaborator.+logElab :: Int -> String -> Idris ()+logElab = logLvlCats elabCats++-- | Log an action of the compiler.+logCodeGen :: Int -> String -> Idris ()+logCodeGen = logLvlCats codegenCats++logIBC :: Int -> String -> Idris ()+logIBC = logLvlCats [IIBC]++-- | Log aspect of Idris execution+--+-- An empty set of logging levels is used to denote all categories.+--+-- @TODO update IDE protocol+logLvlCats :: [LogCat] -- ^ The categories that the message should appear under.+           -> Int      -- ^ The Logging level the message should appear.+           -> String   -- ^ The message to show the developer.+           -> Idris ()+logLvlCats cs l str = do+    i <- getIState+    let lvl  = opt_logLevel (idris_options i)+    let cats = opt_logcats (idris_options i)+    when (lvl >= l) $+      when (inCat cs cats || null cats) $+        case idris_outputmode i of+          RawOutput h -> do+            runIO $ hPutStrLn h str+          IdeMode n h -> do+            let good = SexpList [IntegerAtom (toInteger l), toSExp str]+            runIO . hPutStrLn h $ convSExp "log" good n+  where+    inCat :: [LogCat] -> [LogCat] -> Bool+    inCat cs cats = or $ map (\x -> elem x cats) cs+ cmdOptType :: Opt -> Idris Bool cmdOptType x = do i <- getIState                   return $ x `elem` opt_cmdline (idris_options i)@@ -1396,7 +1443,7 @@         scopedimpl (Just i) = not (toplevel_imp i)         scopedimpl _ = False -        getImps (Bind n (Pi i _ _) sc) imps +        getImps (Bind n (Pi i _ _) sc) imps              | scopedimpl i = getImps sc imps         getImps (Bind n (Pi _ t _) sc) imps             | Just (p, t') <- lookup n imps = argInfo n p t' : getImps sc imps@@ -1628,7 +1675,7 @@     ai inpat qq env ds (PApp fc ftm@(PRef ffc hl f) as)         | f `elem` infns = ai inpat qq env ds (PApp fc (PInferRef ffc hl f) as)         | not (f `elem` map fst env)-                          = let as' = map (fmap (ai inpat qq env ds)) as +                          = let as' = map (fmap (ai inpat qq env ds)) as                                 asdotted' = map (fmap (ai False qq env ds)) as in                                 handleErr $ aiFn topname inpat False qq imp_meths ist fc f ffc ds as' asdotted'         | Just (Just ty) <- lookup f env =@@ -1707,7 +1754,7 @@      -> Either Err PTerm aiFn topname inpat True qq imp_meths ist fc f ffc ds [] _   | inpat && implicitable f && unqualified f = Right $ PPatvar ffc f-  | otherwise +  | otherwise      = case lookupDef f (tt_ctxt ist) of         [] -> Right $ PPatvar ffc f         alts -> let ialts = lookupCtxtName f (idris_implicits ist) in@@ -1743,7 +1790,7 @@                          [] -> nh                          x -> x           case ns' of-            [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f')) +            [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f'))                                      (insertImpl ns (chooseArgs f' as asexp))             [] -> if f `elem` (map fst (idris_metavars ist))                     then Right $ PApp fc (PRef ffc [ffc] f) as@@ -2173,7 +2220,7 @@ -- | Rename any binders which are repeated (so that we don't have to mess -- about with shadowing anywhere else). mkUniqueNames :: [Name] -> [(Name, Name)] -> PTerm -> PTerm-mkUniqueNames env shadows tm +mkUniqueNames env shadows tm       = evalState (mkUniq 0 initMap tm) (S.fromList env) where    initMap = M.fromList shadows@@ -2295,4 +2342,3 @@   mkUniq ql nmap (PUnquote tm) = fmap PUnquote (mkUniq (ql - 1) nmap tm)    mkUniq ql nmap tm = descendM (mkUniq ql nmap) tm-
src/Idris/AbsSyntaxTree.hs view
@@ -68,34 +68,36 @@ eInfoNames :: ElabInfo -> [Name] eInfoNames info = map fst (params info) ++ M.keys (inblock info) -data IOption = IOption { opt_logLevel     :: Int,-                         opt_typecase     :: Bool,-                         opt_typeintype   :: Bool,-                         opt_coverage     :: Bool,-                         opt_showimp      :: Bool, -- ^^ show implicits-                         opt_errContext   :: Bool,-                         opt_repl         :: Bool,-                         opt_verbose      :: Bool,-                         opt_nobanner     :: Bool,-                         opt_quiet        :: Bool,-                         opt_codegen      :: Codegen,-                         opt_outputTy     :: OutputType,-                         opt_ibcsubdir    :: FilePath,-                         opt_importdirs   :: [FilePath],-                         opt_triple       :: String,-                         opt_cpu          :: String,-                         opt_cmdline      :: [Opt], -- remember whole command line-                         opt_origerr      :: Bool,-                         opt_autoSolve    :: Bool, -- ^ automatically apply "solve" tactic in prover-                         opt_autoImport   :: [FilePath], -- ^ e.g. Builtins+Prelude-                         opt_optimise     :: [Optimisation],-                         opt_printdepth   :: Maybe Int,-                         opt_evaltypes    :: Bool, -- ^ normalise types in :t-                         opt_desugarnats  :: Bool-       }-    deriving (Show, Eq)+data IOption = IOption {+    opt_logLevel     :: Int+  , opt_logcats      :: [LogCat]      -- ^ List of logging categories.+  , opt_typecase     :: Bool+  , opt_typeintype   :: Bool+  , opt_coverage     :: Bool+  , opt_showimp      :: Bool          -- ^ show implicits+  , opt_errContext   :: Bool+  , opt_repl         :: Bool+  , opt_verbose      :: Bool+  , opt_nobanner     :: Bool+  , opt_quiet        :: Bool+  , opt_codegen      :: Codegen+  , opt_outputTy     :: OutputType+  , opt_ibcsubdir    :: FilePath+  , opt_importdirs   :: [FilePath]+  , opt_triple       :: String+  , opt_cpu          :: String+  , opt_cmdline      :: [Opt]          -- remember whole command line+  , opt_origerr      :: Bool+  , opt_autoSolve    :: Bool           -- ^ automatically apply "solve" tactic in prover+  , opt_autoImport   :: [FilePath]     -- ^ e.g. Builtins+Prelude+  , opt_optimise     :: [Optimisation]+  , opt_printdepth   :: Maybe Int+  , opt_evaltypes    :: Bool           -- ^ normalise types in :t+  , opt_desugarnats  :: Bool+  } deriving (Show, Eq)  defaultOpts = IOption { opt_logLevel   = 0+                      , opt_logcats    = []                       , opt_typecase   = False                       , opt_typeintype = False                       , opt_coverage   = True@@ -135,7 +137,7 @@  -- | Pretty printing options with default verbosity. defaultPPOption :: PPOption-defaultPPOption = PPOption { ppopt_impl = False, +defaultPPOption = PPOption { ppopt_impl = False,                              ppopt_desugarnats = False,                              ppopt_pinames = False,                              ppopt_depth = Just 200 }@@ -391,6 +393,7 @@              | DocStr (Either Name Const) HowMuchDocs              | TotCheck Name              | Reload+             | Watch              | Load FilePath (Maybe Int) -- up to maximum line number              | ChangeDirectory FilePath              | ModImport String@@ -406,6 +409,7 @@              | Proofs              | Universes              | LogLvl Int+             | LogCategory [LogCat]              | Spec PTerm              | WHNF PTerm              | TestInline PTerm@@ -451,6 +455,44 @@  data OutputFmt = HTMLOutput | LaTeXOutput +-- | Recognised logging categories for the Idris compiler.+--+-- @TODO add in sub categories.+data LogCat = IParse+            | IElab+            | ICodeGen+            | IErasure+            | ICoverage+            | IIBC+            deriving (Show, Eq, Ord)++strLogCat :: LogCat -> String+strLogCat IParse    = "parser"+strLogCat IElab     = "elab"+strLogCat ICodeGen  = "codegen"+strLogCat IErasure  = "erasure"+strLogCat ICoverage = "coverage"+strLogCat IIBC      = "ibc"++codegenCats :: [LogCat]+codegenCats =  [ICodeGen]++parserCats :: [LogCat]+parserCats = [IParse]++elabCats :: [LogCat]+elabCats = [IElab]++loggingCatsStr :: String+loggingCatsStr = unlines+    [ (strLogCat IParse)+    , (strLogCat IElab)+    , (strLogCat ICodeGen)+    , (strLogCat IErasure)+    , (strLogCat ICoverage)+    , (strLogCat IIBC)+    ]+ data Opt = Filename String          | Quiet          | NoBanner@@ -461,11 +503,13 @@          | ShowLibdir          | ShowIncs          | ShowPkgs+         | ShowLoggingCats          | NoBasePkgs          | NoPrelude          | NoBuiltins -- only for the really primitive stuff!          | NoREPL          | OLogging Int+         | OLogCats [LogCat]          | Output String          | Interface          | TypeCase@@ -767,7 +811,7 @@                | PLaterdecl { d_name :: Name, d_name_fc :: FC, d_tcon :: t }                  -- ^ "Placeholder" for data whose constructors are defined later     deriving Functor-    + -- | Transform the FCs in a PData and its associated terms. The first -- function transforms the general-purpose FCs, and the second transforms -- those that are used for semantic source highlighting, so they can be@@ -1088,7 +1132,7 @@                 | MatchRefine Name                 | LetTac Name t | LetTacTy Name t t                 | Exact t | Compute | Trivial | TCInstance-                | ProofSearch Bool Bool Int (Maybe Name) +                | ProofSearch Bool Bool Int (Maybe Name)                               [Name] -- allowed local names                               [Name] -- hints                   -- ^ the bool is whether to search recursively@@ -1179,7 +1223,7 @@ data PArg' t = PImp { priority :: Int,                       machine_inf :: Bool, -- true if the machine inferred it                       argopts :: [ArgOpt],-                      pname :: Name, +                      pname :: Name,                       getTm :: t }              | PExp { priority :: Int,                       argopts :: [ArgOpt],@@ -1890,7 +1934,7 @@       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 (PConstSugar fc tm) = prettySe d p bnd tm -- should never occur, but harmless      prettySe d p bnd _ = text "missing pretty-printer for term" @@ -2064,9 +2108,9 @@ 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 "class" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds+   = text "interface" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds showDeclImp o (PInstance _ _ _ _ cs n _ _ t _ ds)-   = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds+   = text "implementation" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds showDeclImp _ _ = text "..." -- showDeclImp (PImport o) = "import " ++ o @@ -2137,7 +2181,7 @@ showTmImpls :: PTerm -> String showTmImpls = flip (displayS . renderCompact . prettyImp verbosePPOption) "" --- | Show a term with specific options +-- | Show a term with specific options showTmOpts :: PPOption -> PTerm -> String showTmOpts opt = flip (displayS . renderPretty 1.0 10000000 . prettyImp opt) "" @@ -2253,7 +2297,7 @@  -- Return names which are valid implicits in the given term (type). implicitNamesIn :: [Name] -> IState -> PTerm -> [Name]-implicitNamesIn uvars ist tm +implicitNamesIn uvars ist tm       = let (imps, fns) = execState (ni 0 [] tm) ([], []) in             nub imps \\ nub fns   where@@ -2282,15 +2326,15 @@     ni 0 env (PRef _ _ n)         | 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 +        | n `elem` uvars = do ni 0 env f                               mapM_ (ni 0 env) (map getTm as)         | otherwise = do case lookupTy n (tt_ctxt ist) of                               [] -> return ()                               _ -> addFn n                          mapM_ (ni 0 env) (map getTm as)-    ni 0 env (PApp _ f as) = do ni 0 env f +    ni 0 env (PApp _ f as) = do ni 0 env f                                 mapM_ (ni 0 env) (map getTm as)-    ni 0 env (PAppBind _ f as) = do ni 0 env f +    ni 0 env (PAppBind _ f as) = do ni 0 env f                                     mapM_ (ni 0 env) (map getTm as)     ni 0 env (PCase _ c os)  = do ni 0 env c     -- names in 'os', not counting the names bound in the cases@@ -2307,7 +2351,7 @@     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 (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
src/Idris/CaseSplit.hs view
@@ -65,20 +65,20 @@         -- ASSUMPTION: tm is in normal form after elabValBind, so we don't         -- need to do anything special to find out what family each argument         -- is in-        logLvl 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats)+        logElab 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats) --         iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty)) --         iputStrLn (show pats)-        let t = mergeUserImpl (addImplPat ist t') (delab ist tm) +        let t = mergeUserImpl (addImplPat ist t') (delab ist tm)         let ctxt = tt_ctxt ist         case lookup n pats of              Nothing -> ifail $ show n ++ " is not a pattern variable"              Just ty ->                 do let splits = findPats ist ty-                   logLvl 1 ("New patterns " ++ showSep ", "  +                   logElab 1 ("New patterns " ++ showSep ", "                          (map showTmImpls splits))                    let newPats_in = zipWith (replaceVar ctxt n) splits (repeat t)-                   logLvl 4 ("Working from " ++ show t)-                   logLvl 4 ("Trying " ++ showSep "\n" +                   logElab 4 ("Working from " ++ show t)+                   logElab 4 ("Trying " ++ showSep "\n"                                (map (showTmImpls) newPats_in))                    newPats_in <- mapM elabNewPat newPats_in                    case anyValid [] [] newPats_in of@@ -86,16 +86,16 @@                            let fails' = mergeAllPats ist n t fails                            return (False, (map snd fails'))                         Right newPats -> do-                           logLvl 3 ("Original:\n" ++ show t)-                           logLvl 3 ("Split:\n" +++                           logElab 3 ("Original:\n" ++ show t)+                           logElab 3 ("Split:\n" ++                                       (showSep "\n" (map show newPats)))-                           logLvl 3 "----"+                           logElab 3 "----"                            let newPats' = mergeAllPats ist n t newPats-                           logLvl 1 ("Name updates " ++ showSep "\n"+                           logElab 1 ("Name updates " ++ showSep "\n"                                  (map (\ (p, u) -> show u ++ " " ++ show p) newPats'))                            return (True, (map snd newPats'))-   where -     anyValid ok bad [] = if null ok then Left (reverse bad) +   where+     anyValid ok bad [] = if null ok then Left (reverse bad)                                      else Right (reverse ok)      anyValid ok bad ((tc, p) : ps)          | tc = anyValid (p : ok) bad ps@@ -111,7 +111,7 @@                     put (ms { updates = ((n, stripNS tm) : updates ms) } )  inventName :: Idris.AbsSyntaxTree.IState -> Maybe Name -> Name -> State MergeState Name-inventName ist ty n = +inventName ist ty n =     do ms <- get        let supp = case ty of                        Nothing -> []@@ -131,11 +131,11 @@              do let n' = uniqueNameFrom nsupp badnames                 put (ms { invented = (n, n') : invented ms })                 return n'-                + mkSupply :: [Name] -> [Name] mkSupply ns = mkSupply' ns (map nextName ns)   where mkSupply' xs ns' = xs ++ mkSupply ns'-   + varlist :: [Name] varlist = map (sUN . (:[])) "xyzwstuv" -- EB's personal preference :) @@ -147,7 +147,7 @@ mergeAllPats :: IState -> Name -> PTerm -> [PTerm] -> [(PTerm, [(Name, PTerm)])] mergeAllPats ist cv t [] = [] mergeAllPats ist cv t (p : ps)-    = let (p', MS _ _ _ u) = runState (mergePat ist t p Nothing) +    = let (p', MS _ _ _ u) = runState (mergePat ist t p Nothing)                                       (MS [] [] (filter (/=cv) (patvars t)) [])           ps' = mergeAllPats ist cv t ps in           ((p', u) : ps')@@ -192,7 +192,7 @@ mergeUserImpl x y = x  argTys :: IState -> PTerm -> [Maybe Name]-argTys ist (PRef fc hls n) +argTys ist (PRef fc hls n)     = case lookupTy n (tt_ctxt ist) of            [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing            _ -> repeat Nothing@@ -227,7 +227,7 @@                               i <- getIState                               return (True, delab i tm))                           (\e -> do i <- getIState-                                    logLvl 5 $ "Not a valid split:\n" ++ pshow i e+                                    logElab 5 $ "Not a valid split:\n" ++ pshow i e                                     return (False, t))  findPats :: IState -> Type -> [PTerm]@@ -250,7 +250,7 @@         subst orig@(PRef _ _ v) | v == n = t                                 | isDConName v ctxt = orig         subst (PRef _ _ _) = Placeholder-        subst (PApp fc (PRef _ _ t) pats) +        subst (PApp fc (PRef _ _ t) pats)             | isTConName t ctxt = Placeholder -- infer types         subst (PApp fc f pats) = PApp fc f (map substArg pats)         subst x = x@@ -265,9 +265,9 @@             -> Idris (Bool, [[(Name, PTerm)]]) splitOnLine l n fn = do     cl <- getInternalApp fn l-    logLvl 3 ("Working with " ++ showTmImpls cl)+    logElab 3 ("Working with " ++ showTmImpls cl)     tms <- split n cl-    return tms +    return tms  replaceSplits :: String -> [[(Name, PTerm)]] -> Bool -> Idris [String] replaceSplits l ups impossible@@ -277,7 +277,7 @@     rep str ((n, tm) : ups) = rep (updatePat False (show n) (nshow tm) str) ups      updateRHSs i [] = return []-    updateRHSs i (x : xs) +    updateRHSs i (x : xs)        | impossible = do xs' <- updateRHSs i xs                          return (setImpossible False x : xs')        | otherwise = do (x', i') <- updateRHS (null xs) i x@@ -286,7 +286,7 @@      updateRHS last i ('?':'=':xs) = do (xs', i') <- updateRHS last i xs                                        return ("?=" ++ xs', i')-    updateRHS last i ('?':xs) +    updateRHS last i ('?':xs)         = do let (nm, rest_in) = span (not . (\x -> isSpace x || x == ')'                                                               || x == '(')) xs              let rest = if last then rest_in else@@ -341,7 +341,7 @@                    | otherwise = tm  -getUniq :: (Show t, Num t) => [Char] -> t -> Idris ([Char], t) +getUniq :: (Show t, Num t) => [Char] -> t -> Idris ([Char], t) getUniq nm i        = do ist <- getIState             let n = nameRoot [] nm ++ "_" ++ show i@@ -360,7 +360,7 @@           -> Name     -- ^ User given name           -> FilePath -- ^ Source file name           -> Idris String-getClause l fn un fp +getClause l fn un fp     = do i <- getIState          case lookupCtxt un (idris_classes i) of               [c] -> return (mkClassBodies i (class_methods c))@@ -370,18 +370,18 @@                                     x -> x                       ist <- get                       let ap = mkApp ist ty []-                      return (show un ++ " " ++ ap ++ "= ?" +                      return (show un ++ " " ++ ap ++ "= ?"                                       ++ show un ++ "_rhs")    where mkApp :: IState -> PTerm -> [Name] -> String          mkApp i (PPi (Exp _ _ False) (MN _ _) _ ty sc) used                = let n = getNameFrom i used ty in-                     show n ++ " " ++ mkApp i sc (n : used) +                     show n ++ " " ++ mkApp i sc (n : used)          mkApp i (PPi (Exp _ _ False) (UN n) _ ty sc) used             | thead n == '_'                = let n = getNameFrom i used ty in-                     show n ++ " " ++ mkApp i sc (n : used) -         mkApp i (PPi (Exp _ _ False) n _ _ sc) used -               = show n ++ " " ++ mkApp i sc (n : used) +                     show n ++ " " ++ mkApp i sc (n : used)+         mkApp i (PPi (Exp _ _ False) n _ _ sc) used+               = show n ++ " " ++ mkApp i sc (n : used)          mkApp i (PPi _ _ _ _ sc) used = mkApp i sc used          mkApp i _ _ = "" @@ -394,16 +394,16 @@                                                    sUN "z"]) used                    ns -> uniqueNameFrom (mkSupply ns) used          getNameFrom i used _ = uniqueNameFrom (mkSupply [sUN "x", sUN "y",-                                                          sUN "z"]) used +                                                          sUN "z"]) used           -- write method declarations, indent with 4 spaces          mkClassBodies :: IState -> [(Name, (FnOpts, PTerm))] -> String-         mkClassBodies i ns +         mkClassBodies i ns              = showSep "\n"-                  (zipWith (\(n, (_, ty)) m -> "    " ++ +                  (zipWith (\(n, (_, ty)) m -> "    " ++                             def (show (nsroot n)) ++ " "                                  ++ mkApp i ty []-                                 ++ "= ?" +                                 ++ "= ?"                                  ++ show un ++ "_rhs_" ++ show m) ns [1..])           def n@(x:xs) | not (isAlphaNum x) = "(" ++ n ++ ")"@@ -456,7 +456,3 @@                 case mptm of                      (False, _) -> return ptm                      (True, ptm') -> return ptm'-                       ---
src/Idris/CmdOptions.hs view
@@ -86,6 +86,11 @@   <|> (Client <$> strOption (long "client"))   -- Logging Flags   <|> (OLogging <$> option auto (long "log" <> metavar "LEVEL" <> help "Debugging log level"))+  <|> (OLogCats <$> option (str >>= parseLogCats)+                           (long "logging-categories"+                         <> metavar "CATS"+                         <> help "Colon separated logging categories. Use --listlogcats to see list."))+   -- Turn off Certain libraries.   <|> flag' NoBasePkgs (long "nobasepkgs" <> help "Do not use the given base package")   <|> flag' NoPrelude (long "noprelude" <> help "Do not use the given prelude")@@ -101,11 +106,13 @@   <|> flag' WarnReach (long "warnreach" <> help "Warn about reachable but inaccessible arguments")   <|> flag' NoCoverage (long "nocoverage")   <|> flag' ErrContext (long "errorcontext")-  <|> flag' ShowLibs (long "link" <> help "Display link flags")-  <|> flag' ShowPkgs (long "listlibs" <> help "Display installed libraries")-  <|> flag' ShowLibdir (long "libdir" <> help "Display library directory")-  <|> flag' ShowIncs (long "include" <> help "Display the includes flags")-  <|> flag' Verbose (short 'V' <> long "verbose" <> help "Loud verbosity")+  -- Show things+  <|> flag' ShowLoggingCats (long "listlogcats"          <> help "Display logging categories")+  <|> flag' ShowLibs        (long "link"                 <> help "Display link flags")+  <|> flag' ShowPkgs        (long "listlibs"             <> help "Display installed libraries")+  <|> flag' ShowLibdir      (long "libdir"               <> help "Display library directory")+  <|> flag' ShowIncs        (long "include"              <> help "Display the includes flags")+  <|> flag' Verbose         (short 'V' <> long "verbose" <> help "Loud verbosity")   <|> (IBCSubDir <$> strOption (long "ibcsubdir" <> metavar "FILE" <> help "Write IBC files into sub directory"))   <|> (ImportDir <$> strOption (short 'i' <> long "idrispath" <> help "Add directory to the list of import paths"))   <|> flag' WarnOnly (long "warn")@@ -161,21 +168,44 @@ parseVersion = infoOption ver (short 'v' <> long "version" <> help "Print version information")  preProcOpts :: [Opt] -> [Opt] -> [Opt]-preProcOpts [] ys = ys+preProcOpts []              ys = ys preProcOpts (NoBuiltins:xs) ys = NoBuiltins : NoPrelude : preProcOpts xs ys-preProcOpts (Output s:xs) ys = Output s : NoREPL : preProcOpts xs ys-preProcOpts (BCAsm s:xs) ys = BCAsm s : NoREPL : preProcOpts xs ys-preProcOpts (x:xs) ys = preProcOpts xs (x:ys)+preProcOpts (Output s:xs)   ys = Output s : NoREPL : preProcOpts xs ys+preProcOpts (BCAsm s:xs)    ys = BCAsm s : NoREPL : preProcOpts xs ys+preProcOpts (x:xs)          ys = preProcOpts xs (x:ys)  parseCodegen :: String -> Codegen parseCodegen "bytecode" = Bytecode-parseCodegen cg = Via (map toLower cg)+parseCodegen cg         = Via (map toLower cg) +parseLogCats :: Monad m => String -> m [LogCat]+parseLogCats s =+    case lastMay (readP_to_S (doParse) s) of+      Just (xs, _) -> return xs+      _            -> fail $ "Incorrect categories specified"+  where+    doParse :: ReadP [LogCat]+    doParse = do+      cs <- sepBy1 parseLogCat (char ':')+      eof+      return (concat cs) +    parseLogCat :: ReadP [LogCat]+    parseLogCat = (string (strLogCat IParse)    *> return parserCats)+              <|> (string (strLogCat IElab)     *> return elabCats)+              <|> (string (strLogCat ICodeGen)  *> return codegenCats)+              <|> (string (strLogCat ICoverage) *> return [ICoverage])+              <|> (string (strLogCat IIBC)      *> return [IIBC])+              <|> (string (strLogCat IErasure)  *> return [IErasure])+              <|> parseLogCatBad +    parseLogCatBad :: ReadP [LogCat]+    parseLogCatBad = do+      s <- look+      fail $ "Category: " ++ s ++ " is not recognised."  parseConsoleWidth :: Monad m => String -> m ConsoleWidth-parseConsoleWidth "auto" = return AutomaticWidth+parseConsoleWidth "auto"     = return AutomaticWidth parseConsoleWidth "infinite" = return InfinitelyWide parseConsoleWidth  s =   case lastMay (readP_to_S (integerReader) s) of
src/Idris/Core/Constraints.hs view
@@ -167,13 +167,11 @@             doms <- gets domainStore             let (oldDom@(Domain _ upper), suspects) = doms M.! Var var             let newDom = Domain lower upper-            when (wipeOut newDom) $ lift $ Error $ At (ufc suspect) $ Msg $ unlines-                $ "Universe inconsistency."-                : ("Working on: " ++ show (UVar var))-                : ("Old domain: " ++ show oldDom)-                : ("New domain: " ++ show newDom)-                : "Involved constraints: "-                : map (("\t"++) . show) (suspect : S.toList suspects)+            when (wipeOut newDom) $+              lift $ Error $+                UniverseError (ufc suspect) (UVar var)+                              (asPair oldDom) (asPair newDom)+                              (suspect : S.toList suspects)             modify $ \ st -> st { domainStore = M.insert (Var var) (newDom, S.insert suspect suspects) doms }             addToQueueLHS (uconstraint suspect) (Var var)         updateLowerBoundOf _ UVal{} _ = return ()
src/Idris/Core/Elaborate.hs view
@@ -863,7 +863,7 @@        ps <- get_probs        ulog <- getUnifyLog        ivs <- get_instances-       case prunStateT 999999 False ps t1 s of+       case prunStateT 999999 False ps Nothing t1 s of             OK ((v, _, _), s') -> do put s'                                      return $! v             Error e1 -> traceWhen ulog ("try failed " ++ show e1) $@@ -906,8 +906,11 @@ -- Bool says whether it's okay to create new unification problems. If set -- to False, then the whole tactic fails if there are any new problems tryAll :: [(Elab' aux a, Name)] -> Elab' aux a-tryAll [(x, _)] = x-tryAll xs = tryAll' [] 999999 xs+tryAll = tryAll' True++tryAll' :: Bool -> [(Elab' aux a, Name)] -> Elab' aux a+tryAll' _ [(x, _)] = x+tryAll' constrok xs = doAll [] 999999 xs   where     cantResolve :: Elab' aux a     cantResolve = lift $ tfail $ CantResolveAlts (map snd xs)@@ -915,44 +918,53 @@     noneValid :: Elab' aux a     noneValid = lift $ tfail $ NoValidAlts (map snd xs) -    tryAll' :: [Elab' aux a] -> -- successes-               Int -> -- most problems-               [(Elab' aux a, Name)] -> -- still to try-               Elab' aux a-    tryAll' [res] pmax [] = res-    tryAll' (_:_) pmax [] = cantResolve-    tryAll' [] pmax    [] = noneValid-    tryAll' cs pmax    ((x, msg):xs)+    doAll :: [Elab' aux a] -> -- successes+             Int -> -- most problems+             [(Elab' aux a, Name)] -> -- still to try+             Elab' aux a+    doAll [res] pmax [] = res+    doAll (_:_) pmax [] = cantResolve+    doAll [] pmax    [] = noneValid+    doAll cs pmax    ((x, msg):xs)        = do s <- get             ps <- get_probs-            case prunStateT pmax True ps x s of+            ivs <- get_instances+            case prunStateT pmax True ps (if constrok then Nothing+                                                      else Just ivs) x s of                 OK ((v, newps, probs), s') ->                        do let cs' = if (newps < pmax)                                       then [do put s'; return $! v]                                       else (do put s'; return $! v) : cs-                         tryAll' cs' newps xs+                         doAll cs' newps xs                 Error err -> do put s-                                tryAll' cs pmax xs+                                doAll cs pmax xs --- Run an elaborator, and fail if any problems are introduced+-- Run an elaborator, and fail if any problems or constraints are introduced prunStateT   :: Int      -> Bool      -> [a]+     -> Maybe [b] -- constraints left, if we're interested      -> Control.Monad.State.Strict.StateT           (ElabState t) TC t1      -> ElabState t      -> TC ((t1, Int, Idris.Core.Unify.Fails), ElabState t)-prunStateT pmax zok ps x s+prunStateT pmax zok ps ivs x s       = case runStateT x s of              OK (v, s'@(ES (p, _) _ _)) ->                  let newps = length (problems p) - length ps+                     ibad = badInstances (instances p) ivs                      newpmax = if newps < 0 then 0 else newps in                  if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0))                     then case reverse (problems p) of                             ((_,_,_,_,e,_,_):_) -> Error e-                    else OK ((v, newpmax, problems p), s')+                    else if ibad +                            then Error (InternalMsg "Constraint introduced in disambiguation")+                            else OK ((v, newpmax, problems p), s')              Error e -> Error e+  where+    badInstances _ Nothing = False+    badInstances inow (Just ithen) = length inow > length ithen  debugElaborator :: [ErrorReportPart] -> Elab' aux a debugElaborator msg = do ps <- fmap proof get
src/Idris/Core/TT.hs view
@@ -533,7 +533,7 @@ instance Show SpecialName where     show (WhereN i p c) = show p ++ ", " ++ show c     show (WithN i n) = "with block in " ++ show n-    show (InstanceN cl inst) = showSep ", " (map T.unpack inst) ++ " instance of " ++ show cl+    show (InstanceN cl inst) = showSep ", " (map T.unpack inst) ++ " implementation of " ++ show cl     show (MethodN m) = "method " ++ show m     show (ParentN p c) = show p ++ "#" ++ T.unpack c     show (CaseN fc n) = "case block in " ++ show n ++
src/Idris/Coverage.hs view
@@ -56,17 +56,17 @@    = do i <- getIState         let lhs_tms = map (\x -> flattenArgs $ delab' i x True True) xs         -- if a placeholder was given, don't bother generating cases for it-        let lhs_tms' = zipWith mergePlaceholders lhs_tms +        let lhs_tms' = zipWith mergePlaceholders lhs_tms                           (map (stripUnmatchable i) (map flattenArgs given))         let lhss = map pUnApply lhs_tms'          let argss = transpose lhss         let all_args = map (genAll i) argss-        logLvl 5 $ "COVERAGE of " ++ show n-        logLvl 5 $ show (lhs_tms, lhss)-        logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)-        logLvl 10 $ show argss ++ "\n" ++ show all_args-        logLvl 3 $ "Original: \n" +++        logCoverage 5 $ "COVERAGE of " ++ show n+        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+        logCoverage 3 $ "Original: \n" ++              showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs)         -- add an infinite supply of explicit arguments to update the possible         -- cases for (the return type may be variadic, or function type, so@@ -77,11 +77,11 @@                           p ++ repeat (PExp 0 [] (sMN 0 "gcarg") Placeholder)                         _       -> repeat (pexp Placeholder)         let tryclauses = mkClauses parg all_args-        logLvl 3 $ show (length tryclauses) ++ " initially to check"-        logLvl 2 $ showSep "\n" (map (showTm i) tryclauses)+        logCoverage 3 $ show (length tryclauses) ++ " initially to check"+        logCoverage 2 $ showSep "\n" (map (showTm i) tryclauses)         let new = filter (noMatch i) (nub tryclauses)-        logLvl 2 $ show (length new) ++ " clauses to check for impossibility"-        logLvl 4 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new)+        logCoverage 2 $ show (length new) ++ " clauses to check for impossibility"+        logCoverage 4 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new) --           ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)         return new --         return (map (\t -> PClause n t [] PImpossible []) new)@@ -92,7 +92,7 @@         pUnApply (PApp _ f args) = map getTm args         pUnApply _ = [] -        flattenArgs (PApp fc (PApp _ f as) as') +        flattenArgs (PApp fc (PApp _ f as) as')              = flattenArgs (PApp fc f (as ++ as'))         flattenArgs t = t @@ -248,7 +248,7 @@      -- put it back to its original form     resugar (PApp _ (PRef fc hl n) [_,_,t,v])-      | n == sigmaCon +      | n == sigmaCon         = PDPair fc [] TypeOrTerm (getTm t) Placeholder (getTm v)     resugar (PApp _ (PRef fc hl n) [_,_,l,r])       | n == pairCon@@ -330,7 +330,7 @@          let tot = if p then Total (args ty) else Partial NotPositive          let ctxt' = setTotal cn tot (tt_ctxt i)          putIState (i { tt_ctxt = ctxt' })-         logLvl 5 $ "Constructor " ++ show cn ++ " is " ++ show tot ++ " with " ++ show mut_ns+         logCoverage 5 $ "Constructor " ++ show cn ++ " is " ++ show tot ++ " with " ++ show mut_ns          addIBC (IBCTotal cn tot)          return tot   where@@ -432,9 +432,9 @@  checkDeclTotality :: (FC, Name) -> Idris Totality checkDeclTotality (fc, n)-    = do logLvl 2 $ "Checking " ++ show n ++ " for totality"+    = do logCoverage 2 $ "Checking " ++ show n ++ " for totality" --          buildSCG (fc, n)---          logLvl 2 $ "Built SCG"+--          logCoverage 2 $ "Built SCG"          i <- getIState          let opts = case lookupCtxt n (idris_flags i) of                               [fs] -> fs@@ -446,7 +446,7 @@               -- typechecking decidable               p@(Partial _) -> do setAccessibility n Frozen                                   addIBC (IBCAccess n Frozen)-                                  logLvl 5 $ "HIDDEN: "+                                  logCoverage 5 $ "HIDDEN: "                                                ++ show n ++ show p               _ -> return ()          return t@@ -469,12 +469,12 @@        [cg] -> case lookupDefExact n (tt_ctxt ist) of            Just (CaseOp _ _ _ pats _ cd) ->              let (args, sc) = cases_totcheck cd in-               do logLvl 2 $ "Building SCG for " ++ show n ++ " from\n"+               do logCoverage 2 $ "Building SCG for " ++ show n ++ " from\n"                                 ++ show pats ++ "\n" ++ show sc                   let newscg = buildSCG' ist (rights pats) args-                  logLvl 5 $ "SCG is: " ++ show newscg+                  logCoverage 5 $ "SCG is: " ++ show newscg                   addToCG n ( cg { scg = newscg } )-       [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"+       [] -> logCoverage 5 $ "Could not build SCG for " ++ show n ++ "\n"        x -> error $ "buildSCG: " ++ show (n, x)  delazy = delazy' False -- not lazy codata@@ -594,20 +594,20 @@    ist <- getIState    case lookupCtxt n (idris_callgraph ist) of        [cg] -> do let ms = mkMultiPaths ist [] (scg cg)-                  logLvl 5 ("Multipath for " ++ show n ++ ":\n" +++                  logCoverage 5 ("Multipath for " ++ show n ++ ":\n" ++                             "from " ++ show (scg cg) ++ "\n" ++                             show (length ms) ++ "\n" ++                             showSep "\n" (map show ms))-                  logLvl 6 (show cg)+                  logCoverage 6 (show cg)                   -- every multipath must have an infinitely descending                   -- thread, then the function terminates                   -- also need to checks functions called are all total                   -- (Unchecked is okay as we'll spot problems here)                   let tot = map (checkMP ist (getArity ist n)) ms-                  logLvl 4 $ "Generated " ++ show (length tot) ++ " paths"-                  logLvl 6 $ "Paths for " ++ show n ++ " yield " ++ (show tot)+                  logCoverage 4 $ "Generated " ++ show (length tot) ++ " paths"+                  logCoverage 6 $ "Paths for " ++ show n ++ " yield " ++ (show tot)                   return (noPartial tot)-       [] -> do logLvl 5 $ "No paths for " ++ show n+       [] -> do logCoverage 5 $ "No paths for " ++ show n                 return Unchecked   where getArity ist n           = case lookupTy n (tt_ctxt ist) of
src/Idris/DeepSeq.hs view
@@ -107,6 +107,7 @@     rnf (ColourREPL bool) = rnf  bool `seq` ()     rnf (Idemode) = ()     rnf (IdemodeSocket) = ()+    rnf (ShowLoggingCats) = ()     rnf (ShowLibs) = ()     rnf (ShowLibdir) = ()     rnf (ShowIncs) = ()@@ -116,6 +117,7 @@     rnf (NoBuiltins) = ()     rnf (NoREPL) = ()     rnf (OLogging i) = rnf  i `seq` ()+    rnf (OLogCats cs) = rnf  cs `seq` ()     rnf (Output str) = rnf  str `seq` ()     rnf (Interface) = ()     rnf (TypeCase) = ()@@ -174,6 +176,7 @@ instance NFData IOption where     rnf (IOption          opt_logLevel+         opt_logcats          opt_typecase          opt_typeintype          opt_coverage@@ -226,7 +229,7 @@ instance NFData LanguageExt where     rnf TypeProviders = ()     rnf ErrorReflection = ()-    + instance NFData Optimisation where     rnf PETransform = () @@ -358,6 +361,9 @@         rnf (Via x1) = rnf x1 `seq` ()         rnf Bytecode = () +instance NFData LogCat where+       rnf _ = ()+ instance NFData CGInfo where         rnf (CGInfo x1 x2 x3 x4 x5)           = rnf x1 `seq`@@ -563,7 +569,7 @@ instance NFData PAltType where         rnf (ExactlyOne x1) = rnf x1 `seq` ()         rnf FirstSuccess = ()-        rnf TryImplicit = () +        rnf TryImplicit = ()  instance (NFData t) => NFData (PTactic' t) where         rnf (Intro x1) = rnf x1 `seq` ()@@ -687,7 +693,7 @@   instance NFData IState where-  rnf (IState x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 +  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)
src/Idris/Delaborate.hs view
@@ -346,11 +346,11 @@   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 resolve type class" <+> pprintTerm i (delabSugared i c)+pprintErr' i (CantResolve _ c) = text "Can't find implementation for" <+> pprintTerm i (delabSugared i c) pprintErr' i (InvalidTCArg n t)     = annTm t (pprintTerm i (delabSugared i t)) <+> text " cannot be a parameter of "         <> annName n <$>-        text "(Type class arguments must be injective)"+        text "(Implementation arguments must be injective)" pprintErr' i (CantResolveAlts as) = text "Can't disambiguate name:" <+>                                     align (cat (punctuate (comma <> space) (map (fmap (fancifyAnnots i True) . annName) as))) pprintErr' i (NoValidAlts as) = text "Can't disambiguate since no name has a suitable type:" <+>
src/Idris/Docs.hs view
@@ -116,7 +116,7 @@              else nest 4 (text "Constructors:" <> line <>                           vsep (map (pprintFDWithoutTotality ist False) args)) pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses ctor)-           = nest 4 (text "Type class" <+> prettyName True (ppopt_impl ppo) [] n <>+           = nest 4 (text "Interface" <+> prettyName True (ppopt_impl ppo) [] n <>                      if nullDocstring doc                        then empty                        else line <> renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) doc)@@ -128,24 +128,24 @@              <$>              maybe empty                    ((<> line) . nest 4 .-                    (text "Instance constructor:" <$>) .+                    (text "Implementation constructor:" <$>) .                     pprintFDWithoutTotality ist False)                    ctor              <>-             nest 4 (text "Instances:" <$>-                       vsep (if null instances then [text "<no instances>"]+             nest 4 (text "Implementations:" <$>+                       vsep (if null instances then [text "<no implementations>"]                              else map pprintInstance normalInstances))              <>              (if null namedInstances then empty-              else line <$> nest 4 (text "Named instances:" <$>+              else line <$> nest 4 (text "Named implementations:" <$>                                     vsep (map pprintInstance namedInstances)))              <>              (if null subclasses then empty-              else line <$> nest 4 (text "Subclasses:" <$>+              else line <$> nest 4 (text "Child interfaces:" <$>                                     vsep (map (dumpInstance . prettifySubclasses) subclasses)))              <>              (if null superclasses then empty-              else line <$> nest 4 (text "Default superclass instances:" <$>+              else line <$> nest 4 (text "Default parent implementations:" <$>                                      vsep (map dumpInstance superclasses)))   where     params' = zip pNames (repeat False)
src/Idris/Elab/Class.hs view
@@ -78,7 +78,7 @@          let idecls = filter instdecl ds -- default superclass instance declarations          mapM_ checkDefaultSuperclassInstance idecls          let mnames = map getMName mdecls-         logLvl 1 $ "Building methods " ++ show mnames+         logElab 1 $ "Building methods " ++ show mnames          ims <- mapM (tdecl mnames) mdecls          defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint)                       (filter clause ds)@@ -94,7 +94,7 @@          let cons = [(cd, pDocs ++ mapMaybe memberDocs ds, cn, NoFC, cty, fc, [])]          let ddecl = PDatadecl tn NoFC tty cons -         logLvl 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)+         logElab 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)           -- Elaborate the data declaration          elabData info (syn { no_imp = no_imp syn ++ mnames,@@ -109,7 +109,7 @@          -- for each method, build a top level function          fns <- mapM (tfun cn constraint (syn { imp_methods = mnames })                            (map fst imethods)) imethods-         logLvl 5 $ "Functions " ++ show fns+         logElab 5 $ "Functions " ++ show fns          -- Elaborate the the top level methods          mapM_ (rec_elabDecl info EAll info) (concat fns) @@ -159,7 +159,7 @@     getMName (PTy _ _ _ _ _ n nfc _) = nsroot n     tdecl allmeths (PTy doc _ syn _ o n nfc t)            = do t' <- implicit' info syn (map (\(n, _, _) -> n) ps ++ allmeths) n t-                logLvl 2 $ "Method " ++ show n ++ " : " ++ showTmImpls t'+                logElab 2 $ "Method " ++ show n ++ " : " ++ showTmImpls t'                 return ( (n, (toExp (map (\(pn, _, _) -> pn) ps) Exp t')),                          (n, (nfc, doc, o, (toExp (map (\(pn, _, _) -> pn) ps)                                               (\ l s p -> Imp l s p Nothing) t'))),@@ -174,7 +174,7 @@                  let ds = map (decorateid defaultdec)                               [PTy emptyDocstring [] syn fc [] n nfc ty',                                PClauses fc (o ++ opts) n cs]-                 logLvl 1 (show ds)+                 logElab 1 (show ds)                  return (n, ((defaultdec n, ds!!1), ds))             _ -> ifail $ show n ++ " is not a method"     defdecl _ _ _ = ifail "Can't happen (defdecl)"@@ -199,8 +199,8 @@              let lhs = PApp fc (PRef fc [] cfn) [pconst capp]              let rhs = PResolveTC (fileFC "HACK")              let ty = PPi constraint cnm NoFC c con-             logLvl 2 ("Dictionary constraint: " ++ showTmImpls ty)-             logLvl 2 (showTmImpls lhs ++ " = " ++ showTmImpls rhs)+             logElab 2 ("Dictionary constraint: " ++ showTmImpls ty)+             logElab 2 (showTmImpls lhs ++ " = " ++ showTmImpls rhs)              i <- getIState              let conn = case con of                             PRef _ _ n -> n@@ -230,9 +230,9 @@              let anames = map (\x -> sMN x "arg") [0..]              let lhs = PApp fc (PRef fc [] m) (pconst capp : lhsArgs margs anames)              let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames)-             logLvl 2 ("Top level type: " ++ showTmImpls ty')-             logLvl 1 (show (m, ty', capp, margs))-             logLvl 2 ("Definition: " ++ showTmImpls lhs ++ " = " ++ showTmImpls rhs)+             logElab 2 ("Top level type: " ++ showTmImpls ty')+             logElab 1 (show (m, ty', capp, margs))+             logElab 2 ("Definition: " ++ showTmImpls lhs ++ " = " ++ showTmImpls rhs)              return [PTy doc [] syn fc o m mfc ty',                      PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]] @@ -318,5 +318,3 @@        | n `elem` ns = i : getDetPos (i + 1) ns sc        | otherwise = getDetPos (i + 1) ns sc     getDetPos _ _ _ = []--
src/Idris/Elab/Clause.hs view
@@ -84,7 +84,7 @@            -- no simplification or PE            let (pats_in, cs_full) = unzip cs_elab            let pats_raw = map (simple_lhs (tt_ctxt ist)) pats_in-           logLvl 3 $ "Elaborated patterns:\n" ++ show pats_raw+           logElab 3 $ "Elaborated patterns:\n" ++ show pats_raw             solveDeferred n @@ -102,7 +102,7 @@            -- If the definition is specialisable, this reduces the            -- RHS            pe_tm <- doPartialEval ist tpats-           let pats_pe = if petrans +           let pats_pe = if petrans                             then map (simple_lhs (tt_ctxt ist)) pe_tm                             else pats_raw @@ -111,7 +111,7 @@            -- Look for 'static' names and generate new specialised            -- definitions for them, as well as generating rewrite rules            -- for partially evaluated definitions-           newrules <- if petrans +           newrules <- if petrans                           then mapM (\ e -> case e of                                             Left _ -> return []                                             Right (l, r) -> elabPE info fc n r) pats_pe@@ -134,12 +134,12 @@            -- pdef is the compile-time pattern definition.            -- This will get further inlined to help with totality checking.            let pdef = map (\(ns, lhs, rhs) -> (map fst ns, lhs, rhs)) $ map debind pats_raw-           -- pdef_pe is the one which will get further optimised +           -- pdef_pe is the one which will get further optimised            -- for run-time, and, partially evaluated            let pdef_pe = map debind pats_transformed -           logLvl 5 $ "Initial typechecked patterns:\n" ++ show pats_raw-           logLvl 5 $ "Initial typechecked pattern def:\n" ++ show pdef+           logElab 5 $ "Initial typechecked patterns:\n" ++ show pats_raw+           logElab 5 $ "Initial typechecked pattern def:\n" ++ show pdef             -- NOTE: Need to store original definition so that proofs which            -- rely on its structure aren't affected by any changes to the@@ -152,10 +152,10 @@            numArgs <- tclift $ sameLength pdef             case specNames opts of-                Just _ -> -                   do logLvl 3 $ "Partially evaluated:\n" ++ show pats_pe+                Just _ ->+                   do logElab 3 $ "Partially evaluated:\n" ++ show pats_pe                 _ -> return ()-           logLvl 3 $ "Transformed:\n" ++ show pats_transformed+           logElab 3 $ "Transformed:\n" ++ show pats_transformed             erInfo <- getErasureInfo <$> getIState            tree@(CaseDef scargs sc _) <- tclift $@@ -167,7 +167,7 @@                               -- missing <- genMissing n scargs sc                               missing' <- filterM (checkPossible info fc True n) missing                               let clhs = map getLHS pdef-                              logLvl 2 $ "Must be unreachable:\n" +++                              logElab 2 $ "Must be unreachable:\n" ++                                           showSep "\n" (map showTmImpls missing') ++                                          "\nAgainst: " ++                                           showSep "\n" (map (\t -> showTmImpls (delab ist t)) (map getLHS pdef))@@ -185,12 +185,12 @@            pdef_in' <- applyOpts $ map (\(ns, lhs, rhs) -> (map fst ns, lhs, rhs)) pdef_pe            let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in' -           logLvl 5 $ "After data structure transformations:\n" ++ show pdef'+           logElab 5 $ "After data structure transformations:\n" ++ show pdef'             ist <- getIState   --          let wf = wellFounded ist n sc            let tot | pcover || AssertTotal `elem` opts = Unchecked -- finish later-                   | PEGenerated `elem` opts = Generated +                   | PEGenerated `elem` opts = Generated                    | otherwise = Partial NotCovering -- already know it's not total    --          case lookupCtxt (namespace info) n (idris_flags ist) of@@ -206,17 +206,17 @@                                 ":warning - Unreachable case: " ++                                    show (delab ist x)) xs            let knowncovering = (pcover && cov) || AssertTotal `elem` opts-           let defaultcase = if knowncovering +           let defaultcase = if knowncovering                                 then STerm Erased-                                else UnmatchedCase $ "*** " ++ -                                      show fc ++ -                                       ":unmatched case in " ++ show n ++ +                                else UnmatchedCase $ "*** " +++                                      show fc +++                                       ":unmatched case in " ++ show n ++                                        " ***"             tree' <- tclift $ simpleCase tcase defaultcase reflect                                         RunTime fc inacc atys pdef' erInfo-           logLvl 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree-           logLvl 3 $ "Optimised: " ++ show tree'+           logElab 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree+           logElab 3 $ "Optimised: " ++ show tree'            ctxt <- getContext            ist <- getIState            let opt = idris_optimisation ist@@ -224,7 +224,7 @@                                                 (idris_patdefs ist) })            let caseInfo = CaseInfo (inlinable opts) (inlinable opts) (dictionary opts)            case lookupTyExact n ctxt of-               Just ty -> +               Just ty ->                    do ctxt' <- do ctxt <- getContext                                   tclift $                                     addCasedef n erInfo caseInfo@@ -242,7 +242,7 @@                       setContext ctxt'                       addIBC (IBCDef n)                       setTotality n tot-                      when (not reflect && PEGenerated `notElem` opts) $ +                      when (not reflect && PEGenerated `notElem` opts) $                                            do totcheck (fc, n)                                               defer_totcheck (fc, n)                       when (tot /= Unchecked) $ addIBC (IBCTotal n tot)@@ -256,7 +256,7 @@                                  -- let scg = buildSCG i sc scargs                                  -- add SCG later, when checking totality                                  let cg = CGInfo scargs' calls [] used []  -- TODO: remove this, not needed anymore-                                 logLvl 2 $ "Called names: " ++ show cg+                                 logElab 2 $ "Called names: " ++ show cg                                  addToCG n cg                                  addToCalledG n (nub (map fst calls)) -- plus names in type!                                  addIBC (IBCCG n)@@ -360,7 +360,7 @@         let undef = case lookupDefExact newnm (tt_ctxt ist) of                          Nothing -> True                          _ -> False-        logLvl 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp))+        logElab 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp))         idrisCatch           (if (undef && all (concreteArg ist) (snd specapp)) then do                 cgns <- getAllNames n@@ -374,32 +374,32 @@                                   [Total _] -> 65536                                   [Productive] -> 16                                   _ -> 1-                let opts = [Specialise ((if pe_simple specdecl -                                            then map (\x -> (x, Nothing)) cgns' +                let opts = [Specialise ((if pe_simple specdecl+                                            then map (\x -> (x, Nothing)) cgns'                                             else []) ++-                                         (n, Just maxred) : +                                         (n, Just maxred) :                                            mapMaybe (specName (pe_simple specdecl))                                                     (snd specapp))]-                logLvl 3 $ "Specialising application: " ++ show specapp+                logElab 3 $ "Specialising application: " ++ show specapp                               ++ " in " ++ show caller ++                               " with " ++ show opts-                logLvl 3 $ "New name: " ++ show newnm-                logLvl 3 $ "PE definition type : " ++ (show specTy)+                logElab 3 $ "New name: " ++ show newnm+                logElab 3 $ "PE definition type : " ++ (show specTy)                             ++ "\n" ++ show opts-                logLvl 3 $ "PE definition " ++ show newnm ++ ":\n" +++                logElab 3 $ "PE definition " ++ show newnm ++ ":\n" ++                              showSep "\n"                                 (map (\ (lhs, rhs) ->                                   (showTmImpls lhs ++ " = " ++                                    showTmImpls rhs)) (pe_clauses specdecl)) -                logLvl 2 $ show n ++ " transformation rule: " +++                logElab 2 $ show n ++ " transformation rule: " ++                            showTmImpls rhs ++ " ==> " ++ showTmImpls lhs                  elabType info defaultSyntax emptyDocstring [] fc opts newnm NoFC specTy                 let def = map (\(lhs, rhs) ->                                  let lhs' = mapPT hiddenToPH $ stripUnmatchable ist lhs in-                                  PClause fc newnm lhs' [] rhs []) -                              (pe_clauses specdecl)    +                                  PClause fc newnm lhs' [] rhs [])+                              (pe_clauses specdecl)                 trans <- elabTransform info fc False rhs lhs                 elabClauses info fc (PEGenerated:opts) newnm def                 return [trans]@@ -407,7 +407,7 @@           -- if it doesn't work, just don't specialise. Could happen for lots           -- of valid reasons (e.g. local variables in scope which can't be           -- lifted out).-          (\e -> do logLvl 3 $ "Couldn't specialise: " ++ (pshow ist e)+          (\e -> do logElab 3 $ "Couldn't specialise: " ++ (pshow ist e)                     return [])      hiddenToPH (PHidden _) = Placeholder@@ -450,7 +450,7 @@     -- get the clause of a specialised application     getSpecClause ist (n, args)        = let newnm = sUN ("PE_" ++ show (nsroot n) ++ "_" ++-                               qhash 5381 (showSep "_" (map showArg args))) in +                               qhash 5381 (showSep "_" (map showArg args))) in                                -- UN (show n ++ show (map snd args)) in              (n, newnm, mkPE_TermDecl ist newnm n args)       where showArg (ExplicitS, n) = qshow n@@ -477,7 +477,7 @@         let lhs = addImplPat i lhs_in         -- if the LHS type checks, it is possible         case elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState-                            (erun fc (buildTC i info ELHS [] fname +                            (erun fc (buildTC i info ELHS [] fname                                                 (allNamesIn lhs_in)                                                 (infTerm lhs))) of             OK (ElabResult lhs' _ _ ctxt' newDecls highlights, _) ->@@ -570,17 +570,17 @@          let lhs = mkLHSapp $ stripLinear i $ stripUnmatchable i $                     propagateParams i params norm_ty (allNamesIn lhs_in) (addImplPat i lhs_in)---         let lhs = mkLHSapp $ +--         let lhs = mkLHSapp $ --                     propagateParams i params fn_ty (addImplPat i lhs_in)-        logLvl 10 (show (params, fn_ty) ++ " " ++ showTmImpls (addImplPat i lhs_in))-        logLvl 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs)-        logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in +++        logElab 10 (show (params, fn_ty) ++ " " ++ showTmImpls (addImplPat i lhs_in))+        logElab 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs)+        logElab 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++                   "\n" ++ show (fn_ty, fn_is))          ((ElabResult lhs' dlhs [] ctxt' newDecls highlights, probs, inj), _) <-            tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState                     (do res <- errAt "left hand side of " fname Nothing-                                 (erun fc (buildTC i info ELHS opts fname +                                 (erun fc (buildTC i info ELHS opts fname                                           (allNamesIn lhs_in)                                           (infTerm lhs)))                         probs <- get_probs@@ -589,16 +589,16 @@         setContext ctxt'         processTacticDecls info newDecls         sendHighlighting highlights-        +         when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)          let lhs_tm = orderPats (getInferTerm lhs')         let lhs_ty = getInferType lhs'         let static_names = getStaticNames i lhs_tm -        logLvl 3 ("Elaborated: " ++ show lhs_tm)-        logLvl 3 ("Elaborated type: " ++ show lhs_ty)-        logLvl 5 ("Injective: " ++ show fname ++ " " ++ show inj)+        logElab 3 ("Elaborated: " ++ show lhs_tm)+        logElab 3 ("Elaborated type: " ++ show lhs_ty)+        logElab 5 ("Injective: " ++ show fname ++ " " ++ show inj)          -- If we're inferring metavariables in the type, don't recheck,         -- because we're only doing this to try to work out those metavariables@@ -615,16 +615,16 @@         -- Issue #1615 on the Issue Tracker.         --     https://github.com/idris-lang/Idris-dev/issues/1615         when (not (null borrowed)) $-          logLvl 5 ("Borrowed names on LHS: " ++ show borrowed)+          logElab 5 ("Borrowed names on LHS: " ++ show borrowed) -        logLvl 3 ("Normalised LHS: " ++ showTmImpls (delabMV i clhs))+        logElab 3 ("Normalised LHS: " ++ showTmImpls (delabMV i clhs))          rep <- useREPL         when rep $ do           addInternalApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs) -- TODO: Should use span instead of line and filename?         addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs)) -        logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)+        logElab 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)         -- Elaborate where block         ist <- getIState         windex <- getName@@ -647,16 +647,16 @@         -- Elaborate those with a type *before* RHS, those without *after*         let (wbefore, wafter) = sepBlocks wb -        logLvl 2 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter+        logElab 2 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter         mapM_ (rec_elabDecl info EAll winfo) wbefore         -- Now build the RHS, using the type of the LHS as the goal.         i <- getIState -- new implicits from where block-        logLvl 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))+        logElab 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))         let rhs = addImplBoundInf i (map fst newargs_all) (defs \\ decls)                                  (expandParams decorate newargs defs (defs \\ decls) rhs_in)-        logLvl 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs+        logElab 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs         ctxt <- getContext -- new context with where block added-        logLvl 5 "STARTING CHECK"+        logElab 5 "STARTING CHECK"         ((rhs', defer, is, probs, ctxt', newDecls, highlights), _) <-            tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patRHS") clhsty initEState                     (do pbinds ist lhs_tm@@ -671,7 +671,7 @@                               (erun fc $ psolve lhs_tm)                         tt <- get_term                         aux <- getAux-                        let (tm, ds) = runState (collectDeferred (Just fname) +                        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))@@ -681,9 +681,9 @@          when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs) -        logLvl 5 "DONE CHECK"-        logLvl 4 $ "---> " ++ show rhs'-        when (not (null defer)) $ logLvl 1 $ "DEFERRED " +++        logElab 5 "DONE CHECK"+        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'@@ -700,20 +700,20 @@         mapM_ (elabCaseBlock winfo opts) is          ctxt <- getContext-        logLvl 5 $ "Rechecking"-        logLvl 6 $ " ==> " ++ show (forget rhs')+        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)-        logLvl 6 $ " ==> " ++ showEnvDbg [] crhsty ++ "   against   " ++ showEnvDbg [] clhsty+        logElab 6 $ " ==> " ++ showEnvDbg [] crhsty ++ "   against   " ++ showEnvDbg [] clhsty         ctxt <- getContext         let constv = next_tvar ctxt         case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of             OK (_, cs) -> when (PEGenerated `notElem` opts) $ do-                             addConstraints fc cs -                             logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs ++ "\n" ++ show (clhsty, crhsty)+                             addConstraints fc cs+                             logElab 6 $ "CONSTRAINTS ADDED: " ++ show cs ++ "\n" ++ show (clhsty, crhsty)                              return ()             Error e -> ierror (At fc (CantUnify False (clhsty, Nothing) (crhsty, Nothing) e [] 0))         i <- getIState@@ -805,14 +805,14 @@                          [t] -> t                          _ -> []         let params = getParamsInType i [] fn_is (normalise ctxt [] fn_ty)-        let lhs = stripLinear i $ stripUnmatchable i $ -                   propagateParams i params fn_ty (allNamesIn lhs_in) +        let lhs = stripLinear i $ stripUnmatchable i $+                   propagateParams i params fn_ty (allNamesIn lhs_in)                     (addImplPat i lhs_in)-        logLvl 2 ("LHS: " ++ show lhs)+        logElab 2 ("LHS: " ++ show lhs)         (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-             tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState               (errAt "left hand side of with in " fname Nothing-                (erun fc (buildTC i info ELHS opts fname +                (erun fc (buildTC i info ELHS opts fname                                   (allNamesIn lhs_in)                                   (infTerm lhs))) )         setContext ctxt'@@ -823,12 +823,12 @@         let lhs_ty = getInferType lhs'         let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))         let static_names = getStaticNames i lhs_tm-        logLvl 5 (show lhs_tm ++ "\n" ++ show static_names)+        logElab 5 (show lhs_tm ++ "\n" ++ show static_names)         (clhs, clhsty) <- recheckC fc id [] lhs_tm-        logLvl 5 ("Checked " ++ show clhs)+        logElab 5 ("Checked " ++ show clhs)         let bargs = getPBtys (explicitNames (normalise ctxt [] lhs_tm))         let wval = addImplBound i (map fst bargs) wval_in-        logLvl 5 ("Checking " ++ showTmImpls wval)+        logElab 5 ("Checking " ++ showTmImpls wval)         -- Elaborate wval in this context         ((wval', defer, is, ctxt', newDecls, highlights), _) <-             tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "withRHS")@@ -851,11 +851,11 @@         let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'         addDeferred def''         mapM_ (elabCaseBlock info opts) is-        logLvl 5 ("Checked wval " ++ show wval')+        logElab 5 ("Checked wval " ++ show wval')         (cwval, cwvalty) <- recheckC fc id [] (getInferTerm wval')         let cwvaltyN = explicitNames (normalise ctxt [] cwvalty)         let cwvalN = explicitNames (normalise ctxt [] cwval)-        logLvl 3 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty)+        logElab 3 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty)         -- We're going to assume the with type is not a function shortly,         -- so report an error if it is (you can't match on a function anyway         -- so this doesn't lose anything)@@ -876,9 +876,9 @@         -- Highlight explicit proofs         sendHighlighting $ [(fc, AnnBoundName n False) | (n, fc) <- maybeToList pn_in] -        logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) +++        logElab 10 ("With type " ++ show (getRetTy cwvaltyN) ++                   " depends on " ++ show pdeps ++ " from " ++ show pvars)-        logLvl 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post)+        logElab 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post)         windex <- getName         -- build a type declaration for the new function:         -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty@@ -886,7 +886,7 @@         let wargtype = getRetTy cwvaltyN         let wargname = sMN windex "warg" -        logLvl 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)+        logElab 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)         let wtype = bindTyArgs (flip (Pi Nothing) (TType (UVar 0))) (bargs_pre ++                      (wargname, wargtype) :                      map (abstract wargname wargval wargtype) bargs_post ++@@ -896,13 +896,13 @@                                          P Bound wargname Erased, wargval])]                           Nothing -> [])                      (substTerm wargval (P Bound wargname wargtype) ret_ty)-        logLvl 3 ("New function type " ++ show wtype)+        logElab 3 ("New function type " ++ show wtype)         let wname = SN (WithN windex fname)          let imps = getImps wtype -- add to implicits context         putIState (i { idris_implicits = addDef wname imps (idris_implicits i) })         let statics = getStatics static_names wtype-        logLvl 5 ("Static positions " ++ show statics)+        logElab 5 ("Static positions " ++ show statics)         i <- getIState         putIState (i { idris_statics = addDef wname statics (idris_statics i) }) @@ -919,7 +919,7 @@         --    ==>  fname' ps   wpat [rest], match pats against toplevel for ps         wb <- mapM (mkAuxC mpn wname lhs (map fst bargs_pre) (map fst bargs_post))                        withblock-        logLvl 3 ("with block " ++ show wb)+        logElab 3 ("with block " ++ show wb)         -- propagate totality assertion to the new definitions         when (AssertTotal `elem` opts) $ setFlags wname [AssertTotal]         mapM_ (rec_elabDecl info EAll info) wb@@ -935,7 +935,7 @@                                                [ pimp (sUN "A") Placeholder False                                                , pimp (sUN "x") Placeholder False                                                ])])-        logLvl 5 ("New RHS " ++ showTmImpls rhs)+        logElab 5 ("New RHS " ++ showTmImpls rhs)         ctxt <- getContext -- New context with block added         i <- getIState         ((rhs', defer, is, ctxt', newDecls, highlights), _) <-@@ -955,7 +955,7 @@         let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'         addDeferred def''         mapM_ (elabCaseBlock info opts) is-        logLvl 5 ("Checked RHS " ++ show rhs')+        logElab 5 ("Checked RHS " ++ show rhs')         (crhs, crhsty) <- recheckC fc id [] rhs'         return $ (Right (clhs, crhs), lhs)   where@@ -971,18 +971,18 @@     mkAux pn wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)         = do i <- getIState              let tm = addImplPat i tm_in-             logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " +++             logElab 2 ("Matching " ++ showTmImpls tm ++ " against " ++                                       showTmImpls toplhs)              case matchClause i toplhs tm of                 Left (a,b) -> ifail $ show fc ++ ":with clause does not match top level"                 Right mvars ->-                    do logLvl 3 ("Match vars : " ++ show mvars)+                    do logElab 3 ("Match vars : " ++ show mvars)                        lhs <- updateLHS n pn wname mvars ns ns' (fullApp tm) w                        return $ PClause fc wname lhs ws rhs wheres     mkAux pn wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval pn' withs)         = do i <- getIState              let tm = addImplPat i tm_in-             logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " +++             logElab 2 ("Matching " ++ showTmImpls tm ++ " against " ++                                       showTmImpls toplhs)              withs' <- mapM (mkAuxC pn wname toplhs ns ns') withs              case matchClause i toplhs tm of@@ -1001,7 +1001,7 @@               ns' = map (keepMvar (map fst mvars) fc') ns_in' in               return $ substMatches mvars $                   PApp fc (PRef fc' [] wname)-                      (map pexp ns ++ pexp w : (map pexp ns') ++ +                      (map pexp ns ++ pexp w : (map pexp ns') ++                         case pn of                              Nothing -> []                              Just pnm -> [pexp (PRef fc [] pnm)])
src/Idris/Elab/Data.hs view
@@ -51,14 +51,14 @@ import Util.Pretty  warnLC :: FC -> Name -> Idris ()-warnLC fc n +warnLC fc n    = iWarn fc $ annName n <+> text "has a name which may be implicitly bound."            <> line <> text "This is likely to lead to problems!"  elabData :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm)-> [(Name, Docstring (Either Err PTerm))] -> FC -> DataOpts -> PData -> Idris () elabData info syn doc argDocs fc opts (PLaterdecl n nfc t_in)     = do let codata = Codata `elem` opts-         logLvl 1 (show (fc, doc))+         logElab 1 (show (fc, doc))          checkUndefined fc n          when (implicitable n) $ warnLC fc n          (cty, _, t, inacc) <- buildType info syn fc [] n t_in@@ -69,7 +69,7 @@  elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)     = do let codata = Codata `elem` opts-         logLvl 1 (show fc)+         logElab 1 (show fc)          undef <- isUndefined fc n          when (implicitable n) $ warnLC fc n          (cty, ckind, t, inacc) <- buildType info syn fc [] n t_in@@ -91,7 +91,7 @@          i <- getIState          let as = map (const (Left (Msg ""))) (getArgTys cty)          let params = findParams  (map snd cons)-         logLvl 2 $ "Parameters : " ++ show params+         logElab 2 $ "Parameters : " ++ show params          -- TI contains information about mutually declared types - this will          -- be updated when the mutual block is complete          putIState (i { idris_datatypes =@@ -232,7 +232,7 @@ 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-         logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t_in+         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          let cty' = normalise ctxt [] cty@@ -242,13 +242,13 @@          -- Check that the constructor type is, in fact, a part of the family being defined          tyIs n cty' -         logLvl 5 $ show fc ++ ":Constructor " ++ show n ++ " elaborated : " ++ show t-         logLvl 5 $ "Inaccessible args: " ++ show inacc-         logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty'+         logElab 5 $ show fc ++ ":Constructor " ++ show n ++ " elaborated : " ++ show t+         logElab 5 $ "Inaccessible args: " ++ show inacc+         logElab 2 $ "---> " ++ show n ++ " : " ++ show cty'           -- Add to the context (this is temporary, so that later constructors          -- can be indexed by it)-         updateContext (addTyDecl n (DCon 0 0 False) cty) +         updateContext (addTyDecl n (DCon 0 0 False) cty)           addIBC (IBCDef n)          checkDocs fc argDocs t@@ -298,12 +298,12 @@         = tclift $ tfail (At fc (UniqueKindError UniqueType n))     checkUniqueKind (UType AllTypes) (UType AllTypes) = return ()     checkUniqueKind (UType AllTypes) (UType UniqueType) = return ()-    checkUniqueKind (UType AllTypes) _ +    checkUniqueKind (UType AllTypes) _         = tclift $ tfail (At fc (UniqueKindError AllTypes n))     checkUniqueKind _ _ = return ()      -- Constructor's kind must be <= expected kind-    addDataConstraint (TType con) (TType exp) +    addDataConstraint (TType con) (TType exp)        = do ctxt <- getContext             let v = next_tvar ctxt             addConstraints fc (v, [ULT con exp])@@ -354,7 +354,7 @@     _  -> State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorDef)                     (ierror . Elaborating "clauses of " elimDeclName Nothing)   where elimLog :: String -> EliminatorState ()-        elimLog s = State.lift (logLvl 2 s)+        elimLog s = State.lift (logElab 2 s)          elimFC :: FC         elimFC = fileFC "(casefun)"
src/Idris/Elab/Instance.hs view
@@ -71,7 +71,7 @@     let constraint = PApp fc (PRef fc [] n) (map pexp ps)     let iname = mkiname n (namespace info) ps expn     let emptyclass = null (class_methods ci)-    when (what /= EDefns) $ do +    when (what /= EDefns) $ do          nty <- elabType' True info syn doc argDocs fc [] 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@@ -106,19 +106,19 @@                        (decorate ns iname n,                            op, coninsert cs t', t'))               (class_methods ci)-         logLvl 3 (show (mtys, ips))-         logLvl 5 ("Before defaults: " ++ show ds ++ "\n" ++ show (map fst (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-         logLvl 3 ("After defaults: " ++ show ds_defs ++ "\n")+         logElab 3 ("After defaults: " ++ show ds_defs ++ "\n")          let ds' = reorderDefs (map fst (class_methods ci)) $ ds_defs-         logLvl 1 ("Reordered: " ++ show ds' ++ "\n")+         logElab 1 ("Reordered: " ++ show ds' ++ "\n")          mapM_ (warnMissing ds' ns iname) (map fst (class_methods ci))          mapM_ (checkInClass (map fst (class_methods ci))) (concatMap defined ds')          let wbTys = map mkTyDecl mtys          let wbVals = map (decorateid (decorate ns iname)) ds'          let wb = wbTys ++ wbVals-         logLvl 3 $ "Method types " ++ showSep "\n" (map (show . showDeclImp verbosePPOption . mkTyDecl) mtys)-         logLvl 3 $ "Instance is " ++ show ps ++ " implicits " +++         logElab 3 $ "Method types " ++ showSep "\n" (map (show . showDeclImp verbosePPOption . mkTyDecl) mtys)+         logElab 3 $ "Instance is " ++ show ps ++ " implicits " ++                                       show (concat (nub wparams))           -- Bring variables in instance head into scope@@ -134,12 +134,12 @@          let rhs = PApp fc (PRef fc [] (instanceCtorName ci))                            (map (pexp . mkMethApp) mtys) -         logLvl 5 $ "Instance LHS " ++ show lhs ++ " " ++ show headVars-         logLvl 5 $ "Instance RHS " ++ show rhs+         logElab 5 $ "Instance LHS " ++ show lhs ++ " " ++ show headVars+         logElab 5 $ "Instance RHS " ++ show rhs           let idecls = [PClauses fc [Dictionary] iname                                  [PClause fc iname lhs [] rhs wb]]-         logLvl 1 (show idecls)+         logElab 1 (show idecls)          push_estack iname True          mapM_ (rec_elabDecl info EAll info) idecls          pop_estack@@ -203,7 +203,7 @@                                        Left _ -> Nothing             _ -> Nothing     overlapping t' = tclift $ tfail (At fc (Msg $-                          "Overlapping instance: " ++ show t' ++ " already defined"))+                          "Overlapping implementation: " ++ show t' ++ " already defined"))     getRetType (PPi _ _ _ _ sc) = getRetType sc     getRetType t = t @@ -267,11 +267,11 @@     reorderDefs :: [Name] -> [PDecl] -> [PDecl]     reorderDefs ns [] = []     reorderDefs [] ds = ds-    reorderDefs (n : ns) ds = case pick n [] ds of +    reorderDefs (n : ns) ds = case pick n [] ds of                                   Just (def, ds') -> def : reorderDefs ns ds'                                   Nothing -> reorderDefs ns ds -    pick n acc [] = Nothing +    pick n acc [] = Nothing     pick n acc (def@(PClauses _ _ cn cs) : ds)          | nsroot n == nsroot cn = Just (def, acc ++ ds)     pick n acc (d : ds) = pick n (acc ++ [d]) ds@@ -313,13 +313,13 @@         let (_, args) = unApply (instantiateRetTy ty)         ci 0 ist args   where-    ci i ist (a : as) | i `elem` ds +    ci i ist (a : as) | i `elem` ds        = if isInj ist a then ci (i + 1) ist as             else tclift $ tfail (At fc (InvalidTCArg n a))     ci i ist (a : as) = ci (i + 1) ist as     ci i ist [] = return () -    isInj i (P Bound n _) = True +    isInj i (P Bound n _) = True     isInj i (P _ n _) = isConName n (tt_ctxt i)     isInj i (App _ f a) = isInj i f && isInj i a     isInj i (V _) = True@@ -329,4 +329,3 @@     instantiateRetTy (Bind n (Pi _ _ _) sc)        = substV (P Bound n Erased) (instantiateRetTy sc)     instantiateRetTy t = t-
src/Idris/Elab/Provider.hs view
@@ -84,7 +84,7 @@          rhs <- execute (mkApp (P Ref (sUN "run__provider") Erased)                                           [Erased, e])          let rhs' = normalise ctxt [] rhs-         logLvl 3 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs+         logElab 3 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs           -- Extract the provided term or postulate from the type provider          provided <- getProvided fc rhs'@@ -95,11 +95,11 @@                do -- Finally add a top-level definition of the provided term                   elabType info syn doc [] fc [] n NoFC ty                   elabClauses info fc [] n [PClause fc n (PApp fc (PRef fc [] n) []) [] (delab i tm) []]-                  logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm+                  logElab 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm              | ProvPostulate _ <- what ->                do -- Add the postulate                   elabPostulate info syn doc fc nfc [] n (delab i tm)-                  logLvl 3 $ "Elaborated provided postulate " ++ show n+                  logElab 3 $ "Elaborated provided postulate " ++ show n              | otherwise ->                ierror . Msg $ "Attempted to provide a postulate where a term was expected."
src/Idris/Elab/Record.hs view
@@ -47,18 +47,18 @@            -> SyntaxInfo -- ^ Constructor SyntaxInfo            -> Idris () elabRecord info what doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc csyn-  = do logLvl 1 $ "Building data declaration for " ++ show tyn+  = do logElab 1 $ "Building data declaration for " ++ show tyn        -- Type constructor        let tycon = generateTyConType params-       logLvl 1 $ "Type constructor " ++ showTmImpls tycon-       +       logElab 1 $ "Type constructor " ++ showTmImpls tycon+        -- Data constructor        dconName <- generateDConName (fmap fst cname)        let dconTy = generateDConType params fieldsWithNameAndDoc-       logLvl 1 $ "Data constructor: " ++ showTmImpls dconTy+       logElab 1 $ "Data constructor: " ++ showTmImpls dconTy         -- Build data declaration for elaboration-       logLvl 1 $ foldr (++) "" $ intersperse "\n" (map show dconsArgDocs)+       logElab 1 $ foldr (++) "" $ intersperse "\n" (map show dconsArgDocs)        let datadecl = case what of                            ETypes -> PLaterdecl tyn NoFC tycon                            _ -> PDatadecl tyn NoFC tycon [(cdoc, dconsArgDocs, dconName, NoFC, dconTy, fc, [])]@@ -71,8 +71,8 @@        addIBC (IBCRecord tyn)         when (what /= ETypes) $ do-           logLvl 1 $ "fieldsWithName " ++ show fieldsWithName-           logLvl 1 $ "fieldsWIthNameAndDoc " ++ show fieldsWithNameAndDoc+           logElab 1 $ "fieldsWithName " ++ show fieldsWithName+           logElab 1 $ "fieldsWIthNameAndDoc " ++ show fieldsWithNameAndDoc            elabRecordFunctions info rsyn fc tyn paramsAndDoc fieldsWithNameAndDoc dconName target             sendHighlighting $@@ -162,10 +162,10 @@                     -> PTerm -- ^ Target type                     -> Idris () elabRecordFunctions info rsyn fc tyn params fields dconName target-  = do logLvl 1 $ "Elaborating helper functions for record " ++ show tyn+  = do logElab 1 $ "Elaborating helper functions for record " ++ show tyn -       logLvl 1 $ "Fields: " ++ show fieldNames-       logLvl 1 $ "Params: " ++ show paramNames+       logElab 1 $ "Fields: " ++ show fieldNames+       logElab 1 $ "Params: " ++ show paramNames        -- The elaborated constructor type for the data declaration        i <- getIState        ttConsTy <-@@ -175,11 +175,11 @@         -- The arguments to the constructor        let constructorArgs = getArgTys ttConsTy-       logLvl 1 $ "Cons args: " ++ show constructorArgs-       logLvl 1 $ "Free fields: " ++ show (filter (not . isFieldOrParam') constructorArgs)+       logElab 1 $ "Cons args: " ++ show constructorArgs+       logElab 1 $ "Free fields: " ++ show (filter (not . isFieldOrParam') constructorArgs)        -- If elaborating the constructor has resulted in some new implicit fields we make projection functions for them.        let freeFieldsForElab = map (freeField i) (filter (not . isFieldOrParam') constructorArgs)-           +        -- The parameters for elaboration with their documentation        -- Parameter functions are all prefixed with "param_".        let paramsForElab = [((nsroot n), (paramName n), impl, t, d) | (n, _, _, t, d) <- params] -- zipParams i params paramDocs]@@ -187,14 +187,14 @@        -- The fields (written by the user) with their documentation.        let userFieldsForElab = [((nsroot n), n, p, t, d) | (n, nfc, p, t, d) <- fields] -       -- All things we need to elaborate projection functions for, together with a number denoting their position in the constructor.           -       let projectors = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (freeFieldsForElab ++ paramsForElab ++ userFieldsForElab) [0..]]       +       -- All things we need to elaborate projection functions for, together with a number denoting their position in the constructor.+       let projectors = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (freeFieldsForElab ++ paramsForElab ++ userFieldsForElab) [0..]]        -- Build and elaborate projection functions        elabProj dconName projectors -       logLvl 1 $ "Dependencies: " ++ show fieldDependencies+       logElab 1 $ "Dependencies: " ++ show fieldDependencies -       logLvl 1 $ "Depended on: " ++ show dependedOn+       logElab 1 $ "Depended on: " ++ show dependedOn         -- All things we need to elaborate update functions for, together with a number denoting their position in the constructor.        let updaters = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (paramsForElab ++ userFieldsForElab) [0..]]@@ -237,7 +237,7 @@                           plicity = impl -- All free fields are implicit as they are machine generated                           fieldType = delab i (snd arg) -- The type of the field                           doc = emptyDocstring -- No docmentation for machine generated fields-                      in (nameInCons, nameFree, plicity, fieldType, doc) +                      in (nameInCons, nameFree, plicity, fieldType, doc)      freeName :: Name -> Name     freeName (UN n) = sUN ("free_" ++ str n)@@ -278,7 +278,7 @@     -- | Decides whether a setter should be generated for a field or not.     optionalSetter :: Name -> Bool     optionalSetter n = n `elem` dependedOn-        +     -- | A map from a field name to the other fields it depends on.     fieldDependencies :: [(Name, [Name])]     fieldDependencies = map (uncurry fieldDep) [(n, t) | (n, _, _, t, _) <- fields ++ params]@@ -314,15 +314,15 @@                -> Int -- ^ Argument Index                -> Idris () elabProjection info cname pname plicity projTy pdoc psyn fc targetTy cn phArgs fnames index-  = do logLvl 1 $ "Generating Projection for " ++ show pname-       +  = do logElab 1 $ "Generating Projection for " ++ show pname+        let ty = generateTy-       logLvl 1 $ "Type of " ++ show pname ++ ": " ++ show ty-       +       logElab 1 $ "Type of " ++ show pname ++ ": " ++ show ty+        let lhs = generateLhs-       logLvl 1 $ "LHS of " ++ show pname ++ ": " ++ showTmImpls lhs+       logElab 1 $ "LHS of " ++ show pname ++ ": " ++ showTmImpls lhs        let rhs = generateRhs-       logLvl 1 $ "RHS of " ++ show pname ++ ": " ++ showTmImpls rhs+       logElab 1 $ "RHS of " ++ show pname ++ ": " ++ showTmImpls rhs         rec_elabDecl info EAll info ty @@ -372,24 +372,24 @@            -> Bool -- ^ Optional            -> Idris () elabUpdate info cname pname plicity pty pdoc psyn fc sty cn args fnames i optional-  = do logLvl 1 $ "Generating Update for " ++ show pname-       +  = do logElab 1 $ "Generating Update for " ++ show pname+        let ty = generateTy-       logLvl 1 $ "Type of " ++ show set_pname ++ ": " ++ show ty-       +       logElab 1 $ "Type of " ++ show set_pname ++ ": " ++ show ty+        let lhs = generateLhs-       logLvl 1 $ "LHS of " ++ show set_pname ++ ": " ++ showTmImpls lhs-       +       logElab 1 $ "LHS of " ++ show set_pname ++ ": " ++ showTmImpls lhs+        let rhs = generateRhs-       logLvl 1 $ "RHS of " ++ show set_pname ++ ": " ++ showTmImpls rhs+       logElab 1 $ "RHS of " ++ show set_pname ++ ": " ++ showTmImpls rhs -       let clause = PClause fc set_pname lhs [] rhs []       +       let clause = PClause fc set_pname lhs [] rhs []         idrisCatch (do rec_elabDecl info EAll info ty                       rec_elabDecl info EAll info $ PClauses fc [] set_pname [clause])-         (\err -> logLvl 1 $ "Could not generate update function for " ++ show pname)+         (\err -> logElab 1 $ "Could not generate update function for " ++ show pname)                   {-if optional-                  then logLvl 1 $ "Could not generate update function for " ++ show pname+                  then logElab 1 $ "Could not generate update function for " ++ show pname                   else tclift $ tfail $ At fc (Elaborating "record update function " pname err)) -}   where     -- | The type of the update function.@@ -463,4 +463,3 @@ -- | Creates an PArg from a plicity and a name where the term is a PRef. asPRefArg :: Plicity -> Name -> PArg asPRefArg p n = asArg p (nsroot n) $ PRef emptyFC [] (nsroot n)-
src/Idris/Elab/Term.hs view
@@ -91,7 +91,7 @@                                 g <- goal                                 ptm <- get_term                                 resolveTC' True True 10 g fn ist) ivs-         +          when (not pattern) $ solveAutos ist fn False           tm <- get_term@@ -138,7 +138,7 @@ -- (Separate, so we don't go overboard resolving things that we don't -- know about yet on the LHS of a pattern def) -buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> +buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name ->          [Name] -> -- Cached names in the PTerm, before adding PAlternatives          PTerm ->          ElabD ElabResult@@ -147,7 +147,7 @@          let inf = case lookupCtxt fn (idris_tyinfodata ist) of                         [TIPartial] -> True                         _ -> False-         -- set name supply to begin after highest index in tm +         -- set name supply to begin after highest index in tm          initNextNameFrom ns          elab ist info emode opts fn tm          probs <- get_probs@@ -171,7 +171,7 @@             else return (ElabResult tm ds (map snd is) ctxt impls highlights)   where pattern = emode == ELHS --- return whether arguments of the given constructor name can be +-- return whether arguments of the given constructor name can be -- matched on. If they're polymorphic, no, unless the type has beed made -- concrete by the time we get around to elaborating the argument. getUnmatchable :: Context -> Name -> [Bool]@@ -180,11 +180,11 @@           Nothing -> []           Just ty -> checkArgs [] [] ty   where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool]-        checkArgs env ns (Bind n (Pi _ t _) sc) +        checkArgs env ns (Bind n (Pi _ t _) sc)             = let env' = case t of                               TType _ -> n : env                               _ -> env in-                  checkArgs env' (intersect env (refsIn t) : ns) +                  checkArgs env' (intersect env (refsIn t) : ns)                             (instantiate (P Bound n t) sc)         checkArgs env ns t             = map (not . null) (reverse ns)@@ -193,7 +193,7 @@  data ElabCtxt = ElabCtxt { e_inarg :: Bool,                            e_isfn :: Bool, -- ^ Function part of application-                           e_guarded :: Bool, +                           e_guarded :: Bool,                            e_intype :: Bool,                            e_qq :: Bool,                            e_nomatching :: Bool -- ^ can't pattern match@@ -267,17 +267,17 @@     -- normally correct to call elabE - the ones that don't are desugarings     -- typically     elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()-    elabE ina fc' t = +    elabE ina fc' t =      do solved <- get_recents         as <- get_autos         hs <- get_holes         -- If any of the autos use variables which have recently been solved,         -- have another go at solving them now.-        mapM_ (\(a, (failc, ns)) -> +        mapM_ (\(a, (failc, ns)) ->                        if any (\n -> n `elem` solved) ns && head hs /= a                               then solveAuto ist fn False (a, failc)                               else return ()) as-     +         itm <- if not pattern then insertImpLam ina t else return t         ct <- insertCoerce ina itm         t' <- insertLazy ct@@ -343,7 +343,7 @@ --  elab' (_,_,inty) (PConstant c) --     | constType c && pattern && not reflection && not inty --       = lift $ tfail (Msg "Typecase is not allowed")-    elab' ina fc tm@(PConstant fc' c) +    elab' ina fc tm@(PConstant fc' c)          | pattern && not reflection && not (e_qq ina) && not (e_intype ina)            && isTypeConst c               = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)@@ -397,7 +397,7 @@                 UType _ -> elab' ina (Just fc) (PApp fc (PRef fc hls upairTy)                                                       [pexp l,pexp r])                 _ -> case tc of-                        P _ n _ | n == upairTy +                        P _ n _ | n == upairTy                           -> elab' ina (Just fc) (PApp fc (PRef fc hls upairCon)                                                 [pimp (sUN "A") Placeholder False,                                                  pimp (sUN "B") Placeholder False,@@ -464,8 +464,8 @@                                   case as'' of                                        [x] -> elab' ina fc x                                        _ -> do hds <- mapM showHd as''-                                               tryAll (zip (map (elab' ina fc) as'')-                                                           hds))+                                               tryAll' False (zip (map (elab' ina fc) as'')+                                                                  hds))         where showHd (PApp _ (PRef _ _ (UN l)) [_, _, arg])                  | l == txt "Delay" = showHd (getTm arg)               showHd (PApp _ (PRef _ _ n) _) = return n@@ -509,7 +509,7 @@         ty <- goal         let doelab = elab' ina fc orig         tryCatch doelab-            (\err -> +            (\err ->                 if recoverableErr err                    then -- trace ("NEED IMPLICIT! " ++ show orig ++ "\n" ++                         --      show alts ++ "\n" ++@@ -547,7 +547,7 @@         pruneAlts err alts _ = filter isLend alts          hasArg n env ap | isLend ap = True -- special case hack for 'Borrowed'-        hasArg n env (PApp _ (PRef _ _ a) _) +        hasArg n env (PApp _ (PRef _ _ a) _)              = case lookupTyExact a (tt_ctxt ist) of                     Just ty -> let args = map snd (getArgTys (normalise (tt_ctxt ist) env ty)) in                                    any (fnIs n) args@@ -662,7 +662,7 @@                introTy (Var tyn) (Just n)                addPSname n -- okay for proof search                focus tyn-               +                elabE (ec { e_inarg = True, e_intype = True }) (Just fc) ty                elabE (ec { e_inarg = True }) (Just fc) sc                solve@@ -701,10 +701,10 @@                    Placeholder -> return ()                    _ -> do focus tyn                            explicit tyn-                           elabE (ina { e_inarg = True, e_intype = True }) +                           elabE (ina { e_inarg = True, e_intype = True })                                  (Just fc) ty                focus valn-               elabE (ina { e_inarg = True, e_intype = True }) +               elabE (ina { e_inarg = True, e_intype = True })                      (Just fc) val                ivs' <- get_instances                env <- get_env@@ -808,14 +808,14 @@             annot <- findHighlight f             mapM_ checkKnownImplicit args_in             let args = insertScopedImps fc (normalise ctxt env fty) args_in-            let unmatchableArgs = if pattern +            let unmatchableArgs = if pattern                                      then getUnmatchable (tt_ctxt ist) f                                      else []---             trace ("BEFORE " ++ show f ++ ": " ++ show ty) $ +--             trace ("BEFORE " ++ show f ++ ": " ++ show ty) $             when (pattern && not reflection && not (e_qq ina) && not (e_intype ina)                           && isTConName f (tt_ctxt ist)) $               lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)---             trace (show (f, args_in, args)) $ +--             trace (show (f, args_in, args)) $             if (f `elem` map fst env && length args == 1 && length args_in == 1)                then -- simple app, as below                     do simple_app False@@ -853,7 +853,7 @@                     mapM (uncurry highlightSource) $                       (ffc, annot) : map (\f -> (f, annot)) hls -                    elabArgs ist (ina { e_inarg = e_inarg ina || not isinf }) +                    elabArgs ist (ina { e_inarg = e_inarg ina || not isinf })                            [] fc False f                              (zip ns (unmatchableArgs ++ repeat False))                              (f == sUN "Force")@@ -880,7 +880,7 @@                                  ivs' <- get_instances                                  -- Attempt to resolve any type classes which have 'complete' types,                                  -- i.e. no holes in them-                                 when (not pattern || (e_inarg ina && not tcgen && +                                 when (not pattern || (e_inarg ina && not tcgen &&                                                       not (e_guarded ina))) $                                     mapM_ (\n -> do focus n                                                     g <- goal@@ -893,14 +893,14 @@                                                      else movelast n)                                           (ivs' \\ ivs)                                  return []-      where +      where             -- Run the elaborator, which returns how many implicit             -- args were needed, then run it again with those args. We need             -- this because we have to elaborate the whole application to             -- find out whether any computations have caused more implicits             -- to be needed.             implicitApp :: ElabD [ImplicitInfo] -> ElabD ()-            implicitApp elab +            implicitApp elab               | pattern || intransform = do elab; return ()               | otherwise                 = do s <- get@@ -909,7 +909,7 @@                           [] -> return ()                           es -> do put s                                    elab' ina topfc (PAppImpl tm es)-   +             checkKnownImplicit imp                  | UnknownImp `elem` argopts imp                     = lift $ tfail $ UnknownImplicit (pname imp) f@@ -966,7 +966,7 @@               headRef (PAlternative _ _ as) = all headRef as               headRef _ = False -    elab' ina fc (PAppImpl f es) = do appImpl (reverse es) -- not that we look... +    elab' ina fc (PAppImpl f es) = do appImpl (reverse es) -- not that we look...                                       solve         where appImpl [] = elab' (ina { e_isfn = False }) fc f -- e_isfn not set, so no recursive expansion of implicits               appImpl (e : es) = simple_app False@@ -1028,14 +1028,14 @@                    solve     elab' ina _ c@(PCase fc scr opts)         = do attack-             +              tyn <- getNameFrom (sMN 0 "scty")              claim tyn RType              valn <- getNameFrom (sMN 0 "scval")              scvn <- getNameFrom (sMN 0 "scvar")              claim valn (Var tyn)              letbind scvn (Var tyn) (Var valn)-             +              -- Start filling in the scrutinee type, if we can work one              -- out from the case options              let scrTy = getScrType (map fst opts)@@ -1056,7 +1056,7 @@               -- Drop the unique arguments used in the term already              -- and in the scrutinee (since it's-             -- not valid to use them again anyway) +             -- not valid to use them again anyway)              --              -- Also drop unique arguments which don't appear explicitly              -- in either case branch so they don't count as used@@ -1065,7 +1065,7 @@              ptm <- get_term              let inOpts = (filter (/= scvn) (map fst args)) \\ (concatMap (\x -> allNamesIn (snd x)) opts) -             let argsDropped = filter (isUnique envU) +             let argsDropped = filter (isUnique envU)                                    (nub $ allNamesIn scr ++ inApp ptm ++                                     inOpts) @@ -1097,9 +1097,9 @@               getScrType [] = Nothing               getScrType (f : os) = maybe (getScrType os) Just (getAppType f) -              getAppType (PRef _ _ n) = +              getAppType (PRef _ _ n) =                  case lookupTyName n (tt_ctxt ist) of-                      [(n', ty)] | isDConName n' (tt_ctxt ist) -> +                      [(n', ty)] | isDConName n' (tt_ctxt ist) ->                          case unApply (getRetTy ty) of                            (P _ tyn _, args) ->                                Just (PApp fc (PRef fc [] tyn)@@ -1250,12 +1250,12 @@                [] -> lift . tfail . NoSuchVariable $ n                more -> lift . tfail . CantResolveAlts $ map fst more     elab' ina fc (PAs _ n t) = lift . tfail . Msg $ "@-pattern not allowed here"-    elab' ina fc (PHidden t) +    elab' ina fc (PHidden t)       | reflection = elab' ina fc t       | otherwise         = do (h : hs) <- get_holes              -- Dotting a hole means that either the hole or any outer-             -- hole (a hole outside any occurrence of it) +             -- hole (a hole outside any occurrence of it)              -- must be solvable by unification as well as being filled              -- in directly.              -- Delay dotted things to the end, then when we elaborate them@@ -1323,7 +1323,7 @@     -- The delayed things with lower numbered priority will be elaborated     -- first. (In practice, this means delayed alternatives, then PHidden     -- things.)-    delayElab pri t +    delayElab pri t        = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [(pri, t)] })      isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term))@@ -1476,7 +1476,7 @@            let t' = case (t, cs) of                          (PCoerced tm, _) -> tm                          (_, []) -> t-                         (_, cs) -> PAlternative [] TryImplicit +                         (_, cs) -> PAlternative [] TryImplicit                                          (t : map (mkCoerce env t) cs)            return t'        where@@ -1598,7 +1598,7 @@                [] -> asV                _ -> as'   where-    ctxt = tt_ctxt ist +    ctxt = tt_ctxt ist      headIs var f (PRef _ _ f') = typeHead var f f'     headIs var f (PApp _ (PRef _ _ (UN l)) [_, _, arg])@@ -1617,7 +1617,7 @@                             _ -> let ty' = normalise ctxt [] ty in                                      case unApply (getRetTy ty') of                                           (P _ ftyn _, _) -> ftyn == f-                                          (V _, _) -> +                                          (V _, _) ->                                             -- keep, variable --                                             trace ("Keeping " ++ show (f', ty') --                                                      ++ " for " ++ show n) $@@ -1634,22 +1634,22 @@ -- (FIXME: This isn't complete, but I'm leaving it here and coming back -- to it later - just returns 'var' for now. EB) isPlausible :: IState -> Bool -> Env -> Name -> Type -> Bool-isPlausible ist var env n ty +isPlausible ist var env n ty     = let (hvar, classes) = collectConstraints [] [] ty in           case hvar of                Nothing -> True                Just rth -> var -- trace (show (rth, classes)) var    where-     collectConstraints :: [Name] -> [(Term, [Name])] -> Type -> +     collectConstraints :: [Name] -> [(Term, [Name])] -> Type ->                                      (Maybe Name, [(Term, [Name])])      collectConstraints env tcs (Bind n (Pi _ ty _) sc)          = let tcs' = case unApply ty of-                           (P _ c _, _) -> +                           (P _ c _, _) ->                                case lookupCtxtExact c (idris_classes ist) of-                                    Just tc -> ((ty, map fst (class_instances tc)) -                                                     : tcs) +                                    Just tc -> ((ty, map fst (class_instances tc))+                                                     : tcs)                                     Nothing -> tcs-                           _ -> tcs +                           _ -> tcs                       in                collectConstraints (n : env) tcs' sc      collectConstraints env tcs t@@ -1669,7 +1669,7 @@  -- Try again to solve auto implicits solveAuto :: IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()-solveAuto ist fn ambigok (n, failc) +solveAuto ist fn ambigok (n, failc)   = do hs <- get_holes        when (not (null hs)) $ do         env <- get_env@@ -1682,8 +1682,8 @@              (lift $ Error (addLoc failc                    (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env))))         return ()-  where addLoc (FailContext fc f x : prev) err -           = At fc (ElaboratingArg f x +  where addLoc (FailContext fc f x : prev) err+           = At fc (ElaboratingArg f x                    (map (\(FailContext _ f' x') -> (f', x')) prev) err)         addLoc _ err = err @@ -1728,7 +1728,7 @@            t' <- collectDeferred top casenames ctxt t            when (not (n `elem` map fst ds)) $ put (ds ++ [(n, (i, top, t', psns))])            cd env app-    cd env (Bind n b t) +    cd env (Bind n b t)          = do b' <- cdb b               t' <- cd ((n, b) : env) t               return (Bind n b' t')@@ -1737,7 +1737,7 @@         cdb (Guess t v) = liftM2 Guess (cd env t) (cd env v)         cdb b           = do ty' <- cd env (binderTy b)                              return (b { binderTy = ty' })-    cd env (App s f a) = liftM2 (App s) (cd env f) +    cd env (App s f a) = liftM2 (App s) (cd env f)                                         (cd env a)     cd env t = return t @@ -2148,7 +2148,7 @@       | n == tacN "Prim__Fixity", [op'] <- args       = do opTm <- eval op'            case opTm of-             Constant (Str op) -> +             Constant (Str op) ->                let opChars = ":!#$%&*+./<=>?@\\^|-~"                    invalidOperators = [":", "=>", "->", "<-", "=", "?=", "|", "**", "==>", "\\", "%", "~", "?", "!"]                    fixities = idris_infixes ist@@ -2185,7 +2185,7 @@         bname _ = Nothing     runT (Intro xs) = mapM_ (\x -> do attack; intro (Just x)) xs     runT Intros = do g <- goal-                     attack; +                     attack;                      intro (bname g)                      try' (runT Intros)                           (return ()) True@@ -2430,18 +2430,18 @@ withErrorReflection :: Idris a -> Idris a withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)     where handle :: Err -> Idris Err-          handle e@(ReflectionError _ _)  = do logLvl 3 "Skipping reflection of error reflection result"+          handle e@(ReflectionError _ _)  = do logElab 3 "Skipping reflection of error reflection result"                                                return e -- Don't do meta-reflection of errors-          handle e@(ReflectionFailed _ _) = do logLvl 3 "Skipping reflection of reflection failure"+          handle e@(ReflectionFailed _ _) = do logElab 3 "Skipping reflection of reflection failure"                                                return e           -- At and Elaborating are just plumbing - error reflection shouldn't rewrite them-          handle e@(At fc err) = do logLvl 3 "Reflecting body of At"+          handle e@(At fc err) = do logElab 3 "Reflecting body of At"                                     err' <- handle err                                     return (At fc err')-          handle e@(Elaborating what n ty err) = do logLvl 3 "Reflecting body of Elaborating"+          handle e@(Elaborating what n ty err) = do logElab 3 "Reflecting body of Elaborating"                                                     err' <- handle err                                                     return (Elaborating what n ty err')-          handle e@(ElaboratingArg f a prev err) = do logLvl 3 "Reflecting body of ElaboratingArg"+          handle e@(ElaboratingArg f a prev err) = do logElab 3 "Reflecting body of ElaboratingArg"                                                       hs <- getFnHandlers f a                                                       err' <- if null hs                                                                  then handle err@@ -2451,8 +2451,8 @@           handle (ProofSearchFail e) = handle e           -- TODO: argument-specific error handlers go here for ElaboratingArg           handle e = do ist <- getIState-                        logLvl 2 "Starting error reflection"-                        logLvl 5 (show e)+                        logElab 2 "Starting error reflection"+                        logElab 5 (show e)                         let handlers = idris_errorhandlers ist                         applyHandlers e handlers           getFnHandlers :: Name -> Name -> Idris [Name]@@ -2466,7 +2466,7 @@           applyHandlers e handlers =                       do ist <- getIState                          let err = fmap (errReverse ist) e-                         logLvl 3 $ "Using reflection handlers " +++                         logElab 3 $ "Using reflection handlers " ++                                     concat (intersperse ", " (map show handlers))                          let reports = map (\n -> RApp (Var n) (reflectErr err)) handlers @@ -2478,7 +2478,7 @@                          -- Normalize error handler terms to produce the new messages                          ctxt <- getContext                          let results = map (normalise ctxt []) (map fst handlers)-                         logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))+                         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                          let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)@@ -2499,8 +2499,8 @@   -- establish metavars that later function bodies resolve.   forM_ (reverse steps) $ \case     RTyDeclInstrs n fc impls ty ->-      do logLvl 3 $ "Declaration from tactics: " ++ show n ++ " : " ++ show ty-         logLvl 3 $ "  It has impls " ++ show impls+      do logElab 3 $ "Declaration from tactics: " ++ show n ++ " : " ++ show ty+         logElab 3 $ "  It has impls " ++ show impls          updateIState $ \i -> i { idris_implicits =                                     addDef n impls (idris_implicits i) }          addIBC (IBCImp n)@@ -2517,13 +2517,13 @@              in addDeferred ds'            _ -> return ()     RAddInstance className instName ->-      do -- The type class resolution machinery relies on a special -         logLvl 2 $ "Adding elab script instance " ++ show instName +++      do -- The type class resolution machinery relies on a special+         logElab 2 $ "Adding elab script instance " ++ show instName ++                     " for " ++ show className          addInstance False True className instName          addIBC (IBCInstance False True className instName)     RClausesInstrs n cs ->-      do logLvl 3 $ "Pattern-matching definition from tactics: " ++ show n+      do logElab 3 $ "Pattern-matching definition from tactics: " ++ show n          solveDeferred n          let lhss = map (\(_, lhs, _) -> lhs) cs          let fc = fileFC "elab_reflected"@@ -2553,7 +2553,7 @@                  calls = findCalls sc' scargs                  used = findUsedArgs sc' scargs'                  cg = CGInfo scargs' calls [] used []-             in do logLvl 2 $ "Called names in reflected elab: " ++ show cg+             in do logElab 2 $ "Called names in reflected elab: " ++ show cg                    addToCG n cg                    addToCalledG n (nub (map fst calls))                    addIBC $ IBCCG n
src/Idris/Elab/Transform.hs view
@@ -53,7 +53,7 @@     = do ctxt <- getContext          i <- getIState          let lhs = addImplPat i lhs_in-         logLvl 5 ("Transform LHS input: " ++ showTmImpls lhs)+         logElab 5 ("Transform LHS input: " ++ showTmImpls lhs)          (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-               tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transLHS") infP initEState                        (erun fc (buildTC i info ETransLHS [] (sUN "transform")@@ -67,11 +67,11 @@           (clhs_tm_in, clhs_ty) <- recheckC_borrowing False False [] fc id [] lhs_tm          let clhs_tm = renamepats pnames clhs_tm_in-         logLvl 3 ("Transform LHS " ++ show clhs_tm)-         logLvl 3 ("Transform type " ++ show clhs_ty)-         +         logElab 3 ("Transform LHS " ++ show clhs_tm)+         logElab 3 ("Transform type " ++ show clhs_ty)+          let rhs = addImplBound i (map fst newargs) rhs_in-         logLvl 5 ("Transform RHS input: " ++ showTmImpls rhs)+         logElab 5 ("Transform RHS input: " ++ showTmImpls rhs)           ((rhs', defer, ctxt', newDecls), _) <-               tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transRHS") clhs_ty initEState@@ -88,7 +88,7 @@           (crhs_tm_in, crhs_ty) <- recheckC_borrowing False False [] fc id [] rhs'          let crhs_tm = renamepats pnames crhs_tm_in-         logLvl 3 ("Transform RHS " ++ show crhs_tm)+         logElab 3 ("Transform RHS " ++ show crhs_tm)           -- Types must always convert          case converts ctxt [] clhs_ty crhs_ty of@@ -118,6 +118,5 @@     -- with any other names when applying rules, so rename here.     pnames = map (\i -> sMN i ("tvar" ++ show i)) [0..] -elabTransform info fc safe lhs_in rhs_in +elabTransform info fc safe lhs_in rhs_in    = ierror (At fc (Msg "Invalid transformation rule (must be function application)"))-
src/Idris/Elab/Type.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE PatternGuards #-}-module Idris.Elab.Type (buildType, elabType, elabType', +module Idris.Elab.Type (buildType, elabType, elabType',                         elabPostulate, elabExtern) where  import Idris.AbsSyntax@@ -52,20 +52,20 @@  import Util.Pretty(pretty, text) -buildType :: ElabInfo -> SyntaxInfo -> FC -> FnOpts -> Name -> PTerm -> +buildType :: ElabInfo -> SyntaxInfo -> FC -> FnOpts -> Name -> PTerm ->              Idris (Type, Type, PTerm, [(Int, Name)]) buildType info syn fc opts n ty' = do          ctxt <- getContext          i <- getIState -         logLvl 2 $ show n ++ " pre-type " ++ showTmImpls ty' ++ show (no_imp syn)+         logElab 2 $ show n ++ " pre-type " ++ showTmImpls ty' ++ show (no_imp syn)          ty' <- addUsingConstraints syn fc ty'          ty' <- addUsingImpls syn n fc ty'          let ty = addImpl (imp_methods syn) i ty' -         logLvl 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'-         logLvl 5 $ show "with methods " ++ show (imp_methods syn)-         logLvl 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty+         logElab 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'+         logElab 5 $ show "with methods " ++ show (imp_methods syn)+         logElab 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty           (ElabResult tyT' defer is ctxt' newDecls highlights, log) <-             tclift $ elaborate ctxt (idris_datatypes i) n (TType (UVal 0)) initEState@@ -76,7 +76,7 @@           let tyT = patToImp tyT' -         logLvl 3 $ show ty ++ "\nElaborated: " ++ show tyT'+         logElab 3 $ show ty ++ "\nElaborated: " ++ show tyT'           ds <- checkAddDef True False fc iderr defer          -- if the type is not complete, note that we'll need to infer@@ -86,20 +86,20 @@           mapM_ (elabCaseBlock info opts) is          ctxt <- getContext-         logLvl 5 $ "Rechecking"-         logLvl 6 $ show tyT-         logLvl 10 $ "Elaborated to " ++ showEnvDbg [] tyT+         logElab 5 $ "Rechecking"+         logElab 6 $ show tyT+         logElab 10 $ "Elaborated to " ++ showEnvDbg [] tyT          (cty, ckind)   <- recheckC fc id [] tyT           -- record the implicit and inaccessible arguments          i <- getIState          let (inaccData, impls) = unzip $ getUnboundImplicits i cty ty          let inacc = inaccessibleImps 0 cty inaccData-         logLvl 3 $ show n ++ ": inaccessible arguments: " ++ show inacc +++         logElab 3 $ show n ++ ": inaccessible arguments: " ++ show inacc ++                      " from " ++ show cty ++ "\n" ++ showTmImpls ty           putIState $ i { idris_implicits = addDef n impls (idris_implicits i) }-         logLvl 3 ("Implicit " ++ show n ++ " " ++ show impls)+         logElab 3 ("Implicit " ++ show n ++ " " ++ show impls)          addIBC (IBCImp n)           when (Constructor `notElem` opts) $ do@@ -114,7 +114,7 @@     patToImp (Bind n b sc) = Bind n b (patToImp sc)     patToImp t = t -    param_pos i ns (Bind n (Pi _ t _) sc) +    param_pos i ns (Bind n (Pi _ t _) sc)         | n `elem` ns = i : param_pos (i + 1) ns sc         | otherwise = param_pos (i + 1) ns sc     param_pos i ns t = []@@ -140,9 +140,9 @@          let nty = cty -- normalise ctxt [] cty          -- if the return type is something coinductive, freeze the definition          ctxt <- getContext-         logLvl 2 $ "Rechecked to " ++ show nty+         logElab 2 $ "Rechecked to " ++ show nty          let nty' = normalise ctxt [] nty-         logLvl 2 $ "Rechecked to " ++ show nty'+         logElab 2 $ "Rechecked to " ++ show nty'           -- Add function name to internals (used for making :addclause know          -- the name unambiguously)@@ -158,7 +158,7 @@                                         [TI _ True _ _ _] -> True                                         _ -> False                         _ -> False-         -- Productivity checking now via checking for guarded 'Delay' +         -- 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, []))]@@ -177,7 +177,7 @@          addIBC (IBCOpt n)          when (Implicit `elem` opts') $ do addCoercion n                                            addIBC (IBCCoercion n)-         when (AutoHint `elem` opts') $ +         when (AutoHint `elem` opts') $              case fam of                 P _ tyn _ -> do addAutoHint tyn n                                 addIBC (IBCAutoHint tyn n)@@ -201,7 +201,7 @@          sendHighlighting [(nfc, AnnName n Nothing Nothing Nothing)]          -- if it's an export list type, make a note of it          case (unApply usety) of-              (P _ ut _, _) +              (P _ ut _, _)                  | ut == ffiexport -> do addIBC (IBCExport n)                                          addExport n               _ -> return ()@@ -256,6 +256,3 @@      -- remove it from the deferred definitions list     solveDeferred n---
src/Idris/Elab/Utils.hs view
@@ -37,14 +37,14 @@          (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs ctxt env t' t of                                    Error e -> tfail (At fc (mkerr e))                                    OK x -> return x-         logLvl 6 $ "CONSTRAINTS ADDED: " ++ show (tm, ty, cs)+         logElab 6 $ "CONSTRAINTS ADDED: " ++ show (tm, ty, cs)          when addConstrs $ addConstraints fc cs          mapM_ (checkDeprecated fc) (allTTNames tm)          mapM_ (checkDeprecated fc) (allTTNames ty)          return (tm, ty)  checkDeprecated :: FC -> Name -> Idris ()-checkDeprecated fc n +checkDeprecated fc n     = do r <- getDeprecated n          case r of               Nothing -> return ()@@ -64,9 +64,9 @@             -> [(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 ((n, (i, top, t, psns)) : ns)                = do ctxt <- getContext-                    logLvl 5 $ "Rechecking deferred name " ++ show (n, t)+                    logElab 5 $ "Rechecking deferred name " ++ show (n, t)                     (t', _) <- recheckC fc (mkerr n) [] t                     when add $ do addDeferred [(n, (i, top, t, psns, toplvl))]                                   addIBC (IBCDef n)@@ -93,7 +93,7 @@ elabCaseBlock :: ElabInfo -> FnOpts -> PDecl -> Idris () elabCaseBlock info opts d@(PClauses f o n ps)         = do addIBC (IBCDef n)-             logLvl 5 $ "CASE BLOCK: " ++ show (n, d)+             logElab 5 $ "CASE BLOCK: " ++ show (n, d)              let opts' = nub (o ++ opts)              -- propagate totality assertion to the new definitions              when (AssertTotal `elem` opts) $ setFlags n [AssertTotal]@@ -104,16 +104,16 @@ -- they are the same!) checkInferred :: FC -> PTerm -> PTerm -> Idris () checkInferred fc inf user =-     do logLvl 6 $ "Checked to\n" ++ showTmImpls inf ++ "\n\nFROM\n\n" +++     do logElab 6 $ "Checked to\n" ++ showTmImpls inf ++ "\n\nFROM\n\n" ++                                      showTmImpls user-        logLvl 10 $ "Checking match"+        logElab 10 $ "Checking match"         i <- getIState         tclift $ case matchClause' True i user inf of             _ -> return () --             Left (x, y) -> tfail $ At fc --                                     (Msg $ "The type-checked term and given term do not match: " --                                            ++ show x ++ " and " ++ show y)-        logLvl 10 $ "Checked match"+        logElab 10 $ "Checked match" --                           ++ "\n" ++ showImp True inf ++ "\n" ++ showImp True user)  -- | Return whether inferred term is different from given term@@ -121,7 +121,7 @@ inferredDiff :: FC -> PTerm -> PTerm -> Idris Bool inferredDiff fc inf user =      do i <- getIState-        logLvl 6 $ "Checked to\n" ++ showTmImpls inf ++ "\n" +++        logElab 6 $ "Checked to\n" ++ showTmImpls inf ++ "\n" ++                                      showTmImpls user         tclift $ case matchClause' True i user inf of             Right vs -> return False@@ -152,7 +152,7 @@  -- if 't' is a type class application, assume its arguments are injective pbinds :: IState -> Term -> ElabD ()-pbinds i (Bind n (PVar t) sc) +pbinds i (Bind n (PVar t) sc)     = do attack; patbind n          env <- get_env          case unApply (normalise (tt_ctxt i) env t) of@@ -207,14 +207,14 @@     | (P nt tn _, args) <- unApply tm, nt /= Bound        = case lookupCtxtExact tn (idris_datatypes i) of             Just t -> nub $ paramNames args env [x | x <- [0..length args],-                                                     not (x `elem` param_pos t)] +                                                     not (x `elem` param_pos t)]                           ++ getFlexInType i env ps f ++                              getFlexInType i env ps a             Nothing -> let ppos = case lookupCtxtExact tn (idris_fninfo i) of                                        Just fi -> fn_params fi                                        Nothing -> []                        in nub $ paramNames args env [x | x <- [0..length args],-                                                         not (x `elem` ppos)] +                                                         not (x `elem` ppos)]                            ++ getFlexInType i env ps f ++                               getFlexInType i env ps a     | otherwise = nub $ getFlexInType i env ps f ++@@ -228,7 +228,7 @@                                  flex = getFlexInType i env fix t in                                  [x | x <- fix, not (x `elem` flex)] -getTCinj i (Bind n (Pi _ t _) sc) +getTCinj i (Bind n (Pi _ t _) sc)     = getTCinj i t ++ getTCinj i (instantiate (P Bound n t) sc) getTCinj i ap@(App _ f a)     | (P _ n _, args) <- unApply ap,@@ -258,7 +258,7 @@ getUniqueUsed :: Context -> Term -> [Name] getUniqueUsed ctxt tm = execState (getUniq [] [] tm) []   where-    getUniq :: Env -> [(Name, Bool)] -> Term -> State [Name] () +    getUniq :: Env -> [(Name, Bool)] -> Term -> State [Name] ()     getUniq env us (Bind n b sc)        = let uniq = case check ctxt env (forgetEnv (map fst env) (binderTy b)) of                          OK (_, UType UniqueType) -> True@@ -285,9 +285,9 @@ -- In a functional application, return the names which are used -- directly in a static position getStaticNames :: IState -> Term -> [Name]-getStaticNames ist (Bind n (PVar _) sc) +getStaticNames ist (Bind n (PVar _) sc)     = getStaticNames ist (instantiate (P Bound n Erased) sc)-getStaticNames ist tm +getStaticNames ist tm     | (P _ fn _, args) <- unApply tm         = case lookupCtxtExact fn (idris_statics ist) of                Just stpos -> getStatics args stpos@@ -305,15 +305,12 @@ getStatics _ _ = []  mkStatic :: [Name] -> PDecl -> PDecl-mkStatic ns (PTy doc argdocs syn fc o n nfc ty) +mkStatic ns (PTy doc argdocs syn fc o n nfc ty)     = PTy doc argdocs syn fc o n nfc (mkStaticTy ns ty) mkStatic ns t = t  mkStaticTy :: [Name] -> PTerm -> PTerm-mkStaticTy ns (PPi p n fc ty sc) +mkStaticTy ns (PPi p n fc ty sc)     | 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---
src/Idris/Elab/Value.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}-module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms, +module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms,                         elabExec, elabREPL) where  import Idris.AbsSyntax@@ -58,7 +58,7 @@    = do ctxt <- getContext         i <- getIState         let tm = addImpl [] i tm_in-        logLvl 10 (showTmImpls tm)+        logElab 10 (showTmImpls tm)         -- try:         --    * ordinary elaboration         --    * elaboration as a Type@@ -80,7 +80,7 @@         addDeferred def''         mapM_ (elabCaseBlock info []) is -        logLvl 3 ("Value: " ++ show vtm)+        logElab 3 ("Value: " ++ show vtm)         (vtm_in, vty) <- recheckC (fileFC "(input)") id [] vtm          let vtm = if norm then normalise (tt_ctxt i) [] vtm_in@@ -127,7 +127,7 @@                     printtm tm                     ])   where-    runtm t = PApp fc (PRef fc [] (sUN "run__IO")) +    runtm t = PApp fc (PRef fc [] (sUN "run__IO"))                   [pimp (sUN "ffi") (PRef fc [] (sUN "FFI_C")) False, pexp t]     printtm t = PApp fc (PRef fc [] (sUN "printLn"))                   [pimp (sUN "ffi") (PRef fc [] (sUN "FFI_C")) False, pexp t]
src/Idris/ElabDecls.hs view
@@ -159,25 +159,25 @@      = return () -- nothing to elaborate elabDecl' what info (PTy doc argdocs s f o n nfc ty)   | what /= EDefns-    = do logLvl 1 $ "Elaborating type decl " ++ show n ++ show o+    = do logElab 1 $ "Elaborating type decl " ++ show n ++ show o          elabType info s doc argdocs f o n nfc ty          return () elabDecl' what info (PPostulate b doc s f nfc o n ty)   | what /= EDefns-    = do logLvl 1 $ "Elaborating postulate " ++ show n ++ show o-         if b +    = do logElab 1 $ "Elaborating postulate " ++ show n ++ show o+         if b             then elabExtern info s doc f nfc o n ty             else elabPostulate info s doc f nfc o n ty elabDecl' what info (PData doc argDocs s f co d)   | what /= ETypes-    = do logLvl 1 $ "Elaborating " ++ show (d_name d)+    = do logElab 1 $ "Elaborating " ++ show (d_name d)          elabData info s doc argDocs f co d   | otherwise-    = do logLvl 1 $ "Elaborating [type of] " ++ show (d_name d)+    = do logElab 1 $ "Elaborating [type of] " ++ show (d_name d)          elabData info s doc argDocs f co (PLaterdecl (d_name d) (d_name_fc d) (d_tcon d)) elabDecl' what info d@(PClauses f o n ps)   | what /= ETypes-    = do logLvl 1 $ "Elaborating clause " ++ show n+    = do logElab 1 $ "Elaborating clause " ++ show n          i <- getIState -- get the type options too          let o' = case lookupCtxt n (idris_flags i) of                     [fs] -> fs@@ -191,11 +191,11 @@          -- record mutually defined data definitions          let datans = concatMap declared (filter isDataDecl ps)          mapM_ (setMutData datans) datans-         logLvl 1 $ "Rechecking for positivity " ++ show datans+         logElab 1 $ "Rechecking for positivity " ++ show datans          mapM_ (\x -> do setTotality x Unchecked) datans          -- Do totality checking after entire mutual block          i <- get-         mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n+         mapM_ (\n -> do logElab 5 $ "Simplifying " ++ show n                          ctxt' <- do ctxt <- getContext                                      tclift $ simplifyCasedef n (getErasureInfo i) ctxt                          setContext ctxt')@@ -216,7 +216,7 @@  elabDecl' what info (PParams f ns ps)     = do i <- getIState-         logLvl 1 $ "Expanding params block with " ++ show ns ++ " decls " +++         logElab 1 $ "Expanding params block with " ++ show ns ++ " decls " ++                 show (concatMap tldeclared ps)          let nblock = pblock i          mapM_ (elabDecl' what info) nblock@@ -240,17 +240,17 @@  elabDecl' what info (PClass doc s f cs n nfc ps pdocs fds ds cn cd)   | what /= EDefns-    = do logLvl 1 $ "Elaborating class " ++ show n+    = 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)-    = do logLvl 1 $ "Elaborating instance " ++ show n+    = do logElab 1 $ "Elaborating instance " ++ show n          elabInstance info s doc argDocs what f cs n nfc ps t expn ds elabDecl' what info (PRecord doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn)-    = do logLvl 1 $ "Elaborating record " ++ show name+    = do logElab 1 $ "Elaborating record " ++ show name          elabRecord info what doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn {-   | otherwise-    = do logLvl 1 $ "Elaborating [type of] " ++ show tyn+    = do logElab 1 $ "Elaborating [type of] " ++ show tyn          elabData info s doc [] f [] (PLaterdecl tyn ty) -} elabDecl' _ info (PDSL n dsl)@@ -261,7 +261,7 @@   | what /= EDefns = directiveAction i elabDecl' what info (PProvider doc syn fc nfc provWhat n)   | what /= EDefns-    = do logLvl 1 $ "Elaborating type provider " ++ show n+    = do logElab 1 $ "Elaborating type provider " ++ show n          elabProvider doc info syn fc nfc provWhat n elabDecl' what info (PTransform fc safety old new)     = do elabTransform info fc safety old new
src/Idris/Erasure.hs view
@@ -85,10 +85,10 @@             usage = M.toList minUse          -- Print some debug info.-        logLvl 5 $ "Original deps:\n" ++ unlines (map fmtItem . M.toList $ depMap)-        logLvl 3 $ "Reachable names:\n" ++ unlines (map (indent . show) . S.toList $ reachableNames)-        logLvl 4 $ "Minimal usage:\n" ++ fmtUseMap usage-        logLvl 5 $ "Residual deps:\n" ++ unlines (map fmtItem . M.toList $ residDeps)+        logErasure 5 $ "Original deps:\n" ++ unlines (map fmtItem . M.toList $ depMap)+        logErasure 3 $ "Reachable names:\n" ++ unlines (map (indent . show) . S.toList $ reachableNames)+        logErasure 4 $ "Minimal usage:\n" ++ fmtUseMap usage+        logErasure 5 $ "Residual deps:\n" ++ unlines (map fmtItem . M.toList $ residDeps)          -- Check that everything reachable is accessible.         checkEnabled <- (WarnReach `elem`) . opt_cmdline . idris_options <$> getIState@@ -135,7 +135,7 @@       where         fmt n [] = show n ++ " (no more information available)"         fmt n rs = show n ++ " from " ++ intercalate ", " [show rn ++ " arg# " ++ show ri | (rn,ri) <- rs]-        warn = logLvl 0+        warn = logErasure 0  -- Find the minimal consistent usage by forward chaining. minimalUsage :: Deps -> (Deps, (Set Name, UseMap))@@ -150,7 +150,7 @@  forwardChain :: Deps -> (Deps, DepSet) forwardChain deps-    | Just trivials <- M.lookup S.empty deps +    | Just trivials <- M.lookup S.empty deps         = (M.unionWith S.union trivials)             `second` forwardChain (remove trivials . M.delete S.empty $ deps)     | otherwise = (deps, M.empty)@@ -164,7 +164,7 @@ -- starting the depth-first search from a list of Names. buildDepMap :: Ctxt ClassInfo -> [(Name, Int)] -> [(Name, Int)] ->                Context -> [Name] -> Deps-buildDepMap ci used externs ctx startNames +buildDepMap ci used externs ctx startNames     = addPostulates used $ dfs S.empty M.empty startNames   where     -- mark the result of Main.main as used with the empty assumption@@ -181,7 +181,7 @@         usedNames = allNames deps S.\\ specialPrims         usedPrims = [(p_name p, p_arity p) | p <- primitives, p_name p `S.member` usedNames] -        postulates used = +        postulates used =             [ [] ==> concat                 -- Main.main ( + export lists) and run__IO, are always evaluated                 -- but they elude analysis since they come from the seed term.@@ -190,7 +190,7 @@                 ,[(sUN "call__IO", Result), (sUN "call__IO", Arg 2)]                  -- Explicit usage declarations from a %used pragma-                , map (\(n, i) -> (n, Arg i)) used +                , map (\(n, i) -> (n, Arg i)) used                  -- MkIO is read by run__IO,                 -- but this cannot be observed in the source code of programs.@@ -200,7 +200,7 @@                 -- Foreign calls are built with pairs, but mkForeign doesn't                 -- have an implementation so analysis won't see them                 , [(pairCon, Arg 2),-                   (pairCon, Arg 3)] -- Used in foreign calls +                   (pairCon, Arg 3)] -- Used in foreign calls                  -- these have been discovered as builtins but are not listed                 -- among Idris.Primitives.primitives@@ -211,7 +211,7 @@                 -- believe_me is a primitive but it only uses its third argument                 -- it is special-cased in usedNames above                 , it "prim__believe_me" [2]-    +                 -- in general, all other primitives use all their arguments                 , [(n, Arg i) | (n,arity) <- usedPrims, i <- [0..arity-1]] @@ -324,7 +324,7 @@             , viMethod = meth j             })           | (v, j) <- zip ns [0..]]-        +         -- this is safe because it's certainly a patvar         varIdx = fromJust (viFunArg var)
src/Idris/IBC.hs view
@@ -113,7 +113,7 @@                                 Nothing -> True                                 Just p -> not p && reexport                 when redo $-                  do logLvl 1 $ "Loading ibc " ++ fp ++ " " ++ show reexport+                  do logIBC 1 $ "Loading ibc " ++ fp ++ " " ++ show reexport                      archiveFile <- runIO $ B.readFile fp                      case toArchiveOrFail archiveFile of                         Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"@@ -189,7 +189,7 @@  writeIBC :: FilePath -> FilePath -> Idris () writeIBC src f-    = do logLvl 1 $ "Writing ibc " ++ show f+    = do logIBC 1 $ "Writing ibc " ++ show f          i <- getIState --          case (Data.List.map fst (idris_metavars i)) \\ primDefs of --                 (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"@@ -198,8 +198,8 @@          ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })          idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)                         writeArchive f ibcf-                        logLvl 1 "Written")-            (\c -> do logLvl 1 $ "Failed " ++ pshow i c)+                        logIBC 1 "Written")+            (\c -> do logIBC 1 $ "Failed " ++ pshow i c)          return ()  -- Write a package index containing all the imports in the current IState@@ -208,20 +208,20 @@ writePkgIndex f     = do i <- getIState          let imps = map (\ (x, y) -> (True, x)) $ idris_imported i-         logLvl 1 $ "Writing package index " ++ show f ++ " including\n" +++         logIBC 1 $ "Writing package index " ++ show f ++ " including\n" ++                 show (map snd imps)          resetNameIdx          let ibcf = initIBC { ibc_imports = imps }          idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)                         writeArchive f ibcf-                        logLvl 1 "Written")-            (\c -> do logLvl 1 $ "Failed " ++ pshow i c)+                        logIBC 1 "Written")+            (\c -> do logIBC 1 $ "Failed " ++ pshow i c)          return ()  mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile mkIBC [] f = return f mkIBC (i:is) f = do ist <- getIState-                    logLvl 5 $ show i ++ " " ++ show (L.length is)+                    logIBC 5 $ show i ++ " " ++ show (L.length is)                     f' <- ibc ist i f                     mkIBC is f' @@ -319,7 +319,7 @@ process reexp i fn = do                 ver <- getEntry 0 "ver" i                 when (ver /= ibcVersion) $ do-                                    logLvl 1 "ibc out of date"+                                    logIBC 1 "ibc out of date"                                     let e = if ver < ibcVersion                                             then " an earlier " else " a later "                                     ifail $ "Incompatible ibc version.\nThis library was built with"@@ -415,10 +415,12 @@ --                         then logLvl 1 $ "Already read " ++ f                        putIState (i { imported = f : imported i })                        case fp of-                            LIDR fn -> do logLvl 1 $ "Failed at " ++ fn-                                          ifail "Must be an ibc"-                            IDR fn -> do logLvl 1 $ "Failed at " ++ fn-                                         ifail "Must be an ibc"+                            LIDR fn -> do+                              logIBC 1 $ "Failed at " ++ fn+                              ifail "Must be an ibc"+                            IDR fn -> do+                              logIBC 1 $ "Failed at " ++ fn+                              ifail "Must be an ibc"                             IBC fn src -> loadIBC (reexp && re) fn)              fs @@ -515,13 +517,13 @@                do d' <- updateDef d                   case d' of                        TyDecl _ _ -> return ()-                       _ -> do logLvl 1 $ "SOLVING " ++ show n+                       _ -> do logIBC 1 $ "SOLVING " ++ show n                                solveDeferred n                   updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) }) --                   logLvl 1 $ "Added " ++ show (n, d')-                  if (not reexp) then do logLvl 1 $ "Not exporting " ++ show n+                  if (not reexp) then do logIBC 1 $ "Not exporting " ++ show n                                          setAccessibility n Hidden-                                 else logLvl 1 $ "Exporting " ++ show n) ds+                                 else logIBC 1 $ "Exporting " ++ show n) ds   where     updateDef (CaseOp c t args o s cd)       = do o' <- mapM updateOrig o@@ -586,7 +588,7 @@ pAccess reexp ds         = mapM_ (\ (n, a_in) ->                       do let a = if reexp then a_in else Hidden-                         logLvl 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a+                         logIBC 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a                          updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })) ds  pFlags :: [(Name, [FnOpt])] -> Idris ()@@ -1843,7 +1845,7 @@                    _ -> error "Corrupted binary data for PTerm"  instance Binary PAltType where-        put x +        put x           = case x of                 ExactlyOne x1 -> do putWord8 0                                     put x1
src/Idris/IdrisDoc.hs view
@@ -581,7 +581,7 @@  createOtherDoc ist (ClassDoc n docstring fds _ _ _ _ c) = do   H.dt ! (A.id $ toValue $ show n) $ do-    H.span ! class_ "word" $ do "class"; nbsp+    H.span ! class_ "word" $ do "interface"; nbsp     H.span ! class_ "name type"            ! title  (toValue $ show n)            $ toHtml $ name $ nsroot n
src/Idris/Interactive.hs view
@@ -400,10 +400,14 @@                 = n : guessImps ist ctxt sc            | isClass ist ty                 = n : guessImps ist ctxt sc-           | TType _ <- ty = n : guessImps ist ctxt sc+           | paramty ty = n : guessImps ist ctxt sc            | 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
src/Idris/ParseExpr.hs view
@@ -1118,7 +1118,7 @@                         return (n, fc, e))                 <|> do e <- expr syn                        return (defname, NoFC, e)-        defname = sMN 0 "constrarg"+        defname = sMN 0 "constraint"  {- | Parses a type declaration list @
src/Idris/ParseHelpers.hs view
@@ -246,7 +246,8 @@                                       "case", "of", "total", "partial", "mutual",                                       "infix", "infixl", "infixr", "rewrite",                                       "where", "with", "syntax", "proof", "postulate",-                                      "using", "namespace", "class", "instance", "parameters",+                                      "using", "namespace", "class", "instance", +                                      "interface", "implementation", "parameters",                                       "public", "private", "abstract", "implicit",                                       "quoteGoal", "constructor",                                       "if", "then", "else"]
src/Idris/Parser.hs view
@@ -189,7 +189,7 @@            <?> "declaration"  internalDecl :: SyntaxInfo -> IdrisParser [PDecl]-internalDecl syn +internalDecl syn          = do fc <- getFC               -- if we're after maxline, stop at the next type declaration               -- (so we get all cases of a definition to preserve totality@@ -204,20 +204,21 @@               -- the end of the definition, reset the state. But I've lost               -- patience with trying to find out how to do that from the               -- trifecta docs, so this does the job instead.-              if continue then +              if continue then                  do notEndBlock                     declBody continue                 else try (do notEndBlock                              declBody continue)                      <|> fail "End of readable input"   where declBody :: Bool -> IdrisParser [PDecl]-        declBody b = declBody' b+        declBody b = +                   try (instance_ True syn)+                   <|> declBody' b                    <|> using_ syn                    <|> params syn                    <|> mutual syn                    <|> namespace syn                    <|> class_ syn-                   <|> instance_ syn                    <|> do d <- dsl syn; return [d]                    <|> directive syn                    <|> provider syn@@ -283,7 +284,7 @@      isDeclRule (DeclRule _ _) = True      isDeclRule _ = False -declExtension :: SyntaxInfo -> [Maybe (Name, SynMatch)] -> [Syntax] +declExtension :: SyntaxInfo -> [Maybe (Name, SynMatch)] -> [Syntax]                  -> IdrisParser [PDecl] declExtension syn ns rules =   choice $ flip map (groupBy (ruleGroup `on` syntaxSymbols) rules) $ \rs ->@@ -318,7 +319,7 @@     updateNs :: [(Name, SynMatch)] -> PDecl -> PDecl     updateNs ns (PTy doc argdoc s fc o n fc' t)           = PTy doc argdoc s fc o (updateB ns n) fc' t-    updateNs ns (PClauses fc o n cs) +    updateNs ns (PClauses fc o n cs)          = PClauses fc o (updateB ns n) (map (updateClause ns) cs)     updateNs ns (PCAF fc n t) = PCAF fc (updateB ns n) t     updateNs ns (PData ds cds s fc o dat)@@ -338,10 +339,10 @@                   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'-                     ps ity (fmap (updateB ns) ni) +                     ps ity (fmap (updateB ns) ni)                             (map (updateNs ns) ds)     updateNs ns (PMutual fc ds) = PMutual fc (map (updateNs ns) ds)-    updateNs ns (PProvider docs s fc fc' pw n) +    updateNs ns (PProvider docs s fc fc' pw n)         = PProvider docs s fc fc' pw (updateB ns n)     updateNs ns d = d @@ -482,7 +483,7 @@        where ts = dropWhile isSpace . dropWhileEnd isSpace $ s     mkSimple' (e : es) = e : mkSimple' es     mkSimple' [] = []-    +     -- Prevent syntax variable capture by making all binders under syntax unique     -- (the ol' Common Lisp GENSYM approach)     uniquifyBinders :: [Name] -> PTerm -> IdrisParser PTerm@@ -798,7 +799,7 @@                        ds <- many (fnDecl syn)                        closeBlock                        return (concat ds)-                    <?> "instance block"+                    <?> "implementation block"  {- | Parses a methods and instances block (for type classes) @@ -825,7 +826,7 @@                     ist <- get                     let cd' = annotate syn ist cd -                    ds <- many (notEndBlock >> instance_ syn <|> fnDecl syn)+                    ds <- many (notEndBlock >> try (instance_ True syn) <|> fnDecl syn)                     closeBlock                     return (cn, cd', concat ds)                  <?> "class block"@@ -856,7 +857,7 @@ class_ syn = do (doc, argDocs, acc)                   <- try (do (doc, argDocs) <- docstring syn                              acc <- optional accessibility-                             reservedHL "class"+                             classKeyword                              return (doc, argDocs, acc))                 fc <- getFC                 cons <- constraintList syn@@ -872,6 +873,15 @@   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 }      carg :: IdrisParser (Name, FC, PTerm)     carg = do lchar '('; (i, ifc) <- name; lchar ':'; ty <- expr syn; lchar ')'@@ -892,9 +902,12 @@ InstanceName ::= '[' Name ']'; @ -}-instance_ :: SyntaxInfo -> IdrisParser [PDecl]-instance_ syn = do (doc, argDocs)-                     <- try (docstring syn <* reservedHL "instance")+instance_ :: Bool -> SyntaxInfo -> IdrisParser [PDecl]+instance_ kwopt syn +              = do (doc, argDocs)+                     <- try (docstring syn <* if kwopt then optional instanceKeyword+                                                       else do instanceKeyword+                                                               return (Just ()))                    fc <- getFC                    en <- optional instanceName                    cs <- constraintList syn@@ -903,14 +916,22 @@                    args <- many (simpleExpr syn)                    let sc = PApp fc (PRef cnfc [cnfc] cn) (map pexp args)                    let t = bindList (PPi constraint) cs sc-                   ds <- option [] (instanceBlock syn)+                   ds <- instanceBlock syn                    return [PInstance doc argDocs syn fc cs' cn cnfc args t en ds]-                 <?> "instance declaration"+                 <?> "implementation declaration"   where instanceName :: IdrisParser Name         instanceName = do lchar '['; n_in <- fst <$> fnName; lchar ']'                           let n = expandNS syn n_in                           return n-                       <?> "instance name"+                       <?> "implementation name"+        instanceKeyword :: IdrisParser ()+        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 }   -- | Parse a docstring@@ -1552,7 +1573,7 @@         ids <- allImportDirs         fp <- findImport ids ibcsd file         if file `elem` imported i-          then do logLvl 1 $ "Already read " ++ file+          then do logParser 1 $ "Already read " ++ file                   return Nothing           else do putIState (i { imported = file : imported i })                   case fp of@@ -1560,7 +1581,7 @@                     LIDR fn -> loadSource True  fn Nothing                     IBC fn src ->                       idrisCatch (loadIBC True fn)-                                 (\c -> do logLvl 1 $ fn ++ " failed " ++ pshow i c+                                 (\c -> do logParser 1 $ fn ++ " failed " ++ pshow i c                                            case src of                                              IDR sfn -> loadSource False sfn Nothing                                              LIDR sfn -> loadSource True sfn Nothing)@@ -1569,7 +1590,7 @@ {- | Load idris code from file -} loadFromIFile :: Bool -> IFileType -> Maybe Int -> Idris () loadFromIFile reexp i@(IBC fn src) maxline-   = do logLvl 1 $ "Skipping " ++ getSrcFile i+   = do logParser 1 $ "Skipping " ++ getSrcFile i         idrisCatch (loadIBC reexp fn)                 (\err -> ierror $ LoadingFailed fn err)   where@@ -1593,7 +1614,7 @@ {- | Load Idris source code-} loadSource :: Bool -> FilePath -> Maybe Int -> Idris () loadSource lidr f toline-             = do logLvl 1 ("Reading " ++ f)+             = do logParser 1 ("Reading " ++ f)                   i <- getIState                   let def_total = default_total i                   file_in <- runIO $ readSource f@@ -1637,7 +1658,7 @@                                    ]                       histogram = groupBy ((==) `on` fst) . sortBy (comparing fst) $ aliasNames                   case map head . filter ((/= 1) . length) $ histogram of-                    []       -> logLvl 3 $ "Module aliases: " ++ show (M.toList modAliases)+                    []       -> logParser 3 $ "Module aliases: " ++ show (M.toList modAliases)                     (n,fc):_ -> throwError . At fc . Msg $ "import alias not unique: " ++ show n                    i <- getIState@@ -1676,7 +1697,7 @@                   -- Parsing done, now process declarations                    let ds = namespaces mname ds'-                  logLvl 3 (show $ showDecls verbosePPOption ds)+                  logParser 3 (show $ showDecls verbosePPOption ds)                   i <- getIState                   logLvl 10 (show (toAlist (idris_implicits i)))                   logLvl 3 (show (idris_infixes i))
src/Idris/ProofSearch.hs view
@@ -478,8 +478,7 @@                                                      return (num + 1)                         _ -> return 0 -    solven 0 = return ()-    solven n = do solve; solven (n - 1)+    solven n = replicateM_ n solve      resolve n depth        | depth == 0 = fail $ "Can't resolve type class"
src/Idris/Prover.hs view
@@ -156,8 +156,8 @@      iputGoal rendered dumpState ist inElab menv ps | (h : hs) <- holes ps = do   let OK ty  = goalAtFocus ps-  let OK env = envAtFocus ps-  let state = prettyOtherGoals hs <> line <>+      OK env = envAtFocus ps+      state = prettyOtherGoals hs <> line <>               prettyAssumptions inElab ty env <> line <>               prettyMetaValues (reverse menv) <>               prettyGoal (zip (assumptionNames env) (repeat False)) ty@@ -215,21 +215,19 @@       bindingOf h False <+> colon <+> align (prettyG bnd ty)      prettyAssumptions inElab g env =-      if length env == 0 then-        empty+      if null env then empty       else         text "----------              Assumptions:              ----------" <>         nest nestingSize (prettyPs inElab g [] $ reverse env)      prettyOtherGoals hs =-      if length hs == 0 then-        empty+      if null hs then empty       else         text "----------              Other goals:              ----------" <$$>-        nest nestingSize (align . cat . punctuate (text ",") . map (flip bindingOf False) $ hs)+        nest nestingSize (align . cat . punctuate (text ",") . map (`bindingOf` False) $ hs)      freeEnvNames :: Env -> [Name]-    freeEnvNames = foldl (++) [] . map (\(n, b) -> freeNames (Bind n b Erased))+    freeEnvNames = concatMap (\(n, b) -> freeNames (Bind n b Erased))  lifte :: ElabState EState -> ElabD a -> Idris a lifte st e = do (v, _) <- elabStep st e@@ -247,7 +245,7 @@      (sexp, id) <- case IdeMode.parseMessage l of                      Left err -> ierror err                      Right (sexp, id) -> return (sexp, id)-     putIState $ i { idris_outputmode = (IdeMode id h) }+     putIState $ i { idris_outputmode = IdeMode id h }      case IdeMode.sexpToCommand sexp of        Just (IdeMode.REPLCompletions prefix) ->          do (unused, compls) <- proverCompletion (assumptionNames e) (reverse prefix, "")@@ -309,7 +307,7 @@               Success (Left cmd') ->                 case cmd' of                   EQED -> do hs <- lifte e get_holes-                             when (not (null hs)) $ ifail "Incomplete proof"+                             unless (null hs) $ ifail "Incomplete proof"                              iputStrLn "Proof completed!"                              return (False, prev, e, True, prf, env, Right $ iPrintResult "")                   EUndo -> do (prf', env', st', prev') <- undoElab prf env e prev@@ -333,8 +331,8 @@                                   return (d', prev, st', done, prf', env, go)               Success (Right cmd') ->                 case cmd' of-                  DoLetP _ _ _ -> ifail "Pattern-matching let not supported here"-                  DoBindP _ _ _ _ -> ifail "Pattern-matching <- not supported here"+                  DoLetP  {} -> ifail "Pattern-matching let not supported here"+                  DoBindP {} -> ifail "Pattern-matching <- not supported here"                   DoLet fc i ifc Placeholder expr ->                     do (tm, ty) <- elabVal recinfo ERHS (inLets ist env expr)                        ctxt <- getContext@@ -380,7 +378,7 @@                    else do ok                            elabloop fn d prompt prf' st prev' h' env' -  where +  where     -- A bit of a hack: wrap the value up in a let binding, which will     -- normalise away. It would be better to figure out how to call     -- the elaborator with a custom environment here to avoid the@@ -412,7 +410,7 @@                   return (i, h)          (cmd, step) <- case x of             Nothing -> do iPrintError ""; ifail "Abandoned"-            Just input -> do return (parseTactic i input, input)+            Just input -> return (parseTactic i input, input)          case cmd of             Success Abandon -> do iPrintError ""; ifail "Abandoned"             _ -> return ()@@ -426,7 +424,7 @@                                       iputStrLn $ "TT: " ++ show tm ++ "\n"                                       return (False, e, False, prf, Right $ iPrintResult "")               Success Qed -> do hs <- lifte e get_holes-                                when (not (null hs)) $ ifail "Incomplete proof"+                                unless (null hs) $ ifail "Incomplete proof"                                 iputStrLn "Proof completed!"                                 return (False, e, True, prf, Right $ iPrintResult "")               Success (TCheck (PRef _ _ n)) -> checkNameType e prf n
src/Idris/REPL.hs view
@@ -94,6 +94,10 @@ import Data.Either (partitionEithers) import Control.DeepSeq +import Control.Concurrent.Async (race)+import System.FSNotify (withManager, watchDir)+import System.FSNotify.Devel (allEvents, doAllEvents)+ import Numeric ( readHex )  import Debug.Trace@@ -126,10 +130,8 @@                 do ms <- H.catch (lift $ processInput input orig mods efile)                                  (ctrlC (return (Just mods)))                    case ms of-                        Just mods -> let efile' = case mods of-                                                       [] -> efile-                                                       (e:_) -> e in-                                         repl orig mods efile'+                        Just mods -> let efile' = fromMaybe efile (listToMaybe mods)+                                     in repl orig mods efile'                         Nothing -> return () --                             ctrlC) --       ctrlC@@ -154,15 +156,13 @@  -- | Run the REPL server startServer :: PortID -> IState -> [FilePath] -> Idris ()-startServer port orig fn_in = do tid <- runIO $ forkOS (serverLoop port)+startServer port orig fn_in = do tid <- runIO $ forkIO (serverLoop port)                                  return ()   where serverLoop port = withSocketsDo $                               do sock <- listenOnLocalhost port                                  loop fn orig { idris_colourRepl = False } sock -        fn = case fn_in of-                  (f:_) -> f-                  _ -> ""+        fn = fromMaybe "" (listToMaybe fn_in)          loop fn ist sock             = do (h,_,_) <- accept sock@@ -276,9 +276,7 @@              i <- getIState              putIState $ i { idris_outputmode = (IdeMode id h) }              idrisCatch -- to report correct id back!-               (do let fn = case mods of-                              (f:_) -> f-                              _     -> ""+               (do let fn = fromMaybe "" (listToMaybe mods)                    case IdeMode.sexpToCommand sexp of                      Just cmd -> runIdeModeCommand h id orig fn mods cmd                      Nothing  -> iPrintError "did not understand" )@@ -677,30 +675,54 @@             (_, ".lidr") -> True             _ -> False +reload :: IState -> [FilePath] -> Idris (Maybe [FilePath])+reload orig inputs = do+  i <- getIState+  -- The $!! here prevents a space leak on reloading.+  -- This isn't a solution - but it's a temporary stopgap.+  -- See issue #2386+  putIState $!! orig { idris_options = idris_options i+    , idris_colourTheme = idris_colourTheme i+    , imported = imported i+  }+  clearErr+  fmap Just $ loadInputs inputs Nothing++watch :: IState -> [FilePath] -> Idris (Maybe [FilePath])+watch orig inputs = do+  let inputSet = S.fromList inputs+  let dirs = nub $ map takeDirectory inputs+  resp <- runIO $ do+    signal <- newEmptyMVar+    withManager $ \mgr -> do+      forM_ dirs $ \dir ->+        watchDir mgr dir (allEvents $ flip S.member inputSet) (doAllEvents $ putMVar signal)+      race getLine (takeMVar signal)+  case resp of+    Left _ -> return (Just inputs) -- canceled, so nop+    Right _ -> reload orig inputs >> watch orig inputs+ processInput :: String ->                 IState -> [FilePath] -> FilePath -> Idris (Maybe [FilePath]) processInput cmd orig inputs efile     = do i <- getIState          let opts = idris_options i          let quiet = opt_quiet opts-         let fn = case inputs of-                        (f:_) -> f-                        _ -> ""+         let fn = fromMaybe "" (listToMaybe inputs)          c <- colourise          case parseCmd i "(input)" cmd of             Failure err ->   do iputStrLn $ show (fixColour c err)                                 return (Just inputs)             Success (Right Reload) ->-                -- The $!! here prevents a space leak on reloading.-                -- This isn't a solution - but it's a temporary stopgap.-                -- See issue #2386-                do putIState $!! orig { idris_options = idris_options i-                                      , idris_colourTheme = idris_colourTheme i-                                      , imported = imported i-                                      }-                   clearErr-                   mods <- loadInputs inputs Nothing-                   return (Just mods)+                reload orig inputs+            Success (Right Watch) ->+                if null inputs then+                  do iputStrLn "No loaded files to watch."+                     return (Just inputs)+                else+                  do iputStrLn efile+                     iputStrLn $ "Watching for .idr changes in " ++ show inputs ++ ", press enter to cancel."+                     watch orig inputs             Success (Right (Load f toline)) ->                 -- The $!! here prevents a space leak on reloading.                 -- This isn't a solution - but it's a temporary stopgap.@@ -801,11 +823,11 @@                                 Nothing -> iPrintError $ "Can't find import " ++ f process fn (Eval t)                  = withErrorReflection $-                   do logLvl 5 $ show t+                   do logParser 5 $ show t                       getIState >>= flip warnDisamb t                       (tm, ty) <- elabREPL recinfo ERHS t                       ctxt <- getContext-                      let tm' = perhapsForce $ normaliseBlocking ctxt [] +                      let tm' = perhapsForce $ normaliseBlocking ctxt []                                                   [sUN "foreign",                                                    sUN "prim_read",                                                    sUN "prim_write"]@@ -814,8 +836,8 @@                       -- Add value to context, call it "it"                       updateContext (addCtxtDef (sUN "it") (Function ty' tm'))                       ist <- getIState-                      logLvl 3 $ "Raw: " ++ show (tm', ty')-                      logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'+                      logParser 3 $ "Raw: " ++ show (tm', ty')+                      logParser 10 $ "Debug: " ++ showEnvDbg [] tm'                       let tmDoc = pprintDelab ist tm'                           -- errReverse to make type more readable                           tyDoc =  pprintDelab ist (errReverse ist ty')@@ -824,7 +846,7 @@                         | otherwise = tm  process fn (NewDefn decls) = do-        logLvl 3 ("Defining names using these decls: " ++ show (showDecls verbosePPOption decls))+        logParser 3 ("Defining names using these decls: " ++ show (showDecls verbosePPOption decls))         mapM_ defineName namedGroups where   namedGroups = groupBy (\d1 d2 -> getName d1 == getName d2) decls   getName :: PDecl -> Maybe Name@@ -951,10 +973,10 @@                = let current = case n of                                    MN _ _ -> text ""                                    UN nm | ('_':'_':_) <- str nm -> text ""-                                   _ -> text "  " <> +                                   _ -> text "  " <>                                         bindingOf n False-                                            <+> colon -                                            <+> align (tPretty bnd ist t) +                                            <+> colon+                                            <+> align (tPretty bnd ist t)                                             <> line                  in                     current <> putTy ppo ist (i-1) ((n,False):bnd) sc@@ -986,8 +1008,8 @@         iPrintTermWithType (pprintTT [] tm) (pprintTT [] ty)  process fn (DocStr (Left n) w)-  | UN ty <- n, ty == T.pack "Type" = getIState >>= iRenderResult . pprintTypeDoc  -  | otherwise = do    +  | UN ty <- n, ty == T.pack "Type" = getIState >>= iRenderResult . pprintTypeDoc+  | otherwise = do         ist <- getIState         let docs = lookupCtxtName n (idris_docstrings ist) ++                    map (\(n,d)-> (n, (d, [])))@@ -1010,7 +1032,7 @@ process fn Universes                      = do i <- getIState                           let cs = idris_constraints i-                          let cslist = S.toAscList cs +                          let cslist = S.toAscList cs --                        iputStrLn $ showSep "\n" (map show cs)                           iputStrLn $ show (map uconstraint cslist)                           let n = length cslist@@ -1226,6 +1248,7 @@                        runIO $ generate codegen (fst (head (idris_imported i))) ir   where fc = fileFC "main" process fn (LogLvl i) = setLogLevel i+process fn (LogCategory cs) = setLogCats cs -- Elaborate as if LHS of a pattern (debug command) process fn (Pattelab t)      = do (tm, ty) <- elabVal recinfo ELHS t@@ -1252,7 +1275,7 @@                                   Nothing -> iPrintError $ "Could not load dynamic lib \"" ++ l ++ "\""                                   Just x -> do let libs = idris_dynamic_libs i                                                if x `elem` libs-                                                  then do logLvl 1 ("Tried to load duplicate library " ++ lib_name x)+                                                  then do logParser 1 ("Tried to load duplicate library " ++ lib_name x)                                                           return ()                                                   else putIState $ i { idris_dynamic_libs = x:libs }     where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace@@ -1523,18 +1546,18 @@             importlists <- getImports [] inputs -           logLvl 1 (show (map (\(i,m) -> (i, map import_path m)) importlists))+           logParser 1 (show (map (\(i,m) -> (i, map import_path m)) importlists))             let ninputs = zip [1..] inputs            ifiles <- mapWhileOK (\(num, input) ->                 do putIState ist-                   modTree <- buildTree +                   modTree <- buildTree                                    (map snd (take (num-1) ninputs))                                    importlists                                    input                    let ifiles = getModuleFiles modTree-                   logLvl 1 ("MODULE TREE : " ++ show modTree)-                   logLvl 1 ("RELOAD: " ++ show ifiles)+                   logParser 1 ("MODULE TREE : " ++ show modTree)+                   logParser 1 ("RELOAD: " ++ show ifiles)                    when (not (all ibc ifiles) || loadCode) $                         tryLoad False (filter (not . ibc) ifiles)                    -- return the files that need rechecking@@ -1777,12 +1800,13 @@        ok <- noErrors        when (not ok) $ runIO (exitWith (ExitFailure 1))   where-    makeOption (OLogging i) = setLogLevel i-    makeOption TypeCase = setTypeCase True-    makeOption TypeInType = setTypeInType True-    makeOption NoCoverage = setCoverage False-    makeOption ErrContext = setErrContext True-    makeOption _ = return ()+    makeOption (OLogging i)  = setLogLevel i+    makeOption (OLogCats cs) = setLogCats cs+    makeOption TypeCase      = setTypeCase True+    makeOption TypeInType    = setTypeInType True+    makeOption NoCoverage    = setCoverage False+    makeOption ErrContext    = setErrContext True+    makeOption _             = return ()      addPkgDir :: String -> Idris ()     addPkgDir p = do ddir <- runIO $ getIdrisLibDir
src/Idris/REPLParser.hs view
@@ -43,11 +43,11 @@               ("desugarnats", DesugarNats)]  help :: [([String], CmdArg, String)]-help = (["<expr>"], NoArg, "Evaluate an expression") : +help = (["<expr>"], NoArg, "Evaluate an expression") :   [ (map (':' :) names, args, text) | (names, args, text, _) <- parserCommandsForHelp ]  allHelp :: [([String], CmdArg, String)]-allHelp = [ (map (':' :) names, args, text) +allHelp = [ (map (':' :) names, args, text)           | (names, args, text, _) <- parserCommandsForHelp ++ parserCommands ]  parserCommandsForHelp :: CommandTable@@ -67,6 +67,7 @@   , 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"@@ -98,7 +99,7 @@   , (["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 ["w", "warranty"] Warranty "Displays warranty information"+  , noArgCmd ["warranty"] Warranty "Displays warranty information"   , (["let"], ManyArgs DeclArg     , "Evaluate a declaration, such as a function definition, instance implementation, or fixity declaration"     , cmd_let)@@ -124,7 +125,7 @@   , exprArgCmd ["spec"] Spec "?"   , exprArgCmd ["whnf"] WHNF "(Debugging) Show weak head normal form of an expression"   , exprArgCmd ["inline"] TestInline "?"-  , proofArgCmd ["cs", "casesplit"] CaseSplitAt +  , 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"@@ -138,6 +139,10 @@       ":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@@ -148,8 +153,8 @@     , cmd_refine)   , (["debugunify"], SeqArgs ExprArg ExprArg     , "(Debugging) Try to unify two expressions", const $ do-       l <- P.simpleExpr defaultSyntax -       r <- P.simpleExpr defaultSyntax +       l <- P.simpleExpr defaultSyntax+       r <- P.simpleExpr defaultSyntax        eof        return (Right (DebugUnify l r))     )@@ -171,9 +176,9 @@   (names, NoArg, doc, proofArg command)  pCmd :: P.IdrisParser (Either String Command)-pCmd = choice [ do c <- cmd names; parser c +pCmd = choice [ do c <- cmd names; parser c               | (names, _, _, parser) <- parserCommandsForHelp ++ parserCommands ]-     <|> unrecognized +     <|> unrecognized      <|> nop      <|> eval     where nop = do eof; return (Right NOP)@@ -227,7 +232,7 @@   -genArg :: String -> P.IdrisParser a -> (a -> Command) +genArg :: String -> P.IdrisParser a -> (a -> Command)            -> String -> P.IdrisParser (Either String Command) genArg argName argParser cmd name = do     let emptyArgs = do eof; failure@@ -246,12 +251,12 @@ strArg = genArg "string" (many anyChar)  moduleArg :: (FilePath -> Command) -> String -> P.IdrisParser (Either String Command)-moduleArg = genArg "module" (fmap (toPath . fst) P.identifier) +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) +namespaceArg = genArg "namespace" (fmap (toNS . fst) P.identifier)   where     toNS  = splitOn "." @@ -290,7 +295,7 @@         c <- fmap fst P.constant         eof         return $ Right (DocStr (Right c) FullDocs)-    +     let pType = do         P.reserved "Type"         eof@@ -391,6 +396,25 @@     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
src/Util/System.hs view
@@ -24,6 +24,8 @@  #ifdef FREESTANDING import Tools_idris+import System.FilePath (isAbsolute, dropFileName)+import System.Directory (doesDirectoryExist) import System.Environment (getEnv, setEnv, getExecutablePath) #endif
stack.yaml view
@@ -2,12 +2,12 @@ packages: - '.' flags:-  # idris:-  #   FFI: true-  #   GMP: True-  #   curses: True+   idris:+     FFI: true+     GMP: True+     curses: True extra-deps:  - annotated-wl-pprint-0.7.0 - cheapskate-0.1.0.4-# - hscurses-1.4.2.0-# - libffi-0.1+- hscurses-1.4.2.0+- libffi-0.1
test/Makefile view
@@ -1,4 +1,4 @@-.PHONY: test test_java test_js update diff distclean $(TESTS)+.PHONY: test test_java test_js time update diff distclean $(TESTS)  TESTS = $(sort $(patsubst %/,%.test,$(wildcard */))) @@ -15,6 +15,9 @@  diff: 	/usr/bin/env perl ./runtest.pl all -d++time:+	/usr/bin/env perl ./runtest.pl all -t  distclean: 	rm -f *~
test/basic015/basic015.idr view
@@ -44,11 +44,11 @@  ------- A main program to read dimensions, generate and tranpose a vector -instance Functor (Vect m) where+implementation Functor (Vect m) where     map m [] = []     map m (x :: xs) = m x :: map m xs -instance Show a => Show (Vect m a) where+implementation Show a => Show (Vect m a) where     show x = show (toList x)       where         toList : Vect m a -> List a
test/classes001/ClassName.idr view
@@ -2,7 +2,7 @@  ||| A fancy shower with a constructor ||| @ a the thing to be shown-class MyShow a where+interface MyShow a where   ||| Build a MyShow   constructor MkMyShow   ||| The shower@@ -12,7 +12,7 @@ twiceAString : MyShow a => a -> String twiceAString x = myShow x ++ myShow x -instance MyShow Integer where+implementation MyShow Integer where   myShow x = show x  badShow : MyShow Integer@@ -25,17 +25,17 @@ test2 = Refl  -||| Superclass fun-class MyMagma a where+||| Parent interface fun+interface MyMagma a where   constructor MkMyMagma   total op : a -> a -> a  ||| Semigroup-class MyMagma a => MySemigroup a where+interface MyMagma a => MySemigroup a where   constructor MkMySemigroup   total isAssoc : (x, y, z : a) -> op x $ op y z = op (op x y) z -instance [addition] MyMagma Nat where+implementation [addition] MyMagma Nat where   op = plus  additionS : MySemigroup Nat
test/classes001/expected view
@@ -1,4 +1,4 @@-Type class MyShow+Interface MyShow     A fancy shower with a constructor  Parameters:@@ -9,7 +9,7 @@         The shower                  The function is Total-Instance constructor:+Implementation constructor:     MkMyShow : (myShow : a -> String) -> MyShow a         Build a MyShow         Arguments:@@ -17,7 +17,7 @@                          myShow : a -> String  -- The shower             -Instances:+Implementations:     MyShow Integer MkMyShow : (myShow : a -> String) -> MyShow a     Build a MyShow
test/corecords001/corecords001.idr view
@@ -5,7 +5,7 @@   head : a   tail : Str a -instance Functor Str where+implementation Functor Str where   map f (x :: xs) = (f x) :: (map f xs)  total -- marked total to check that corecords are indeed treated as coinductive types
test/docs001/docs001.idr view
@@ -1,7 +1,7 @@-||| class+||| interface ||| @ t a type-class C (t : Type) where-  ||| member of class+interface C (t : Type) where+  ||| member of interface   m : t  ||| type@@ -10,11 +10,11 @@ ||| type 2 data D a b = E -||| instance of class-instance C A where+||| implementation of interface+implementation C A where   m = B -||| another instance of class+||| another implementation of interface ||| @ a parameter type-instance C (D a b) where+implementation C (D a b) where   m = E
test/docs001/expected view
@@ -1,17 +1,17 @@-Type class C-    class+Interface C+    interface  Parameters:     t   -- a type  Methods:     m : C t => t-        member of class+        member of interface                  The function is Total-Instances:+Implementations:     C A-        instance of class+        implementation of interface     C (D a b)-        another instance of class+        another implementation of interface         a   -- parameter type
test/docs003/docs003.idr view
@@ -1,9 +1,9 @@ module docs003 -instance [mine] Functor List where+implementation [mine] Functor List where   map m [] = []   map m (x :: xs) = m x :: map m xs  ||| More functors!-instance [another] Functor List where+implementation [another] Functor List where   map f xs = map @{mine} f xs
test/docs003/expected view
@@ -1,4 +1,4 @@-Type class Functor+Interface Functor     Functors allow a uniform action over a parameterised type.  Parameters:@@ -10,7 +10,7 @@         parameterised type                  The function is Total-Instances:+Implementations:     Functor List     Functor (IO' ffi)     Functor Stream@@ -21,12 +21,12 @@     Functor Maybe     Functor (Either e) -Named instances:+Named implementations:     docs003.mine : Functor List     docs003.another : Functor List         More functors! -Subclasses:+Child interfaces:     Traversable f     Applicative f Named instance:
test/effects003/VectMissing.idr view
@@ -3,7 +3,7 @@ import Data.Fin import Data.Vect -instance Uninhabited (Elem x []) where+implementation Uninhabited (Elem x []) where     uninhabited Here impossible  shrink : (xs : Vect (S n) a) -> Elem x xs -> Vect n a
test/effects003/hangman.idr view
@@ -27,10 +27,10 @@                 (missing : Vect m Char) ->                 Hangman (Running guesses m) -instance Default (Hangman NotRunning) where+implementation Default (Hangman NotRunning) where     default = Init -instance Show (Hangman s) where+implementation Show (Hangman s) where     show Init = "Not ready yet"     show (GameWon w) = "You won! Successfully guessed " ++ w     show (GameLost w) = "You lost! The word was " ++ w@@ -139,7 +139,7 @@ is in the word, update the vector of missing letters to be the right length). -} -instance Handler HangmanRules m where+implementation Handler HangmanRules m where     handle (MkH w g got []) Won k = k () (GameWon w)     handle (MkH w Z got m) Lost k = k () (GameLost w)
test/error003/ErrorReflection.idr view
@@ -11,7 +11,7 @@  data Ty = TUnit | TFun Ty Ty -instance Show Ty where+implementation Show Ty where   show TUnit = "()"   show (TFun t1 t2) = "(" ++ show t1 ++ " => " ++ show t2 ++ ")" @@ -33,7 +33,7 @@            | TFun Ty' Ty'            | TVar Int String -- To show in unification failures -  instance Show Ty' where+  implementation Show Ty' where     show TUnit = "()"     show (TFun x y) = "(" ++ show x ++ " => " ++ show y ++ ")"     show (TVar i n) = n ++ "(" ++ cast i ++ ")"
test/idrisdoc004/TestTypeclasses.idr view
@@ -3,6 +3,6 @@ ||| This is a test ||| ||| @ a Test arg-class Test a where+interface Test a where   ||| Test function   test : a -> Int
test/interactive010/expected view
@@ -1,14 +1,12 @@ Prelude.List.(++) : List a -> List a -> List a Prelude.Strings.(++) : String -> String -> String-Prelude.Classes./ : (__pi_arg : Double) →-                    (__pi_arg1 : Double) → Double+a is not an implicit argument of Prelude.Classes./ Usage is :doc <functionname> Usage is :wc <functionname> Usage is :printdef <functionname>-prim__divFloat-Prelude.Classes./+pat {ty504} : Type u. pat {__class505} : Prelude.Classes.Fractional {ty504}. Prelude.Classes./ {ty504} {__class505} - : Double -> Double -> Double+ : pty {ty504} : Type u. pty {__class505} : Prelude.Classes.Fractional {ty504}. {ty504} -> {ty504} -> {ty504} (input):1:1: error: expected: ":",     dependent type signature,     end of input@@ -19,4 +17,4 @@     end of input ++<EOF>  ^       -prim__divFloat+Can't find implementation for Fractional ty
test/interactive010/input view
@@ -1,9 +1,8 @@ :type ++-:core /+:core (/) {a=Double} :doc + :wc + :printdef --:spec / :patt / / ++
test/interactive011/interactive011.idr view
@@ -2,7 +2,7 @@  data Foo = Bar | Baz -instance Show Foo where+implementation Show Foo where  append : Vect n a -> Vect m a -> Vect (n + m) a append (x :: xs) ys = ?append_rhs_2
test/meta002/AgdaStyleReflection.idr view
@@ -17,7 +17,7 @@   plicity : Plicity   argValue : a -instance Functor Arg where+implementation Functor Arg where   map f (MkArg plic x) = MkArg plic (f x)  ||| Reflected terms, in the tradition of Agda's reflection library
test/meta002/Deriving.idr view
@@ -14,7 +14,7 @@ decVectEq : DecEq a => (xs, ys : Vect n a) -> Dec (xs = ys) %runElab (deriveDecEq `{decVectEq}) -instance DecEq a => DecEq (Vect n a) where+implementation DecEq a => DecEq (Vect n a) where   decEq xs ys = decVectEq xs ys  forgetProof : Dec a -> Bool
test/meta002/Tacs.idr view
@@ -102,7 +102,7 @@    %name Ty t,t',t'' -  instance Quotable Ty TT where+  implementation Quotable Ty TT where     quotedTy = `(Ty : Type)     quote UNIT = `(UNIT : Ty)     quote (ARR t t') = `(ARR ~(quote t) ~(quote t'))
test/proof003/test015.idr view
@@ -7,7 +7,7 @@      B0 : Bit Z      B1 : Bit (S Z) -instance Show (Bit n) where+implementation Show (Bit n) where      show = show' where         show' : Bit x -> String         show' B0 = "0"@@ -19,7 +19,7 @@      Zero : Binary Z Z      (#)  : Binary w v -> Bit bit -> Binary (S w) (bit + 2 * v) -instance Show (Binary w k) where+implementation Show (Binary w k) where      show Zero = ""      show (bin # bit) = show bin ++ show bit
test/proofsearch001/proofsearch001.idr view
@@ -1,7 +1,7 @@ %default total -class C a (f : Bool -> Bool) | a where {}-instance C Int Bool.not where {}+interface C a (f : Bool -> Bool) | a where {}+implementation C Int Bool.not where {}  foo : C Int g => {auto pf : g True = False} -> Unit foo = ()
test/proofsearch003/proofsearch003.idr view
@@ -6,10 +6,10 @@   Seq12 : {n : Fin 8} -> Seq (weaken n) (FS n)   Seq21 : {n : Fin 8} -> Seq (FS n) (weaken n) -class Evil t where+interface Evil t where   value : t -> Fin 9 -instance Evil Wrapper where+implementation Evil Wrapper where   value (Wrap n) = n  consTest : (Evil t) => (a : t) -> (b : t) ->
test/records002/record002.idr view
@@ -2,7 +2,7 @@   constructor MkFoo   num : Int -instance Show (Foo n) where+implementation Show (Foo n) where   show f = show (param_param f) ++ ", " ++ show (num f)  main : IO ()
test/reg001/reg001.idr view
@@ -7,7 +7,7 @@ import Data.Fin import Control.Isomorphism -class Functor f => VerifiedFunctor (f : Type -> Type) where+interface Functor f => VerifiedFunctor (f : Type -> Type) where    identity : (fa : f a) -> map Basics.id fa = fa  data Imp : Type where@@ -66,7 +66,7 @@ soTrue {b = False} x    =  soFalseElim x soTrue {b = True}  x    =  Refl -class Eq alpha => ReflEqEq alpha where+interface Eq alpha => ReflEqEq alpha where   reflexive_eqeq : (a : alpha) -> So (a == a)  modifyFun : (Eq alpha) =>@@ -126,7 +126,7 @@  data Result str a = Success str a | Failure String -instance Functor (Result str) where+implementation Functor (Result str) where    map f (Success s x) = Success s (f x)    map f (Failure e  ) = Failure e @@ -154,13 +154,13 @@ admissible {t} x Right = column {t} x >= 2  -class Set univ where+interface Set univ where   member : univ -> univ -> Type  isSubsetOf : Set univ => univ -> univ -> Type isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b) -class Set univ => HasPower univ where+interface Set univ => HasPower univ where   Powerset : (a : univ) ->               Sigma univ (\Pa => (c : univ) ->                                  (isSubsetOf c a) -> member c Pa)
test/reg018/reg018b.idr view
@@ -8,7 +8,7 @@ showB (I x) = "I" ++ showB x showB (Z x) = "Z" ++ showB x -instance Show B where show = showB+implementation Show B where show = showB  os : B os = Z os
test/reg027/expected view
@@ -1,4 +1,4 @@ <<int fn>> 6-reg027a.idr:9:10:-Overlapping instance: Show (Int -> a) already defined+reg027a.idr:9:16:+Overlapping implementation: Show (Int -> a) already defined
test/reg027/reg027.idr view
@@ -1,22 +1,22 @@ module Main -instance Show (Int -> b) where+implementation Show (Int -> b) where     show x = "<<int fn>>" -instance Show (Char -> b) where+implementation Show (Char -> b) where     show x = "<<char fn>>"  IntFn : Type -> Type IntFn = \x => Int -> x -instance Functor IntFn where -- (\x => Int -> x) where+implementation Functor IntFn where -- (\x => Int -> x) where   map f intf = \x => f (intf x) -instance Applicative (\x => Int -> x) where+implementation Applicative (\x => Int -> x) where   pure v = \x => v   (<*>) f a = \x => f x (a x) -instance Monad IntFn where +implementation Monad IntFn where    f >>= k = \x => k (f x) x  dbl : IntFn Int
test/reg027/reg027a.idr view
@@ -3,8 +3,8 @@ IntFn : Type -> Type IntFn = \x => Int -> x   -instance Show (IntFn a) where+implementation Show (IntFn a) where     show x = "<<char fn>>"   -instance Show (Int -> b) where+implementation Show (Int -> b) where     show x = "<<int fn>>"
test/reg035/reg035a.lidr view
@@ -30,7 +30,7 @@ > data Set : Type -> Type where >   Setify : (as : List a) -> Set a -> instance (Eq a) => Eq (Set a) where+> implementation (Eq a) => Eq (Set a) where >   (==) (Setify as) (Setify bs) = setEq as bs  > postulate reflexive_Set_eqeq : (Eq a) =>
test/reg036/reg036.idr view
@@ -8,5 +8,5 @@   showHV : Shows m ts => HV ts -> String   showHV (MkHV v) = show v -  instance Shows m ts => Show (HV ts) where+  implementation Shows m ts => Show (HV ts) where     show = showHV
test/reg037/reg037.idr view
@@ -1,9 +1,9 @@  --- Parser regression for (=) as a function name (fnName) -class Foo (t : a -> b -> Type) where+interface Foo (t : a -> b -> Type) where   foo : (x : _) -> (y : _) -> t x y -> t x y -instance Foo ((=) {A=a} {B=b}) where+implementation Foo ((=) {A=a} {B=b}) where   foo x y prf = prf
test/reg038/reg038.idr view
@@ -1,17 +1,17 @@-class C t (f : t -> t) (r : t -> t -> Type) where+interface C t (f : t -> t) (r : t -> t -> Type) where     g : (a : t) -> r (f a) (f a) -> r (f a) (f a)  data Foo : {t : Type} -> t -> t -> Type where   MkFoo : {t : Type} -> {x : t} -> {y : t} -> Foo x y -instance C t f (Foo {t = t}) where+implementation C t f (Foo {t = t}) where   g x = id  data Bar : {t1 : Type} -> {t2 : Type} -> t1 -> t2 -> Type where   MkBar : {x : t1} -> Bar x x -instance C s f (Bar {t1 = s} {t2 = s}) where+implementation C s f (Bar {t1 = s} {t2 = s}) where     g x = id -instance C s f ((=) {A = s} {B = s}) where+implementation C s f ((=) {A = s} {B = s}) where     g x = id
test/reg045/reg045.idr view
@@ -4,7 +4,7 @@   (::) : a -> Lazy (ListZ a) -> ListZ a   Nil  : ListZ a -instance Show a => Show (ListZ a) where+implementation Show a => Show (ListZ a) where   show xs = "[" ++ show' "" xs ++ "]"       where         show' acc Nil        = acc
test/reg058/implicits.idr view
@@ -3,10 +3,10 @@ InterpBool : () -> Type InterpBool () = {x : Type} -> x -> Nat -class IdrisBug (u : ()) where+interface IdrisBug (u : ()) where   idrisBug : InterpBool u -instance IdrisBug () where+implementation IdrisBug () where   idrisBug _ = Z  f : Nat
test/reg059/reg059.idr view
@@ -1,8 +1,8 @@-class Monad m => ContainerMonad (m : Type -> Type) where+interface Monad m => ContainerMonad (m : Type -> Type) where     Elem : a -> m a -> Type     tagElem : (mx : m a) -> m (x : a ** Elem x mx) -class Monad m => ContainerMonad2 a (m : Type -> Type) where+interface Monad m => ContainerMonad2 a (m : Type -> Type) where     Elem2 : a -> m a -> Type     tagElem2 : (mx : m a) -> m (x : a ** Elem2 x mx)
test/reg060/reg060.idr view
@@ -1,12 +1,12 @@ -class MyFunctor (f : Type -> Type) where+interface MyFunctor (f : Type -> Type) where   mymap : (m : a -> b) -> f a -> f b  data Foo x y = Bar y -instance MyFunctor (Foo m) where+implementation MyFunctor (Foo m) where   mymap m x = ?wibble -instance [foo] Functor m => MyFunctor m where+implementation [foo] Functor m => MyFunctor m where   mymap m x = map m x
test/reg065/reg065.idr view
@@ -1,21 +1,21 @@-||| Test that dependent type class definitions work.+||| Test that dependent type interface definitions work. ||| ||| Fixes a regression where previous methods used in a later method's-||| type would lead to "can't resolve type class" errors+||| type would lead to "can't find interface" errors module TypeClassDep  import Data.Vect  -class Foo a where+interface Foo a where   getLen : Nat   item : a -> Vect getLen a -instance Foo () where+implementation Foo () where   getLen  = 3   item () = [(), (), ()] -instance Foo String where+implementation Foo String where   getLen = 1   item str = [str]
test/runtest.pl view
@@ -49,16 +49,24 @@ # output and report results. # sub runtest {-    my ($test, $update) = @_;+    my ($test, $update, $showTime) = @_;      my $sandbox = sandbox_path($test);      chdir($test); +    my $startTime = time();     print "Running $test...\n";     my $got = `$sandbox ./run @idrOpts`;     my $exp = `cat expected`; +    my $endTime = time();+    my $elapsedTime = $endTime - $startTime;++    if ($showTime == 1 ){+      printf("Duration of $test was %d\n", $elapsedTime);+    }+     # Allow for variant expected output for tests by overriding expected     # when there is an expected.<os> file in the test.     # This should be the exception but there are sometimes valid reasons@@ -155,15 +163,17 @@  # Run the tests. -my $update  = 0;-my $diff    = 0;-my $show    = 0;-my $usejava = 0;+my $update   = 0;+my $diff     = 0;+my $show     = 0;+my $usejava  = 0;+my $showTime = 0;  while (my $opt = shift @opts) {     if    ($opt eq "-u") { $update = 1; }     elsif ($opt eq "-d") { $diff = 1; }     elsif ($opt eq "-s") { $show = 1; }+    elsif ($opt eq "-t") { $showTime = 1; }     else { push(@idrOpts, $opt); } } @@ -171,9 +181,11 @@ my $path   = $ENV{PATH}; $ENV{PATH} = cwd() . "/" . $idris . ":" . $path; +my $startTime = time();+ foreach my $test (@tests) {     if ($diff == 0 && $show == 0) {-	    runtest($test,$update);+	    runtest($test,$update,$showTime);     }     else {         chdir $test;@@ -190,6 +202,13 @@         }         chdir "..";     }+}++my $endTime = time();+my $elapsedTime = $endTime - $startTime;++if ($showTime == 1) {+  printf("Duration of Entire Test Suite was %d\n", $elapsedTime); }  exit $exitstatus;
test/sugar001/test007.idr view
@@ -13,10 +13,10 @@     fetchVal [] = Nothing     fetchVal ((v, val) :: xs) = if (x == v) then (Just val) else (fetchVal xs) -instance Functor Eval where+implementation Functor Eval where     map f (MkEval g) = MkEval (\e => map f (g e)) -instance Applicative Eval where+implementation Applicative Eval where     pure x = MkEval (\e => Just x)      (<*>) (MkEval f) (MkEval g) = MkEval (\x => appAux (f x) (g x)) where
test/syntax002/syntax002.idr view
@@ -7,7 +7,7 @@      = data tname = conname tysyn  decl syntax EmptyShow {n} =-     instance Show n where+     implementation Show n where         show x = "Nothing"   fun add : (Int -> Int -> Int) = \x, y => x + y
test/tutorial002/tutorial002.idr view
@@ -5,7 +5,7 @@     BO : Binary n -> Binary (n + n)     BI : Binary n -> Binary (S (n + n)) -instance Show (Binary n) where+implementation Show (Binary n) where     show (BO x) = show x ++ "0"     show (BI x) = show x ++ "1"     show BEnd = ""
test/tutorial003/tutorial003.idr view
@@ -13,10 +13,10 @@     fetchVal [] = Nothing     fetchVal ((v, val) :: xs) = if (x == v) then (Just val) else (fetchVal xs) -instance Functor Eval where+implementation Functor Eval where     map f (MkEval g) = MkEval (\e => map f (g e)) -instance Applicative Eval where+implementation Applicative Eval where     pure x = MkEval (\e => Just x)      (<*>) (MkEval f) (MkEval g) = MkEval (\x => app (f x) (g x)) where
test/unique001/unique001c.idr view
@@ -25,14 +25,14 @@ share ULeaf = Leaf share (UNode x y z) = Node (share x) y (share z) -class UFunctor (f : Type -> AnyType) where+interface UFunctor (f : Type -> AnyType) where     fmap : (a -> b) -> f a -> f b -instance UFunctor List where+implementation UFunctor List where     fmap f [] = []     fmap f (x :: xs) = f x :: fmap f xs -instance UFunctor UList where+implementation UFunctor UList where     fmap f UNil = UNil     fmap f (UCons x xs) = UCons (f x) (fmap f xs)