packages feed

idris 0.9.4.1 → 0.9.5

raw patch · 88 files changed

+5343/−4110 lines, 88 filesdep ~haskeline

Dependency ranges changed: haskeline

Files

idris.cabal view
@@ -1,5 +1,5 @@ Name:           idris-Version:        0.9.4.1+Version:        0.9.5 License:        BSD3 License-file:   LICENSE Author:         Edwin Brady@@ -27,6 +27,10 @@                 * do notation, idiom brackets, syntactic conveniences for lists,                    tuples, dependent pairs                 .+                * Totality checking+                .+                * Coinductive types+                .                 * Indentation significant syntax, extensible syntax                 .                 * Tactic based theorem proving (influenced by Coq)@@ -43,10 +47,9 @@ Data-files:            rts/libidris_rts.a rts/idris_rts.h rts/idris_gc.h                        rts/idris_stdfgn.h rts/idris_main.c rts/idris_gmp.h                        rts/libtest.c-Extra-source-files:    lib/Makefile  lib/*.idr lib/prelude/*.idr lib/network/*.idr-                       lib/control/monad/*.idr lib/language/*.idr-                       lib/base.ipkg-                       tutorial/examples/*.idr+Extra-source-files:    lib/Makefile  lib/*.idr lib/Prelude/*.idr lib/Network/*.idr+                       lib/Control/Monad/*.idr lib/Language/*.idr+                       tutorial/examples/*.idr lib/base.ipkg                        rts/*.c rts/*.h rts/Makefile  source-repository head@@ -69,6 +72,7 @@                               Idris.Compiler, Idris.Prover, Idris.ElabTerm,                               Idris.Coverage, Idris.IBC, Idris.Unlit,                               Idris.DataOpts, Idris.Transforms, Idris.DSL, +                              Idris.UnusedArgs,                                Util.Pretty, Util.System,                               Pkg.Package, Pkg.PParser,@@ -79,9 +83,10 @@                                Paths_idris -               Build-depends:   base>=4 && <5, parsec, mtl, Cabal, haskeline<0.7,-                                containers, process, transformers, filepath, directory,-                                binary, bytestring, pretty+               Build-depends:   base>=4 && <5, parsec, mtl, Cabal, +                                haskeline>=0.7,+                                containers, process, transformers, filepath, +                                directory, binary, bytestring, pretty                                                 Extensions:      MultiParamTypeClasses, FunctionalDependencies,                                 FlexibleInstances, TemplateHaskell
+ lib/Builtins.idr view
@@ -0,0 +1,270 @@+%access public+%default total++data Exists : (a : Set) -> (P : a -> Set) -> Set where+    Ex_intro : {P : a -> Set} -> (x : a) -> P x -> Exists a P++getWitness : {P : a -> Set} -> Exists a P -> a+getWitness (a ** v) = a++getProof : {P : a -> Set} -> (s : Exists a P) -> P (getWitness s)+getProof (a ** v) = v++FalseElim : _|_ -> a++-- For rewrite tactic+replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Set} -> x = y -> P x -> P y+replace refl prf = prf++sym : {l:a} -> {r:a} -> l = r -> r = l+sym refl = refl++lazy : a -> a+lazy x = x -- compiled specially++malloc : Int -> a -> a+malloc size x = x -- compiled specially++trace_malloc : a -> a+trace_malloc x = x -- compiled specially++believe_me : a -> b -- compiled specially as id, use with care!+believe_me x = prim__believe_me _ _ x++namespace Builtins {++id : a -> a+id x = x++const : a -> b -> a+const x _ = x++fst : (s, t) -> s+fst (x, y) = x++snd : (a, b) -> b+snd (x, y) = y++infixl 9 .++(.) : (b -> c) -> (a -> b) -> a -> c+(.) f g x = f (g x)++flip : (a -> b -> c) -> b -> a -> c+flip f x y = f y x++infixr 1 $++($) : (a -> b) -> a -> b+f $ a = f a++cong : {f : t -> u} -> (a = b) -> f a = f b+cong refl = refl++data Bool = False | True++boolElim : Bool -> |(t : a) -> |(f : a) -> a +boolElim True  t e = t+boolElim False t e = e++data so : Bool -> Set where oh : so True++syntax if [test] then [t] else [e] = boolElim test t e+syntax [test] "?" [t] ":" [e] = if test then t else e++infixl 4 &&, ||++(||) : Bool -> Bool -> Bool+(||) False x = x+(||) True _  = True++(&&) : Bool -> Bool -> Bool+(&&) True x  = x+(&&) False _ = False++not : Bool -> Bool+not True = False+not False = True++infixl 5 ==, /=+infixl 6 <, <=, >, >=+infixl 7 <<, >>+infixl 8 +,-,+++infixl 9 *,/++--- Numeric operators++intToBool : Int -> Bool+intToBool 0 = False+intToBool x = True++boolOp : (a -> a -> Int) -> a -> a -> Bool+boolOp op x y = intToBool (op x y) ++class Eq a where+    (==) : a -> a -> Bool+    (/=) : a -> a -> Bool++    x /= y = not (x == y)+    x == y = not (x /= y)++instance Eq Int where +    (==) = boolOp prim__eqInt++instance Eq Integer where+    (==) = boolOp prim__eqBigInt++instance Eq Float where+    (==) = boolOp prim__eqFloat++instance Eq Char where+    (==) = boolOp prim__eqChar++instance Eq String where+    (==) = boolOp prim__eqString++instance (Eq a, Eq b) => Eq (a, b) where+  (==) (a, c) (b, d) = (a == b) && (c == d)+++data Ordering = LT | EQ | GT++instance Eq Ordering where+    LT == LT = True+    EQ == EQ = True+    GT == GT = True+    _  == _  = False++class Eq a => Ord a where +    compare : a -> a -> Ordering++    (<) : a -> a -> Bool+    (<) x y with (compare x y) +        (<) x y | LT = True+        (<) x y | _  = False++    (>) : a -> a -> Bool+    (>) x y with (compare x y)+        (>) x y | GT = True+        (>) x y | _  = False++    (<=) : a -> a -> Bool+    (<=) x y = x < y || x == y++    (>=) : a -> a -> Bool+    (>=) x y = x > y || x == y++    max : a -> a -> a+    max x y = if (x > y) then x else y++    min : a -> a -> a+    min x y = if (x < y) then x else y++++instance Ord Int where +    compare x y = if (x == y) then EQ else+                  if (boolOp prim__ltInt x y) then LT else+                  GT+++instance Ord Integer where +    compare x y = if (x == y) then EQ else+                  if (boolOp prim__ltBigInt x y) then LT else+                  GT+++instance Ord Float where +    compare x y = if (x == y) then EQ else+                  if (boolOp prim__ltFloat x y) then LT else+                  GT+++instance Ord Char where +    compare x y = if (x == y) then EQ else+                  if (boolOp prim__ltChar x y) then LT else+                  GT+++instance Ord String where +    compare x y = if (x == y) then EQ else+                  if (boolOp prim__ltString x y) then LT else+                  GT+++instance (Ord a, Ord b) => Ord (a, b) where+  compare (xl, xr) (yl, yr) =+    if xl /= yl+      then compare xl yl+      else compare xr yr+++class Num a where +    (+) : a -> a -> a+    (-) : a -> a -> a+    (*) : a -> a -> a++    abs : a -> a+    fromInteger : Int -> a++++instance Num Int where +    (+) = prim__addInt+    (-) = prim__subInt+    (*) = prim__mulInt++    fromInteger = id+    abs x = if x<0 then -x else x+++instance Num Integer where +    (+) = prim__addBigInt+    (-) = prim__subBigInt+    (*) = prim__mulBigInt++    abs x = if x<0 then -x else x+    fromInteger = prim__intToBigInt+++instance Num Float where +    (+) = prim__addFloat+    (-) = prim__subFloat+    (*) = prim__mulFloat++    abs x = if x<0 then -x else x+    fromInteger = prim__intToFloat ++partial+div : Int -> Int -> Int+div = prim__divInt+++(/) : Float -> Float -> Float+(/) = prim__divFloat++--- string operators++(++) : String -> String -> String+(++) = prim__concat++partial+strHead : String -> Char+strHead = prim__strHead++partial+strTail : String -> String+strTail = prim__strTail++strCons : Char -> String -> String+strCons = prim__strCons++partial+strIndex : String -> Int -> Char+strIndex = prim__strIndex++reverse : String -> String+reverse = prim__strRev++}+
+ lib/Control/Monad/Identity.idr view
@@ -0,0 +1,10 @@+module Control.Monad.Identity++import Prelude.Monad ++public record Identity : Set -> Set where+    Id : (runIdentity : a) -> Identity a++instance Monad Identity where+    return x = Id x+    (Id x) >>= k = k x
+ lib/Control/Monad/State.idr view
@@ -0,0 +1,29 @@+module Control.Monad.State++import Control.Monad.Identity+import Prelude.Monad++%access public++class Monad m => MonadState s (m : Set -> Set) where+    get : m s+    put : s -> m ()++record StateT : Set -> (Set -> Set) -> Set -> Set where+    ST : {m : Set -> Set} ->+         (runStateT : s -> m (a, s)) -> StateT s m a++instance Monad m => Monad (StateT s m) where+    return x = ST (\st => return (x, st))++    (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+    get   = ST (\x => return (x, x))+    put x = ST (\y => return ((), x)) ++State : Set -> Set -> Set+State s a = StateT s Identity a+
+ lib/IO.idr view
@@ -0,0 +1,53 @@+import Prelude.List++%access public++abstract data IO a = prim__IO a++abstract+io_bind : IO a -> (a -> IO b) -> IO b+io_bind (prim__IO v) k = k v++unsafePerformIO : IO a -> a+-- compiled as primitive++abstract+io_return : a -> IO a+io_return x = prim__IO x++-- This may seem pointless, but we can use it to force an+-- evaluation of main that Epic wouldn't otherwise do...++run__IO : IO () -> IO ()+run__IO v = io_bind v (\v' => io_return v')++data FTy = FInt | FFloat | FChar | FString | FPtr | FAny Set | FUnit++interpFTy : FTy -> Set+interpFTy FInt     = Int+interpFTy FFloat   = Float+interpFTy FChar    = Char+interpFTy FString  = String+interpFTy FPtr     = Ptr+interpFTy (FAny t) = t+interpFTy FUnit    = ()++ForeignTy : (xs:List FTy) -> (t:FTy) -> Set+ForeignTy xs t = mkForeign' (reverse xs) (IO (interpFTy t)) where +   mkForeign' : List FTy -> Set -> Set+   mkForeign' Nil ty       = ty+   mkForeign' (s :: ss) ty = mkForeign' ss (interpFTy s -> ty)+++data Foreign : Set -> Set where+    FFun : String -> (xs:List FTy) -> (t:FTy) -> +           Foreign (ForeignTy xs t)++mkForeign : Foreign x -> x+mkLazyForeign : Foreign x -> x+-- mkForeign and mkLazyForeign compiled as primitives++fork : |(thread:IO ()) -> IO Ptr+fork x = io_return prim__vm -- compiled specially++
+ lib/Language/Reflection.idr view
@@ -0,0 +1,11 @@+module Language.Reflection++TTName : Set+TTName = String++data TT = Var TTName+        | Lam TTName TT TT+        | Pi  TTName TT TT+        | Let TTName TT TT TT+        | App TTName TT TT+
lib/Makefile view
@@ -11,6 +11,6 @@ 	$(IDRIS) --clean base.ipkg  linecount: .PHONY-	wc -l *.idr network/*.idr language/*.idr prelude/*.idr control/monad/*.idr+	wc -l *.idr Network/*.idr Language/*.idr Prelude/*.idr Control/Monad/*.idr  .PHONY:
+ lib/Network/Cgi.idr view
@@ -0,0 +1,130 @@+module Network.Cgi++import System++public+Vars : Set+Vars = List (String, String)++record CGIInfo : Set where+       CGISt : (GET : Vars) ->+               (POST : Vars) ->+               (Cookies : Vars) ->+               (UserAgent : String) ->+               (Headers : String) ->+               (Output : String) -> CGIInfo++add_Headers : String -> CGIInfo -> CGIInfo+add_Headers str st = record { Headers = Headers st ++ str } st++add_Output : String -> CGIInfo -> CGIInfo+add_Output str st = record { Output = Output st ++ str } st++abstract+data CGI : Set -> Set where+    MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a++getAction : CGI a -> CGIInfo -> IO (a, CGIInfo)+getAction (MkCGI act) = act++instance Monad CGI where {+    (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s+                                        getAction (k (fst v)) (snd v))++    return v = MkCGI (\s => return (v, s))+}++setInfo : CGIInfo -> CGI ()+setInfo i = MkCGI (\s => return ((), i))++getInfo : CGI CGIInfo+getInfo = MkCGI (\s => return (s, s))++abstract+lift : IO a -> CGI a +lift op = MkCGI (\st => do { x <- op+                             return (x, st) } ) ++abstract+output : String -> CGI ()+output s = do i <- getInfo+              setInfo (add_Output s i)++abstract+queryVars : CGI Vars+queryVars = do i <- getInfo+               return (GET i)++abstract+postVars : CGI Vars+postVars = do i <- getInfo+              return (POST i)++abstract+cookieVars : CGI Vars+cookieVars = do i <- getInfo+                return (Cookies i)++abstract+queryVar : String -> CGI (Maybe String)+queryVar x = do vs <- queryVars+                return (lookup x vs)++getOutput : CGI String+getOutput = do i <- getInfo+               return (Output i)++getHeaders : CGI String+getHeaders = do i <- getInfo+                return (Headers i)++abstract+flushHeaders : CGI ()+flushHeaders = do o <- getHeaders+                  lift (putStrLn o)++abstract+flush : CGI ()+flush = do o <- getOutput+           lift (putStr o) ++getVars : List Char -> String -> List (String, String)+getVars seps query = mapMaybe readVar (split (\x => elem x seps) query) +  where+    readVar : String -> Maybe (String, String)+    readVar xs with (split (\x => x == '=') xs)+        | [k, v] = Just (trim k, trim v)+        | _      = Nothing++getContent : Int -> IO String+getContent x = getC x "" where+    %assert_total+    getC : Int -> String -> IO String+    getC 0 acc = return $ reverse acc+    getC n acc = if (n > 0)+                    then do x <- getChar+                            getC (n-1) (strCons x acc)+                    else (return "")++abstract+runCGI : CGI a -> IO a+runCGI prog = do +    clen_in <- getEnv "CONTENT_LENGTH"+    let clen = prim__strToInt clen_in+    content <- getContent clen+    query   <- getEnv "QUERY_STRING"+    cookie  <- getEnv "HTTP_COOKIE"+    agent   <- getEnv "HTTP_USER_AGENT"++    let get_vars  = getVars ['&',';'] query+    let post_vars = getVars ['&'] content+    let cookies   = getVars [';'] cookie++    (v, st) <- getAction prog (CGISt get_vars post_vars cookies agent +                 "Content-type: text/html\n" +                 "")+    putStrLn (Headers st)+    putStr (Output st)+    return v++
+ lib/Prelude.idr view
@@ -0,0 +1,299 @@+module Prelude++import Builtins+import IO++import Prelude.Cast+import Prelude.Nat+import Prelude.Fin+import Prelude.List+import Prelude.Maybe+import Prelude.Monad+import Prelude.Applicative+import Prelude.Either+import Prelude.Vect+import Prelude.Strings+import Prelude.Chars++%access public+%default total++-- Show and instances++class Show a where +    show : a -> String++instance Show Nat where +    show O = "O"+    show (S k) = "s" ++ show k++instance Show Int where +    show = prim__intToStr++instance Show Integer where +    show = prim__bigIntToStr++instance Show Float where +    show = prim__floatToStr++instance Show Char where +    show x = strCons x "" ++instance Show String where +    show = id++instance Show Bool where +    show True = "True"+    show False = "False"++instance (Show a, Show b) => Show (a, b) where +    show (x, y) = "(" ++ show x ++ ", " ++ show y ++ ")"++instance Show a => Show (List a) where +    show xs = "[" ++ show' "" xs ++ "]" where +        show' : String -> List a -> String+        show' acc []        = acc+        show' acc [x]       = acc ++ show x+        show' acc (x :: xs) = show' (acc ++ show x ++ ", ") xs++instance Show a => Show (Vect a n) where +    show xs = "[" ++ show' xs ++ "]" where +        show' : Vect a m -> String+        show' []        = ""+        show' [x]       = show x+        show' (x :: xs) = show x ++ ", " ++ show' xs++instance Show a => Show (Maybe a) where +    show Nothing = "Nothing"+    show (Just x) = "Just " ++ show x++---- Monad instances++instance Monad IO where +    return t = io_return t+    b >>= k = io_bind b k++instance Monad Maybe where +    return t = Just t++    Nothing  >>= k = Nothing+    (Just x) >>= k = k x++instance MonadPlus Maybe where +    mzero = Nothing++    mplus (Just x) _       = Just x+    mplus Nothing (Just y) = Just y+    mplus Nothing Nothing  = Nothing++instance Monad List where +    return x = [x]+    m >>= f = concatMap f m++instance MonadPlus List where +    mzero = []+    mplus = (++)++---- Functor instances++instance Functor Maybe where +    fmap f (Just x) = Just (f x)+    fmap f Nothing  = Nothing++instance Functor List where +    fmap = map++---- Applicative instances++instance Applicative Maybe where+    pure = Just++    (Just f) <$> (Just a) = Just (f a)+    _        <$> _        = Nothing+++---- some mathematical operations++%include "math.h"+%lib "m"++exp : Float -> Float+exp x = prim__floatExp x++log : Float -> Float+log x = prim__floatLog x++pi : Float+pi = 3.141592653589793++sin : Float -> Float+sin x = prim__floatSin x++cos : Float -> Float+cos x = prim__floatCos x++tan : Float -> Float+tan x = prim__floatTan x++asin : Float -> Float+asin x = prim__floatASin x++acos : Float -> Float+acos x = prim__floatACos x++atan : Float -> Float+atan x = prim__floatATan x++atan2 : Float -> Float -> Float+atan2 y x = atan (y/x)++sqrt : Float -> Float+sqrt x = prim__floatSqrt x++floor : Float -> Float+floor x = prim__floatFloor x++ceiling : Float -> Float+ceiling x = prim__floatCeil x++---- Ranges++partial+count : (Ord a, Num a) => a -> a -> a -> List a+count a inc b = if a <= b then a :: count (a + inc) inc b+                          else []+  +partial+countFrom : (Ord a, Num a) => a -> a -> List a+countFrom a inc = a :: lazy (countFrom (a + inc) inc)+  +syntax "[" [start] ".." [end] "]" +     = count start 1 end +syntax "[" [start] "," [next] ".." [end] "]" +     = count start (next - start) end ++syntax "[" [start] "..]" +     = countFrom start 1+syntax "[" [start] "," [next] "..]" +     = countFrom start (next - start)++---- More utilities++sum : Num a => List a -> a+sum = foldl (+) 0++prod : Num a => List a -> a+prod = foldl (*) 1++---- some basic io++partial+putStr : String -> IO ()+putStr x = mkForeign (FFun "putStr" [FString] FUnit) x++partial+putStrLn : String -> IO ()+putStrLn x = putStr (x ++ "\n")++partial+print : Show a => a -> IO ()+print x = putStrLn (show x)++partial+getLine : IO String+getLine = return (prim__readString prim__stdin)++partial+putChar : Char -> IO ()+putChar c = mkForeign (FFun "putchar" [FChar] FUnit) c++partial+getChar : IO Char+getChar = mkForeign (FFun "getchar" [] FChar)++---- some basic file handling++abstract +data File = FHandle Ptr++do_fopen : String -> String -> IO Ptr+do_fopen f m = mkForeign (FFun "fileOpen" [FString, FString] FPtr) f m++fopen : String -> String -> IO File+fopen f m = do h <- do_fopen f m+               return (FHandle h) ++data Mode = Read | Write | ReadWrite++partial+openFile : String -> Mode -> IO File+openFile f m = fopen f (modeStr m) where +  modeStr : Mode -> String+  modeStr Read  = "r"+  modeStr Write = "w"+  modeStr ReadWrite = "r+"++partial+do_fclose : Ptr -> IO ()+do_fclose h = mkForeign (FFun "fileClose" [FPtr] FUnit) h++partial+closeFile : File -> IO ()+closeFile (FHandle h) = do_fclose h++partial+do_fread : Ptr -> IO String+do_fread h = return (prim__readString h)++partial+fread : File -> IO String+fread (FHandle h) = do_fread h++partial+do_fwrite : Ptr -> String -> IO ()+do_fwrite h s = mkForeign (FFun "fputStr" [FPtr, FString] FUnit) h s++partial+fwrite : File -> String -> IO ()+fwrite (FHandle h) s = do_fwrite h s++partial+do_feof : Ptr -> IO Int+do_feof h = mkForeign (FFun "feof" [FPtr] FInt) h++feof : File -> IO Bool+feof (FHandle h) = do eof <- do_feof h+                      return (not (eof == 0)) ++partial+nullPtr : Ptr -> IO Bool+nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p +               return (ok /= 0);++partial+validFile : File -> IO Bool+validFile (FHandle h) = do x <- nullPtr h+                           return (not x)++partial -- obviously+while : |(test : IO Bool) -> |(body : IO ()) -> IO ()+while t b = do v <- t+               if v then do b+                            while t b+                    else return ()+               +partial -- no error checking!+readFile : String -> IO String+readFile fn = do h <- openFile fn Read+                 c <- readFile' h ""+                 closeFile h+                 return c+  where +    partial+    readFile' : File -> String -> IO String+    readFile' h contents = +       do x <- feof h+          if not x then do l <- fread h+                           readFile' h (contents ++ l)+                   else return contents+
+ lib/Prelude/Algebra.idr view
@@ -0,0 +1,257 @@+module Prelude.Algebra++import Builtins++-- XXX: change?+infixl 6 <->+infixl 6 <+>+infixl 6 <*>++%access public++--------------------------------------------------------------------------------+-- A modest class hierarchy+--------------------------------------------------------------------------------++-- Sets equipped with a single binary operation that is associative.  Must+-- satisfy the following laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+class Semigroup a where+  (<+>) : a -> a -> a++class Semigroup a => VerifiedSemigroup a where+  semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r++-- Sets equipped with a single binary operation that is associative, along with+-- a neutral element for that binary operation.  Must satisfy the following+-- laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+--   Neutral for <+>:+--     forall a,     a <+> neutral   == a+--     forall a,     neutral <+> a   == a+class Semigroup a => Monoid a where+  neutral : a++class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where+  monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l+  monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r++-- Sets equipped with a single binary operation that is associative, along with+-- a neutral element for that binary operation and inverses for all elements.+-- Must satisfy the following laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+--   Neutral for <+>:+--     forall a,     a <+> neutral   == a+--     forall a,     neutral <+> a   == a+--   Inverse for <+>:+--     forall a,     a <+> inverse a == neutral+--     forall a,     inverse a <+> a == neutral+class Monoid a => Group a where+  inverse : a -> a++class (VerifiedMonoid a, Group a) => VerifiedGroup a where+  groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral+  groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral++(<->) : Group a => a -> a -> a+(<->) left right = left <+> (inverse right)++-- Sets equipped with a single binary operation that is associative and+-- commutative, along with a neutral element for that binary operation and+-- inverses for all elements. Must satisfy the following laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+--   Commutativity of <+>:+--     forall a b,   a <+> b         == b <+> a+--   Neutral for <+>:+--     forall a,     a <+> neutral   == a+--     forall a,     neutral <+> a   == a+--   Inverse for <+>:+--     forall a,     a <+> inverse a == neutral+--     forall a,     inverse a <+> a == neutral+class Group a => AbelianGroup a where { }++class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where+  abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l++-- Sets equipped with two binary operations, one associative and commutative+-- supplied with a neutral element, and the other associative, with+-- distributivity laws relating the two operations.  Must satisfy the following+-- laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+--   Commutativity of <+>:+--     forall a b,   a <+> b         == b <+> a+--   Neutral for <+>:+--     forall a,     a <+> neutral   == a+--     forall a,     neutral <+> a   == a+--   Inverse for <+>:+--     forall a,     a <+> inverse a == neutral+--     forall a,     inverse a <+> a == neutral+--   Associativity of <*>:+--     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c+--   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+  (<*>) : a -> a -> a++class (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where+  ringOpIsAssociative   : (l, c, r : a) -> l <*> (c <*> r) = (l <*> c) <*> r+  ringOpIsDistributiveL : (l, c, r : a) -> l <*> (c <+> r) = (l <*> c) <+> (l <*> r)+  ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <*> r = (l <*> r) <+> (l <*> c)++-- Sets equipped with two binary operations, one associative and commutative+-- supplied with a neutral element, and the other associative supplied with a+-- neutral element, with distributivity laws relating the two operations.  Must+-- satisfy the following laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+--   Commutativity of <+>:+--     forall a b,   a <+> b         == b <+> a+--   Neutral for <+>:+--     forall a,     a <+> neutral   == a+--     forall a,     neutral <+> a   == a+--   Inverse for <+>:+--     forall a,     a <+> inverse a == neutral+--     forall a,     inverse a <+> a == neutral+--   Associativity of <*>:+--     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c+--   Neutral for <*>:+--     forall a,     a <*> unity     == a+--     forall a,     unity <*> a     == a+--   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+  unity : a++class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where+  ringWithUnityIsUnityL : (l : a) -> l <*> unity = l+  ringWithUnityIsUnityR : (r : a) -> unity <*> r = r++-- Sets equipped with a binary operation that is commutative, associative and+-- idempotent.  Must satisfy the following laws:+--   Associativity of join:+--     forall a b c, join a (join b c) == join (join a b) c+--   Commutativity of join:+--     forall a b,   join a b          == join b a+--   Idempotency of join:+--     forall a,     join a a          == a+--  Join semilattices capture the notion of sets with a "least upper bound".+class JoinSemilattice a where+  join : a -> a -> a++class JoinSemilattice a => VerifiedJoinSemilattice a where+  joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r+  joinSemilatticeJoinIsCommutative : (l, r : a)    -> join l r = join r l+  joinSemilatticeJoinIsIdempotent  : (e : a)       -> join e e = e++-- Sets equipped with a binary operation that is commutative, associative and+-- idempotent.  Must satisfy the following laws:+--   Associativity of meet:+--     forall a b c, meet a (meet b c) == meet (meet a b) c+--   Commutativity of meet:+--     forall a b,   meet a b          == meet b a+--   Idempotency of meet:+--     forall a,     meet a a          == a+--  Meet semilattices capture the notion of sets with a "greatest lower bound".+class MeetSemilattice a where+  meet : a -> a -> a++class MeetSemilattice a => VerifiedMeetSemilattice a where+  meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r+  meetSemilatticeMeetIsCommutative : (l, r : a)    -> meet l r = meet r l+  meetSemilatticeMeetIsIdempotent  : (e : a)       -> meet e e = e++-- Sets equipped with a binary operation that is commutative, associative and+-- idempotent and supplied with a neutral element.  Must satisfy the following+-- laws:+--   Associativity of join:+--     forall a b c, join a (join b c) == join (join a b) c+--   Commutativity of join:+--     forall a b,   join a b          == join b a+--   Idempotency of join:+--     forall a,     join a a          == a+--   Bottom:+--     forall a,     join a bottom     == bottom+--  Join semilattices capture the notion of sets with a "least upper bound"+--  equipped with a "bottom" element.+class JoinSemilattice a => BoundedJoinSemilattice a where+  bottom  : a++class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where+  boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = bottom++-- Sets equipped with a binary operation that is commutative, associative and+-- idempotent and supplied with a neutral element.  Must satisfy the following+-- laws:+--   Associativity of meet:+--     forall a b c, meet a (meet b c) == meet (meet a b) c+--   Commutativity of meet:+--     forall a b,   meet a b          == meet b a+--   Idempotency of meet:+--     forall a,     meet a a          == a+--   Top:+--     forall a,     meet a top        == top+--  Meet semilattices capture the notion of sets with a "greatest lower bound"+--  equipped with a "top" element.+class MeetSemilattice a => BoundedMeetSemilattice a where+  top : a++class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where+  boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = top++-- Sets equipped with two binary operations that are both commutative,+-- associative and idempotent, along with absorbtion laws for relating the two+-- binary operations.  Must satisfy the following:+--   Associativity of meet and join:+--     forall a b c, meet a (meet b c) == meet (meet a b) c+--     forall a b c, join a (join b c) == join (join a b) c+--   Commutativity of meet and join:+--     forall a b,   meet a b          == meet b a+--     forall a b,   join a b          == join b a+--   Idempotency of meet and join:+--     forall a,     meet a a          == a+--     forall a,     join a a          == a+--   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 { }++class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where+  latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l+  latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l++-- Sets equipped with two binary operations that are both commutative,+-- associative and idempotent and supplied with neutral elements, along with+-- absorbtion laws for relating the two binary operations.  Must satisfy the+-- following:+--   Associativity of meet and join:+--     forall a b c, meet a (meet b c) == meet (meet a b) c+--     forall a b c, join a (join b c) == join (join a b) c+--   Commutativity of meet and join:+--     forall a b,   meet a b          == meet b a+--     forall a b,   join a b          == join b a+--   Idempotency of meet and join:+--     forall a,     meet a a          == a+--     forall a,     join a a          == a+--   Absorbtion laws for meet and join:+--     forall a b,   meet a (join a b) == a+--     forall a b,   join a (meet a b) == a+--   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 { }++class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }+  +  +-- XXX todo:+--   Fields and vector spaces.+--   Structures where "abs" make sense.+--   Euclidean domains, etc.+--   Where to put fromInteger and fromRational?
+ lib/Prelude/Applicative.idr view
@@ -0,0 +1,13 @@+module Prelude.Applicative++import Builtins++---- Applicative functors/Idioms++infixl 2 <$> ++class Applicative (f : Set -> Set) where +    pure  : a -> f a+    (<$>) : f (a -> b) -> f a -> f b ++
+ lib/Prelude/Cast.idr view
@@ -0,0 +1,49 @@+module Prelude.Cast++class Cast from to where+    cast : from -> to++-- String casts++instance Cast String Int where+    cast = prim__strToInt++instance Cast String Float where+    cast = prim__strToFloat++instance Cast String Integer where+    cast = prim__strToBigInt++-- Int casts++instance Cast Int String where+    cast = prim__intToStr++instance Cast Int Float where+    cast = prim__intToFloat++instance Cast Int Integer where+    cast = prim__intToBigInt ++instance Cast Int Char where+    cast = prim__intToChar++-- Float casts++instance Cast Float String where+    cast = prim__floatToStr++instance Cast Float Int where+    cast = prim__floatToInt++-- Integer casts++instance Cast Integer String where+    cast = prim__bigIntToStr++-- Char casts++instance Cast Char Int where+    cast = prim__charToInt++
+ lib/Prelude/Chars.idr view
@@ -0,0 +1,34 @@+module Prelude.Char++import Builtins++isUpper : Char -> Bool+isUpper x = x >= 'A' && x <= 'Z'++isLower : Char -> Bool+isLower x = x >= 'a' && x <= 'z'++isAlpha : Char -> Bool+isAlpha x = isUpper x || isLower x ++isDigit : Char -> Bool+isDigit x = (x >= '0' && x <= '9')++isAlphaNum : Char -> Bool+isAlphaNum x = isDigit x || isAlpha x++isSpace : Char -> Bool+isSpace x = x == ' '  || x == '\t' || x == '\r' ||+            x == '\n' || x == '\f' || x == '\v' ||+            x == '\xa0'++toUpper : Char -> Char+toUpper x = if (isLower x) +               then (prim__intToChar (prim__charToInt x - 32))+               else x++toLower : Char -> Char+toLower x = if (isUpper x)+               then (prim__intToChar (prim__charToInt x + 32))+               else x+
+ lib/Prelude/Complex.idr view
@@ -0,0 +1,70 @@+{-+  © 2012 Copyright Mekeor Melire+-}+++module Prelude.Complex++import Builtins+import Prelude++------------------------------ Rectangular form ++infix 6 :++data Complex a = (:+) a a++realPart : Complex a -> a+realPart (r:+i) = r++imagPart : Complex a -> a+imagPart (r:+i) = i++instance Eq a => Eq (Complex a) where+    (==) a b = realPart a == realPart b && imagPart a == imagPart b++instance Show a => Show (Complex a) where+    show (r:+i) = "("++show r++":+"++show i++")"++++-- when we have a type class 'Fractional' (which contains Float and Double),+-- we can do:+{-+instance 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)+                        in+                          (real:+imag)+-}++++------------------------------ Polarform++mkPolar : Float -> Float -> Complex Float+mkPolar radius angle = radius * cos angle :+ radius * sin angle++cis : Float -> Complex Float+cis angle = cos angle :+ sin angle++magnitude : Complex Float -> Float+magnitude (r:+i) = sqrt (r*r+i*i)++phase : Complex Float -> Float+phase (x:+y) = atan2 y x+++------------------------------ Conjugate++conjugate : Num a => Complex a -> Complex a+conjugate (r:+i) = (r :+ (0-i))++-- We can't do "instance Num a => Num (Complex a)" because+-- we need "abs" which needs "magnitude" which needs "sqrt" which needs Float+instance Num (Complex Float) where+    (+) (a:+b) (c:+d) = ((a+b):+(c+d))+    (-) (a:+b) (c:+d) = ((a-b):+(c-d))+    (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d))+    fromInteger x = (fromInteger x:+0)+    abs (a:+b) = (magnitude (a:+b):+0)
+ lib/Prelude/Either.idr view
@@ -0,0 +1,63 @@+module Prelude.Either++import Builtins++import Prelude.Maybe+import Prelude.List++data Either a b+  = Left a+  | Right b++--------------------------------------------------------------------------------+-- Syntactic tests+--------------------------------------------------------------------------------++isLeft : Either a b -> Bool+isLeft (Left l)  = True+isLeft (Right r) = False++isRight : Either a b -> Bool+isRight (Left l)  = False+isRight (Right r) = True++--------------------------------------------------------------------------------+-- Misc.+--------------------------------------------------------------------------------++choose : (b : Bool) -> Either (so b) (so (not b))+choose True  = Left oh+choose False = Right oh++either : Either a b -> (a -> c) -> (b -> c) -> c+either (Left x)  l r = l x+either (Right x) l r = r x++lefts : List (Either a b) -> List a+lefts []      = []+lefts (x::xs) =+  case x of+    Left  l => l :: lefts xs+    Right r => lefts xs++rights : List (Either a b) -> List b+rights []      = []+rights (x::xs) =+  case x of+    Left  l => rights xs+    Right r => r :: rights xs++partitionEithers : List (Either a b) -> (List a, List b)+partitionEithers l = (lefts l, rights l)+    +fromEither : Either a a -> a+fromEither (Left l)  = l+fromEither (Right r) = r++--------------------------------------------------------------------------------+-- Conversions+--------------------------------------------------------------------------------++maybeToEither : e -> Maybe a -> Either e a+maybeToEither def (Just j) = Right j+maybeToEither def Nothing  = Left  def
+ lib/Prelude/Fin.idr view
@@ -0,0 +1,19 @@+module Prelude.Fin++import Prelude.Nat++data Fin : Nat -> Set where+    fO : Fin (S k)+    fS : Fin k -> Fin (S k)++instance Eq (Fin n) where+   (==) = eq where+     eq : Fin m -> Fin m -> Bool+     eq fO fO = True+     eq (fS k) (fS k') = eq k k'+     eq _ _ = False++wkn : Fin n -> Fin (S n)+wkn fO = fO+wkn (fS k) = fS (wkn k)+
+ lib/Prelude/Heap.idr view
@@ -0,0 +1,209 @@+--------------------------------------------------------------------------------+-- Okasaki-style maxiphobic heaps.  See the paper:+--   ``Fun with binary heap trees'', Chris Okasaki, Fun of programming, 2003.+--------------------------------------------------------------------------------++module Prelude.Heap++import Builtins++import Prelude+import Prelude.Algebra+import Prelude.List+import Prelude.Nat++%access public++abstract data MaxiphobicHeap : Set -> Set where+  Empty : MaxiphobicHeap a+  Node  : Nat -> MaxiphobicHeap a -> a -> MaxiphobicHeap a -> MaxiphobicHeap a++----------------------------------------- ---------------------------------------+-- Syntactic tests+--------------------------------------------------------------------------------++total isEmpty : MaxiphobicHeap a -> Bool+isEmpty Empty = True+isEmpty _     = False++total size : MaxiphobicHeap a -> Nat+size Empty          = O+size (Node s l e r) = s++isValidHeap : Ord a => MaxiphobicHeap a -> Bool+isValidHeap Empty          = True+isValidHeap (Node s l e r) =+  dominates e l && dominates e r && s == S (size l + size r)+  where+    dominates : Ord a => a -> MaxiphobicHeap a -> Bool+    dominates e Empty           = True+    dominates e (Node s l e' r) = e' <= e++--------------------------------------------------------------------------------+-- Basic heaps+--------------------------------------------------------------------------------++total empty : MaxiphobicHeap a+empty = Empty++total singleton : a -> MaxiphobicHeap a+singleton e = Node 1 Empty e Empty++--------------------------------------------------------------------------------+-- Inserting items and merging heaps+--------------------------------------------------------------------------------++private orderBySize : MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a ->+  (MaxiphobicHeap a, MaxiphobicHeap a, MaxiphobicHeap a)+orderBySize left centre right =+  if size left == largest then+    (left, centre, right)+  else if size centre == largest then+    (centre, left, right)+  else+    (right, left, centre)+  where+    largest : Nat+    largest = maximum (size left) $ maximum (size centre) (size right)++merge : Ord a => MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a+merge Empty               right             = right+merge left                Empty             = left+merge (Node ls ll le lr) (Node rs rl re rr) =+  if le < re then+    let (largest, b, c) = orderBySize ll lr (Node rs rl re rr) in+      Node mergedSize largest le (merge b c)+  else+    let (largest, b, c) = orderBySize rl rr (Node ls ll le lr) in+       Node mergedSize largest re (merge b c)+  where+    mergedSize : Nat+    mergedSize = ls + rs++insert : Ord a => a -> MaxiphobicHeap a -> MaxiphobicHeap a+insert e = merge $ singleton e++--------------------------------------------------------------------------------+-- Heap operations+--------------------------------------------------------------------------------++findMinimum : (h : MaxiphobicHeap a) -> (isEmpty h = False) -> a+findMinimum Empty          p = ?findMinimumEmptyAbsurd+findMinimum (Node s l e r) p = e++deleteMinimum : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> MaxiphobicHeap a+deleteMinimum Empty          p = ?deleteMinimumEmptyAbsurd+deleteMinimum (Node s l e r) p = merge l r++--------------------------------------------------------------------------------+-- Conversions to and from lists (and a derived heap sorting algorithm)+--------------------------------------------------------------------------------++toList : Ord a => MaxiphobicHeap a -> List a+toList Empty          = []+toList (Node s l e r) = toList' (Node s l e r) refl+  where+    toList' : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> List a+    toList' heap p = findMinimum heap p :: (toList $ deleteMinimum heap p)++fromList : Ord a => List a -> MaxiphobicHeap a+fromList = foldr insert empty++sort : Ord a => List a -> List a+sort = Prelude.Heap.toList . Prelude.Heap.fromList++--------------------------------------------------------------------------------+-- Class instances+--------------------------------------------------------------------------------++instance Show a => Show (MaxiphobicHeap a) where+  show Empty = "Empty"+  show (Node s l e r) = "Node (" ++ show l ++ " " ++ show e ++ " " ++ show r ++ ")"++instance 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+  (<+>) = merge++instance Ord a => Monoid (MaxiphobicHeap a) where+  neutral = empty++instance Ord a => JoinSemilattice (MaxiphobicHeap a) where+  join = merge++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++total absurdBoolDischarge : False = True -> _|_+absurdBoolDischarge p = replace {P = disjointTy} p ()+  where+    total disjointTy : Bool -> Set+    disjointTy False  = ()+    disjointTy True   = _|_++total isEmptySizeZero : (h : MaxiphobicHeap a) -> (isEmpty h = True) -> size h = O+isEmptySizeZero Empty          p = refl+isEmptySizeZero (Node s l e r) p = ?isEmptySizeZeroNodeAbsurd++total emptyHeapValid : Ord a => isValidHeap empty = True+emptyHeapValid = refl++total singletonHeapValid : Ord a => (e : a) -> isValidHeap $ singleton e = True+singletonHeapValid e = refl++{-+total mergePreservesValidHeaps : Ord a => (left : MaxiphobicHeap a) ->+  (right : MaxiphobicHeap a) -> (leftValid : isValidHeap left = True) ->+  (rightValid : isValidHeap right = True) -> isValidHeap $ merge left right = True+mergePreservesValidHeaps Empty              Empty              lp rp = refl+mergePreservesValidHeaps Empty              (Node rs rl re rr) lp rp = rp+mergePreservesValidHeaps (Node ls ll le lr) Empty              lp rp = lp+mergePreservesValidHeaps (Node ls ll le lr) (Node rs rl re rr) lp rp =+  ?mergePreservesValidHeapsBody+-}++--------------------------------------------------------------------------------+-- Proofs+--------------------------------------------------------------------------------++isEmptySizeZeroNodeAbsurd = proof {+    intros;+    refine FalseElim;+    refine absurdBoolDischarge;+    exact p;+}++findMinimumEmptyAbsurd = proof {+    intros;+    refine FalseElim;+    refine absurdBoolDischarge;+    rewrite p;+    trivial;+}++deleteMinimumEmptyAbsurd = proof {+    intros;+    refine FalseElim;+    refine absurdBoolDischarge;+    rewrite p;+    trivial;+}++--------------------------------------------------------------------------------+-- Debug+--------------------------------------------------------------------------------++{-  XXX: poor performance when compiled, diverges when used in the REPL, but it+         does seem to work correctly!+main : IO ()+main = do+  _ <- print $ main.sort [10, 3, 7, 2, 9, 1, 8, 0, 6, 4, 5]+  _ <- print $ main.sort ["orange", "apple", "pear", "lime", "durian"]+  _ <- print $ main.sort [("jim", 19, "cs"), ("alice", 20, "english"), ("bob", 50, "engineering")]+  return ()+-}
+ lib/Prelude/List.idr view
@@ -0,0 +1,639 @@+module Prelude.List++import Builtins++import Prelude.Algebra+import Prelude.Maybe+import Prelude.Nat++%access public+%default total++infixr 7 :: ++data List a+  = Nil+  | (::) a (List a)++--------------------------------------------------------------------------------+-- Syntactic tests+--------------------------------------------------------------------------------++isNil : List a -> Bool+isNil []      = True+isNil (x::xs) = False++isCons : List a -> Bool+isCons []      = False+isCons (x::xs) = True++--------------------------------------------------------------------------------+-- Indexing into lists+--------------------------------------------------------------------------------++%assert_total+head : (l : List a) -> (isCons l = True) -> a+head (x::xs) p = x++head' : (l : List a) -> Maybe a+head' []      = Nothing+head' (x::xs) = Just x++%assert_total+tail : (l : List a) -> (isCons l = True) -> List a+tail (x::xs) p = xs++tail' : (l : List a) -> Maybe (List a)+tail' []      = Nothing+tail' (x::xs) = Just xs++%assert_total+last : (l : List a) -> (isCons l = True) -> a+last (x::xs) p =+  case xs of+    []    => x+    y::ys => last (y::ys) ?lastProof++last' : (l : List a) -> Maybe a+last' []      = Nothing+last' (x::xs) =+  case xs of+    []    => Just x+    y::ys => last' xs++%assert_total+init : (l : List a) -> (isCons l = True) -> List a+init (x::xs) p =+  case xs of+    []    => []+    y::ys => x :: init (y::ys) ?initProof++init' : (l : List a) -> Maybe (List a)+init' []      = Nothing+init' (x::xs) =+  case xs of+    []    => Just []+    y::ys =>+      -- XXX: Problem with typechecking a "do" block here+      case init' $ y::ys of+        Nothing => Nothing+        Just j  => Just $ x :: j++--------------------------------------------------------------------------------+-- Sublists+--------------------------------------------------------------------------------++take : Nat -> List a -> List a+take O     xs      = []+take (S n) []      = []+take (S n) (x::xs) = x :: take n xs++drop : Nat -> List a -> List a+drop O     xs      = xs+drop (S n) []      = []+drop (S n) (x::xs) = drop n xs++takeWhile : (a -> Bool) -> List a -> List a+takeWhile p []      = []+takeWhile p (x::xs) = if p x then x :: takeWhile p xs else []++dropWhile : (a -> Bool) -> List a -> List a+dropWhile p []      = []+dropWhile p (x::xs) = if p x then dropWhile p xs else x::xs++--------------------------------------------------------------------------------+-- Misc.+--------------------------------------------------------------------------------++list : a -> (a -> List a -> a) -> List a -> a+list nil cons []      = nil+list nil cons (x::xs) = cons x xs++length : List a -> Nat+length []      = 0+length (x::xs) = 1 + length xs++--------------------------------------------------------------------------------+-- Building (bigger) lists+--------------------------------------------------------------------------------++(++) : List a -> List a -> List a+(++) [] right      = right+(++) (x::xs) right = x :: (xs ++ right)++partial+repeat : a -> List a+repeat x = x :: repeat x++%assert_total+replicate : Nat -> a -> List a+replicate n x = take n (repeat x)++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++instance (Eq a) => Eq (List a) where+  (==) []      []      = True+  (==) (x::xs) (y::ys) =+    if x == y then+      xs == ys+    else+      False+  (==) _ _ = False+++instance Ord a => Ord (List a) where+  compare [] [] = EQ+  compare [] _ = LT+  compare _ [] = GT+  compare (x::xs) (y::ys) =+    if x /= y then+      compare x y+    else+      compare xs ys++instance Semigroup (List a) where+  (<+>) = (++)++instance Monoid (List a) where+  neutral = []++-- XXX: unification failure+-- instance VerifiedSemigroup (List a) where+--  semigroupOpIsAssociative = appendAssociative++--------------------------------------------------------------------------------+-- Zips and unzips+--------------------------------------------------------------------------------++%assert_total+zipWith : (f : a -> b -> c) -> (l : List a) -> (r : List b) ->+  (length l = length r) -> List c+zipWith f []      []      p = []+zipWith f (x::xs) (y::ys) p = f x y :: (zipWith f xs ys ?zipWithTailProof)++%assert_total+zipWith3 : (f : a -> b -> c -> d) -> (x : List a) -> (y : List b) ->+  (z : List c) -> (length x = length y) -> (length y = length z) -> List d+zipWith3 f []      []      []      refl refl = []+zipWith3 f (x::xs) (y::ys) (z::zs) p q =+  f x y z :: (zipWith3 f xs ys zs ?zipWith3TailProof ?zipWith3TailProof')++zip : (l : List a) -> (r : List b) -> (length l = length r) -> List (a, b)+zip = zipWith (\x => \y => (x, y))++zip3 : (x : List a) -> (y : List b) -> (z : List c) -> (length x = length y) ->+  (length y = length z) -> List (a, b, c)+zip3 = zipWith3 (\x => \y => \z => (x, y, z))++unzip : List (a, b) -> (List a, List b)+unzip []           = ([], [])+unzip ((l, r)::xs) with (unzip xs)+  | (lefts, rights) = (l::lefts, r::rights)++unzip3 : List (a, b, c) -> (List a, List b, List c)+unzip3 []              = ([], [], [])+unzip3 ((l, c, r)::xs) with (unzip3 xs)+  | (lefts, centres, rights) = (l::lefts, c::centres, r::rights)++--------------------------------------------------------------------------------+-- Maps+--------------------------------------------------------------------------------++map : (a -> b) -> List a -> List b+map f []      = []+map f (x::xs) = f x :: map f xs++mapMaybe : (a -> Maybe b) -> List a -> List b+mapMaybe f []      = []+mapMaybe f (x::xs) =+  case f x of+    Nothing => mapMaybe f xs+    Just j  => j :: mapMaybe f xs++--------------------------------------------------------------------------------+-- Folds+--------------------------------------------------------------------------------++foldl : (a -> b -> a) -> a -> List b -> a+foldl f e []      = e+foldl f e (x::xs) = foldl f (f e x) xs++foldr : (a -> b -> b) -> b -> List a -> b+foldr f e []      = e+foldr f e (x::xs) = f x (foldr f e xs)++--------------------------------------------------------------------------------+-- Special folds+--------------------------------------------------------------------------------++mconcat : Monoid a => List a -> a+mconcat = foldr (<+>) neutral++concat : List (List a) -> List a+concat []      = []+concat (x::xs) = x ++ concat xs++concatMap : (a -> List b) -> List a -> List b+concatMap f []      = []+concatMap f (x::xs) = f x ++ concatMap f xs++and : List Bool -> Bool+and = foldr (&&) True++or : List Bool -> Bool+or = foldr (||) False++any : (a -> Bool) -> List a -> Bool+any p = or . map p++all : (a -> Bool) -> List a -> Bool+all p = and . map p++--------------------------------------------------------------------------------+-- Transformations+--------------------------------------------------------------------------------++reverse : List a -> List a+reverse = reverse' []+  where+    reverse' : List a -> List a -> List a+    reverse' acc []      = acc+    reverse' acc (x::xs) = reverse' (x::acc) xs++intersperse : a -> List a -> List a+intersperse sep []      = []+intersperse sep (x::xs) = x :: intersperse' sep xs+  where+    intersperse' : a -> List a -> List a+    intersperse' sep []      = []+    intersperse' sep (y::ys) = sep :: y :: intersperse' sep ys++intercalate : List a -> List (List a) -> List a+intercalate sep l = concat $ intersperse sep l++--------------------------------------------------------------------------------+-- Membership tests+--------------------------------------------------------------------------------++elemBy : (a -> a -> Bool) -> a -> List a -> Bool+elemBy p e []      = False+elemBy p e (x::xs) =+  if p e x then+    True+  else+    elemBy p e xs++elem : Eq a => a -> List a -> Bool+elem = elemBy (==)++lookupBy : (a -> a -> Bool) -> a -> List (a, b) -> Maybe b+lookupBy p e []      = Nothing+lookupBy p e (x::xs) =+  let (l, r) = x in+    if p e l then+      Just r+    else+      lookupBy p e xs++lookup : Eq a => a -> List (a, b) -> Maybe b+lookup = lookupBy (==)++hasAnyBy : (a -> a -> Bool) -> List a -> List a -> Bool+hasAnyBy p elems []      = False+hasAnyBy p elems (x::xs) =+  if elemBy p x elems then+    True+  else+    hasAnyBy p elems xs++hasAny : Eq a => List a -> List a -> Bool+hasAny = hasAnyBy (==)++--------------------------------------------------------------------------------+-- Searching with a predicate+--------------------------------------------------------------------------------++find : (a -> Bool) -> List a -> Maybe a+find p []      = Nothing+find p (x::xs) =+  if p x then+    Just x+  else+    find p xs++findIndex : (a -> Bool) -> List a -> Maybe Nat+findIndex = findIndex' 0+  where+    findIndex' : Nat -> (a -> Bool) -> List a -> Maybe Nat+    findIndex' cnt p []      = Nothing+    findIndex' cnt p (x::xs) =+      if p x then+        Just cnt+      else+        findIndex' (S cnt) p xs++findIndices : (a -> Bool) -> List a -> List Nat+findIndices = findIndices' 0+  where+    findIndices' : Nat -> (a -> Bool) -> List a -> List Nat+    findIndices' cnt p []      = []+    findIndices' cnt p (x::xs) =+      if p x then+        cnt :: findIndices' (S cnt) p xs+      else+        findIndices' (S cnt) p xs++elemIndexBy : (a -> a -> Bool) -> a -> List a -> Maybe Nat+elemIndexBy p e = findIndex $ p e++elemIndex : Eq a => a -> List a -> Maybe Nat+elemIndex = elemIndexBy (==)++elemIndicesBy : (a -> a -> Bool) -> a -> List a -> List Nat+elemIndicesBy p e = findIndices $ p e++elemIndices : Eq a => a -> List a -> List Nat+elemIndices = elemIndicesBy (==)++--------------------------------------------------------------------------------+-- Filters+--------------------------------------------------------------------------------++filter : (a -> Bool) -> List a -> List a+filter p []      = []+filter p (x::xs) =+  if p x then+    x :: filter p xs+  else+    filter p xs++nubBy : (a -> a -> Bool) -> List a -> List a+nubBy = nubBy' []+  where+    nubBy' : List a -> (a -> a -> Bool) -> List a -> List a+    nubBy' acc p []      = []+    nubBy' acc p (x::xs) =+      if elemBy p x acc then+        nubBy' acc p xs+      else+        x :: nubBy' (x::acc) p xs++nub : Eq a => List a -> List a+nub = nubBy (==)++--------------------------------------------------------------------------------+-- Splitting and breaking lists+--------------------------------------------------------------------------------++span : (a -> Bool) -> List a -> (List a, List a)+span p []      = ([], [])+span p (x::xs) =+  if p x then+    let (ys, zs) = span p xs in+      (x::ys, zs)+  else+    ([], x::xs)++break : (a -> Bool) -> List a -> (List a, List a)+break p = span (not . p)++split : (a -> Bool) -> List a -> List (List a)+split p [] = []+split p xs =+  case break p xs of+    (chunk, [])          => [chunk]+    (chunk, (c :: rest)) => chunk :: split p rest++partition : (a -> Bool) -> List a -> (List a, List a)+partition p []      = ([], [])+partition p (x::xs) =+  let (lefts, rights) = partition p xs in+    if p x then+      (x::lefts, rights)+    else+      (lefts, x::rights)++--------------------------------------------------------------------------------+-- Predicates+--------------------------------------------------------------------------------++isPrefixOfBy : (a -> a -> Bool) -> List a -> List a -> Bool+isPrefixOfBy p [] right        = True+isPrefixOfBy p left []         = False+isPrefixOfBy p (x::xs) (y::ys) =+  if p x y then+    isPrefixOfBy p xs ys+  else+    False++isPrefixOf : Eq a => List a -> List a -> Bool+isPrefixOf = isPrefixOfBy (==)++isSuffixOfBy : (a -> a -> Bool) -> List a -> List a -> Bool+isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right)++isSuffixOf : Eq a => List a -> List a -> Bool+isSuffixOf = isSuffixOfBy (==)++--------------------------------------------------------------------------------+-- Sorting+--------------------------------------------------------------------------------++sorted : Ord a => List a -> Bool+sorted []      = True+sorted (x::xs) =+  case xs of+    Nil     => True+    (y::ys) => x <= y && sorted (y::ys)++mergeBy : (a -> a -> Ordering) -> List a -> List a -> List a+mergeBy order []      right   = right+mergeBy order left    []      = left+mergeBy order (x::xs) (y::ys) =+  case order x y of+    LT => x :: mergeBy order xs (y::ys)+    _  => y :: mergeBy order (x::xs) ys++merge : Ord a => List a -> List a -> List a+merge = mergeBy compare++%assert_total+sort : Ord a => List a -> List a+sort []  = []+sort [x] = [x]+sort xs  =+  let (x, y) = split xs in+    merge (sort x) (sort y) -- not structurally smaller, hence assert+  where+    splitRec : List a -> List a -> (List a -> List a) -> (List a, List a)+    splitRec (_::_::xs) (y::ys) zs = splitRec xs ys (zs . ((::) y))+    splitRec _          ys      zs = (zs [], ys)++    split : List a -> (List a, List a)+    split xs = splitRec xs xs id++--------------------------------------------------------------------------------+-- Conversions+--------------------------------------------------------------------------------++maybeToList : Maybe a -> List a+maybeToList Nothing  = []+maybeToList (Just j) = [j]++listToMaybe : List a -> Maybe a+listToMaybe []      = Nothing+listToMaybe (x::xs) = Just x++--------------------------------------------------------------------------------+-- Misc+--------------------------------------------------------------------------------++catMaybes : List (Maybe a) -> List a+catMaybes []      = []+catMaybes (x::xs) =+  case x of+    Nothing => catMaybes xs+    Just j  => j :: catMaybes xs++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++-- append+appendNilRightNeutral : (l : List a) ->+  l ++ [] = l+appendNilRightNeutral []      = refl+appendNilRightNeutral (x::xs) =+  let inductiveHypothesis = appendNilRightNeutral xs in+    ?appendNilRightNeutralStepCase++appendAssociative : (l : List a) -> (c : List a) -> (r : List a) ->+  l ++ (c ++ r) = (l ++ c) ++ r+appendAssociative []      c r = refl+appendAssociative (x::xs) c r =+  let inductiveHypothesis = appendAssociative xs c r in+    ?appendAssociativeStepCase++-- length+lengthAppend : (left : List a) -> (right : List a) ->+  length (left ++ right) = length left + length right+lengthAppend []      right = refl+lengthAppend (x::xs) right =+  let inductiveHypothesis = lengthAppend xs right in+    ?lengthAppendStepCase++-- map+mapPreservesLength : (f : a -> b) -> (l : List a) ->+  length (map f l) = length l+mapPreservesLength f []      = refl+mapPreservesLength f (x::xs) =+  let inductiveHypothesis = mapPreservesLength f xs in+    ?mapPreservesLengthStepCase++mapDistributesOverAppend : (f : a -> b) -> (l : List a) -> (r : List a) ->+  map f (l ++ r) = map f l ++ map f r+mapDistributesOverAppend f []      r = refl+mapDistributesOverAppend f (x::xs) r =+  let inductiveHypothesis = mapDistributesOverAppend f xs r in+    ?mapDistributesOverAppendStepCase++mapFusion : (f : b -> c) -> (g : a -> b) -> (l : List a) ->+  map f (map g l) = map (f . g) l+mapFusion f g []      = refl+mapFusion f g (x::xs) =+  let inductiveHypothesis = mapFusion f g xs in+    ?mapFusionStepCase++-- hasAny+hasAnyByNilFalse : (p : a -> a -> Bool) -> (l : List a) ->+  hasAnyBy p [] l = False+hasAnyByNilFalse p []      = refl+hasAnyByNilFalse p (x::xs) =+  let inductiveHypothesis = hasAnyByNilFalse p xs in+    ?hasAnyByNilFalseStepCase++hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False+hasAnyNilFalse l = ?hasAnyNilFalseBody+    +--------------------------------------------------------------------------------+-- Proofs+--------------------------------------------------------------------------------++lengthAppendStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++hasAnyNilFalseBody = proof {+    intros;+    rewrite (hasAnyByNilFalse (==) l);+    trivial;+}++hasAnyByNilFalseStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++initProof = proof {+    intros;+    trivial;+}++lastProof = proof {+    intros;+    trivial;+}++appendNilRightNeutralStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++appendAssociativeStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++mapFusionStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++mapDistributesOverAppendStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++mapPreservesLengthStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++zipWithTailProof = proof {+    intros;+    rewrite (succInjective (length xs) (length ys) p);+    trivial;+}++zipWith3TailProof = proof {+    intros;+    rewrite (succInjective (length xs) (length ys) p);+    trivial;+}++zipWith3TailProof' = proof {+    intros;+    rewrite (succInjective (length ys) (length zs) q);+    trivial;+}+
+ lib/Prelude/Maybe.idr view
@@ -0,0 +1,43 @@+module Prelude.Maybe++import Builtins++data Maybe a+    = Nothing+    | Just a++--------------------------------------------------------------------------------+-- Syntactic tests+--------------------------------------------------------------------------------++isNothing : Maybe a -> Bool+isNothing Nothing  = True+isNothing (Just j) = False++isJust : Maybe a -> Bool+isJust Nothing  = False+isJust (Just j) = True++--------------------------------------------------------------------------------+-- Misc+--------------------------------------------------------------------------------++maybe : |(def : b) -> (a -> b) -> Maybe a -> b+maybe n j Nothing  = n+maybe n j (Just x) = j x++fromMaybe : |(def: a) -> Maybe a -> a+fromMaybe def Nothing  = def+fromMaybe def (Just j) = j++toMaybe : Bool -> a -> Maybe a+toMaybe True  j = Just j+toMaybe False j = Nothing++--------------------------------------------------------------------------------+-- Class instances+--------------------------------------------------------------------------------++maybe_bind : Maybe a -> (a -> Maybe b) -> Maybe b+maybe_bind Nothing  k = Nothing+maybe_bind (Just x) k = k x
+ lib/Prelude/Monad.idr view
@@ -0,0 +1,45 @@+module prelude.monad++-- Monads and Functors++import Builtins+import Prelude.List++%access public++infixl 5 >>=++class Monad (m : Set -> Set) where +    return : a -> m a+    (>>=)  : m a -> (a -> m b) -> m b++class Functor (f : Set -> Set) where +    fmap : (a -> b) -> f a -> f b++class Monad m => MonadPlus (m : Set -> Set) where +    mplus : m a -> m a -> m a+    mzero : m a++guard : MonadPlus m => Bool -> m ()+guard True  = return ()+guard False = mzero++when : Monad m => Bool -> m () -> m ()+when True  f = f+when False _ = return ()++sequence : Monad m => List (m a) -> m (List a)+sequence []        = return []+sequence (x :: xs) = [ x' :: xs' | x' <- x, xs' <- sequence xs ]++sequence_ : Monad m => List (m a) -> m ()+sequence_ [] = return ()+sequence_ (x :: xs) = do x; sequence_ xs++mapM : Monad m => (a -> m b) -> List a -> m (List b)+mapM f xs = sequence (map f xs)++mapM_ : Monad m => (a -> m b) -> List a -> m ()+mapM_ f xs = sequence_ (map f xs)++
+ lib/Prelude/Morphisms.idr view
@@ -0,0 +1,7 @@+module Prelude.Morphisms++data Morphism : Set -> Set -> Set where+    Homo : (a -> b) -> Morphism a b++($) : Morphism a b -> a -> b+(Homo f) $ a = f a
+ lib/Prelude/Nat.idr view
@@ -0,0 +1,843 @@+module Prelude.Nat++import Builtins++import Prelude.Algebra+import Prelude.Cast++%access public+%default total++data Nat+  = O+  | S Nat++--------------------------------------------------------------------------------+-- Syntactic tests+--------------------------------------------------------------------------------++total isZero : Nat -> Bool+isZero O     = True+isZero (S n) = False++total isSucc : Nat -> Bool+isSucc O     = False+isSucc (S n) = True++--------------------------------------------------------------------------------+-- Basic arithmetic functions+--------------------------------------------------------------------------------++total plus : Nat -> Nat -> Nat+plus O right        = right+plus (S left) right = S (plus left right)++total mult : Nat -> Nat -> Nat+mult O right        = O+mult (S left) right = plus right $ mult left right++total minus : Nat -> Nat -> Nat+minus O        right     = O+minus left     O         = left+minus (S left) (S right) = minus left right++total power : Nat -> Nat -> Nat+power base O       = S O+power base (S exp) = mult base $ power base exp++hyper : Nat -> Nat -> Nat -> Nat+hyper O        a b      = S b+hyper (S O)    a O      = a+hyper (S(S O)) a O      = O+hyper n        a O      = S O+hyper (S pn)   a (S pb) = hyper pn a (hyper (S pn) a pb)+++--------------------------------------------------------------------------------+-- Comparisons+--------------------------------------------------------------------------------++data LTE  : Nat -> Nat -> Set where+  lteZero : LTE O    right+  lteSucc : LTE left right -> LTE (S left) (S right)++total GTE : Nat -> Nat -> Set+GTE left right = LTE right left++total LT : Nat -> Nat -> Set+LT left right = LTE (S left) right++total GT : Nat -> Nat -> Set+GT left right = LT right left++total lte : Nat -> Nat -> Bool+lte O        right     = True+lte left     O         = False+lte (S left) (S right) = lte left right++total gte : Nat -> Nat -> Bool+gte left right = lte right left++total lt : Nat -> Nat -> Bool+lt left right = lte (S left) right++total gt : Nat -> Nat -> Bool+gt left right = lt right left++total minimum : Nat -> Nat -> Nat+minimum left right =+  if lte left right then+    left+  else+    right++total maximum : Nat -> Nat -> Nat+maximum left right =+  if lte left right then+    right+  else+    left++--------------------------------------------------------------------------------+-- Type class instances+--------------------------------------------------------------------------------++instance Eq Nat where+  O == O         = True+  (S l) == (S r) = l == r+  _ == _         = False++instance Cast Nat Int where+  cast O     = 0+  cast (S k) = 1 + cast k++instance Ord Nat where+  compare O O         = EQ+  compare O (S k)     = LT+  compare (S k) O     = GT+  compare (S x) (S y) = compare x y++instance Num Nat where+  (+) = plus+  (-) = minus+  (*) = mult++  abs x = x++  fromInteger x = fromInteger' x+    where+      %assert_total+      fromInteger' : Int -> Nat+      fromInteger' 0 = O+      fromInteger' n =+        if (n > 0) then+          S (fromInteger' (n - 1))+        else+          O++record Multiplicative : Set where+  getMultiplicative : Nat -> Multiplicative++record Additive : Set where+  getAdditive : Nat -> Additive++instance Semigroup Multiplicative where+  (<+>) left right = getMultiplicative $ left' * right'+    where+      left'  : Nat+      left'  =+       case left of+          getMultiplicative m => m++      right' : Nat+      right' =+        case right of+          getMultiplicative m => m++instance Semigroup Additive where+  left <+> right = getAdditive $ left' + right'+    where+      left'  : Nat+      left'  =+        case left of+          getAdditive m => m++      right' : Nat+      right' =+        case right of+          getAdditive m => m++instance Monoid Multiplicative where+  neutral = getMultiplicative $ S O++instance Monoid Additive where+  neutral = getAdditive O++instance MeetSemilattice Nat where+  meet = minimum++instance JoinSemilattice Nat where+  join = maximum++instance Lattice Nat where { }++instance BoundedJoinSemilattice Nat where+  bottom = O++--------------------------------------------------------------------------------+-- Auxilliary notions+--------------------------------------------------------------------------------++total pred : Nat -> Nat+pred O     = O+pred (S n) = n++--------------------------------------------------------------------------------+-- Fibonacci and factorial+--------------------------------------------------------------------------------++total fib : Nat -> Nat+fib O         = O+fib (S O)     = S O+fib (S (S n)) = fib (S n) + fib n++--------------------------------------------------------------------------------+-- GCD and LCM+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- Division and modulus+--------------------------------------------------------------------------------++total mod : Nat -> Nat -> Nat+mod left O         = left+mod left (S right) = mod' left left right+  where+    total mod' : Nat -> Nat -> Nat -> Nat+    mod' O        centre right = centre+    mod' (S left) centre right =+      if lte centre right then+        centre+      else+        mod' left (centre - (S right)) right++total div : Nat -> Nat -> Nat+div left O         = S left               -- div by zero+div left (S right) = div' left left right+  where+    total div' : Nat -> Nat -> Nat -> Nat+    div' O        centre right = O+    div' (S left) centre right =+      if lte centre right then+        O+      else+        S (div' left (centre - (S right)) right)++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++-- Succ+total eqSucc : (left : Nat) -> (right : Nat) -> (p : left = right) ->+  S left = S right+eqSucc left _ refl = refl++total succInjective : (left : Nat) -> (right : Nat) -> (p : S left = S right) ->+  left = right+succInjective left _ refl = refl++-- Plus+total plusZeroLeftNeutral : (right : Nat) -> 0 + right = right+plusZeroLeftNeutral right = refl++total plusZeroRightNeutral : (left : Nat) -> left + 0 = left+plusZeroRightNeutral O     = refl+plusZeroRightNeutral (S n) =+  let inductiveHypothesis = plusZeroRightNeutral n in+    ?plusZeroRightNeutralStepCase++total plusSuccRightSucc : (left : Nat) -> (right : Nat) ->+  S (left + right) = left + (S right)+plusSuccRightSucc O right        = refl+plusSuccRightSucc (S left) right =+  let inductiveHypothesis = plusSuccRightSucc left right in+    ?plusSuccRightSuccStepCase++total plusCommutative : (left : Nat) -> (right : Nat) ->+  left + right = right + left+plusCommutative O        right = ?plusCommutativeBaseCase+plusCommutative (S left) right =+  let inductiveHypothesis = plusCommutative left right in+    ?plusCommutativeStepCase++total plusAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->+  left + (centre + right) = (left + centre) + right+plusAssociative O        centre right = refl+plusAssociative (S left) centre right =+  let inductiveHypothesis = plusAssociative left centre right in+    ?plusAssociativeStepCase++total plusConstantRight : (left : Nat) -> (right : Nat) -> (c : Nat) ->+  (p : left = right) -> left + c = right + c+plusConstantRight left _ c refl = refl++total plusConstantLeft : (left : Nat) -> (right : Nat) -> (c : Nat) ->+  (p : left = right) -> c + left = c + right+plusConstantLeft left _ c refl = refl++total plusOneSucc : (right : Nat) -> 1 + right = S right+plusOneSucc n = refl++total plusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) ->+  (p : left + right = left + right') -> right = right'+plusLeftCancel O        right right' p = ?plusLeftCancelBaseCase+plusLeftCancel (S left) right right' p =+  let inductiveHypothesis = plusLeftCancel left right right' in+    ?plusLeftCancelStepCase++total plusRightCancel : (left : Nat) -> (left' : Nat) -> (right : Nat) ->+  (p : left + right = left' + right) -> left = left'+plusRightCancel left left' O         p = ?plusRightCancelBaseCase+plusRightCancel left left' (S right) p =+  let inductiveHypothesis = plusRightCancel left left' right in+    ?plusRightCancelStepCase++total plusLeftLeftRightZero : (left : Nat) -> (right : Nat) ->+  (p : left + right = left) -> right = O+plusLeftLeftRightZero O        right p = ?plusLeftLeftRightZeroBaseCase+plusLeftLeftRightZero (S left) right p =+  let inductiveHypothesis = plusLeftLeftRightZero left right in+    ?plusLeftLeftRightZeroStepCase++-- Mult+total multZeroLeftZero : (right : Nat) -> O * right = O+multZeroLeftZero right = refl++total multZeroRightZero : (left : Nat) -> left * O = O+multZeroRightZero O        = refl+multZeroRightZero (S left) =+  let inductiveHypothesis = multZeroRightZero left in+    ?multZeroRightZeroStepCase++total multRightSuccPlus : (left : Nat) -> (right : Nat) ->+  left * (S right) = left + (left * right)+multRightSuccPlus O        right = refl+multRightSuccPlus (S left) right =+  let inductiveHypothesis = multRightSuccPlus left right in+    ?multRightSuccPlusStepCase++total multLeftSuccPlus : (left : Nat) -> (right : Nat) ->+  (S left) * right = right + (left * right)+multLeftSuccPlus left right = refl++total multCommutative : (left : Nat) -> (right : Nat) ->+  left * right = right * left+multCommutative O right        = ?multCommutativeBaseCase+multCommutative (S left) right =+  let inductiveHypothesis = multCommutative left right in+    ?multCommutativeStepCase++total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->+  left * (centre + right) = (left * centre) + (left * right)+multDistributesOverPlusRight O        centre right = refl+multDistributesOverPlusRight (S left) centre right =+  let inductiveHypothesis = multDistributesOverPlusRight left centre right in+    ?multDistributesOverPlusRightStepCase++total multDistributesOverPlusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) ->+  (left + centre) * right = (left * right) + (centre * right)+multDistributesOverPlusLeft O        centre right = refl+multDistributesOverPlusLeft (S left) centre right =+  let inductiveHypothesis = multDistributesOverPlusLeft left centre right in+    ?multDistributesOverPlusLeftStepCase++total multAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->+  left * (centre * right) = (left * centre) * right+multAssociative O        centre right = refl+multAssociative (S left) centre right =+  let inductiveHypothesis = multAssociative left centre right in+    ?multAssociativeStepCase++total multOneLeftNeutral : (right : Nat) -> 1 * right = right+multOneLeftNeutral O         = refl+multOneLeftNeutral (S right) =+  let inductiveHypothesis = multOneLeftNeutral right in+    ?multOneLeftNeutralStepCase++total multOneRightNeutral : (left : Nat) -> left * 1 = left+multOneRightNeutral O        = refl+multOneRightNeutral (S left) =+  let inductiveHypothesis = multOneRightNeutral left in+    ?multOneRightNeutralStepCase++-- Minus+total minusSuccSucc : (left : Nat) -> (right : Nat) ->+  (S left) - (S right) = left - right+minusSuccSucc left right = refl++total minusZeroLeft : (right : Nat) -> 0 - right = O+minusZeroLeft right = refl++total minusZeroRight : (left : Nat) -> left - 0 = left+minusZeroRight O        = refl+minusZeroRight (S left) = refl++total minusZeroN : (n : Nat) -> O = n - n+minusZeroN O     = refl+minusZeroN (S n) = minusZeroN n++total minusOneSuccN : (n : Nat) -> S O = (S n) - n+minusOneSuccN O     = refl+minusOneSuccN (S n) = minusOneSuccN n++total minusSuccOne : (n : Nat) -> S n - 1 = n+minusSuccOne O     = refl+minusSuccOne (S n) = refl++total minusPlusZero : (n : Nat) -> (m : Nat) -> n - (n + m) = O+minusPlusZero O     m = refl+minusPlusZero (S n) m = minusPlusZero n m++total minusMinusMinusPlus : (left : Nat) -> (centre : Nat) -> (right : Nat) ->+  left - centre - right = left - (centre + right)+minusMinusMinusPlus O        O          right = refl+minusMinusMinusPlus (S left) O          right = refl+minusMinusMinusPlus O        (S centre) right = refl+minusMinusMinusPlus (S left) (S centre) right =+  let inductiveHypothesis = minusMinusMinusPlus left centre right in+    ?minusMinusMinusPlusStepCase++total plusMinusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) ->+  (left + right) - (left + right') = right - right'+plusMinusLeftCancel O right right'        = refl+plusMinusLeftCancel (S left) right right' =+  let inductiveHypothesis = plusMinusLeftCancel left right right' in+    ?plusMinusLeftCancelStepCase++total multDistributesOverMinusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) ->+  (left - centre) * right = (left * right) - (centre * right)+multDistributesOverMinusLeft O        O          right = refl+multDistributesOverMinusLeft (S left) O          right =+  ?multDistributesOverMinusLeftBaseCase+multDistributesOverMinusLeft O        (S centre) right = refl+multDistributesOverMinusLeft (S left) (S centre) right =+  let inductiveHypothesis = multDistributesOverMinusLeft left centre right in+    ?multDistributesOverMinusLeftStepCase++total multDistributesOverMinusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->+  left * (centre - right) = (left * centre) - (left * right)+multDistributesOverMinusRight left centre right =+  ?multDistributesOverMinusRightBody++-- Power+total powerSuccPowerLeft : (base : Nat) -> (exp : Nat) -> power base (S exp) =+  base * (power base exp)+powerSuccPowerLeft base exp = refl++total multPowerPowerPlus : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->+  (power base exp) * (power base exp') = power base (exp + exp')+multPowerPowerPlus base O       exp' = ?multPowerPowerPlusBaseCase+multPowerPowerPlus base (S exp) exp' =+  let inductiveHypothesis = multPowerPowerPlus base exp exp' in+    ?multPowerPowerPlusStepCase++total powerZeroOne : (base : Nat) -> power base 0 = S O+powerZeroOne base = refl++total powerOneNeutral : (base : Nat) -> power base 1 = base+powerOneNeutral O        = refl+powerOneNeutral (S base) =+  let inductiveHypothesis = powerOneNeutral base in+    ?powerOneNeutralStepCase++total powerOneSuccOne : (exp : Nat) -> power 1 exp = S O+powerOneSuccOne O       = refl+powerOneSuccOne (S exp) =+  let inductiveHypothesis = powerOneSuccOne exp in+    ?powerOneSuccOneStepCase++total powerSuccSuccMult : (base : Nat) -> power base 2 = mult base base+powerSuccSuccMult O        = refl+powerSuccSuccMult (S base) =+  let inductiveHypothesis = powerSuccSuccMult base in+    ?powerSuccSuccMultStepCase++total powerPowerMultPower : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->+  power (power base exp) exp' = power base (exp * exp')+powerPowerMultPower base exp O        = ?powerPowerMultPowerBaseCase+powerPowerMultPower base exp (S exp') =+  let inductiveHypothesis = powerPowerMultPower base exp exp' in+    ?powerPowerMultPowerStepCase++-- Pred+total predSucc : (n : Nat) -> pred (S n) = n+predSucc n = refl++total minusSuccPred : (left : Nat) -> (right : Nat) ->+  left - (S right) = pred (left - right)+minusSuccPred O        right = refl+minusSuccPred (S left) O =+  let inductiveHypothesis = minusSuccPred left O in+    ?minusSuccPredStepCase+minusSuccPred (S left) (S right) =+  let inductiveHypothesis = minusSuccPred left right in+    ?minusSuccPredStepCase'++-- boolElim+total boolElimSuccSucc : (cond : Bool) -> (t : Nat) -> (f : Nat) ->+  S (boolElim cond t f) = boolElim cond (S t) (S f)+boolElimSuccSucc True  t f = refl+boolElimSuccSucc False t f = refl++total boolElimPlusPlusLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) ->+  left + (boolElim cond t f) = boolElim cond (left + t) (left + f)+boolElimPlusPlusLeft True  left t f = refl+boolElimPlusPlusLeft False left t f = refl++total boolElimPlusPlusRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) ->+  (boolElim cond t f) + right = boolElim cond (t + right) (f + right)+boolElimPlusPlusRight True  right t f = refl+boolElimPlusPlusRight False right t f = refl++total boolElimMultMultLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) ->+  left * (boolElim cond t f) = boolElim cond (left * t) (left * f)+boolElimMultMultLeft True  left t f = refl+boolElimMultMultLeft False left t f = refl++total boolElimMultMultRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) ->+  (boolElim cond t f) * right = boolElim cond (t * right) (f * right)+boolElimMultMultRight True  right t f = refl+boolElimMultMultRight False right t f = refl++-- Orders+total lteNTrue : (n : Nat) -> lte n n = True+lteNTrue O     = refl+lteNTrue (S n) = lteNTrue n++total lteSuccZeroFalse : (n : Nat) -> lte (S n) O = False+lteSuccZeroFalse O     = refl+lteSuccZeroFalse (S n) = refl++-- Minimum and maximum+total minimumZeroZeroRight : (right : Nat) -> minimum 0 right = O+minimumZeroZeroRight O         = refl+minimumZeroZeroRight (S right) = minimumZeroZeroRight right++total minimumZeroZeroLeft : (left : Nat) -> minimum left 0 = O+minimumZeroZeroLeft O        = refl+minimumZeroZeroLeft (S left) = refl++total minimumSuccSucc : (left : Nat) -> (right : Nat) ->+  minimum (S left) (S right) = S (minimum left right)+minimumSuccSucc O        O         = refl+minimumSuccSucc (S left) O         = refl+minimumSuccSucc O        (S right) = refl+minimumSuccSucc (S left) (S right) =+  let inductiveHypothesis = minimumSuccSucc left right in+    ?minimumSuccSuccStepCase++total minimumCommutative : (left : Nat) -> (right : Nat) ->+  minimum left right = minimum right left+minimumCommutative O        O         = refl+minimumCommutative O        (S right) = refl+minimumCommutative (S left) O         = refl+minimumCommutative (S left) (S right) =+  let inductiveHypothesis = minimumCommutative left right in+    ?minimumCommutativeStepCase++total maximumZeroNRight : (right : Nat) -> maximum O right = right+maximumZeroNRight O         = refl+maximumZeroNRight (S right) = refl++total maximumZeroNLeft : (left : Nat) -> maximum left O = left+maximumZeroNLeft O        = refl+maximumZeroNLeft (S left) = refl++total maximumSuccSucc : (left : Nat) -> (right : Nat) ->+  S (maximum left right) = maximum (S left) (S right)+maximumSuccSucc O        O         = refl+maximumSuccSucc (S left) O         = refl+maximumSuccSucc O        (S right) = refl+maximumSuccSucc (S left) (S right) =+  let inductiveHypothesis = maximumSuccSucc left right in+    ?maximumSuccSuccStepCase++total maximumCommutative : (left : Nat) -> (right : Nat) ->+  maximum left right = maximum right left+maximumCommutative O        O         = refl+maximumCommutative (S left) O         = refl+maximumCommutative O        (S right) = refl+maximumCommutative (S left) (S right) =+  let inductiveHypothesis = maximumCommutative left right in+    ?maximumCommutativeStepCase++-- div and mod+total modZeroZero : (n : Nat) -> mod 0 n = O+modZeroZero O     = refl+modZeroZero (S n) = refl++--------------------------------------------------------------------------------+-- Proofs+--------------------------------------------------------------------------------++powerPowerMultPowerStepCase = proof {+    intros;+    rewrite sym inductiveHypothesis;+    rewrite sym (multRightSuccPlus exp exp');+    rewrite (multPowerPowerPlus base exp (mult exp exp'));+    trivial;+}++powerPowerMultPowerBaseCase = proof {+    intros;+    rewrite sym (multZeroRightZero exp);+    trivial;+}++powerSuccSuccMultStepCase = proof {+    intros;+    rewrite (multOneRightNeutral base);+    rewrite sym (multOneRightNeutral base);+    trivial;+}++powerOneSuccOneStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    rewrite sym (plusZeroRightNeutral (power (S O) exp));+    trivial;+}++powerOneNeutralStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++multAssociativeStepCase = proof {+    intros;+    rewrite sym (multDistributesOverPlusLeft centre (mult left centre) right);+    rewrite inductiveHypothesis;+    trivial;+}++minusSuccPredStepCase' = proof {+    intros;+    rewrite sym inductiveHypothesis;+    trivial;+}++minusSuccPredStepCase = proof {+    intros;+    rewrite (minusZeroRight left);+    trivial;+}++multPowerPowerPlusStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    rewrite (multAssociative base (power base exp) (power base exp'));+    trivial;+}++multPowerPowerPlusBaseCase = proof {+    intros;+    rewrite (plusZeroRightNeutral (power base exp'));+    trivial;+}++multOneRightNeutralStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++multOneLeftNeutralStepCase = proof {+    intros;+    rewrite (plusZeroRightNeutral right);+    trivial;+}++multDistributesOverPlusLeftStepCase = proof {+    intros;+    rewrite sym inductiveHypothesis;+    rewrite sym (plusAssociative right (mult left right) (mult centre right));+    trivial;+}++multDistributesOverPlusRightStepCase = proof {+    intros;+    rewrite sym inductiveHypothesis;+    rewrite sym (plusAssociative (plus centre (mult left centre)) right (mult left right));+    rewrite (plusAssociative centre (mult left centre) right);+    rewrite sym (plusCommutative (mult left centre) right);+    rewrite sym (plusAssociative centre right (mult left centre));+    rewrite sym (plusAssociative (plus centre right) (mult left centre) (mult left right));+    trivial;+}++multCommutativeStepCase = proof {+    intros;+    rewrite sym (multRightSuccPlus right left);+    rewrite inductiveHypothesis;+    trivial;+}++multCommutativeBaseCase = proof {+    intros;+    rewrite (multZeroRightZero right);+    trivial;+}++multRightSuccPlusStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    rewrite sym inductiveHypothesis;+    rewrite sym (plusAssociative right left (mult left right));+    rewrite sym (plusCommutative right left);+    rewrite (plusAssociative left right (mult left right));+    trivial;+}++multZeroRightZeroStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++plusAssociativeStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++plusCommutativeStepCase = proof {+    intros;+    rewrite (plusSuccRightSucc right left);+    rewrite inductiveHypothesis;+    trivial;+}++plusSuccRightSuccStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++plusCommutativeBaseCase = proof {+    intros;+    rewrite sym (plusZeroRightNeutral right);+    trivial;+}++plusZeroRightNeutralStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++maximumCommutativeStepCase = proof {+    intros;+    rewrite (boolElimSuccSucc (lte left right) right left);+    rewrite (boolElimSuccSucc (lte right left) left right);+    rewrite inductiveHypothesis;+    trivial;+}++maximumSuccSuccStepCase = proof {+    intros;+    rewrite sym (boolElimSuccSucc (lte left right) (S right) (S left));+    trivial;+}++minimumCommutativeStepCase = proof {+    intros;+    rewrite (boolElimSuccSucc (lte left right) left right);+    rewrite (boolElimSuccSucc (lte right left) right left);+    rewrite inductiveHypothesis;+    trivial;+}++minimumSuccSuccStepCase = proof {+    intros;+    rewrite (boolElimSuccSucc (lte left right) (S left) (S right));+    trivial;+}++multDistributesOverMinusRightBody = proof {+    intros;+    rewrite sym (multCommutative left (minus centre right));+    rewrite sym (multDistributesOverMinusLeft centre right left);+    rewrite sym (multCommutative centre left);+    rewrite sym (multCommutative right left);+    trivial;+}++multDistributesOverMinusLeftStepCase = proof {+    intros;+    rewrite sym (plusMinusLeftCancel right (mult left right) (mult centre right));+    trivial;+}++multDistributesOverMinusLeftBaseCase = proof {+    intros;+    rewrite (minusZeroRight (plus right (mult left right)));+    trivial;+}++plusMinusLeftCancelStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++minusMinusMinusPlusStepCase = proof {+    intros;+    rewrite inductiveHypothesis;+    trivial;+}++plusLeftLeftRightZeroBaseCase = proof {+    intros;+    rewrite p;+    trivial;+}++plusLeftLeftRightZeroStepCase = proof {+    intros;+    refine inductiveHypothesis;+    let p' = succInjective (plus left right) left p;+    rewrite p';+    trivial;+}++plusRightCancelStepCase = proof {+    intros;+    refine inductiveHypothesis;+    refine succInjective _ _ ?;+    rewrite sym (plusSuccRightSucc left right);+    rewrite sym (plusSuccRightSucc left' right);+    rewrite p;+    trivial;+}++plusRightCancelBaseCase = proof {+    intros;+    rewrite (plusZeroRightNeutral left);+    rewrite (plusZeroRightNeutral left');+    rewrite p;+    trivial;+}++plusLeftCancelStepCase = proof {+    intros;+    let injectiveProof = succInjective (plus left right) (plus left right') p;+    rewrite (inductiveHypothesis injectiveProof);+    trivial;+}++plusLeftCancelBaseCase = proof {+    intros;+    rewrite p;+    trivial;+}
+ lib/Prelude/Strings.idr view
@@ -0,0 +1,92 @@+module Prelude.Strings++import Builtins+import Prelude.List+import Prelude.Chars+import Prelude.Cast++-- Some more complex string operations++data StrM : String -> Set where+    StrNil : StrM ""+    StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs)++%assert_total+strHead' : (x : String) -> so (not (x == "")) -> Char+strHead' x p = prim__strHead x++%assert_total+strTail' : (x : String) -> so (not (x == "")) -> String+strTail' x p = prim__strTail x++-- we need the 'believe_me' because the operations are primitives++%assert_total+strM : (x : String) -> StrM x+strM x with (choose (not (x == "")))+  strM x | (Left p)  = believe_me $ StrCons (strHead' x p) (strTail' x p)+  strM x | (Right p) = believe_me StrNil++unpack : String -> List Char+unpack s with (strM s)+  unpack ""             | StrNil = []+  unpack (strCons x xs) | (StrCons _ _) = x :: unpack xs++pack : List Char -> String+pack [] = ""+pack (x :: xs) = strCons x (pack xs)++instance Cast String (List Char) where+    cast = unpack++instance Cast (List Char) String where+    cast = pack++span : (Char -> Bool) -> String -> (String, String)+span p xs with (strM xs)+  span p ""             | StrNil        = ("", "")+  span p (strCons x xs) | (StrCons _ _) with (p x)+    | True with (span p xs)+      | (ys, zs) = (strCons x ys, zs)+    | False = ("", strCons x xs)++break : (Char -> Bool) -> String -> (String, String)+break p = span (not . p)++split : (Char -> Bool) -> String -> List String+split p xs = map pack (split p (unpack xs))++ltrim : String -> String+ltrim xs with (strM xs)+    ltrim "" | StrNil = ""+    ltrim (strCons x xs) | StrCons _ _+        = if (isSpace x) then (ltrim xs) else (strCons x xs)++trim : String -> String+trim xs = ltrim (reverse (ltrim (reverse xs)))++words' : List Char -> List (List Char)+words' s = case dropWhile isSpace s of+            [] => []+            s' => let (w, s'') = break isSpace s'+                  in w :: words' s''++words : String -> List String+words s = map pack $ words' $ unpack s++partial+foldr1 : (a -> a -> a) -> List a -> a	+foldr1 f [x] = x+foldr1 f (x::xs) = f x (foldr1 f xs)++%assert_total -- due to foldr1, but used safely+unwords' : List (List Char) -> List Char+unwords' [] = []                         +unwords' ws = (foldr1 addSpace ws)+        where+            addSpace : List Char -> List Char -> List Char+            addSpace w s = w ++ (' ' :: s) +          +unwords : List String -> String+unwords = pack . unwords' . map unpack+
+ lib/Prelude/Vect.idr view
@@ -0,0 +1,306 @@+module Prelude.Vect++import Prelude.Fin+import Prelude.List+import Prelude.Nat++%access public+%default total++infixr 7 :: ++data Vect : Set -> Nat -> Set where+  Nil  : Vect a O+  (::) : a -> Vect a n -> Vect a (S n)++--------------------------------------------------------------------------------+-- Indexing into vectors+--------------------------------------------------------------------------------++tail : Vect a (S n) -> Vect a n+tail (x::xs) = xs++head : Vect a (S n) -> a+head (x::xs) = x++last : Vect a (S n) -> a+last (x::[])    = x+last (x::y::ys) = last $ y::ys++init : Vect a (S n) -> Vect a n+init (x::[])    = []+init (x::y::ys) = x :: init (y::ys)++index : Fin n -> Vect a n -> a+index fO     (x::xs) = x+index (fS k) (x::xs) = index k xs+index fO     [] impossible++--------------------------------------------------------------------------------+-- Subvectors+--------------------------------------------------------------------------------++take : Fin n -> Vect a n -> (p ** Vect a p)+take fO     xs      = (_ ** [])+take (fS k) []      impossible+take (fS k) (x::xs) with (take k xs)+  | (_ ** tail) = (_ ** x::tail)++drop : Fin n -> Vect a n -> (p ** Vect a p)+drop fO     xs      = (_ ** xs)+drop (fS k) []      impossible+drop (fS k) (x::xs) = drop k xs++--------------------------------------------------------------------------------+-- Conversions to and from list+--------------------------------------------------------------------------------++toList : Vect a n -> List a+toList []      = []+toList (x::xs) = x :: toList xs++fromList : (l : List a) -> Vect a (length l)+fromList []      = []+fromList (x::xs) = x :: fromList xs++--------------------------------------------------------------------------------+-- Building (bigger) vectors+--------------------------------------------------------------------------------++(++) : Vect a m -> Vect a n -> Vect a (m + n)+(++) []      ys = ys+(++) (x::xs) ys = x :: xs ++ ys++replicate : (n : Nat) -> a -> Vect a n+replicate O     x = []+replicate (S k) x = x :: replicate k x++--------------------------------------------------------------------------------+-- Maps+--------------------------------------------------------------------------------++map : (a -> b) -> Vect a n -> Vect b n+map f []        = []+map f (x::xs) = f x :: map f xs++-- XXX: causes Idris to enter an infinite loop when type checking in the REPL+--mapMaybe : (a -> Maybe b) -> Vect a n -> (p ** Vect b p)+--mapMaybe f []      = (_ ** [])+--mapMaybe f (x::xs) = mapMaybe' (f x) +-- XXX: working around the type restrictions on case statements+--  where+--    mapMaybe' : (Maybe b) -> (n ** Vect b n) -> (p ** Vect b p)+--    mapMaybe' Nothing  (n ** tail) = (n   ** tail)+--    mapMaybe' (Just j) (n ** tail) = (S n ** j::tail)++--------------------------------------------------------------------------------+-- Folds+--------------------------------------------------------------------------------++total foldl : (a -> b -> a) -> a -> Vect b m -> a+foldl f e []      = e+foldl f e (x::xs) = foldl f (f e x) xs++total foldr : (a -> b -> b) -> b -> Vect a m -> b+foldr f e []      = e+foldr f e (x::xs) = f x (foldr f e xs)++--------------------------------------------------------------------------------+-- Special folds+--------------------------------------------------------------------------------++total and : Vect Bool m -> Bool+and = foldr (&&) True++total or : Vect Bool m -> Bool+or = foldr (||) False++total any : (a -> Bool) -> Vect a m -> Bool+any p = or . map p++total all : (a -> Bool) -> Vect a m -> Bool+all p = and . map p++--------------------------------------------------------------------------------+-- Transformations+--------------------------------------------------------------------------------++total reverse : Vect a n -> Vect a n+reverse = reverse' []+  where+    total reverse' : Vect a m -> Vect a n -> Vect a (m + n)+    reverse' acc []      ?= acc+    reverse' acc (x::xs) ?= reverse' (x::acc) xs++total intersperse' : a -> Vect a m -> (p ** Vect a p)+intersperse' sep []      = (_ ** [])+intersperse' sep (y::ys) with (intersperse' sep ys)+  | (_ ** tail) = (_ ** sep::y::tail)++total intersperse : a -> Vect a m -> (p ** Vect a p)+intersperse sep []      = (_ ** [])+intersperse sep (x::xs) with (intersperse' sep xs)+  | (_ ** tail) = (_ ** x::tail)++--------------------------------------------------------------------------------+-- Membership tests+--------------------------------------------------------------------------------++elemBy : (a -> a -> Bool) -> a -> Vect a n -> Bool+elemBy p e []      = False+elemBy p e (x::xs) with (p e x)+  | True  = True+  | False = elemBy p e xs++elem : Eq a => a -> Vect a n -> Bool+elem = elemBy (==)++lookupBy : (a -> a -> Bool) -> a -> Vect (a, b) n -> Maybe b+lookupBy p e []           = Nothing+lookupBy p e ((l, r)::xs) with (p e l)+  | True  = Just r+  | False = lookupBy p e xs++lookup : Eq a => a -> Vect (a, b) n -> Maybe b+lookup = lookupBy (==)++hasAnyBy : (a -> a -> Bool) -> Vect a m -> Vect a n -> Bool+hasAnyBy p elems []      = False+hasAnyBy p elems (x::xs) with (elemBy p x elems)+  | True  = True+  | False = hasAnyBy p elems xs++hasAny : Eq a => Vect a m -> Vect a n -> Bool+hasAny = hasAnyBy (==)++--------------------------------------------------------------------------------+-- Searching with a predicate+--------------------------------------------------------------------------------++find : (a -> Bool) -> Vect a n -> Maybe a+find p []      = Nothing+find p (x::xs) with (p x)+  | True  = Just x+  | False = find p xs++findIndex : (a -> Bool) -> Vect a n -> Maybe Nat+findIndex = findIndex' 0+  where+    findIndex' : Nat -> (a -> Bool) -> Vect a n -> Maybe Nat+    findIndex' cnt p []      = Nothing+    findIndex' cnt p (x::xs) with (p x)+      | True  = Just cnt+      | False = findIndex' (S cnt) p xs++total findIndices : (a -> Bool) -> Vect a m -> (p ** Vect Nat p)+findIndices = findIndices' 0+  where+    total findIndices' : Nat -> (a -> Bool) -> Vect a m -> (p ** Vect Nat p)+    findIndices' cnt p []      = (_ ** [])+    findIndices' cnt p (x::xs) with (findIndices' (S cnt) p xs)+      | (_ ** tail) =+       if p x then+        (_ ** cnt::tail)+       else+        (_ ** tail)++elemIndexBy : (a -> a -> Bool) -> a -> Vect a m -> Maybe Nat+elemIndexBy p e = findIndex $ p e++elemIndex : Eq a => a -> Vect a m -> Maybe Nat+elemIndex = elemIndexBy (==)++total elemIndicesBy : (a -> a -> Bool) -> a -> Vect a m -> (p ** Vect Nat p)+elemIndicesBy p e = findIndices $ p e++total elemIndices : Eq a => a -> Vect a m -> (p ** Vect Nat p)+elemIndices = elemIndicesBy (==)++--------------------------------------------------------------------------------+-- Filters+--------------------------------------------------------------------------------++total filter : (a -> Bool) -> Vect a n -> (p ** Vect a p)+filter p [] = ( _ ** [] )+filter p (x::xs) with (filter p xs)+  | (_ ** tail) =+    if p x then+      (_ ** x::tail)+    else+      (_ ** tail)++nubBy : (a -> a -> Bool) -> Vect a n -> (p ** Vect a p)+nubBy = nubBy' []+  where+    nubBy' : Vect a m -> (a -> a -> Bool) -> Vect a n -> (p ** Vect a p)+    nubBy' acc p []      = (_ ** [])+    nubBy' acc p (x::xs) with (elemBy p x acc)+      | True  = nubBy' acc p xs+      | False with (nubBy' (x::acc) p xs)+        | (_ ** tail) = (_ ** x::tail)++nub : Eq a => Vect a n -> (p ** Vect a p)+nub = nubBy (==)++--------------------------------------------------------------------------------+-- Splitting and breaking lists+--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- Predicates+--------------------------------------------------------------------------------++isPrefixOfBy : (a -> a -> Bool) -> Vect a m -> Vect a n -> Bool+isPrefixOfBy p [] right        = True+isPrefixOfBy p left []         = False+isPrefixOfBy p (x::xs) (y::ys) with (p x y)+  | True  = isPrefixOfBy p xs ys+  | False = False++isPrefixOf : Eq a => Vect a m -> Vect a n -> Bool+isPrefixOf = isPrefixOfBy (==)++isSuffixOfBy : (a -> a -> Bool) -> Vect a m -> Vect a n -> Bool+isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right)++isSuffixOf : Eq a => Vect a m -> Vect a n -> Bool+isSuffixOf = isSuffixOfBy (==)++--------------------------------------------------------------------------------+-- Conversions+--------------------------------------------------------------------------------++total maybeToVect : Maybe a -> (p ** Vect a p)+maybeToVect Nothing  = (_ ** [])+maybeToVect (Just j) = (_ ** [j])++total vectToMaybe : Vect a n -> Maybe a+vectToMaybe []      = Nothing+vectToMaybe (x::xs) = Just x++--------------------------------------------------------------------------------+-- Misc+--------------------------------------------------------------------------------++catMaybes : Vect (Maybe a) n -> (p ** Vect a p)+catMaybes []             = (_ ** [])+catMaybes (Nothing::xs)  = catMaybes xs+catMaybes ((Just j)::xs) with (catMaybes xs)+  | (_ ** tail) = (_ ** j::tail)++--------------------------------------------------------------------------------+-- Proofs+--------------------------------------------------------------------------------++Prelude.Vect.reverse'_lemma_2 = proof {+    intros;+    rewrite (plusSuccRightSucc m n1);+    exact value;+}++Prelude.Vect.reverse'_lemma_1 = proof {+    intros;+    rewrite sym (plusZeroRightNeutral m);+    exact value;+}+
+ lib/System.idr view
@@ -0,0 +1,31 @@+module System++import Prelude++%default partial+%access public++getArgs : IO (List String)+getArgs = do n <- numArgs+             ga' [] 0 n +  where+    numArgs : IO Int+    numArgs = mkForeign (FFun "idris_numArgs" [FPtr] FInt) prim__vm++    getArg : Int -> IO String+    getArg x = mkForeign (FFun "idris_getArg" [FPtr, FInt] (FAny String)) prim__vm x++    ga' : List String -> Int -> Int -> IO (List String)+    ga' acc i n = if (i == n) then (return $ reverse acc) else+                    do arg <- getArg i+                       ga' (arg :: acc) (i+1) n++getEnv : String -> IO String+getEnv x = mkForeign (FFun "getenv" [FString] FString) x++exit : Int -> IO ()+exit code = mkForeign (FFun "exit" [FInt] FUnit) code++usleep : Int -> IO ()+usleep i = mkForeign (FFun "usleep" [FInt] FUnit) i+
lib/base.ipkg view
@@ -1,15 +1,16 @@ package base -opts = "--noprelude"-modules = builtins, prelude, io, system,+opts = "--noprelude --total"+modules = Builtins, Prelude, IO, System, -          prelude.algebra, prelude.cast, prelude.nat, prelude.fin,-          prelude.list, prelude.maybe, prelude.monad, prelude.applicative,-          prelude.either, prelude.vect, prelude.strings, prelude.char,-          prelude.heap, prelude.complex,+          Prelude.Algebra, Prelude.Cast, Prelude.Nat, Prelude.Fin,+          Prelude.List, Prelude.Maybe, Prelude.Monad, Prelude.Applicative,+          Prelude.Either, Prelude.Vect, Prelude.Strings, Prelude.Chars, Prelude.Heap,+          Prelude.Complex, Prelude.Morphisms, -          network.cgi,+          Network.Cgi, -          language.reflection,+          Language.Reflection, -          control.monad.identity, control.monad.state+          Control.Monad.Identity, Control.Monad.State, Control.Category,+          Control.Arrow
− lib/builtins.idr 
@@ -1,266 +0,0 @@-%access public--data Exists : (a : Set) -> (P : a -> Set) -> Set where-    Ex_intro : {P : a -> Set} -> (x : a) -> P x -> Exists a P--getWitness : {P : a -> Set} -> Exists a P -> a-getWitness (a ** v) = a--getProof : {P : a -> Set} -> (s : Exists a P) -> P (getWitness s)-getProof (a ** v) = v--FalseElim : _|_ -> a---- For rewrite tactic-replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Set} -> x = y -> P x -> P y-replace refl prf = prf--sym : {l:a} -> {r:a} -> l = r -> r = l-sym refl = refl--lazy : a -> a-lazy x = x -- compiled specially--malloc : Int -> a -> a-malloc size x = x -- compiled specially--trace_malloc : a -> a-trace_malloc x = x -- compiled specially--believe_me : a -> b -- compiled specially as id, use with care!-believe_me x = prim__believe_me _ _ x--namespace builtins {--id : a -> a-id x = x--const : a -> b -> a-const x _ = x--fst : (s, t) -> s-fst (x, y) = x--snd : (a, b) -> b-snd (x, y) = y--infixl 9 .--(.) : (b -> c) -> (a -> b) -> a -> c-(.) f g x = f (g x)--flip : (a -> b -> c) -> b -> a -> c-flip f x y = f y x--infixr 1 $--($) : (a -> b) -> a -> b-f $ a = f a--cong : {f : t -> u} -> (a = b) -> f a = f b-cong refl = refl--data Bool = False | True--boolElim : (x:Bool) -> |(t : a) -> |(f : a) -> a -boolElim True  t e = t-boolElim False t e = e--data so : Bool -> Set where oh : so True--syntax if [test] then [t] else [e] = boolElim test t e-syntax [test] "?" [t] ":" [e] = if test then t else e--infixl 4 &&, ||--(||) : Bool -> Bool -> Bool-(||) False x = x-(||) True _  = True--(&&) : Bool -> Bool -> Bool-(&&) True x  = x-(&&) False _ = False--not : Bool -> Bool-not True = False-not False = True--infixl 5 ==, /=-infixl 6 <, <=, >, >=-infixl 7 <<, >>-infixl 8 +,-,++-infixl 9 *,/----- Numeric operators--intToBool : Int -> Bool-intToBool 0 = False-intToBool x = True--boolOp : (a -> a -> Int) -> a -> a -> Bool-boolOp op x y = intToBool (op x y) --class Eq a where-    (==) : a -> a -> Bool-    (/=) : a -> a -> Bool--    x /= y = not (x == y)-    x == y = not (x /= y)--instance Eq Int where -    (==) = boolOp prim__eqInt--instance Eq Integer where-    (==) = boolOp prim__eqBigInt--instance Eq Float where-    (==) = boolOp prim__eqFloat--instance Eq Char where-    (==) = boolOp prim__eqChar--instance Eq String where-    (==) = boolOp prim__eqString--instance (Eq a, Eq b) => Eq (a, b) where-  (==) (a, c) (b, d) = (a == b) && (c == d)---data Ordering = LT | EQ | GT--instance Eq Ordering where-    LT == LT = True-    EQ == EQ = True-    GT == GT = True-    _  == _  = False--class Eq a => Ord a where -    compare : a -> a -> Ordering--    (<) : a -> a -> Bool-    (<) x y with (compare x y) -        (<) x y | LT = True-        (<) x y | _  = False--    (>) : a -> a -> Bool-    (>) x y with (compare x y)-        (>) x y | GT = True-        (>) x y | _  = False--    (<=) : a -> a -> Bool-    (<=) x y = x < y || x == y--    (>=) : a -> a -> Bool-    (>=) x y = x > y || x == y--    max : a -> a -> a-    max x y = if (x > y) then x else y--    min : a -> a -> a-    min x y = if (x < y) then x else y----instance Ord Int where -    compare x y = if (x == y) then EQ else-                  if (boolOp prim__ltInt x y) then LT else-                  GT---instance Ord Integer where -    compare x y = if (x == y) then EQ else-                  if (boolOp prim__ltBigInt x y) then LT else-                  GT---instance Ord Float where -    compare x y = if (x == y) then EQ else-                  if (boolOp prim__ltFloat x y) then LT else-                  GT---instance Ord Char where -    compare x y = if (x == y) then EQ else-                  if (boolOp prim__ltChar x y) then LT else-                  GT---instance Ord String where -    compare x y = if (x == y) then EQ else-                  if (boolOp prim__ltString x y) then LT else-                  GT---instance (Ord a, Ord b) => Ord (a, b) where-  compare (xl, xr) (yl, yr) =-    if xl /= yl-      then compare xl yl-      else compare xr yr---class Num a where -    (+) : a -> a -> a-    (-) : a -> a -> a-    (*) : a -> a -> a--    abs : a -> a-    fromInteger : Int -> a----instance Num Int where -    (+) = prim__addInt-    (-) = prim__subInt-    (*) = prim__mulInt--    fromInteger = id-    abs x = if x<0 then -x else x---instance Num Integer where -    (+) = prim__addBigInt-    (-) = prim__subBigInt-    (*) = prim__mulBigInt--    abs x = if x<0 then -x else x-    fromInteger = prim__intToBigInt---instance Num Float where -    (+) = prim__addFloat-    (-) = prim__subFloat-    (*) = prim__mulFloat--    abs x = if x<0 then -x else x-    fromInteger = prim__intToFloat ---div : Int -> Int -> Int-div = prim__divInt---(/) : Float -> Float -> Float-(/) = prim__divFloat----- string operators--(++) : String -> String -> String-(++) = prim__concat--strHead : String -> Char-strHead = prim__strHead--strTail : String -> String-strTail = prim__strTail--strCons : Char -> String -> String-strCons = prim__strCons--strIndex : String -> Int -> Char-strIndex = prim__strIndex--reverse : String -> String-reverse = prim__strRev--}-
− lib/checkall.idr 
@@ -1,31 +0,0 @@-module checkall---- This file just exists to typecheck all the prelude modules--- Add imports here --import builtins-import prelude-import io-import system--import prelude.algebra-import prelude.cast-import prelude.nat-import prelude.fin-import prelude.list-import prelude.maybe-import prelude.monad-import prelude.applicative-import prelude.either-import prelude.vect-import prelude.strings-import prelude.char-import prelude.heap-import prelude.complex--import network.cgi --import language.reflection--import control.monad.identity-import control.monad.state
− lib/control/monad/identity.idr 
@@ -1,10 +0,0 @@-module control.monad.identity--import prelude.monad --public record Identity : Set -> Set where-    Id : (runIdentity : a) -> Identity a--instance Monad Identity where-    return x = Id x-    (Id x) >>= k = k x
− lib/control/monad/state.idr 
@@ -1,29 +0,0 @@-module control.monad.state--import control.monad.identity-import prelude.monad--%access public--class Monad m => MonadState s (m : Set -> Set) where-    get : m s-    put : s -> m ()--record StateT : Set -> (Set -> Set) -> Set -> Set where-    ST : {m : Set -> Set} ->-         (runStateT : s -> m (a, s)) -> StateT s m a--instance Monad m => Monad (StateT s m) where-    return x = ST (\st => return (x, st))--    (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-    get   = ST (\x => return (x, x))-    put x = ST (\y => return ((), x)) --State : Set -> Set -> Set-State s a = StateT s Identity a-
− lib/io.idr 
@@ -1,53 +0,0 @@-import prelude.list--%access public--abstract data IO a = prim__IO a--abstract-io_bind : IO a -> (a -> IO b) -> IO b-io_bind (prim__IO v) k = k v--unsafePerformIO : IO a -> a--- compiled as primitive--abstract-io_return : a -> IO a-io_return x = prim__IO x---- This may seem pointless, but we can use it to force an--- evaluation of main that Epic wouldn't otherwise do...--run__IO : IO () -> IO ()-run__IO v = io_bind v (\v' => io_return v')--data FTy = FInt | FFloat | FChar | FString | FPtr | FAny Set | FUnit--interpFTy : FTy -> Set-interpFTy FInt     = Int-interpFTy FFloat   = Float-interpFTy FChar    = Char-interpFTy FString  = String-interpFTy FPtr     = Ptr-interpFTy (FAny t) = t-interpFTy FUnit    = ()--ForeignTy : (xs:List FTy) -> (t:FTy) -> Set-ForeignTy xs t = mkForeign' (reverse xs) (IO (interpFTy t)) where -   mkForeign' : List FTy -> Set -> Set-   mkForeign' Nil ty       = ty-   mkForeign' (s :: ss) ty = mkForeign' ss (interpFTy s -> ty)---data Foreign : Set -> Set where-    FFun : String -> (xs:List FTy) -> (t:FTy) -> -           Foreign (ForeignTy xs t)--mkForeign : Foreign x -> x-mkLazyForeign : Foreign x -> x--- mkForeign and mkLazyForeign compiled as primitives--fork : |(thread:IO ()) -> IO Ptr-fork x = io_return prim__vm -- compiled specially--
− lib/language/reflection.idr 
@@ -1,11 +0,0 @@-module language.reflection--TTName : Set-TTName = String--data TT = Var TTName-        | Lam TTName TT TT-        | Pi  TTName TT TT-        | Let TTName TT TT TT-        | App TTName TT TT-
− lib/network/cgi.idr 
@@ -1,127 +0,0 @@-module network.cgi--import system--public-Vars : Set-Vars = List (String, String)--record CGIInfo : Set where-       CGISt : (GET : Vars) ->-               (POST : Vars) ->-               (Cookies : Vars) ->-               (UserAgent : String) ->-               (Headers : String) ->-               (Output : String) -> CGIInfo--add_Headers : String -> CGIInfo -> CGIInfo-add_Headers str st = record { Headers = Headers st ++ str } st--add_Output : String -> CGIInfo -> CGIInfo-add_Output str st = record { Output = Output st ++ str } st--abstract-data CGI : Set -> Set where-    MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a--getAction : CGI a -> CGIInfo -> IO (a, CGIInfo)-getAction (MkCGI act) = act--instance Monad CGI where {-    (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s-                                        getAction (k (fst v)) (snd v))--    return v = MkCGI (\s => return (v, s))-}--setInfo : CGIInfo -> CGI ()-setInfo i = MkCGI (\s => return ((), i))--getInfo : CGI CGIInfo-getInfo = MkCGI (\s => return (s, s))--abstract-lift : IO a -> CGI a -lift op = MkCGI (\st => do { x <- op-                             return (x, st) } ) --abstract-output : String -> CGI ()-output s = do i <- getInfo-              setInfo (add_Output s i)--abstract-queryVars : CGI Vars-queryVars = do i <- getInfo-               return (GET i)--abstract-postVars : CGI Vars-postVars = do i <- getInfo-              return (POST i)--abstract-cookieVars : CGI Vars-cookieVars = do i <- getInfo-                return (Cookies i)--abstract-queryVar : String -> CGI (Maybe String)-queryVar x = do vs <- queryVars-                return (lookup x vs)--getOutput : CGI String-getOutput = do i <- getInfo-               return (Output i)--getHeaders : CGI String-getHeaders = do i <- getInfo-                return (Headers i)--abstract-flushHeaders : CGI ()-flushHeaders = do o <- getHeaders-                  lift (putStrLn o)--abstract-flush : CGI ()-flush = do o <- getOutput-           lift (putStr o) --getVars : List Char -> String -> List (String, String)-getVars seps query = mapMaybe readVar (split (\x => elem x seps) query) -  where-    readVar : String -> Maybe (String, String)-    readVar xs with (split (\x => x == '=') xs)-        | [k, v] = Just (trim k, trim v)-        | _      = Nothing--getContent : Int -> IO String-getContent x = getC x "" where-    getC : Int -> String -> IO String-    getC 0 acc = return $ reverse acc-    getC n acc = do x <- getChar-                    getC (n-1) (strCons x acc)--abstract-runCGI : CGI a -> IO a-runCGI prog = do -    clen_in <- getEnv "CONTENT_LENGTH"-    let clen = prim__strToInt clen_in-    content <- getContent clen-    query   <- getEnv "QUERY_STRING"-    cookie  <- getEnv "HTTP_COOKIE"-    agent   <- getEnv "HTTP_USER_AGENT"--    let get_vars  = getVars ['&',';'] query-    let post_vars = getVars ['&'] content-    let cookies   = getVars [';'] cookie--    (v, st) <- getAction prog (CGISt get_vars post_vars cookies agent -                 "Content-type: text/html\n" -                 "")-    putStrLn (Headers st)-    putStr (Output st)-    return v--
− lib/prelude.idr 
@@ -1,278 +0,0 @@-module prelude--import builtins-import io--import prelude.cast-import prelude.nat-import prelude.fin-import prelude.list-import prelude.maybe-import prelude.monad-import prelude.applicative-import prelude.either-import prelude.vect-import prelude.strings-import prelude.char--%access public---- Show and instances--class Show a where -    show : a -> String--instance Show Nat where -    show O = "O"-    show (S k) = "s" ++ show k--instance Show Int where -    show = prim__intToStr--instance Show Integer where -    show = prim__bigIntToStr--instance Show Float where -    show = prim__floatToStr--instance Show Char where -    show x = strCons x "" --instance Show String where -    show = id--instance Show Bool where -    show True = "True"-    show False = "False"--instance (Show a, Show b) => Show (a, b) where -    show (x, y) = "(" ++ show x ++ ", " ++ show y ++ ")"--instance Show a => Show (List a) where -    show xs = "[" ++ show' "" xs ++ "]" where -        show' : String -> List a -> String-        show' acc []        = acc-        show' acc [x]       = acc ++ show x-        show' acc (x :: xs) = show' (acc ++ show x ++ ", ") xs--instance Show a => Show (Vect a n) where -    show xs = "[" ++ show' xs ++ "]" where -        show' : Vect a m -> String-        show' []        = ""-        show' [x]       = show x-        show' (x :: xs) = show x ++ ", " ++ show' xs--instance Show a => Show (Maybe a) where -    show Nothing = "Nothing"-    show (Just x) = "Just " ++ show x------ Monad instances--instance Monad IO where -    return t = io_return t-    b >>= k = io_bind b k--instance Monad Maybe where -    return t = Just t--    Nothing  >>= k = Nothing-    (Just x) >>= k = k x--instance MonadPlus Maybe where -    mzero = Nothing--    mplus (Just x) _       = Just x-    mplus Nothing (Just y) = Just y-    mplus Nothing Nothing  = Nothing--instance Monad List where -    return x = [x]-    m >>= f = concatMap f m--instance MonadPlus List where -    mzero = []-    mplus = (++)------ Functor instances--instance Functor Maybe where -    fmap f (Just x) = Just (f x)-    fmap f Nothing  = Nothing--instance Functor List where -    fmap = map------ Applicative instances--instance Applicative Maybe where-    pure = Just--    (Just f) <$> (Just a) = Just (f a)-    _        <$> _        = Nothing------- some mathematical operations--%include "math.h"-%lib "m"--exp : Float -> Float-exp x = prim__floatExp x--log : Float -> Float-log x = prim__floatLog x--pi : Float-pi = 3.141592653589793--sin : Float -> Float-sin x = prim__floatSin x--cos : Float -> Float-cos x = prim__floatCos x--tan : Float -> Float-tan x = prim__floatTan x--asin : Float -> Float-asin x = prim__floatASin x--acos : Float -> Float-acos x = prim__floatACos x--atan : Float -> Float-atan x = prim__floatATan x--atan2 : Float -> Float -> Float-atan2 y x = atan (y/x)--sqrt : Float -> Float-sqrt x = prim__floatSqrt x--floor : Float -> Float-floor x = prim__floatFloor x--ceiling : Float -> Float-ceiling x = prim__floatCeil x------ Ranges--count : (Ord a, Num a) => a -> a -> a -> List a-count a inc b = if a <= b then a :: count (a + inc) inc b-                          else []-  -countFrom : (Ord a, Num a) => a -> a -> List a-countFrom a inc = a :: lazy (countFrom (a + inc) inc)-  -syntax "[" [start] ".." [end] "]" -     = count start 1 end -syntax "[" [start] "," [next] ".." [end] "]" -     = count start (next - start) end --syntax "[" [start] "..]" -     = countFrom start 1-syntax "[" [start] "," [next] "..]" -     = countFrom start (next - start)------ More utilities--sum : Num a => List a -> a-sum = foldl (+) 0--prod : Num a => List a -> a-prod = foldl (*) 1------ some basic io--putStr : String -> IO ()-putStr x = mkForeign (FFun "putStr" [FString] FUnit) x--putStrLn : String -> IO ()-putStrLn x = putStr (x ++ "\n")--print : Show a => a -> IO ()-print x = putStrLn (show x)--getLine : IO String-getLine = return (prim__readString prim__stdin)--putChar : Char -> IO ()-putChar c = mkForeign (FFun "putchar" [FChar] FUnit) c--getChar : IO Char-getChar = mkForeign (FFun "getchar" [] FChar)------ some basic file handling--abstract -data File = FHandle Ptr--do_fopen : String -> String -> IO Ptr-do_fopen f m = mkForeign (FFun "fileOpen" [FString, FString] FPtr) f m--fopen : String -> String -> IO File-fopen f m = do h <- do_fopen f m-               return (FHandle h) --data Mode = Read | Write | ReadWrite--openFile : String -> Mode -> IO File-openFile f m = fopen f (modeStr m) where -  modeStr : Mode -> String-  modeStr Read  = "r"-  modeStr Write = "w"-  modeStr ReadWrite = "r+"--do_fclose : Ptr -> IO ()-do_fclose h = mkForeign (FFun "fileClose" [FPtr] FUnit) h--closeFile : File -> IO ()-closeFile (FHandle h) = do_fclose h--do_fread : Ptr -> IO String-do_fread h = return (prim__readString h)--fread : File -> IO String-fread (FHandle h) = do_fread h--do_fwrite : Ptr -> String -> IO ()-do_fwrite h s = mkForeign (FFun "fputStr" [FPtr, FString] FUnit) h s--fwrite : File -> String -> IO ()-fwrite (FHandle h) s = do_fwrite h s--do_feof : Ptr -> IO Int-do_feof h = mkForeign (FFun "feof" [FPtr] FInt) h--feof : File -> IO Bool-feof (FHandle h) = do eof <- do_feof h-                      return (not (eof == 0)) --nullPtr : Ptr -> IO Bool-nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p -               return (ok /= 0);--validFile : File -> IO Bool-validFile (FHandle h) = do x <- nullPtr h-                           return (not x)--while : |(test : IO Bool) -> |(body : IO ()) -> IO ()-while t b = do v <- t-               if v then do b-                            while t b-                    else return ()-               --readFile : String -> IO String-readFile fn = do h <- openFile fn Read-                 c <- readFile' h ""-                 closeFile h-                 return c-  where -    readFile' : File -> String -> IO String-    readFile' h contents = -       do x <- feof h-          if not x then do l <- fread h-                           readFile' h (contents ++ l)-                   else return contents-
− lib/prelude/algebra.idr 
@@ -1,257 +0,0 @@-module prelude.algebra--import builtins---- XXX: change?-infixl 6 <->-infixl 6 <+>-infixl 6 <*>--%access public------------------------------------------------------------------------------------- A modest class hierarchy------------------------------------------------------------------------------------- Sets equipped with a single binary operation that is associative.  Must--- satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c-class Semigroup a where-  (<+>) : a -> a -> a--class Semigroup a => VerifiedSemigroup a where-  semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r---- Sets equipped with a single binary operation that is associative, along with--- a neutral element for that binary operation.  Must satisfy the following--- laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a-class Semigroup a => Monoid a where-  neutral : a--class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where-  monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l-  monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r---- Sets equipped with a single binary operation that is associative, along with--- a neutral element for that binary operation and inverses for all elements.--- Must satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral-class Monoid a => Group a where-  inverse : a -> a--class (VerifiedMonoid a, Group a) => VerifiedGroup a where-  groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral-  groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral--(<->) : Group a => a -> a -> a-(<->) left right = left <+> (inverse right)---- Sets equipped with a single binary operation that is associative and--- commutative, along with a neutral element for that binary operation and--- inverses for all elements. Must satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Commutativity of <+>:---     forall a b,   a <+> b         == b <+> a---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral-class Group a => AbelianGroup a where { }--class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where-  abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l---- Sets equipped with two binary operations, one associative and commutative--- supplied with a neutral element, and the other associative, with--- distributivity laws relating the two operations.  Must satisfy the following--- laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Commutativity of <+>:---     forall a b,   a <+> b         == b <+> a---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral---   Associativity of <*>:---     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c---   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-  (<*>) : a -> a -> a--class (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where-  ringOpIsAssociative   : (l, c, r : a) -> l <*> (c <*> r) = (l <*> c) <*> r-  ringOpIsDistributiveL : (l, c, r : a) -> l <*> (c <+> r) = (l <*> c) <+> (l <*> r)-  ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <*> r = (l <*> r) <+> (l <*> c)---- Sets equipped with two binary operations, one associative and commutative--- supplied with a neutral element, and the other associative supplied with a--- neutral element, with distributivity laws relating the two operations.  Must--- satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Commutativity of <+>:---     forall a b,   a <+> b         == b <+> a---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral---   Associativity of <*>:---     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c---   Neutral for <*>:---     forall a,     a <*> unity     == a---     forall a,     unity <*> a     == a---   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-  unity : a--class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where-  ringWithUnityIsUnityL : (l : a) -> l <*> unity = l-  ringWithUnityIsUnityR : (r : a) -> unity <*> r = r---- Sets equipped with a binary operation that is commutative, associative and--- idempotent.  Must satisfy the following laws:---   Associativity of join:---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of join:---     forall a b,   join a b          == join b a---   Idempotency of join:---     forall a,     join a a          == a---  Join semilattices capture the notion of sets with a "least upper bound".-class JoinSemilattice a where-  join : a -> a -> a--class JoinSemilattice a => VerifiedJoinSemilattice a where-  joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r-  joinSemilatticeJoinIsCommutative : (l, r : a)    -> join l r = join r l-  joinSemilatticeJoinIsIdempotent  : (e : a)       -> join e e = e---- Sets equipped with a binary operation that is commutative, associative and--- idempotent.  Must satisfy the following laws:---   Associativity of meet:---     forall a b c, meet a (meet b c) == meet (meet a b) c---   Commutativity of meet:---     forall a b,   meet a b          == meet b a---   Idempotency of meet:---     forall a,     meet a a          == a---  Meet semilattices capture the notion of sets with a "greatest lower bound".-class MeetSemilattice a where-  meet : a -> a -> a--class MeetSemilattice a => VerifiedMeetSemilattice a where-  meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r-  meetSemilatticeMeetIsCommutative : (l, r : a)    -> meet l r = meet r l-  meetSemilatticeMeetIsIdempotent  : (e : a)       -> meet e e = e---- Sets equipped with a binary operation that is commutative, associative and--- idempotent and supplied with a neutral element.  Must satisfy the following--- laws:---   Associativity of join:---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of join:---     forall a b,   join a b          == join b a---   Idempotency of join:---     forall a,     join a a          == a---   Bottom:---     forall a,     join a bottom     == bottom---  Join semilattices capture the notion of sets with a "least upper bound"---  equipped with a "bottom" element.-class JoinSemilattice a => BoundedJoinSemilattice a where-  bottom  : a--class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where-  boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = bottom---- Sets equipped with a binary operation that is commutative, associative and--- idempotent and supplied with a neutral element.  Must satisfy the following--- laws:---   Associativity of meet:---     forall a b c, meet a (meet b c) == meet (meet a b) c---   Commutativity of meet:---     forall a b,   meet a b          == meet b a---   Idempotency of meet:---     forall a,     meet a a          == a---   Top:---     forall a,     meet a top        == top---  Meet semilattices capture the notion of sets with a "greatest lower bound"---  equipped with a "top" element.-class MeetSemilattice a => BoundedMeetSemilattice a where-  top : a--class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where-  boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = top---- Sets equipped with two binary operations that are both commutative,--- associative and idempotent, along with absorbtion laws for relating the two--- binary operations.  Must satisfy the following:---   Associativity of meet and join:---     forall a b c, meet a (meet b c) == meet (meet a b) c---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of meet and join:---     forall a b,   meet a b          == meet b a---     forall a b,   join a b          == join b a---   Idempotency of meet and join:---     forall a,     meet a a          == a---     forall a,     join a a          == a---   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 { }--class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where-  latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l-  latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l---- Sets equipped with two binary operations that are both commutative,--- associative and idempotent and supplied with neutral elements, along with--- absorbtion laws for relating the two binary operations.  Must satisfy the--- following:---   Associativity of meet and join:---     forall a b c, meet a (meet b c) == meet (meet a b) c---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of meet and join:---     forall a b,   meet a b          == meet b a---     forall a b,   join a b          == join b a---   Idempotency of meet and join:---     forall a,     meet a a          == a---     forall a,     join a a          == a---   Absorbtion laws for meet and join:---     forall a b,   meet a (join a b) == a---     forall a b,   join a (meet a b) == a---   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 { }--class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }-  -  --- XXX todo:---   Fields and vector spaces.---   Structures where "abs" make sense.---   Euclidean domains, etc.---   Where to put fromInteger and fromRational?
− lib/prelude/applicative.idr 
@@ -1,13 +0,0 @@-module prelude.applicative--import builtins------ Applicative functors/Idioms--infixl 2 <$> --class Applicative (f : Set -> Set) where -    pure  : a -> f a-    (<$>) : f (a -> b) -> f a -> f b --
− lib/prelude/cast.idr 
@@ -1,49 +0,0 @@-module prelude.cast--class Cast from to where-    cast : from -> to---- String casts--instance Cast String Int where-    cast = prim__strToInt--instance Cast String Float where-    cast = prim__strToFloat--instance Cast String Integer where-    cast = prim__strToBigInt---- Int casts--instance Cast Int String where-    cast = prim__intToStr--instance Cast Int Float where-    cast = prim__intToFloat--instance Cast Int Integer where-    cast = prim__intToBigInt --instance Cast Int Char where-    cast = prim__intToChar---- Float casts--instance Cast Float String where-    cast = prim__floatToStr--instance Cast Float Int where-    cast = prim__floatToInt---- Integer casts--instance Cast Integer String where-    cast = prim__bigIntToStr---- Char casts--instance Cast Char Int where-    cast = prim__charToInt--
− lib/prelude/char.idr 
@@ -1,34 +0,0 @@-module prelude.char--import builtins--isUpper : Char -> Bool-isUpper x = x >= 'A' && x <= 'Z'--isLower : Char -> Bool-isLower x = x >= 'a' && x <= 'z'--isAlpha : Char -> Bool-isAlpha x = isUpper x || isLower x --isDigit : Char -> Bool-isDigit x = (x >= '0' && x <= '9')--isAlphaNum : Char -> Bool-isAlphaNum x = isDigit x || isAlpha x--isSpace : Char -> Bool-isSpace x = x == ' '  || x == '\t' || x == '\r' ||-            x == '\n' || x == '\f' || x == '\v' ||-            x == '\xa0'--toUpper : Char -> Char-toUpper x = if (isLower x) -               then (prim__intToChar (prim__charToInt x - 32))-               else x--toLower : Char -> Char-toLower x = if (isUpper x)-               then (prim__intToChar (prim__charToInt x + 32))-               else x-
− lib/prelude/complex.idr 
@@ -1,70 +0,0 @@-{--  © 2012 Copyright Mekeor Melire--}---module prelude.complex--import builtins-import prelude-------------------------------- Rectangular form --infix 6 :+-data Complex a = (:+) a a--realPart : Complex a -> a-realPart (r:+i) = r--imagPart : Complex a -> a-imagPart (r:+i) = i--instance Eq a => Eq (Complex a) where-    (==) a b = realPart a == realPart b && imagPart a == imagPart b--instance Show a => Show (Complex a) where-    show (r:+i) = "("++show r++":+"++show i++")"------ when we have a type class 'Fractional' (which contains Float and Double),--- we can do:-{--instance 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)-                        in-                          (real:+imag)--}---------------------------------- Polarform--mkPolar : Float -> Float -> Complex Float-mkPolar radius angle = radius * cos angle :+ radius * sin angle--cis : Float -> Complex Float-cis angle = cos angle :+ sin angle--magnitude : Complex Float -> Float-magnitude (r:+i) = sqrt (r*r+i*i)--phase : Complex Float -> Float-phase (x:+y) = atan2 y x--------------------------------- Conjugate--conjugate : Num a => Complex a -> Complex a-conjugate (r:+i) = (r :+ (0-i))---- We can't do "instance Num a => Num (Complex a)" because--- we need "abs" which needs "magnitude" which needs "sqrt" which needs Float-instance Num (Complex Float) where-    (+) (a:+b) (c:+d) = ((a+b):+(c+d))-    (-) (a:+b) (c:+d) = ((a-b):+(c-d))-    (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d))-    fromInteger x = (fromInteger x:+0)-    abs (a:+b) = (magnitude (a:+b):+0)
− lib/prelude/either.idr 
@@ -1,63 +0,0 @@-module prelude.either--import builtins--import prelude.maybe-import prelude.list--data Either a b-  = Left a-  | Right b------------------------------------------------------------------------------------- Syntactic tests-----------------------------------------------------------------------------------isLeft : Either a b -> Bool-isLeft (Left l)  = True-isLeft (Right r) = False--isRight : Either a b -> Bool-isRight (Left l)  = False-isRight (Right r) = True------------------------------------------------------------------------------------- Misc.-----------------------------------------------------------------------------------choose : (b : Bool) -> Either (so b) (so (not b))-choose True  = Left oh-choose False = Right oh--either : Either a b -> (a -> c) -> (b -> c) -> c-either (Left x)  l r = l x-either (Right x) l r = r x--lefts : List (Either a b) -> List a-lefts []      = []-lefts (x::xs) =-  case x of-    Left  l => l :: lefts xs-    Right r => lefts xs--rights : List (Either a b) -> List b-rights []      = []-rights (x::xs) =-  case x of-    Left  l => rights xs-    Right r => r :: rights xs--partitionEithers : List (Either a b) -> (List a, List b)-partitionEithers l = (lefts l, rights l)-    -fromEither : Either a a -> a-fromEither (Left l)  = l-fromEither (Right r) = r------------------------------------------------------------------------------------- Conversions-----------------------------------------------------------------------------------maybeToEither : e -> Maybe a -> Either e a-maybeToEither def (Just j) = Right j-maybeToEither def Nothing  = Left  def
− lib/prelude/fin.idr 
@@ -1,19 +0,0 @@-module prelude.fin--import prelude.nat--data Fin : Nat -> Set where-    fO : Fin (S k)-    fS : Fin k -> Fin (S k)--instance Eq (Fin n) where-   (==) = eq where-     eq : Fin m -> Fin m -> Bool-     eq fO fO = True-     eq (fS k) (fS k') = eq k k'-     eq _ _ = False--wkn : Fin n -> Fin (S n)-wkn fO = fO-wkn (fS k) = fS (wkn k)-
− lib/prelude/heap.idr 
@@ -1,209 +0,0 @@------------------------------------------------------------------------------------ Okasaki-style maxiphobic heaps.  See the paper:---   ``Fun with binary heap trees'', Chris Okasaki, Fun of programming, 2003.-----------------------------------------------------------------------------------module prelude.heap--import builtins--import prelude-import prelude.algebra-import prelude.list-import prelude.nat--%access public--abstract data MaxiphobicHeap : Set -> Set where-  Empty : MaxiphobicHeap a-  Node  : Nat -> MaxiphobicHeap a -> a -> MaxiphobicHeap a -> MaxiphobicHeap a------------------------------------------- ------------------------------------------ Syntactic tests-----------------------------------------------------------------------------------total isEmpty : MaxiphobicHeap a -> Bool-isEmpty Empty = True-isEmpty _     = False--total size : MaxiphobicHeap a -> Nat-size Empty          = O-size (Node s l e r) = s--isValidHeap : Ord a => MaxiphobicHeap a -> Bool-isValidHeap Empty          = True-isValidHeap (Node s l e r) =-  dominates e l && dominates e r && s == S (size l + size r)-  where-    dominates : Ord a => a -> MaxiphobicHeap a -> Bool-    dominates e Empty           = True-    dominates e (Node s l e' r) = e' <= e------------------------------------------------------------------------------------- Basic heaps-----------------------------------------------------------------------------------total empty : MaxiphobicHeap a-empty = Empty--total singleton : a -> MaxiphobicHeap a-singleton e = Node 1 Empty e Empty------------------------------------------------------------------------------------- Inserting items and merging heaps-----------------------------------------------------------------------------------private orderBySize : MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a ->-  (MaxiphobicHeap a, MaxiphobicHeap a, MaxiphobicHeap a)-orderBySize left centre right =-  if size left == largest then-    (left, centre, right)-  else if size centre == largest then-    (centre, left, right)-  else-    (right, left, centre)-  where-    largest : Nat-    largest = maximum (size left) $ maximum (size centre) (size right)--merge : Ord a => MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a-merge Empty               right             = right-merge left                Empty             = left-merge (Node ls ll le lr) (Node rs rl re rr) =-  if le < re then-    let (largest, b, c) = orderBySize ll lr (Node rs rl re rr) in-      Node mergedSize largest le (merge b c)-  else-    let (largest, b, c) = orderBySize rl rr (Node ls ll le lr) in-       Node mergedSize largest re (merge b c)-  where-    mergedSize : Nat-    mergedSize = ls + rs--insert : Ord a => a -> MaxiphobicHeap a -> MaxiphobicHeap a-insert e = merge $ singleton e------------------------------------------------------------------------------------- Heap operations-----------------------------------------------------------------------------------findMinimum : (h : MaxiphobicHeap a) -> (isEmpty h = False) -> a-findMinimum Empty          p = ?findMinimumEmptyAbsurd-findMinimum (Node s l e r) p = e--deleteMinimum : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> MaxiphobicHeap a-deleteMinimum Empty          p = ?deleteMinimumEmptyAbsurd-deleteMinimum (Node s l e r) p = merge l r------------------------------------------------------------------------------------- Conversions to and from lists (and a derived heap sorting algorithm)-----------------------------------------------------------------------------------toList : Ord a => MaxiphobicHeap a -> List a-toList Empty          = []-toList (Node s l e r) = toList' (Node s l e r) refl-  where-    toList' : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> List a-    toList' heap p = findMinimum heap p :: (toList $ deleteMinimum heap p)--fromList : Ord a => List a -> MaxiphobicHeap a-fromList = foldr insert empty--sort : Ord a => List a -> List a-sort = prelude.heap.toList . prelude.heap.fromList------------------------------------------------------------------------------------- Class instances-----------------------------------------------------------------------------------instance Show a => Show (MaxiphobicHeap a) where-  show Empty = "Empty"-  show (Node s l e r) = "Node (" ++ show l ++ " " ++ show e ++ " " ++ show r ++ ")"--instance 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-  (<+>) = merge--instance Ord a => Monoid (MaxiphobicHeap a) where-  neutral = empty--instance Ord a => JoinSemilattice (MaxiphobicHeap a) where-  join = merge------------------------------------------------------------------------------------- Properties-----------------------------------------------------------------------------------total absurdBoolDischarge : False = True -> _|_-absurdBoolDischarge p = replace {P = disjointTy} p ()-  where-    total disjointTy : Bool -> Set-    disjointTy False  = ()-    disjointTy True   = _|_--total isEmptySizeZero : (h : MaxiphobicHeap a) -> (isEmpty h = True) -> size h = O-isEmptySizeZero Empty          p = refl-isEmptySizeZero (Node s l e r) p = ?isEmptySizeZeroNodeAbsurd--total emptyHeapValid : Ord a => isValidHeap empty = True-emptyHeapValid = refl--total singletonHeapValid : Ord a => (e : a) -> isValidHeap $ singleton e = True-singletonHeapValid e = refl--{--total mergePreservesValidHeaps : Ord a => (left : MaxiphobicHeap a) ->-  (right : MaxiphobicHeap a) -> (leftValid : isValidHeap left = True) ->-  (rightValid : isValidHeap right = True) -> isValidHeap $ merge left right = True-mergePreservesValidHeaps Empty              Empty              lp rp = refl-mergePreservesValidHeaps Empty              (Node rs rl re rr) lp rp = rp-mergePreservesValidHeaps (Node ls ll le lr) Empty              lp rp = lp-mergePreservesValidHeaps (Node ls ll le lr) (Node rs rl re rr) lp rp =-  ?mergePreservesValidHeapsBody--}------------------------------------------------------------------------------------- Proofs-----------------------------------------------------------------------------------isEmptySizeZeroNodeAbsurd = proof {-    intros;-    refine FalseElim;-    refine absurdBoolDischarge;-    exact p;-}--findMinimumEmptyAbsurd = proof {-    intros;-    refine FalseElim;-    refine absurdBoolDischarge;-    rewrite p;-    trivial;-}--deleteMinimumEmptyAbsurd = proof {-    intros;-    refine FalseElim;-    refine absurdBoolDischarge;-    rewrite p;-    trivial;-}------------------------------------------------------------------------------------- Debug-----------------------------------------------------------------------------------{-  XXX: poor performance when compiled, diverges when used in the REPL, but it-         does seem to work correctly!-main : IO ()-main = do-  _ <- print $ main.sort [10, 3, 7, 2, 9, 1, 8, 0, 6, 4, 5]-  _ <- print $ main.sort ["orange", "apple", "pear", "lime", "durian"]-  _ <- print $ main.sort [("jim", 19, "cs"), ("alice", 20, "english"), ("bob", 50, "engineering")]-  return ()--}
− lib/prelude/list.idr 
@@ -1,629 +0,0 @@-module prelude.list--import builtins--import prelude.algebra-import prelude.maybe-import prelude.nat--%access public--infixr 7 :: --data List a-  = Nil-  | (::) a (List a)------------------------------------------------------------------------------------- Syntactic tests-----------------------------------------------------------------------------------isNil : List a -> Bool-isNil []      = True-isNil (x::xs) = False--isCons : List a -> Bool-isCons []      = False-isCons (x::xs) = True------------------------------------------------------------------------------------- Indexing into lists-----------------------------------------------------------------------------------head : (l : List a) -> (isCons l = True) -> a-head (x::xs) p = x--head' : (l : List a) -> Maybe a-head' []      = Nothing-head' (x::xs) = Just x--tail : (l : List a) -> (isCons l = True) -> List a-tail (x::xs) p = xs--tail' : (l : List a) -> Maybe (List a)-tail' []      = Nothing-tail' (x::xs) = Just xs--last : (l : List a) -> (isCons l = True) -> a-last (x::xs) p =-  case xs of-    []    => x-    y::ys => last (y::ys) ?lastProof--last' : (l : List a) -> Maybe a-last' []      = Nothing-last' (x::xs) =-  case xs of-    []    => Just x-    y::ys => last' xs--init : (l : List a) -> (isCons l = True) -> List a-init (x::xs) p =-  case xs of-    []    => []-    y::ys => x :: init (y::ys) ?initProof--init' : (l : List a) -> Maybe (List a)-init' []      = Nothing-init' (x::xs) =-  case xs of-    []    => Just []-    y::ys =>-      -- XXX: Problem with typechecking a "do" block here-      case init' $ y::ys of-        Nothing => Nothing-        Just j  => Just $ x :: j------------------------------------------------------------------------------------- Sublists-----------------------------------------------------------------------------------take : Nat -> List a -> List a-take O     xs      = []-take (S n) []      = []-take (S n) (x::xs) = x :: take n xs--drop : Nat -> List a -> List a-drop O     xs      = xs-drop (S n) []      = []-drop (S n) (x::xs) = drop n xs--takeWhile : (a -> Bool) -> List a -> List a-takeWhile p []      = []-takeWhile p (x::xs) = if p x then x :: takeWhile p xs else []--dropWhile : (a -> Bool) -> List a -> List a-dropWhile p []      = []-dropWhile p (x::xs) = if p x then dropWhile p xs else x::xs------------------------------------------------------------------------------------- Misc.-----------------------------------------------------------------------------------list : a -> (a -> List a -> a) -> List a -> a-list nil cons []      = nil-list nil cons (x::xs) = cons x xs--length : List a -> Nat-length []      = 0-length (x::xs) = 1 + length xs------------------------------------------------------------------------------------- Building (bigger) lists-----------------------------------------------------------------------------------(++) : List a -> List a -> List a-(++) [] right      = right-(++) (x::xs) right = x :: (xs ++ right)--repeat : a -> List a-repeat x = x :: repeat x--replicate : Nat -> a -> List a-replicate n x = take n (repeat x)------------------------------------------------------------------------------------- Instances-----------------------------------------------------------------------------------instance (Eq a) => Eq (List a) where-  (==) []      []      = True-  (==) (x::xs) (y::ys) =-    if x == y then-      xs == ys-    else-      False-  (==) _ _ = False---instance Ord a => Ord (List a) where-  compare [] [] = EQ-  compare [] _ = LT-  compare _ [] = GT-  compare (x::xs) (y::ys) =-    if x /= y then-      compare x y-    else-      compare xs ys--instance Semigroup (List a) where-  (<+>) = (++)--instance Monoid (List a) where-  neutral = []---- XXX: unification failure--- instance VerifiedSemigroup (List a) where---  semigroupOpIsAssociative = appendAssociative------------------------------------------------------------------------------------- Zips and unzips-----------------------------------------------------------------------------------zipWith : (f : a -> b -> c) -> (l : List a) -> (r : List b) ->-  (length l = length r) -> List c-zipWith f []      []      p = []-zipWith f (x::xs) (y::ys) p = f x y :: (zipWith f xs ys ?zipWithTailProof)--zipWith3 : (f : a -> b -> c -> d) -> (x : List a) -> (y : List b) ->-  (z : List c) -> (length x = length y) -> (length y = length z) -> List d-zipWith3 f []      []      []      p q = []-zipWith3 f (x::xs) (y::ys) (z::zs) p q =-  f x y z :: (zipWith3 f xs ys zs ?zipWith3TailProof ?zipWith3TailProof')--zip : (l : List a) -> (r : List b) -> (length l = length r) -> List (a, b)-zip = zipWith (\x => \y => (x, y))--zip3 : (x : List a) -> (y : List b) -> (z : List c) -> (length x = length y) ->-  (length y = length z) -> List (a, b, c)-zip3 = zipWith3 (\x => \y => \z => (x, y, z))--unzip : List (a, b) -> (List a, List b)-unzip []           = ([], [])-unzip ((l, r)::xs) with (unzip xs)-  | (lefts, rights) = (l::lefts, r::rights)--unzip3 : List (a, b, c) -> (List a, List b, List c)-unzip3 []              = ([], [], [])-unzip3 ((l, c, r)::xs) with (unzip3 xs)-  | (lefts, centres, rights) = (l::lefts, c::centres, r::rights)------------------------------------------------------------------------------------- Maps-----------------------------------------------------------------------------------map : (a -> b) -> List a -> List b-map f []      = []-map f (x::xs) = f x :: map f xs--mapMaybe : (a -> Maybe b) -> List a -> List b-mapMaybe f []      = []-mapMaybe f (x::xs) =-  case f x of-    Nothing => mapMaybe f xs-    Just j  => j :: mapMaybe f xs------------------------------------------------------------------------------------- Folds-----------------------------------------------------------------------------------foldl : (a -> b -> a) -> a -> List b -> a-foldl f e []      = e-foldl f e (x::xs) = foldl f (f e x) xs--foldr : (a -> b -> b) -> b -> List a -> b-foldr f e []      = e-foldr f e (x::xs) = f x (foldr f e xs)------------------------------------------------------------------------------------- Special folds-----------------------------------------------------------------------------------mconcat : Monoid a => List a -> a-mconcat = foldr (<+>) neutral--concat : List (List a) -> List a-concat []      = []-concat (x::xs) = x ++ concat xs--concatMap : (a -> List b) -> List a -> List b-concatMap f []      = []-concatMap f (x::xs) = f x ++ concatMap f xs--and : List Bool -> Bool-and = foldr (&&) True--or : List Bool -> Bool-or = foldr (||) False--any : (a -> Bool) -> List a -> Bool-any p = or . map p--all : (a -> Bool) -> List a -> Bool-all p = and . map p------------------------------------------------------------------------------------- Transformations-----------------------------------------------------------------------------------reverse : List a -> List a-reverse = reverse' []-  where-    reverse' : List a -> List a -> List a-    reverse' acc []      = acc-    reverse' acc (x::xs) = reverse' (x::acc) xs--intersperse : a -> List a -> List a-intersperse sep []      = []-intersperse sep (x::xs) = x :: intersperse' sep xs-  where-    intersperse' : a -> List a -> List a-    intersperse' sep []      = []-    intersperse' sep (y::ys) = sep :: y :: intersperse' sep ys--intercalate : List a -> List (List a) -> List a-intercalate sep l = concat $ intersperse sep l------------------------------------------------------------------------------------- Membership tests-----------------------------------------------------------------------------------elemBy : (a -> a -> Bool) -> a -> List a -> Bool-elemBy p e []      = False-elemBy p e (x::xs) =-  if p e x then-    True-  else-    elemBy p e xs--elem : Eq a => a -> List a -> Bool-elem = elemBy (==)--lookupBy : (a -> a -> Bool) -> a -> List (a, b) -> Maybe b-lookupBy p e []      = Nothing-lookupBy p e (x::xs) =-  let (l, r) = x in-    if p e l then-      Just r-    else-      lookupBy p e xs--lookup : Eq a => a -> List (a, b) -> Maybe b-lookup = lookupBy (==)--hasAnyBy : (a -> a -> Bool) -> List a -> List a -> Bool-hasAnyBy p elems []      = False-hasAnyBy p elems (x::xs) =-  if elemBy p x elems then-    True-  else-    hasAnyBy p elems xs--hasAny : Eq a => List a -> List a -> Bool-hasAny = hasAnyBy (==)------------------------------------------------------------------------------------- Searching with a predicate-----------------------------------------------------------------------------------find : (a -> Bool) -> List a -> Maybe a-find p []      = Nothing-find p (x::xs) =-  if p x then-    Just x-  else-    find p xs--findIndex : (a -> Bool) -> List a -> Maybe Nat-findIndex = findIndex' 0-  where-    findIndex' : Nat -> (a -> Bool) -> List a -> Maybe Nat-    findIndex' cnt p []      = Nothing-    findIndex' cnt p (x::xs) =-      if p x then-        Just cnt-      else-        findIndex' (S cnt) p xs--findIndices : (a -> Bool) -> List a -> List Nat-findIndices = findIndices' 0-  where-    findIndices' : Nat -> (a -> Bool) -> List a -> List Nat-    findIndices' cnt p []      = []-    findIndices' cnt p (x::xs) =-      if p x then-        cnt :: findIndices' (S cnt) p xs-      else-        findIndices' (S cnt) p xs--elemIndexBy : (a -> a -> Bool) -> a -> List a -> Maybe Nat-elemIndexBy p e = findIndex $ p e--elemIndex : Eq a => a -> List a -> Maybe Nat-elemIndex = elemIndexBy (==)--elemIndicesBy : (a -> a -> Bool) -> a -> List a -> List Nat-elemIndicesBy p e = findIndices $ p e--elemIndices : Eq a => a -> List a -> List Nat-elemIndices = elemIndicesBy (==)------------------------------------------------------------------------------------- Filters-----------------------------------------------------------------------------------filter : (a -> Bool) -> List a -> List a-filter p []      = []-filter p (x::xs) =-  if p x then-    x :: filter p xs-  else-    filter p xs--nubBy : (a -> a -> Bool) -> List a -> List a-nubBy = nubBy' []-  where-    nubBy' : List a -> (a -> a -> Bool) -> List a -> List a-    nubBy' acc p []      = []-    nubBy' acc p (x::xs) =-      if elemBy p x acc then-        nubBy' acc p xs-      else-        x :: nubBy' (x::acc) p xs--nub : Eq a => List a -> List a-nub = nubBy (==)------------------------------------------------------------------------------------- Splitting and breaking lists-----------------------------------------------------------------------------------span : (a -> Bool) -> List a -> (List a, List a)-span p []      = ([], [])-span p (x::xs) =-  if p x then-    let (ys, zs) = span p xs in-      (x::ys, zs)-  else-    ([], x::xs)--break : (a -> Bool) -> List a -> (List a, List a)-break p = span (not . p)--split : (a -> Bool) -> List a -> List (List a)-split p [] = []-split p xs =-  case break p xs of-    (chunk, [])          => [chunk]-    (chunk, (c :: rest)) => chunk :: split p rest--partition : (a -> Bool) -> List a -> (List a, List a)-partition p []      = ([], [])-partition p (x::xs) =-  let (lefts, rights) = partition p xs in-    if p x then-      (x::lefts, rights)-    else-      (lefts, x::rights)------------------------------------------------------------------------------------- Predicates-----------------------------------------------------------------------------------isPrefixOfBy : (a -> a -> Bool) -> List a -> List a -> Bool-isPrefixOfBy p [] right        = True-isPrefixOfBy p left []         = False-isPrefixOfBy p (x::xs) (y::ys) =-  if p x y then-    isPrefixOfBy p xs ys-  else-    False--isPrefixOf : Eq a => List a -> List a -> Bool-isPrefixOf = isPrefixOfBy (==)--isSuffixOfBy : (a -> a -> Bool) -> List a -> List a -> Bool-isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right)--isSuffixOf : Eq a => List a -> List a -> Bool-isSuffixOf = isSuffixOfBy (==)------------------------------------------------------------------------------------- Sorting-----------------------------------------------------------------------------------sorted : Ord a => List a -> Bool-sorted []      = True-sorted (x::xs) =-  case xs of-    Nil     => True-    (y::ys) => x <= y && sorted (y::ys)--mergeBy : (a -> a -> Ordering) -> List a -> List a -> List a-mergeBy order []      right   = right-mergeBy order left    []      = left-mergeBy order (x::xs) (y::ys) =-  case order x y of-    LT => x :: mergeBy order xs (y::ys)-    _  => y :: mergeBy order (x::xs) ys--merge : Ord a => List a -> List a -> List a-merge = mergeBy compare--sort : Ord a => List a -> List a-sort []  = []-sort [x] = [x]-sort xs  =-  let (x, y) = split xs in-    merge (sort x) (sort y)-  where-    splitRec : List a -> List a -> (List a -> List a) -> (List a, List a)-    splitRec (_::_::xs) (y::ys) zs = splitRec xs ys (zs . ((::) y))-    splitRec _          ys      zs = (zs [], ys)--    split : List a -> (List a, List a)-    split xs = splitRec xs xs id------------------------------------------------------------------------------------- Conversions-----------------------------------------------------------------------------------maybeToList : Maybe a -> List a-maybeToList Nothing  = []-maybeToList (Just j) = [j]--listToMaybe : List a -> Maybe a-listToMaybe []      = Nothing-listToMaybe (x::xs) = Just x------------------------------------------------------------------------------------- Misc-----------------------------------------------------------------------------------catMaybes : List (Maybe a) -> List a-catMaybes []      = []-catMaybes (x::xs) =-  case x of-    Nothing => catMaybes xs-    Just j  => j :: catMaybes xs------------------------------------------------------------------------------------- Properties------------------------------------------------------------------------------------- append-appendNilRightNeutral : (l : List a) ->-  l ++ [] = l-appendNilRightNeutral []      = refl-appendNilRightNeutral (x::xs) =-  let inductiveHypothesis = appendNilRightNeutral xs in-    ?appendNilRightNeutralStepCase--appendAssociative : (l : List a) -> (c : List a) -> (r : List a) ->-  l ++ (c ++ r) = (l ++ c) ++ r-appendAssociative []      c r = refl-appendAssociative (x::xs) c r =-  let inductiveHypothesis = appendAssociative xs c r in-    ?appendAssociativeStepCase---- length-lengthAppend : (left : List a) -> (right : List a) ->-  length (left ++ right) = length left + length right-lengthAppend []      right = refl-lengthAppend (x::xs) right =-  let inductiveHypothesis = lengthAppend xs right in-    ?lengthAppendStepCase---- map-mapPreservesLength : (f : a -> b) -> (l : List a) ->-  length (map f l) = length l-mapPreservesLength f []      = refl-mapPreservesLength f (x::xs) =-  let inductiveHypothesis = mapPreservesLength f xs in-    ?mapPreservesLengthStepCase--mapDistributesOverAppend : (f : a -> b) -> (l : List a) -> (r : List a) ->-  map f (l ++ r) = map f l ++ map f r-mapDistributesOverAppend f []      r = refl-mapDistributesOverAppend f (x::xs) r =-  let inductiveHypothesis = mapDistributesOverAppend f xs r in-    ?mapDistributesOverAppendStepCase--mapFusion : (f : b -> c) -> (g : a -> b) -> (l : List a) ->-  map f (map g l) = map (f . g) l-mapFusion f g []      = refl-mapFusion f g (x::xs) =-  let inductiveHypothesis = mapFusion f g xs in-    ?mapFusionStepCase---- hasAny-hasAnyByNilFalse : (p : a -> a -> Bool) -> (l : List a) ->-  hasAnyBy p [] l = False-hasAnyByNilFalse p []      = refl-hasAnyByNilFalse p (x::xs) =-  let inductiveHypothesis = hasAnyByNilFalse p xs in-    ?hasAnyByNilFalseStepCase--hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False-hasAnyNilFalse l = ?hasAnyNilFalseBody-    ------------------------------------------------------------------------------------ Proofs-----------------------------------------------------------------------------------lengthAppendStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--hasAnyNilFalseBody = proof {-    intros;-    rewrite (hasAnyByNilFalse (==) l);-    trivial;-}--hasAnyByNilFalseStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--initProof = proof {-    intros;-    trivial;-}--lastProof = proof {-    intros;-    trivial;-}--appendNilRightNeutralStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--appendAssociativeStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--mapFusionStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--mapDistributesOverAppendStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--mapPreservesLengthStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--zipWithTailProof = proof {-    intros;-    rewrite (succInjective (length xs) (length ys) p);-    trivial;-}--zipWith3TailProof = proof {-    intros;-    rewrite (succInjective (length xs) (length ys) p);-    trivial;-}--zipWith3TailProof' = proof {-    intros;-    rewrite (succInjective (length ys) (length zs) q);-    trivial;-}-
− lib/prelude/maybe.idr 
@@ -1,43 +0,0 @@-module prelude.maybe--import builtins--data Maybe a-    = Nothing-    | Just a------------------------------------------------------------------------------------- Syntactic tests-----------------------------------------------------------------------------------isNothing : Maybe a -> Bool-isNothing Nothing  = True-isNothing (Just j) = False--isJust : Maybe a -> Bool-isJust Nothing  = False-isJust (Just j) = True------------------------------------------------------------------------------------- Misc-----------------------------------------------------------------------------------maybe : |(def : b) -> (a -> b) -> Maybe a -> b-maybe n j Nothing  = n-maybe n j (Just x) = j x--fromMaybe : |(def: a) -> Maybe a -> a-fromMaybe def Nothing  = def-fromMaybe def (Just j) = j--toMaybe : Bool -> a -> Maybe a-toMaybe True  j = Just j-toMaybe False j = Nothing------------------------------------------------------------------------------------- Class instances-----------------------------------------------------------------------------------maybe_bind : Maybe a -> (a -> Maybe b) -> Maybe b-maybe_bind Nothing  k = Nothing-maybe_bind (Just x) k = k x
− lib/prelude/monad.idr 
@@ -1,45 +0,0 @@-module prelude.monad---- Monads and Functors--import builtins-import prelude.list--%access public--infixl 5 >>=--class Monad (m : Set -> Set) where -    return : a -> m a-    (>>=)  : m a -> (a -> m b) -> m b--class Functor (f : Set -> Set) where -    fmap : (a -> b) -> f a -> f b--class Monad m => MonadPlus (m : Set -> Set) where -    mplus : m a -> m a -> m a-    mzero : m a--guard : MonadPlus m => Bool -> m ()-guard True  = return ()-guard False = mzero--when : Monad m => Bool -> m () -> m ()-when True  f = f-when False _ = return ()--sequence : Monad m => List (m a) -> m (List a)-sequence []        = return []-sequence (x :: xs) = [ x' :: xs' | x' <- x, xs' <- sequence xs ]--sequence_ : Monad m => List (m a) -> m ()-sequence_ [] = return ()-sequence_ (x :: xs) = do x; sequence_ xs--mapM : Monad m => (a -> m b) -> List a -> m (List b)-mapM f xs = sequence (map f xs)--mapM_ : Monad m => (a -> m b) -> List a -> m ()-mapM_ f xs = sequence_ (map f xs)--
− lib/prelude/nat.idr 
@@ -1,842 +0,0 @@-module prelude.nat--import builtins--import prelude.algebra-import prelude.cast--%access public--data Nat-  = O-  | S Nat------------------------------------------------------------------------------------- Syntactic tests-----------------------------------------------------------------------------------total isZero : Nat -> Bool-isZero O     = True-isZero (S n) = False--total isSucc : Nat -> Bool-isSucc O     = False-isSucc (S n) = True------------------------------------------------------------------------------------- Basic arithmetic functions-----------------------------------------------------------------------------------total plus : Nat -> Nat -> Nat-plus O right        = right-plus (S left) right = S (plus left right)--total mult : Nat -> Nat -> Nat-mult O right        = O-mult (S left) right = plus right $ mult left right--total minus : Nat -> Nat -> Nat-minus O        right     = O-minus left     O         = left-minus (S left) (S right) = minus left right--total power : Nat -> Nat -> Nat-power base O       = S O-power base (S exp) = mult base $ power base exp--hyper : Nat -> Nat -> Nat -> Nat-hyper O        a b      = S b-hyper (S O)    a O      = a-hyper (S(S O)) a O      = O-hyper n        a O      = S O-hyper (S pn)   a (S pb) = hyper pn a (hyper (S pn) a pb)-------------------------------------------------------------------------------------- Comparisons-----------------------------------------------------------------------------------data LTE  : Nat -> Nat -> Set where-  lteZero : LTE O    right-  lteSucc : LTE left right -> LTE (S left) (S right)--total GTE : Nat -> Nat -> Set-GTE left right = LTE right left--total LT : Nat -> Nat -> Set-LT left right = LTE (S left) right--total GT : Nat -> Nat -> Set-GT left right = LT right left--total lte : Nat -> Nat -> Bool-lte O        right     = True-lte left     O         = False-lte (S left) (S right) = lte left right--total gte : Nat -> Nat -> Bool-gte left right = lte right left--total lt : Nat -> Nat -> Bool-lt left right = lte (S left) right--total gt : Nat -> Nat -> Bool-gt left right = lt right left--total minimum : Nat -> Nat -> Nat-minimum left right =-  if lte left right then-    left-  else-    right--total maximum : Nat -> Nat -> Nat-maximum left right =-  if lte left right then-    right-  else-    left------------------------------------------------------------------------------------- Type class instances-----------------------------------------------------------------------------------instance Eq Nat where-  O == O         = True-  (S l) == (S r) = l == r-  _ == _         = False--instance Cast Nat Int where-  cast O     = 0-  cast (S k) = 1 + cast k--instance Ord Nat where-  compare O O         = EQ-  compare O (S k)     = LT-  compare (S k) O     = GT-  compare (S x) (S y) = compare x y--instance Num Nat where-  (+) = plus-  (-) = minus-  (*) = mult--  abs x = x--  fromInteger x = fromInteger' x-    where-      %assert_total-      fromInteger' : Int -> Nat-      fromInteger' 0 = O-      fromInteger' n =-        if (n > 0) then-          S (fromInteger' (n - 1))-        else-          O--record Multiplicative : Set where-  getMultiplicative : Nat -> Multiplicative--record Additive : Set where-  getAdditive : Nat -> Additive--instance Semigroup Multiplicative where-  (<+>) left right = getMultiplicative $ left' * right'-    where-      left'  : Nat-      left'  =-       case left of-          getMultiplicative m => m--      right' : Nat-      right' =-        case right of-          getMultiplicative m => m--instance Semigroup Additive where-  left <+> right = getAdditive $ left' + right'-    where-      left'  : Nat-      left'  =-        case left of-          getAdditive m => m--      right' : Nat-      right' =-        case right of-          getAdditive m => m--instance Monoid Multiplicative where-  neutral = getMultiplicative $ S O--instance Monoid Additive where-  neutral = getAdditive O--instance MeetSemilattice Nat where-  meet = minimum--instance JoinSemilattice Nat where-  join = maximum--instance Lattice Nat where { }--instance BoundedJoinSemilattice Nat where-  bottom = O------------------------------------------------------------------------------------- Auxilliary notions-----------------------------------------------------------------------------------total pred : Nat -> Nat-pred O     = O-pred (S n) = n------------------------------------------------------------------------------------- Fibonacci and factorial-----------------------------------------------------------------------------------total fib : Nat -> Nat-fib O         = O-fib (S O)     = S O-fib (S (S n)) = fib (S n) + fib n------------------------------------------------------------------------------------- GCD and LCM---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Division and modulus-----------------------------------------------------------------------------------total mod : Nat -> Nat -> Nat-mod left O         = left-mod left (S right) = mod' left left right-  where-    total mod' : Nat -> Nat -> Nat -> Nat-    mod' O        centre right = centre-    mod' (S left) centre right =-      if lte centre right then-        centre-      else-        mod' left (centre - (S right)) right--total div : Nat -> Nat -> Nat-div left O         = S left               -- div by zero-div left (S right) = div' left left right-  where-    total div' : Nat -> Nat -> Nat -> Nat-    div' O        centre right = O-    div' (S left) centre right =-      if lte centre right then-        O-      else-        S (div' left (centre - (S right)) right)------------------------------------------------------------------------------------- Properties------------------------------------------------------------------------------------- Succ-total eqSucc : (left : Nat) -> (right : Nat) -> (p : left = right) ->-  S left = S right-eqSucc left right refl = refl--total succInjective : (left : Nat) -> (right : Nat) -> (p : S left = S right) ->-  left = right-succInjective left right refl = refl---- Plus-total plusZeroLeftNeutral : (right : Nat) -> 0 + right = right-plusZeroLeftNeutral right = refl--total plusZeroRightNeutral : (left : Nat) -> left + 0 = left-plusZeroRightNeutral O     = refl-plusZeroRightNeutral (S n) =-  let inductiveHypothesis = plusZeroRightNeutral n in-    ?plusZeroRightNeutralStepCase--total plusSuccRightSucc : (left : Nat) -> (right : Nat) ->-  S (left + right) = left + (S right)-plusSuccRightSucc O right        = refl-plusSuccRightSucc (S left) right =-  let inductiveHypothesis = plusSuccRightSucc left right in-    ?plusSuccRightSuccStepCase--total plusCommutative : (left : Nat) -> (right : Nat) ->-  left + right = right + left-plusCommutative O        right = ?plusCommutativeBaseCase-plusCommutative (S left) right =-  let inductiveHypothesis = plusCommutative left right in-    ?plusCommutativeStepCase--total plusAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->-  left + (centre + right) = (left + centre) + right-plusAssociative O        centre right = refl-plusAssociative (S left) centre right =-  let inductiveHypothesis = plusAssociative left centre right in-    ?plusAssociativeStepCase--total plusConstantRight : (left : Nat) -> (right : Nat) -> (c : Nat) ->-  (p : left = right) -> left + c = right + c-plusConstantRight left right c refl = refl--total plusConstantLeft : (left : Nat) -> (right : Nat) -> (c : Nat) ->-  (p : left = right) -> c + left = c + right-plusConstantLeft left right c refl = refl--total plusOneSucc : (right : Nat) -> 1 + right = S right-plusOneSucc n = refl--total plusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) ->-  (p : left + right = left + right') -> right = right'-plusLeftCancel O        right right' p = ?plusLeftCancelBaseCase-plusLeftCancel (S left) right right' p =-  let inductiveHypothesis = plusLeftCancel left right right' in-    ?plusLeftCancelStepCase--total plusRightCancel : (left : Nat) -> (left' : Nat) -> (right : Nat) ->-  (p : left + right = left' + right) -> left = left'-plusRightCancel left left' O         p = ?plusRightCancelBaseCase-plusRightCancel left left' (S right) p =-  let inductiveHypothesis = plusRightCancel left left' right in-    ?plusRightCancelStepCase--total plusLeftLeftRightZero : (left : Nat) -> (right : Nat) ->-  (p : left + right = left) -> right = O-plusLeftLeftRightZero O        right p = ?plusLeftLeftRightZeroBaseCase-plusLeftLeftRightZero (S left) right p =-  let inductiveHypothesis = plusLeftLeftRightZero left right in-    ?plusLeftLeftRightZeroStepCase---- Mult-total multZeroLeftZero : (right : Nat) -> O * right = O-multZeroLeftZero right = refl--total multZeroRightZero : (left : Nat) -> left * O = O-multZeroRightZero O        = refl-multZeroRightZero (S left) =-  let inductiveHypothesis = multZeroRightZero left in-    ?multZeroRightZeroStepCase--total multRightSuccPlus : (left : Nat) -> (right : Nat) ->-  left * (S right) = left + (left * right)-multRightSuccPlus O        right = refl-multRightSuccPlus (S left) right =-  let inductiveHypothesis = multRightSuccPlus left right in-    ?multRightSuccPlusStepCase--total multLeftSuccPlus : (left : Nat) -> (right : Nat) ->-  (S left) * right = right + (left * right)-multLeftSuccPlus left right = refl--total multCommutative : (left : Nat) -> (right : Nat) ->-  left * right = right * left-multCommutative O right        = ?multCommutativeBaseCase-multCommutative (S left) right =-  let inductiveHypothesis = multCommutative left right in-    ?multCommutativeStepCase--total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->-  left * (centre + right) = (left * centre) + (left * right)-multDistributesOverPlusRight O        centre right = refl-multDistributesOverPlusRight (S left) centre right =-  let inductiveHypothesis = multDistributesOverPlusRight left centre right in-    ?multDistributesOverPlusRightStepCase--total multDistributesOverPlusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) ->-  (left + centre) * right = (left * right) + (centre * right)-multDistributesOverPlusLeft O        centre right = refl-multDistributesOverPlusLeft (S left) centre right =-  let inductiveHypothesis = multDistributesOverPlusLeft left centre right in-    ?multDistributesOverPlusLeftStepCase--total multAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->-  left * (centre * right) = (left * centre) * right-multAssociative O        centre right = refl-multAssociative (S left) centre right =-  let inductiveHypothesis = multAssociative left centre right in-    ?multAssociativeStepCase--total multOneLeftNeutral : (right : Nat) -> 1 * right = right-multOneLeftNeutral O         = refl-multOneLeftNeutral (S right) =-  let inductiveHypothesis = multOneLeftNeutral right in-    ?multOneLeftNeutralStepCase--total multOneRightNeutral : (left : Nat) -> left * 1 = left-multOneRightNeutral O        = refl-multOneRightNeutral (S left) =-  let inductiveHypothesis = multOneRightNeutral left in-    ?multOneRightNeutralStepCase---- Minus-total minusSuccSucc : (left : Nat) -> (right : Nat) ->-  (S left) - (S right) = left - right-minusSuccSucc left right = refl--total minusZeroLeft : (right : Nat) -> 0 - right = O-minusZeroLeft right = refl--total minusZeroRight : (left : Nat) -> left - 0 = left-minusZeroRight O        = refl-minusZeroRight (S left) = refl--total minusZeroN : (n : Nat) -> O = n - n-minusZeroN O     = refl-minusZeroN (S n) = minusZeroN n--total minusOneSuccN : (n : Nat) -> S O = (S n) - n-minusOneSuccN O     = refl-minusOneSuccN (S n) = minusOneSuccN n--total minusSuccOne : (n : Nat) -> S n - 1 = n-minusSuccOne O     = refl-minusSuccOne (S n) = refl--total minusPlusZero : (n : Nat) -> (m : Nat) -> n - (n + m) = O-minusPlusZero O     m = refl-minusPlusZero (S n) m = minusPlusZero n m--total minusMinusMinusPlus : (left : Nat) -> (centre : Nat) -> (right : Nat) ->-  left - centre - right = left - (centre + right)-minusMinusMinusPlus O        O          right = refl-minusMinusMinusPlus (S left) O          right = refl-minusMinusMinusPlus O        (S centre) right = refl-minusMinusMinusPlus (S left) (S centre) right =-  let inductiveHypothesis = minusMinusMinusPlus left centre right in-    ?minusMinusMinusPlusStepCase--total plusMinusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) ->-  (left + right) - (left + right') = right - right'-plusMinusLeftCancel O right right'        = refl-plusMinusLeftCancel (S left) right right' =-  let inductiveHypothesis = plusMinusLeftCancel left right right' in-    ?plusMinusLeftCancelStepCase--total multDistributesOverMinusLeft : (left : Nat) -> (centre : Nat) -> (right : Nat) ->-  (left - centre) * right = (left * right) - (centre * right)-multDistributesOverMinusLeft O        O          right = refl-multDistributesOverMinusLeft (S left) O          right =-  ?multDistributesOverMinusLeftBaseCase-multDistributesOverMinusLeft O        (S centre) right = refl-multDistributesOverMinusLeft (S left) (S centre) right =-  let inductiveHypothesis = multDistributesOverMinusLeft left centre right in-    ?multDistributesOverMinusLeftStepCase--total multDistributesOverMinusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->-  left * (centre - right) = (left * centre) - (left * right)-multDistributesOverMinusRight left centre right =-  ?multDistributesOverMinusRightBody---- Power-total powerSuccPowerLeft : (base : Nat) -> (exp : Nat) -> power base (S exp) =-  base * (power base exp)-powerSuccPowerLeft base exp = refl--total multPowerPowerPlus : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->-  (power base exp) * (power base exp') = power base (exp + exp')-multPowerPowerPlus base O       exp' = ?multPowerPowerPlusBaseCase-multPowerPowerPlus base (S exp) exp' =-  let inductiveHypothesis = multPowerPowerPlus base exp exp' in-    ?multPowerPowerPlusStepCase--total powerZeroOne : (base : Nat) -> power base 0 = S O-powerZeroOne base = refl--total powerOneNeutral : (base : Nat) -> power base 1 = base-powerOneNeutral O        = refl-powerOneNeutral (S base) =-  let inductiveHypothesis = powerOneNeutral base in-    ?powerOneNeutralStepCase--total powerOneSuccOne : (exp : Nat) -> power 1 exp = S O-powerOneSuccOne O       = refl-powerOneSuccOne (S exp) =-  let inductiveHypothesis = powerOneSuccOne exp in-    ?powerOneSuccOneStepCase--total powerSuccSuccMult : (base : Nat) -> power base 2 = mult base base-powerSuccSuccMult O        = refl-powerSuccSuccMult (S base) =-  let inductiveHypothesis = powerSuccSuccMult base in-    ?powerSuccSuccMultStepCase--total powerPowerMultPower : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->-  power (power base exp) exp' = power base (exp * exp')-powerPowerMultPower base exp O        = ?powerPowerMultPowerBaseCase-powerPowerMultPower base exp (S exp') =-  let inductiveHypothesis = powerPowerMultPower base exp exp' in-    ?powerPowerMultPowerStepCase---- Pred-total predSucc : (n : Nat) -> pred (S n) = n-predSucc n = refl--total minusSuccPred : (left : Nat) -> (right : Nat) ->-  left - (S right) = pred (left - right)-minusSuccPred O        right = refl-minusSuccPred (S left) O =-  let inductiveHypothesis = minusSuccPred left O in-    ?minusSuccPredStepCase-minusSuccPred (S left) (S right) =-  let inductiveHypothesis = minusSuccPred left right in-    ?minusSuccPredStepCase'---- boolElim-total boolElimSuccSucc : (cond : Bool) -> (t : Nat) -> (f : Nat) ->-  S (boolElim cond t f) = boolElim cond (S t) (S f)-boolElimSuccSucc True  t f = refl-boolElimSuccSucc False t f = refl--total boolElimPlusPlusLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) ->-  left + (boolElim cond t f) = boolElim cond (left + t) (left + f)-boolElimPlusPlusLeft True  left t f = refl-boolElimPlusPlusLeft False left t f = refl--total boolElimPlusPlusRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) ->-  (boolElim cond t f) + right = boolElim cond (t + right) (f + right)-boolElimPlusPlusRight True  right t f = refl-boolElimPlusPlusRight False right t f = refl--total boolElimMultMultLeft : (cond : Bool) -> (left : Nat) -> (t : Nat) -> (f : Nat) ->-  left * (boolElim cond t f) = boolElim cond (left * t) (left * f)-boolElimMultMultLeft True  left t f = refl-boolElimMultMultLeft False left t f = refl--total boolElimMultMultRight : (cond : Bool) -> (right : Nat) -> (t : Nat) -> (f : Nat) ->-  (boolElim cond t f) * right = boolElim cond (t * right) (f * right)-boolElimMultMultRight True  right t f = refl-boolElimMultMultRight False right t f = refl---- Orders-total lteNTrue : (n : Nat) -> lte n n = True-lteNTrue O     = refl-lteNTrue (S n) = lteNTrue n--total lteSuccZeroFalse : (n : Nat) -> lte (S n) O = False-lteSuccZeroFalse O     = refl-lteSuccZeroFalse (S n) = refl---- Minimum and maximum-total minimumZeroZeroRight : (right : Nat) -> minimum 0 right = O-minimumZeroZeroRight O         = refl-minimumZeroZeroRight (S right) = minimumZeroZeroRight right--total minimumZeroZeroLeft : (left : Nat) -> minimum left 0 = O-minimumZeroZeroLeft O        = refl-minimumZeroZeroLeft (S left) = refl--total minimumSuccSucc : (left : Nat) -> (right : Nat) ->-  minimum (S left) (S right) = S (minimum left right)-minimumSuccSucc O        O         = refl-minimumSuccSucc (S left) O         = refl-minimumSuccSucc O        (S right) = refl-minimumSuccSucc (S left) (S right) =-  let inductiveHypothesis = minimumSuccSucc left right in-    ?minimumSuccSuccStepCase--total minimumCommutative : (left : Nat) -> (right : Nat) ->-  minimum left right = minimum right left-minimumCommutative O        O         = refl-minimumCommutative O        (S right) = refl-minimumCommutative (S left) O         = refl-minimumCommutative (S left) (S right) =-  let inductiveHypothesis = minimumCommutative left right in-    ?minimumCommutativeStepCase--total maximumZeroNRight : (right : Nat) -> maximum O right = right-maximumZeroNRight O         = refl-maximumZeroNRight (S right) = refl--total maximumZeroNLeft : (left : Nat) -> maximum left O = left-maximumZeroNLeft O        = refl-maximumZeroNLeft (S left) = refl--total maximumSuccSucc : (left : Nat) -> (right : Nat) ->-  S (maximum left right) = maximum (S left) (S right)-maximumSuccSucc O        O         = refl-maximumSuccSucc (S left) O         = refl-maximumSuccSucc O        (S right) = refl-maximumSuccSucc (S left) (S right) =-  let inductiveHypothesis = maximumSuccSucc left right in-    ?maximumSuccSuccStepCase--total maximumCommutative : (left : Nat) -> (right : Nat) ->-  maximum left right = maximum right left-maximumCommutative O        O         = refl-maximumCommutative (S left) O         = refl-maximumCommutative O        (S right) = refl-maximumCommutative (S left) (S right) =-  let inductiveHypothesis = maximumCommutative left right in-    ?maximumCommutativeStepCase---- div and mod-total modZeroZero : (n : Nat) -> mod 0 n = O-modZeroZero O     = refl-modZeroZero (S n) = refl------------------------------------------------------------------------------------- Proofs-----------------------------------------------------------------------------------powerPowerMultPowerStepCase = proof {-    intros;-    rewrite sym inductiveHypothesis;-    rewrite sym (multRightSuccPlus exp exp');-    rewrite (multPowerPowerPlus base exp (mult exp exp'));-    trivial;-}--powerPowerMultPowerBaseCase = proof {-    intros;-    rewrite sym (multZeroRightZero exp);-    trivial;-}--powerSuccSuccMultStepCase = proof {-    intros;-    rewrite (multOneRightNeutral base);-    rewrite sym (multOneRightNeutral base);-    trivial;-}--powerOneSuccOneStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    rewrite sym (plusZeroRightNeutral (power (S O) exp));-    trivial;-}--powerOneNeutralStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--multAssociativeStepCase = proof {-    intros;-    rewrite sym (multDistributesOverPlusLeft centre (mult left centre) right);-    rewrite inductiveHypothesis;-    trivial;-}--minusSuccPredStepCase' = proof {-    intros;-    rewrite sym inductiveHypothesis;-    trivial;-}--minusSuccPredStepCase = proof {-    intros;-    rewrite (minusZeroRight left);-    trivial;-}--multPowerPowerPlusStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    rewrite (multAssociative base (power base exp) (power base exp'));-    trivial;-}--multPowerPowerPlusBaseCase = proof {-    intros;-    rewrite (plusZeroRightNeutral (power base exp'));-    trivial;-}--multOneRightNeutralStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--multOneLeftNeutralStepCase = proof {-    intros;-    rewrite (plusZeroRightNeutral right);-    trivial;-}--multDistributesOverPlusLeftStepCase = proof {-    intros;-    rewrite sym inductiveHypothesis;-    rewrite sym (plusAssociative right (mult left right) (mult centre right));-    trivial;-}--multDistributesOverPlusRightStepCase = proof {-    intros;-    rewrite sym inductiveHypothesis;-    rewrite sym (plusAssociative (plus centre (mult left centre)) right (mult left right));-    rewrite (plusAssociative centre (mult left centre) right);-    rewrite sym (plusCommutative (mult left centre) right);-    rewrite sym (plusAssociative centre right (mult left centre));-    rewrite sym (plusAssociative (plus centre right) (mult left centre) (mult left right));-    trivial;-}--multCommutativeStepCase = proof {-    intros;-    rewrite sym (multRightSuccPlus right left);-    rewrite inductiveHypothesis;-    trivial;-}--multCommutativeBaseCase = proof {-    intros;-    rewrite (multZeroRightZero right);-    trivial;-}--multRightSuccPlusStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    rewrite sym inductiveHypothesis;-    rewrite sym (plusAssociative right left (mult left right));-    rewrite sym (plusCommutative right left);-    rewrite (plusAssociative left right (mult left right));-    trivial;-}--multZeroRightZeroStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--plusAssociativeStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--plusCommutativeStepCase = proof {-    intros;-    rewrite (plusSuccRightSucc right left);-    rewrite inductiveHypothesis;-    trivial;-}--plusSuccRightSuccStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--plusCommutativeBaseCase = proof {-    intros;-    rewrite sym (plusZeroRightNeutral right);-    trivial;-}--plusZeroRightNeutralStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--maximumCommutativeStepCase = proof {-    intros;-    rewrite (boolElimSuccSucc (lte left right) right left);-    rewrite (boolElimSuccSucc (lte right left) left right);-    rewrite inductiveHypothesis;-    trivial;-}--maximumSuccSuccStepCase = proof {-    intros;-    rewrite sym (boolElimSuccSucc (lte left right) (S right) (S left));-    trivial;-}--minimumCommutativeStepCase = proof {-    intros;-    rewrite (boolElimSuccSucc (lte left right) left right);-    rewrite (boolElimSuccSucc (lte right left) right left);-    rewrite inductiveHypothesis;-    trivial;-}--minimumSuccSuccStepCase = proof {-    intros;-    rewrite (boolElimSuccSucc (lte left right) (S left) (S right));-    trivial;-}--multDistributesOverMinusRightBody = proof {-    intros;-    rewrite sym (multCommutative left (minus centre right));-    rewrite sym (multDistributesOverMinusLeft centre right left);-    rewrite sym (multCommutative centre left);-    rewrite sym (multCommutative right left);-    trivial;-}--multDistributesOverMinusLeftStepCase = proof {-    intros;-    rewrite sym (plusMinusLeftCancel right (mult left right) (mult centre right));-    trivial;-}--multDistributesOverMinusLeftBaseCase = proof {-    intros;-    rewrite (minusZeroRight (plus right (mult left right)));-    trivial;-}--plusMinusLeftCancelStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--minusMinusMinusPlusStepCase = proof {-    intros;-    rewrite inductiveHypothesis;-    trivial;-}--plusLeftLeftRightZeroBaseCase = proof {-    intros;-    rewrite p;-    trivial;-}--plusLeftLeftRightZeroStepCase = proof {-    intros;-    refine inductiveHypothesis;-    let p' = succInjective (plus left right) left p;-    rewrite p';-    trivial;-}--plusRightCancelStepCase = proof {-    intros;-    refine inductiveHypothesis;-    refine succInjective _ _ ?;-    rewrite sym (plusSuccRightSucc left right);-    rewrite sym (plusSuccRightSucc left' right);-    rewrite p;-    trivial;-}--plusRightCancelBaseCase = proof {-    intros;-    rewrite (plusZeroRightNeutral left);-    rewrite (plusZeroRightNeutral left');-    rewrite p;-    trivial;-}--plusLeftCancelStepCase = proof {-    intros;-    let injectiveProof = succInjective (plus left right) (plus left right') p;-    rewrite (inductiveHypothesis injectiveProof);-    trivial;-}--plusLeftCancelBaseCase = proof {-    intros;-    rewrite p;-    trivial;-}
− lib/prelude/strings.idr 
@@ -1,89 +0,0 @@-module prelude.strings--import builtins-import prelude.list-import prelude.char-import prelude.cast---- Some more complex string operations--data StrM : String -> Set where-    StrNil : StrM ""-    StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs)--strHead' : (x : String) -> so (not (x == "")) -> Char-strHead' x p = prim__strHead x--strTail' : (x : String) -> so (not (x == "")) -> String-strTail' x p = prim__strTail x---- we need the 'believe_me' because the operations are primitives--strM : (x : String) -> StrM x-strM x with (choose (not (x == "")))-  strM x | (Left p)  = believe_me $ StrCons (strHead' x p) (strTail' x p)-  strM x | (Right p) = believe_me StrNil--unpack : String -> List Char-unpack s with (strM s)-  unpack ""             | StrNil = []-  unpack (strCons x xs) | (StrCons _ _) = x :: unpack xs--pack : List Char -> String-pack [] = ""-pack (x :: xs) = strCons x (pack xs)--instance Cast String (List Char) where-    cast = unpack--instance Cast (List Char) String where-    cast = pack--span : (Char -> Bool) -> String -> (String, String)-span p xs with (strM xs)-  span p ""             | StrNil        = ("", "")-  span p (strCons x xs) | (StrCons _ _) with (p x)-    | True with (span p xs)-      | (ys, zs) = (strCons x ys, zs)-    | False = ("", strCons x xs)--break : (Char -> Bool) -> String -> (String, String)-break p = span (not . p)--split : (Char -> Bool) -> String -> List String-split p xs = map pack (split p (unpack xs))--ltrim : String -> String-ltrim xs with (strM xs)-    ltrim "" | StrNil = ""-    ltrim (strCons x xs) | StrCons _ _-        = if (isSpace x) then (ltrim xs) else (strCons x xs)--trim : String -> String-trim xs = ltrim (reverse (ltrim (reverse xs)))--words' : List Char -> List (List Char)-words' s = case dropWhile isSpace s of-            [] => []-            s' => let (w, s'') = break isSpace s'-                  in w :: words' s''--words : String -> List String-words s = map pack $ words' $ unpack s--foldr1 : (a -> a -> a) -> List a -> a	-foldr1 f [x] = x-foldr1 f (x::xs) = f x (foldr1 f xs)---unwords' : List (List Char) -> List Char-unwords' [] = []                         -unwords' ws = (foldr1 addSpace ws)-        where-            addSpace : List Char -> List Char -> List Char-            addSpace w s = w ++ (' ' :: s) -          -               -unwords :  List String -> String-unwords = pack . unwords' . map unpack-
− lib/prelude/vect.idr 
@@ -1,307 +0,0 @@-module prelude.vect--import prelude.fin-import prelude.list-import prelude.nat--%access public--infixr 7 :: --data Vect : Set -> Nat -> Set where-  Nil  : Vect a O-  (::) : a -> Vect a n -> Vect a (S n)------------------------------------------------------------------------------------- Indexing into vectors-----------------------------------------------------------------------------------tail : Vect a (S n) -> Vect a n-tail (x::xs) = xs--head : Vect a (S n) -> a-head (x::xs) = x--last : Vect a (S n) -> a-last (x::[])    = x-last (x::y::ys) = last $ y::ys--init : Vect a (S n) -> Vect a n-init (x::[])    = []-init (x::y::ys) = x :: init (y::ys)--index : Fin n -> Vect a n -> a-index fO     (x::xs) = x-index (fS k) (x::xs) = index k xs-index fO     [] impossible-index (fS _) [] impossible------------------------------------------------------------------------------------- Subvectors-----------------------------------------------------------------------------------take : Fin n -> Vect a n -> (p ** Vect a p)-take fO     xs      = (_ ** [])-take (fS k) []      impossible-take (fS k) (x::xs) with (take k xs)-  | (_ ** tail) = (_ ** x::tail)--drop : Fin n -> Vect a n -> (p ** Vect a p)-drop fO     xs      = (_ ** xs)-drop (fS k) []      impossible-drop (fS k) (x::xs) = drop k xs------------------------------------------------------------------------------------- Conversions to and from list-----------------------------------------------------------------------------------total toList : Vect a n -> List a-toList []      = []-toList (x::xs) = x :: toList xs--total fromList : (l : List a) -> Vect a (length l)-fromList []      = []-fromList (x::xs) = x :: fromList xs------------------------------------------------------------------------------------- Building (bigger) vectors-----------------------------------------------------------------------------------total-(++) : Vect a m -> Vect a n -> Vect a (m + n)-(++) []      ys = ys-(++) (x::xs) ys = x :: xs ++ ys--replicate : (n : Nat) -> a -> Vect a n-replicate O     x = []-replicate (S k) x = x :: replicate k x------------------------------------------------------------------------------------- Maps-----------------------------------------------------------------------------------total map : (a -> b) -> Vect a n -> Vect b n-map f []        = []-map f (x::xs) = f x :: map f xs---- XXX: causes Idris to enter an infinite loop when type checking in the REPL---mapMaybe : (a -> Maybe b) -> Vect a n -> (p ** Vect b p)---mapMaybe f []      = (_ ** [])---mapMaybe f (x::xs) = mapMaybe' (f x) --- XXX: working around the type restrictions on case statements---  where---    mapMaybe' : (Maybe b) -> (n ** Vect b n) -> (p ** Vect b p)---    mapMaybe' Nothing  (n ** tail) = (n   ** tail)---    mapMaybe' (Just j) (n ** tail) = (S n ** j::tail)------------------------------------------------------------------------------------- Folds-----------------------------------------------------------------------------------total foldl : (a -> b -> a) -> a -> Vect b m -> a-foldl f e []      = e-foldl f e (x::xs) = foldl f (f e x) xs--total foldr : (a -> b -> b) -> b -> Vect a m -> b-foldr f e []      = e-foldr f e (x::xs) = f x (foldr f e xs)------------------------------------------------------------------------------------- Special folds-----------------------------------------------------------------------------------total and : Vect Bool m -> Bool-and = foldr (&&) True--total or : Vect Bool m -> Bool-or = foldr (||) False--total any : (a -> Bool) -> Vect a m -> Bool-any p = or . map p--total all : (a -> Bool) -> Vect a m -> Bool-all p = and . map p------------------------------------------------------------------------------------- Transformations-----------------------------------------------------------------------------------total reverse : Vect a n -> Vect a n-reverse = reverse' []-  where-    total reverse' : Vect a m -> Vect a n -> Vect a (m + n)-    reverse' acc []      ?= acc-    reverse' acc (x::xs) ?= reverse' (x::acc) xs--total intersperse' : a -> Vect a m -> (p ** Vect a p)-intersperse' sep []      = (_ ** [])-intersperse' sep (y::ys) with (intersperse' sep ys)-  | (_ ** tail) = (_ ** sep::y::tail)--total intersperse : a -> Vect a m -> (p ** Vect a p)-intersperse sep []      = (_ ** [])-intersperse sep (x::xs) with (intersperse' sep xs)-  | (_ ** tail) = (_ ** x::tail)------------------------------------------------------------------------------------- Membership tests-----------------------------------------------------------------------------------elemBy : (a -> a -> Bool) -> a -> Vect a n -> Bool-elemBy p e []      = False-elemBy p e (x::xs) with (p e x)-  | True  = True-  | False = elemBy p e xs--elem : Eq a => a -> Vect a n -> Bool-elem = elemBy (==)--lookupBy : (a -> a -> Bool) -> a -> Vect (a, b) n -> Maybe b-lookupBy p e []           = Nothing-lookupBy p e ((l, r)::xs) with (p e l)-  | True  = Just r-  | False = lookupBy p e xs--lookup : Eq a => a -> Vect (a, b) n -> Maybe b-lookup = lookupBy (==)--hasAnyBy : (a -> a -> Bool) -> Vect a m -> Vect a n -> Bool-hasAnyBy p elems []      = False-hasAnyBy p elems (x::xs) with (elemBy p x elems)-  | True  = True-  | False = hasAnyBy p elems xs--hasAny : Eq a => Vect a m -> Vect a n -> Bool-hasAny = hasAnyBy (==)------------------------------------------------------------------------------------- Searching with a predicate-----------------------------------------------------------------------------------find : (a -> Bool) -> Vect a n -> Maybe a-find p []      = Nothing-find p (x::xs) with (p x)-  | True  = Just x-  | False = find p xs--findIndex : (a -> Bool) -> Vect a n -> Maybe Nat-findIndex = findIndex' 0-  where-    findIndex' : Nat -> (a -> Bool) -> Vect a n -> Maybe Nat-    findIndex' cnt p []      = Nothing-    findIndex' cnt p (x::xs) with (p x)-      | True  = Just cnt-      | False = findIndex' (S cnt) p xs--total findIndices : (a -> Bool) -> Vect a m -> (p ** Vect Nat p)-findIndices = findIndices' 0-  where-    total findIndices' : Nat -> (a -> Bool) -> Vect a m -> (p ** Vect Nat p)-    findIndices' cnt p []      = (_ ** [])-    findIndices' cnt p (x::xs) with (findIndices' (S cnt) p xs)-      | (_ ** tail) =-       if p x then-        (_ ** cnt::tail)-       else-        (_ ** tail)--elemIndexBy : (a -> a -> Bool) -> a -> Vect a m -> Maybe Nat-elemIndexBy p e = findIndex $ p e--elemIndex : Eq a => a -> Vect a m -> Maybe Nat-elemIndex = elemIndexBy (==)--total elemIndicesBy : (a -> a -> Bool) -> a -> Vect a m -> (p ** Vect Nat p)-elemIndicesBy p e = findIndices $ p e--total elemIndices : Eq a => a -> Vect a m -> (p ** Vect Nat p)-elemIndices = elemIndicesBy (==)------------------------------------------------------------------------------------- Filters-----------------------------------------------------------------------------------total filter : (a -> Bool) -> Vect a n -> (p ** Vect a p)-filter p [] = ( _ ** [] )-filter p (x::xs) with (filter p xs)-  | (_ ** tail) =-    if p x then-      (_ ** x::tail)-    else-      (_ ** tail)--nubBy : (a -> a -> Bool) -> Vect a n -> (p ** Vect a p)-nubBy = nubBy' []-  where-    nubBy' : Vect a m -> (a -> a -> Bool) -> Vect a n -> (p ** Vect a p)-    nubBy' acc p []      = (_ ** [])-    nubBy' acc p (x::xs) with (elemBy p x acc)-      | True  = nubBy' acc p xs-      | False with (nubBy' (x::acc) p xs)-        | (_ ** tail) = (_ ** x::tail)--nub : Eq a => Vect a n -> (p ** Vect a p)-nub = nubBy (==)------------------------------------------------------------------------------------- Splitting and breaking lists---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Predicates-----------------------------------------------------------------------------------isPrefixOfBy : (a -> a -> Bool) -> Vect a m -> Vect a n -> Bool-isPrefixOfBy p [] right        = True-isPrefixOfBy p left []         = False-isPrefixOfBy p (x::xs) (y::ys) with (p x y)-  | True  = isPrefixOfBy p xs ys-  | False = False--isPrefixOf : Eq a => Vect a m -> Vect a n -> Bool-isPrefixOf = isPrefixOfBy (==)--isSuffixOfBy : (a -> a -> Bool) -> Vect a m -> Vect a n -> Bool-isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right)--isSuffixOf : Eq a => Vect a m -> Vect a n -> Bool-isSuffixOf = isSuffixOfBy (==)------------------------------------------------------------------------------------- Conversions-----------------------------------------------------------------------------------total maybeToVect : Maybe a -> (p ** Vect a p)-maybeToVect Nothing  = (_ ** [])-maybeToVect (Just j) = (_ ** [j])--total vectToMaybe : Vect a n -> Maybe a-vectToMaybe []      = Nothing-vectToMaybe (x::xs) = Just x------------------------------------------------------------------------------------- Misc-----------------------------------------------------------------------------------catMaybes : Vect (Maybe a) n -> (p ** Vect a p)-catMaybes []             = (_ ** [])-catMaybes (Nothing::xs)  = catMaybes xs-catMaybes ((Just j)::xs) with (catMaybes xs)-  | (_ ** tail) = (_ ** j::tail)------------------------------------------------------------------------------------- Proofs-----------------------------------------------------------------------------------prelude.vect.reverse'_lemma_2 = proof {-    intros;-    rewrite (plusSuccRightSucc m n1);-    exact value;-}--prelude.vect.reverse'_lemma_1 = proof {-    intros;-    rewrite sym (plusZeroRightNeutral m);-    exact value;-}-
− lib/system.idr 
@@ -1,30 +0,0 @@-module system--import prelude--%access public--getArgs : IO (List String)-getArgs = do n <- numArgs-             ga' [] 0 n -  where-    numArgs : IO Int-    numArgs = mkForeign (FFun "idris_numArgs" [FPtr] FInt) prim__vm--    getArg : Int -> IO String-    getArg x = mkForeign (FFun "idris_getArg" [FPtr, FInt] (FAny String)) prim__vm x--    ga' : List String -> Int -> Int -> IO (List String)-    ga' acc i n = if (i == n) then (return $ reverse acc) else-                    do arg <- getArg i-                       ga' (arg :: acc) (i+1) n--getEnv : String -> IO String-getEnv x = mkForeign (FFun "getenv" [FString] FString) x--exit : Int -> IO ()-exit code = mkForeign (FFun "exit" [FInt] FUnit) code--usleep : Int -> IO ()-usleep i = mkForeign (FFun "usleep" [FInt] FUnit) i-
rts/idris_rts.c view
@@ -80,7 +80,7 @@         void* ptr = (void*)(vm->heap_next + sizeof(size_t));         *((size_t*)(vm->heap_next)) = size + sizeof(size_t);         vm -> heap_next += size + sizeof(size_t);-        bzero(ptr, size);+        memset(ptr, 0, size);         return ptr;     } else {         gc(vm);
rts/idris_rts.h view
@@ -129,6 +129,7 @@  #define SETTAG(x, a) (x)->info.c.tag = (a) #define SETARG(x, i, a) ((VAL*)((x)->info.c.args))[i] = ((VAL)(a))+#define GETARG(x, i) ((VAL*)((x)->info.c.args))[i]  void PROJECT(VM* vm, VAL r, int loc, int arity);  void SLIDE(VM* vm, int args);
rts/libidris_rts.a view

binary file changed (27208 → 27120 bytes)

src/Core/CaseTree.hs view
@@ -1,6 +1,8 @@-module Core.CaseTree(CaseDef(..), SC(..), CaseAlt(..), CaseTree,-                     simpleCase, small, namesUsed) where+{-# LANGUAGE PatternGuards #-} +module Core.CaseTree(CaseDef(..), SC(..), CaseAlt(..), Phase(..), CaseTree,+                     simpleCase, small, namesUsed, findCalls, findUsedArgs) where+ import Core.TT  import Control.Monad.State@@ -12,9 +14,11 @@     deriving Show  data SC = Case Name [CaseAlt] -- invariant: lowest tags first+        | ProjCase Term [CaseAlt] -- special case for projections         | STerm Term         | UnmatchedCase String -- error message-    deriving (Show, Eq, Ord)+        | ImpossibleCase -- already checked to be impossible+    deriving (Eq, Ord) {-!  deriving instance Binary SC  !-}@@ -27,6 +31,28 @@ deriving instance Binary CaseAlt  !-} +instance Show SC where+    show sc = show' 1 sc+      where+        show' i (Case n alts) = "case " ++ show n ++ " of\n" ++ indent i ++ +                                    showSep ("\n" ++ indent i) (map (showA i) alts)+        show' i (ProjCase tm alts) = "case " ++ show tm ++ " of " +++                                      showSep ("\n" ++ indent i) (map (showA i) alts)+        show' i (STerm tm) = show tm+        show' i (UnmatchedCase str) = "error " ++ show str+        show' i ImpossibleCase = "impossible"++        indent i = concat $ take i (repeat "    ")++        showA i (ConCase n t args sc) +           = show n ++ "(" ++ showSep (", ") (map show args) ++ ") => "+                ++ show' (i+1) sc+        showA i (ConstCase t sc) +           = show t ++ " => " ++ show' (i+1) sc+        showA i (DefaultCase sc) +           = "_ => " ++ show' (i+1) sc+              + type CaseTree = SC type Clause   = ([Pat], (Term, Term)) type CS = ([Term], Int)@@ -43,7 +69,7 @@  -- simple terms can be inlined trivially - good for primitives in particular small :: SC -> Bool-small t = termsize t < 150+small t = False -- termsize t < 150  namesUsed :: SC -> [Name] namesUsed sc = nub $ nu' [] sc where@@ -62,32 +88,99 @@     nut ps (Bind n b sc) = nut (n:ps) sc     nut ps _ = [] -simpleCase :: Bool -> Bool -> FC -> [([Name], Term, Term)] -> TC CaseDef-simpleCase tc cover fc [] +-- Return all called functions, and which arguments are used in each argument position+-- for the call, in order to help reduce compilation time, and trace all unused+-- arguments++findCalls :: SC -> [Name] -> [(Name, [[Name]])]+findCalls sc topargs = nub $ nu' topargs sc where+    nu' ps (Case n alts) = nub (concatMap (nua (n : ps)) alts)+    nu' ps (STerm t)     = nub $ nut ps t+    nu' ps _ = []++    nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc) +    nua ps (ConstCase _ sc) = nu' ps sc+    nua ps (DefaultCase sc) = nu' ps sc++    nut ps (P Ref n _) | n `elem` ps = []+                     | otherwise = [(n, [])] -- tmp+    nut ps fn@(App f a) +        | (P Ref n _, args) <- unApply fn+             = if n `elem` ps then nut ps f ++ nut ps a+                  else [(n, map argNames args)] ++ concatMap (nut ps) args+        | otherwise = nut ps f ++ nut ps a+    nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc+    nut ps (Bind n b sc) = nut (n:ps) sc+    nut ps _ = []++    argNames tm = let ns = directUse tm in+                      filter (\x -> x `elem` ns) topargs++-- Find names which are used directly (i.e. not in a function call) in a term++directUse :: Eq n => TT n -> [n]+directUse (P _ n _) = [n]+directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n])+                                        ++ directUse t+directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])+directUse fn@(App f a) +    | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them+    | otherwise = nub $ directUse f ++ directUse a+directUse (Proj x i) = nub $ directUse x+directUse _ = []++-- Find all directly used arguments (i.e. used but not in function calls)++findUsedArgs :: SC -> [Name] -> [Name]+findUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nub $ nu' sc) where+    nu' (Case n alts) = n : concatMap nua alts+    nu' (STerm t)     = directUse t+    nu' _             = []++    nua (ConCase n i args sc) = nu' sc +    nua (ConstCase _ sc)      = nu' sc+    nua (DefaultCase sc)      = nu' sc++data Phase = CompileTime | RunTime+    deriving (Show, Eq)++-- Generate a simple case tree+-- Work Left to Right at Compile Time ++simpleCase :: Bool -> Bool -> Phase -> FC -> [([Name], Term, Term)] -> TC CaseDef+simpleCase tc cover phase fc []                   = return $ CaseDef [] (UnmatchedCase "No pattern clauses") []-simpleCase tc cover fc cs -      = let pats       = map (\ (avs, l, r) -> (avs, toPats tc l, (l, r))) cs+simpleCase tc cover phase fc cs +      = let proj       = phase == RunTime+            pats       = map (\ (avs, l, r) -> +                                   (avs, rev phase (toPats tc l), (l, r))) cs             chkPats    = mapM chkAccessible pats in             case chkPats of                 OK pats ->                     let numargs    = length (fst (head pats))                          ns         = take numargs args                         (tree, st) = runState -                                         (match ns pats (defaultCase cover)) ([], numargs) in-                        return $ CaseDef ns (prune tree) (fst st)+                                         (match (rev phase ns) pats (defaultCase cover)) ([], numargs)+                        t          = CaseDef ns (prune proj (depatt ns tree)) (fst st) in+                        if proj then return (stripLambdas t) else return t                 Error err -> Error (At fc err)     where args = map (\i -> MN i "e") [0..]           defaultCase True = STerm Erased           defaultCase False = UnmatchedCase "Error" -          chkAccessible (avs, l, c) = do mapM_ (acc l) avs-                                         return (l, c)+          chkAccessible (avs, l, c) +               | phase == RunTime = return (l, c)+               | otherwise = do mapM_ (acc l) avs+                                return (l, c)            acc [] n = Error (Inaccessible n)            acc (PV x : xs) n | x == n = OK ()           acc (PCon _ _ ps : xs) n = acc (ps ++ xs) n           acc (_ : xs) n = acc xs n +rev CompileTime = id+rev _ = reverse+ data Pat = PCon Name Int [Pat]          | PConst Const          | PV Name@@ -123,9 +216,9 @@                                           then return PAny                                            else do put (n : ns)                                                   return (PV n)-    toPat' (App f a)          args = toPat' f (a : args)-    toPat' (Constant (I c)) [] = return $ PConst (I c) -    toPat' _                _  = return PAny+    toPat' (App f a)  args = toPat' f (a : args)+    toPat' (Constant x@(I _)) [] = return $ PConst x +    toPat' _            _  = return PAny   data Partition = Cons [Clause]@@ -154,7 +247,9 @@ match [] (([], ret) : xs) err      = do (ts, v) <- get          put (ts ++ (map (fst.snd) xs), v)-         return $ STerm (snd ret) -- run out of arguments+         case snd ret of+            Impossible -> return ImpossibleCase+            tm -> return $ STerm tm -- run out of arguments match vs cs err = do let ps = partition cs                      cs <- mixture vs ps err                      return cs@@ -246,22 +341,82 @@     do let alts' = map (repVar v) alts        match vs alts' err   where-    repVar v (PV p : ps , (lhs, res)) = (ps, (lhs, subst p (P Bound v (V 0)) res))+    repVar v (PV p : ps , (lhs, res)) = (ps, (lhs, subst p (P Bound v Erased) res))     repVar v (PAny : ps , res) = (ps, res) -prune :: SC -> SC-prune (Case n alts) -    = let alts' = map pruneAlt $ -                      filter notErased alts in+-- fix: case e of S k -> f (S k)  ==> case e of S k -. f e+depatt :: [Name] -> SC -> SC+depatt ns tm = dp [] tm+  where+    dp ms (STerm tm) = STerm (applyMaps ms tm)+    dp ms (Case x alts) = Case x (map (dpa ms x) alts)+    dp ms sc = sc++    dpa ms x (ConCase n i args sc)+        = ConCase n i args (dp ((x, (n, args)) : ms) sc)+    dpa ms x (ConstCase c sc) = ConstCase c (dp ms sc)+    dpa ms x (DefaultCase sc) = DefaultCase (dp ms sc)++    applyMaps ms f@(App _ _)+       | (P nt cn pty, args) <- unApply f+            = let args' = map (applyMaps ms) args in+                  applyMap ms nt cn pty args'+        where+          applyMap [] nt cn pty args' = mkApp (P nt cn pty) args'+          applyMap ((x, (n, args)) : ms) nt cn pty args'+            | and ((n == cn) : zipWith same args args') = P Ref x Erased+            | otherwise = applyMap ms nt cn pty args'+          same n (P _ n' _) = n == n'+          same _ _ = False+    applyMaps ms (App f a) = App (applyMaps ms f) (applyMaps ms a)+    applyMaps ms t = t++prune :: Bool -> -- ^ Convert single branches to projections (only useful at runtime)+         SC -> SC+prune proj (Case n alts) +    = let alts' = filter notErased (map pruneAlt alts) in           case alts' of-            [] -> STerm Erased+            [] -> ImpossibleCase+            as@[ConCase cn i args sc] -> if proj then mkProj n 0 args sc+                                                 else Case n as             as  -> Case n as-    where pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune sc)-          pruneAlt (ConstCase c sc) = ConstCase c (prune sc)-          pruneAlt (DefaultCase sc) = DefaultCase (prune sc)+    where pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc)+          pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)+          pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)            notErased (DefaultCase (STerm Erased)) = False+          notErased (DefaultCase ImpossibleCase) = False           notErased _ = True-prune t = t++          mkProj n i []       sc = sc+          mkProj n i (x : xs) sc = mkProj n (i + 1) xs (projRep x n i sc)++          projRep :: Name -> Name -> Int -> SC -> SC+          projRep arg n i (Case x alts)+                | x == arg = ProjCase (Proj (P Bound n Erased) i) +                                      (map (projRepAlt arg n i) alts)+                | otherwise = Case x (map (projRepAlt arg n i) alts)+          projRep arg n i (ProjCase t alts)+                = ProjCase (projRepTm arg n i t) (map (projRepAlt arg n i) alts)+          projRep arg n i (STerm t) = STerm (projRepTm arg n i t)+          projRep arg n i c = c -- unmatched++          projRepAlt arg n i (ConCase cn t args rhs)+              = ConCase cn t args (projRep arg n i rhs)+          projRepAlt arg n i (ConstCase t rhs)+              = ConstCase t (projRep arg n i rhs)+          projRepAlt arg n i (DefaultCase rhs)+              = DefaultCase (projRep arg n i rhs)++          projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t ++prune _ t = t++stripLambdas :: CaseDef -> CaseDef+stripLambdas (CaseDef ns (STerm (Bind x (Lam _) sc)) tm)+    = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm)+stripLambdas x = x++
src/Core/CoreParser.hs view
@@ -20,9 +20,9 @@               opLetter = iOpLetter,               identLetter = identLetter haskellDef <|> lchar '.',               reservedOpNames = [":", "..", "=", "\\", "|", "<-", "->", "=>", "**"],-              reservedNames = ["let", "in", "data", "record", "Set", +              reservedNames = ["let", "in", "data", "codata", "record", "Set",                                 "do", "dsl", "import", "impossible", -                               "case", "of", "total",+                               "case", "of", "total", "partial",                                "infix", "infixl", "infixr",                                 "where", "with", "syntax", "proof", "postulate",                                "using", "namespace", "class", "instance",
src/Core/Elaborate.hs view
@@ -148,7 +148,7 @@ unique_hole :: Name -> Elab' aux Name unique_hole n = do ES p _ _ <- get                    let bs = bound_in (pterm (fst p)) ++ bound_in (ptype (fst p))-                   n' <- uniqueNameCtxt (context (fst p)) n (holes (fst p) ++ bs)+                   n' <- uniqueNameCtxt (context (fst p)) n (holes (fst p) ++ bs ++ dontunify (fst p))                    return n'   where     bound_in (Bind n b sc) = n : bi b ++ bound_in sc@@ -305,7 +305,7 @@                                 when i (movelast n)      mkMN n@(MN _ _) = n-    mkMN n@(UN x) = MN 0 x+    mkMN n@(UN x) = MN 1000 x     mkMN (NS n xs) = NS (mkMN n) xs  apply :: Raw -> [(Bool, Int)] -> Elab' aux [Name]@@ -317,24 +317,21 @@        -- HMMM: Actually, if we get it wrong, the typechecker will complain!        -- so do nothing        ptm <- get_term-       let dontunify = if null imps then [] -- do all we can -                          else-                          map fst (filter (not.snd) (zip args (map fst imps)))+       hs <- get_holes        ES (p, a) s prev <- get-       let (n, hs) = -- trace ("AVOID UNIFY: " ++ show (fn, dontunify)) $ +       let dont = nub $ head hs : dontunify p +++                          if null imps then [] -- do all we can +                             else+                             map fst (filter (not.snd) (zip args (map fst imps)))+       let (n, hs) = -- trace ("AVOID UNIFY: " ++ show (fn, dont) ++ "\n" ++ show ptm) $                        unified p-       let unify = dropGiven dontunify hs-       put (ES (p { unified = (n, unify) }, a) s prev)+       let unify = dropGiven dont hs+       put (ES (p { dontunify = dont, unified = (n, unify) }, a) s prev)        end_unify        return (map (updateUnify unify) args)   where updateUnify hs n = case lookup n hs of                                 Just (P _ t _) -> t                                 _ -> n-        dropGiven du [] = []-        dropGiven du ((n, P a t ty) : us) | n `elem` du && not (t `elem` du)-                                   = (t, P a n ty) : dropGiven du us-        dropGiven du (u@(n, _) : us) | n `elem` du = dropGiven du us-        dropGiven du (u : us) = u : dropGiven du us  apply2 :: Raw -> [Maybe (Elab' aux ())] -> Elab' aux ()  apply2 fn elabs = @@ -375,6 +372,11 @@            when (null claims) (start_unify n)            let sc' = instantiate (P Bound n t) sc            claim n (forget t)+           case i of+               Nothing -> return ()+               Just _ -> -- don't solve by unification as there is an explicit value+                         do ES (p, a) s prev <- get+                            put (ES (p { dontunify = n : dontunify p }, a) s prev)            doClaims sc' is ((n, i) : claims)     doClaims t [] claims = return (reverse claims)     doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n
src/Core/Evaluate.hs view
@@ -5,10 +5,10 @@                 simplify, specialise, hnf, convEq, convEq',                 Def(..), Accessibility(..), Totality(..), PReason(..),                 Context, initContext, ctxtAlist, uconstraints, next_tvar,-                addToCtxt, setAccess, setTotal, addCtxtDef, addTyDecl, addDatatype, -                addCasedef, addOperator,-                lookupNames, lookupTy, lookupP, lookupDef, lookupVal, lookupTotal,-                lookupTyEnv, isConName, isFnName,+                addToCtxt, setAccess, setTotal, addCtxtDef, addTyDecl, +                addDatatype, addCasedef, simplifyCasedef, addOperator,+                lookupNames, lookupTy, lookupP, lookupDef, lookupVal, +                lookupTotal, lookupTyEnv, isConName, isFnName,                 Value(..)) where  import Debug.Trace@@ -167,7 +167,7 @@                        ev ntimes (n:stk) True env tm                 [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty                                           return $ VP nt n vty-                [(CaseOp inl _ _ [] tree _ _, Public)] -> -- unoptimised version+                [(CaseOp inl _ _ _ [] tree _ _, Public)] -> -- unoptimised version                    if simpl && (not inl || elem n stk)                          then liftM (VP Ref n) (ev ntimes stk top env ty)                         else do c <- evCase ntimes (n:stk) top env [] [] tree @@ -231,7 +231,7 @@         = traceWhen traceon (show stk) $           do let val = lookupDefAcc Nothing n atRepl ctxt              case val of-                [(CaseOp inl _ _ ns tree _ _, Public)]  ->+                [(CaseOp inl _ _ _ ns tree _ _, Public)]  ->                   if simpl && (not inl || elem n stk)                       then return $ unload env (VP Ref n ty) args                      else do c <- evCase ntimes (n:stk) top env ns args tree@@ -391,7 +391,7 @@     ev env (P Ref n ty) = case lookupDef Nothing n ctxt of         [Function _ t]           -> ev env t         [TyDecl nt ty]           -> return $ HP nt n ty-        [CaseOp inl _ _ [] tree _ _] ->+        [CaseOp inl _ _ _ [] tree _ _] ->             do c <- evCase env [] [] tree                case c of                    (Nothing, _, _) -> return $ HP Ref n ty@@ -421,7 +421,7 @@                                                app <- apply env sc' as                                                wknH (-1) app     apply env (HP Ref n ty) args-        | [CaseOp _ _ _ ns tree _ _] <- lookupDef Nothing n ctxt+        | [CaseOp _ _ _ _ ns tree _ _] <- lookupDef Nothing n ctxt             = do c <- evCase env ns args tree                  case c of                     (Nothing, _, env') -> return $ unload env' (HP Ref n ty) args@@ -548,8 +548,8 @@     sameDefs ps x y = case (lookupDef Nothing x ctxt, lookupDef Nothing y ctxt) of                         ([Function _ xdef], [Function _ ydef])                               -> ceq ((x,y):ps) xdef ydef-                        ([CaseOp _ _ _ _ xdef _ _],   -                         [CaseOp _ _ _ _ ydef _ _])+                        ([CaseOp _ _ _ _ _ xdef _ _],   +                         [CaseOp _ _ _ _ _ ydef _ _])                               -> caseeq ((x,y):ps) xdef ydef                         _ -> return False @@ -571,7 +571,9 @@ data Def = Function Type Term          | TyDecl NameType Type           | Operator Type Int ([Value] -> Maybe Value)-         | CaseOp Bool Type [([Name], Term, Term)] -- Bool for inlineable+         | CaseOp Bool Type -- bool for inlinable+                  [Either Term (Term, Term)] -- original definition+                  [([Name], Term, Term)] -- simplified definition                   [Name] SC -- Compile time case definition                   [Name] SC -- Run time cae definitions {-! @@ -582,7 +584,7 @@     show (Function ty tm) = "Function: " ++ show (ty, tm)     show (TyDecl nt ty) = "TyDecl: " ++ show nt ++ " " ++ show ty     show (Operator ty _ _) = "Operator: " ++ show ty-    show (CaseOp _ ty ps ns sc ns' sc') +    show (CaseOp _ ty ps_in ps ns sc ns' sc')          = "Case: " ++ show ty ++ " " ++ show ps ++ "\n" ++                                          show ns ++ " " ++ show sc ++ "\n" ++                                         show ns' ++ " " ++ show sc'@@ -602,22 +604,25 @@     deriving (Show, Eq)  data Totality = Total [Int] -- well-founded arguments+              | Productive               | Partial PReason               | Unchecked     deriving Eq  data PReason = Other [Name] | Itself | NotCovering | NotPositive | UseUndef Name-             | Mutual [Name]+             | Mutual [Name] | NotProductive     deriving (Show, Eq)  instance Show Totality where     show (Total args)= "Total" -- ++ show args ++ " decreasing arguments"+    show Productive = "Productive" -- ++ show args ++ " decreasing arguments"     show Unchecked = "not yet checked for totality"     show (Partial Itself) = "possibly not total as it is not well founded"     show (Partial NotCovering) = "not total as there are missing cases"     show (Partial NotPositive) = "not strictly positive"+    show (Partial NotProductive) = "not productive"     show (Partial (Other ns)) = "possibly not total due to: " ++ showSep ", " (map show ns)-    show (Partial (Mutual ns)) = "possibly not total due to mutual recursive path " ++ +    show (Partial (Mutual ns)) = "possibly not total due to recursive path " ++                                   showSep " --> " (map show ns)  {-!@@ -632,9 +637,11 @@ deriving instance Binary PReason !-} -data Context = MkContext { uconstraints :: [UConstraint],-                           next_tvar    :: Int,-                           definitions  :: Ctxt (Def, Accessibility, Totality) }+data Context = MkContext { +                  uconstraints :: [UConstraint],+                  next_tvar    :: Int,+                  definitions  :: Ctxt (Def, Accessibility, Totality) +                }  initContext = MkContext [] 0 emptyContext @@ -687,19 +694,53 @@                   (TyDecl (DCon tag (arity ty')) ty, Public, Unchecked) ctxt)  addCasedef :: Name -> Bool -> Bool -> Bool -> -              [([Name], Term, Term)] -> [([Name], Term, Term)] ->+              [Either Term (Term, Term)] -> +              [([Name], Term, Term)] -> +              [([Name], Term, Term)] ->               Type -> Context -> Context-addCasedef n alwaysInline tcase covering ps psrt ty uctxt +addCasedef n alwaysInline tcase covering ps_in ps psrt ty uctxt      = let ctxt = definitions uctxt-          ctxt' = case (simpleCase tcase covering (FC "" 0) ps, -                        simpleCase tcase covering (FC "" 0) psrt) of+          access = case lookupDefAcc Nothing n False uctxt of+                        [(_, acc)] -> acc+                        _ -> Public+          ctxt' = case (simpleCase tcase covering CompileTime (FC "" 0) ps, +                        simpleCase tcase covering RunTime (FC "" 0) psrt) of                     (OK (CaseDef args sc _), OK (CaseDef args' sc' _)) -> -                                       let inl = alwaysInline || small sc' in-                                           addDef n (CaseOp inl ty ps args sc args' sc',-                                                     Public, Unchecked) ctxt in+                       let inl = alwaysInline || small sc' in+                           addDef n (CaseOp inl ty ps_in ps args sc args' sc',+                                      access, Unchecked) ctxt in           uctxt { definitions = ctxt' } -addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) -> Context -> Context+simplifyCasedef :: Name -> Context -> Context+simplifyCasedef n uctxt+   = let ctxt = definitions uctxt+         ctxt' = case lookupCtxt Nothing n ctxt of+              [(CaseOp inl ty [] ps args sc args' sc', acc, tot)] ->+                 ctxt -- nothing to simplify (or already done...)+              [(CaseOp inl ty ps_in ps args sc args' sc', acc, tot)] ->+                 let pdef = map debind $ map simpl ps_in in+                     case simpleCase False True CompileTime (FC "" 0) pdef of+                       OK (CaseDef args sc _) ->+-- Erase the original patterns, since we won't use them again and it+-- only clutters the .ibc+                          addDef n (CaseOp inl ty [] ps args sc args' sc',+                                    acc, tot) ctxt +              _ -> ctxt in+         uctxt { definitions = ctxt' }+  where                  +    depat acc (Bind n (PVar t) sc) +        = depat (n : acc) (instantiate (P Bound n t) sc)+    depat acc x = (acc, x)+    debind (Right (x, y)) = let (vs, x') = depat [] x +                                (_, y') = depat [] y in+                                (vs, x', y')+    debind (Left x)       = let (vs, x') = depat [] x in+                                (vs, x', Impossible)+    simpl (Right (x, y)) = Right (x, simplify uctxt [] y)+    simpl t = t++addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) -> +               Context -> Context addOperator n ty a op uctxt     = let ctxt = definitions uctxt            ctxt' = addDef n (Operator ty a op, Public, Unchecked) ctxt in@@ -719,7 +760,7 @@                        (Function ty _) -> return ty                        (TyDecl _ ty) -> return ty                        (Operator ty _ _) -> return ty-                       (CaseOp _ ty _ _ _ _ _) -> return ty+                       (CaseOp _ ty _ _ _ _ _ _) -> return ty  isConName :: Maybe [String] -> Name -> Context -> Bool isConName root n ctxt @@ -735,7 +776,7 @@                case tfst def of                     (Function _ _) -> return True                     (Operator _ _ _) -> return True-                    (CaseOp _ _ _ _ _ _ _) -> return True+                    (CaseOp _ _ _ _ _ _ _ _) -> return True                     _ -> return False  lookupP :: Maybe [String] -> Name -> Context -> [Term]@@ -744,7 +785,7 @@         p <- case def of           (Function ty tm, a, _) -> return (P Ref n ty, a)           (TyDecl nt ty, a, _) -> return (P nt n ty, a)-          (CaseOp _ ty _ _ _ _ _, a, _) -> return (P Ref n ty, a)+          (CaseOp _ ty _ _ _ _ _ _, a, _) -> return (P Ref n ty, a)           (Operator ty _ _, a, _) -> return (P Ref n ty, a)         case snd p of             Hidden -> []@@ -753,7 +794,8 @@ lookupDef :: Maybe [String] -> Name -> Context -> [Def] lookupDef root n ctxt = map tfst $ lookupCtxt root n (definitions ctxt) -lookupDefAcc :: Maybe [String] -> Name -> Bool -> Context -> [(Def, Accessibility)]+lookupDefAcc :: Maybe [String] -> Name -> Bool -> Context -> +                [(Def, Accessibility)] lookupDefAcc root n mkpublic ctxt      = map mkp $ lookupCtxt root n (definitions ctxt)   where mkp (d, a, _) = if mkpublic then (d, Public) else (d, a)
src/Core/ProofState.hs view
@@ -5,7 +5,7 @@    evaluation/checking inside the proof system, etc. --}  module Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,-                  Tactic(..), Goal(..), processTactic) where+                  Tactic(..), Goal(..), processTactic, dropGiven) where  import Core.Typecheck import Core.Evaluate@@ -24,6 +24,7 @@                        nextname :: Int,    -- name supply                        pterm    :: Term,   -- current proof term                        ptype    :: Type,   -- original goal+                       dontunify :: [Name], -- explicitly given by programmer, leave it                        unified  :: (Name, [(Name, Term)]),                        solved   :: Maybe (Name, Term),                        problems :: Fails,@@ -73,8 +74,8 @@ -- Some utilites on proof and tactic states  instance Show ProofState where-    show (PS nm [] _ tm _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals"-    show (PS nm (h:hs) _ tm _ _ _ _ _ i _ _ ctxt _ _) +    show (PS nm [] _ tm _ _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals"+    show (PS nm (h:hs) _ tm _ _ _ _ _ _ i _ _ ctxt _ _)            = let OK g = goal (Just h) tm                 wkenv = premises g in                 "Other goals: " ++ show hs ++ "\n" ++@@ -97,12 +98,12 @@                showG ps b = showEnv ps (binderTy b)  instance Pretty ProofState where-  pretty (PS nm [] _ trm _ _ _ _ _ _ _ _ _ _ _) =+  pretty (PS nm [] _ trm _ _ _ _ _ _ _ _ _ _ _ _) =     if size nm > breakingSize then       pretty nm <> colon $$ nest nestingSize (text " no more goals.")     else       pretty nm <> colon <+> text " no more goals."-  pretty p@(PS nm (h:hs) _ tm _ _ _ _ _ i _ _ ctxt _ _) =+  pretty p@(PS nm (h:hs) _ tm _ _ _ _ _ _ i _ _ ctxt _ _) =     let OK g  = goal (Just h) tm in     let wkEnv = premises g in       text "Other goals" <+> colon <+> pretty hs $$@@ -170,7 +171,7 @@ newProof :: Name -> Context -> Type -> ProofState newProof n ctxt ty = let h = holeName 0                           ty' = vToP ty in-                         PS n [h] 1 (Bind h (Hole ty') (P Bound h ty')) ty (h, []) +                         PS n [h] 1 (Bind h (Hole ty') (P Bound h ty')) ty [] (h, [])                              Nothing [] []                             [] []                             Nothing ctxt "" False@@ -265,6 +266,7 @@                                             if n `elem` hs                                                then ps { holes = n : (hs \\ [n]) }                                                else ps)+                        ps <- get                         return t   movelast :: Name -> RunTactic@@ -351,11 +353,13 @@                        let (uh, uns) = unified ps                        action (\ps -> ps { holes = holes ps \\ [x],                                            solved = Just (x, val),+                                           -- dontunify = dontunify ps \\ [x],                                            -- unified = (uh, uns ++ [(x, val)]),                                            instances = instances ps \\ [x] })                        return $ {- Bind x (Let ty val) sc -} instantiate val (pToV x sc)    | otherwise    = lift $ tfail $ IncompleteTerm val-solve _ _ h = fail $ "Not a guess " ++ show h+solve _ _ h = do ps <- get+                 fail $ "Not a guess " ++ show h ++ "\n" ++ show (holes ps, pterm ps)  introTy :: Raw -> Maybe Name -> RunTactic introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =@@ -487,11 +491,20 @@ solve_unified ctxt env tm =      do ps <- get        let (_, ns) = unified ps-       action (\ps -> ps { holes = holes ps \\ map fst ns })-       action (\ps -> ps { pterm = updateSolved ns (pterm ps) })-       action (\ps -> ps { injective = map (tmap (updateSolved ns)) (injective ps) })-       return (updateSolved ns tm)+       let unify = dropGiven (dontunify ps) ns+       action (\ps -> ps { holes = holes ps \\ map fst unify })+       action (\ps -> ps { pterm = updateSolved unify (pterm ps) })+       action (\ps -> ps { injective = map (tmap (updateSolved unify)) (injective ps) })+       return (updateSolved unify tm)+  where +dropGiven du [] = []+dropGiven du ((n, P Bound t ty) : us) | n `elem` du && not (t `elem` du)+                           = (t, P Bound n ty) : dropGiven du us+dropGiven du (u@(n, _) : us) | n `elem` du = dropGiven du us+-- dropGiven du (u@(_, P a n ty) : us) | n `elem` du = dropGiven du us+dropGiven du (u : us) = u : dropGiven du us+ updateSolved xs (Bind n (Hole ty) t)     | Just v <- lookup n xs = instantiate v (pToV n (updateSolved xs t)) updateSolved xs (Bind n b t) @@ -519,9 +532,10 @@                             Nothing -> fail "Nothing to undo."                             Just pold -> return (pold, "") processTactic EndUnify ps -    = let (h, ns) = unified ps+    = let (h, ns_in) = unified ps+          ns = dropGiven (dontunify ps) ns_in           ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns -          tm' = -- trace ("Updating " ++ show ns' ++ " in " ++ show (pterm ps)) $+          tm' = -- trace ("Updating " ++ show ns') $ --  ++ " in " ++ show (pterm ps)) $                 updateSolved ns' (pterm ps)            probs' = updateProblems ns' (problems ps) in           case probs' of
src/Core/TT.hs view
@@ -48,6 +48,8 @@               -- Int is 'score' - how much we did unify               -- Bool indicates recoverability, True indicates more info may make               -- unification succeed+         | InfiniteUnify Name Term [(Name, Type)]+         | CantConvert Term Term [(Name, Type)]          | NoSuchVariable Name          | NoTypeDecl Name          | NotInjective Term Term Term@@ -64,6 +66,8 @@   size (Msg msg) = length msg   size (InternalMsg msg) = length msg   size (CantUnify _ left right err _ score) = size left + size right + size err+  size (InfiniteUnify _ right _) = size right+  size (CantConvert left right _) = size left + size right   size (NoSuchVariable name) = size name   size (NoTypeDecl name) = size name   size (NotInjective l c r) = size l + size c + size r@@ -162,6 +166,7 @@ data Name = UN String           | NS Name [String] -- root, namespaces            | MN Int String+          | NErased -- name of somethng which is never used in scope   deriving (Eq, Ord) {-!  deriving instance Binary Name @@ -171,6 +176,7 @@   size (UN n)     = 1   size (NS n els) = 1 + length els   size (MN i n) = 1+  size NErased = 1  instance Pretty Name where   pretty (UN n) = text n@@ -181,7 +187,7 @@     show (UN n) = n     show (NS n s) = showSep "." (reverse s) ++ "." ++ show n     show (MN i s) = "{" ++ s ++ show i ++ "}"-+    show NErased = "_"  -- Contexts allow us to map names to things. A root name maps to a collection -- of things in different namespaces with that name.@@ -189,6 +195,10 @@ type Ctxt a = Map.Map Name (Map.Map Name a) emptyContext = Map.empty +tcname (UN ('@':_)) = True+tcname (NS n _) = tcname n+tcname _ = False+ nsroot (NS n _) = n nsroot n = n @@ -410,7 +420,9 @@           | Bind n (Binder (TT n)) (TT n)           | App (TT n) (TT n) -- function, function type, arg           | Constant Const+          | Proj (TT n) Int -- argument projection; runtime only           | Erased+          | Impossible -- special case for totality checking           | Set UExp   deriving (Ord, Functor) {-! @@ -458,6 +470,7 @@     (==) (App fx ax)    (App fy ay)    = fx == fy && ax == ay     (==) (Set _)        (Set _)        = True -- deal with constraints later     (==) (Constant x)   (Constant y)   = x == y+    (==) (Proj x i)     (Proj y j)     = x == y && i == j     (==) Erased         _              = True     (==) _              Erased         = True     (==) _              _              = False@@ -487,6 +500,7 @@     subst i (V x) | i == x = e     subst i (Bind x b sc) = Bind x (fmap (subst i) b) (subst (i+1) sc)     subst i (App f a) = App (subst i f) (subst i a)+    subst i (Proj x idx) = Proj (subst i x) idx      subst i t = t  pToV :: Eq n => n -> TT n -> TT n@@ -496,6 +510,7 @@                 | n == x    = Bind x (fmap (pToV' n i) b) sc                 | otherwise = Bind x (fmap (pToV' n i) b) (pToV' n (i+1) sc) pToV' n i (App f a) = App (pToV' n i f) (pToV' n i a)+pToV' n i (Proj t idx) = Proj (pToV' n i t) idx pToV' n i t = t  -- Convert several names. First in the list comes out as V 0@@ -537,6 +552,7 @@              noB' i (Guess t v) = no' i t && no' i v              noB' i b = no' i (binderTy b)     no' i (App f a) = no' i f && no' i a+    no' i (Proj x _) = no' i x     no' i _ = True  -- Returns all names used free in the term@@ -547,6 +563,7 @@                                         ++ freeNames t freeNames (Bind n b sc) = nub $ freeNames (binderTy b) ++ (freeNames sc \\ [n]) freeNames (App f a) = nub $ freeNames f ++ freeNames a+freeNames (Proj x i) = nub $ freeNames x freeNames _ = []  -- Return the arity of a (normalised) type@@ -669,6 +686,8 @@       bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug     prettySe p env (App f a) debug =       bracket p 1 $ prettySe 1 env f debug <+> prettySe 0 env a debug+    prettySe p env (Proj x i) debug =+      prettySe 1 env x debug <+> text ("!" ++ show i)     prettySe p env (Constant c) debug = pretty c     prettySe p env Erased debug = text "[_]"     prettySe p env (Set i) debug = text "Set" <+> (text . show $ i)@@ -699,8 +718,10 @@         | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ " -> " ++ se 10 ((n,b):env) sc     se p env (Bind n b sc) = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc     se p env (App f a) = bracket p 1 $ se 1 env f ++ " " ++ se 0 env a+    se p env (Proj x i) = se 1 env x ++ "!" ++ show i     se p env (Constant c) = show c     se p env Erased = "[__]"+    se p env Impossible = "[impossible]"     se p env (Set i) = "Set " ++ show i      sb env n (Lam t)  = showb env "\\ " " => " n t
src/Core/Typecheck.hs view
@@ -19,17 +19,19 @@    = do c <- convEq ctxt (finalise (normalise ctxt env x))                          (finalise (normalise ctxt env y))         if c then return ()-             else fail ("Can't convert between " ++ -                        showEnv env (finalise (normalise ctxt env x)) ++ " and " ++ -                        showEnv env (finalise (normalise ctxt env y)))+             else lift $ tfail (CantConvert+                          (finalise (normalise ctxt env x))+                          (finalise (normalise ctxt env y)) (errEnv env))  converts :: Context -> Env -> Term -> Term -> TC () converts ctxt env x y = if (finalise (normalise ctxt env x) ==                              finalise (normalise ctxt env y))                           then return ()-                          else fail ("Can't convert between " ++ -                                     showEnvDbg env (finalise (normalise ctxt env x)) ++ " and " ++ -                                     showEnvDbg env (finalise (normalise ctxt env y)))+                          else tfail (CantConvert+                                      (finalise (normalise ctxt env x))+                                      (finalise (normalise ctxt env y)) (errEnv env))++errEnv = map (\(x, b) -> (x, binderTy b))  isSet :: Context -> Env -> Term -> TC () isSet ctxt env tm = isSet' (normalise ctxt env tm)
src/Core/Unify.hs view
@@ -28,15 +28,15 @@     = -- case runStateT (un' False [] topx topy) (UI 0 [] []) of       --    OK (v, UI _ inj []) -> return (filter notTrivial v, inj, [])       --    _ -> -      -- trace ("Unifying " ++ show (topx, topy)) $+--       trace ("Unifying " ++ show (topx, topy)) $                let topxn = normalise ctxt env topx-	           topyn = normalise ctxt env topy in+                   topyn = normalise ctxt env topy in --                     trace ("Unifying " ++ show (topxn, topyn)) $-		     case runStateT (un' False [] topxn topyn)-		  	        (UI 0 [] []) of-	               OK (v, UI _ inj fails) -> return (filter notTrivial v, inj, reverse fails)+                     case runStateT (un' False [] topxn topyn)+        	  	        (UI 0 [] []) of+                       OK (v, UI _ inj fails) -> return (filter notTrivial v, inj, reverse fails) --                     OK (_, UI s _ ((_,_,f):fs)) -> tfail $ CantUnify topx topy f s-		       Error e -> tfail e+        	       Error e -> tfail e   where     notTrivial (x, P _ x' _) = x /= x'     notTrivial _ = True@@ -77,12 +77,12 @@         | holeIn env x = do UI s i f <- get                             when (notP tm && fn) $ put (UI s ((tm, topx, topy) : i) f)                             sc 1-                            return [(x, tm)]+                            checkCycle (x, tm)     un' fn bnames tm (P Bound y _)         | holeIn env y = do UI s i f <- get                             when (notP tm && fn) $ put (UI s ((tm, topx, topy) : i) f)                             sc 1-                            return [(y, tm)]+                            checkCycle (y, tm)     un' fn bnames (V i) (P Bound x _)         | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return []     un' fn bnames (P Bound x _) (V i)@@ -121,6 +121,10 @@         | n == n' = un' False bnames x y     un' fn bnames (Bind n (Lam t) (App x (P Bound n' _))) y         | n == n' = un' False bnames x y+--     un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy) +--         = un' False ((x,y):bnames) sx sy+--     un' fn bnames (Bind x (PVTy _) sx) (Bind y (PVTy _) sy) +--         = un' False ((x,y):bnames) sx sy     un' fn bnames (Bind x bx sx) (Bind y by sy)          = do h1 <- uB bnames bx by              h2 <- un' False ((x,y):bnames) sx sy@@ -165,13 +169,20 @@                        put (UI s i ((binderTy x, binderTy y, env, err) : f))                        return [] -- lift $ tfail err +    checkCycle p@(x, P _ _ _) = return [p] +    checkCycle (x, tm) +        | not (x `elem` freeNames tm) = return [(x, tm)]+        | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) +     combine bnames as [] = return as     combine bnames as ((n, t) : bs)         = case lookup n as of              Nothing -> combine bnames (as ++ [(n,t)]) bs-            Just t' -> do un' False bnames t t'+            Just t' -> do ns <- un' False bnames t t'+                          -- make sure there's n mapping from n in ns+                          let ns' = filter (\ (x, _) -> x/=n) ns                           sc 1-                          combine bnames as bs+                          combine bnames as (ns' ++ bs)      -- If there are any clashes of constructors, deem it unrecoverable, otherwise some     -- more work may help.
src/IRTS/Bytecode.hs view
@@ -30,6 +30,7 @@         | MKCON Reg Int [Reg]         | CASE Reg [(Int, [BC])] (Maybe [BC])         | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards+        | PROJECTINTO Reg Reg Int -- project argument from one reg into another          | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])         | CALL Name         | TAILCALL Name@@ -43,6 +44,7 @@         | BASETOP Int -- set BASE = TOP + n         | STOREOLD -- set OLDBASE = BASE         | OP Reg PrimFn [Reg]+        | NULL Reg -- clear reg         | ERROR String     deriving Show @@ -72,10 +74,12 @@ bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r     where getL (Loc x) = L x+bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r  bc reg (SConst i) r = ASSIGNCONST reg i : clean r bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r     where getL (Loc x) = L x bc reg (SError str) r = [ERROR str]+bc reg SNothing r = NULL reg : clean r bc reg (SCase (Loc l) alts) r     | isConst alts = constCase reg (L l) alts r    | otherwise = conCase reg (L l) alts r
src/IRTS/CodegenC.hs view
@@ -1,5 +1,6 @@ module IRTS.CodegenC where +import Idris.AbsSyntax import IRTS.Bytecode import IRTS.Lang import IRTS.Simplified@@ -112,6 +113,8 @@  bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++                                        ", " ++ show a ++ ");\n"+bcc i (PROJECTINTO r t idx)+    = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"  bcc i (CASE r code def)      = indent i ++ "switch(TAG(" ++ creg r ++ ")) {\n" ++       concatMap (showCase i) code ++@@ -149,6 +152,7 @@         c_irts rty (creg l ++ " = ")                     (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"     where fcall (t, arg) = irts_c t (creg arg)+bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);" -- bcc i _ = indent i ++ "// not done yet\n" @@ -180,7 +184,7 @@  doOp v LFPlus [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFMinus [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"-doOp v LFTimes [l, r] = v ++ "FLOATOP(*" ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LFTimes [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFDiv [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFEq [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LFLt [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"@@ -242,5 +246,5 @@  doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"-doOp v LNoOp [x] = ""+doOp v LNoOp args = "" doOp _ _ _ = "FAIL"
src/IRTS/Compiler.hs view
@@ -10,6 +10,8 @@ import IRTS.Inliner  import Idris.AbsSyntax+import Idris.UnusedArgs+ import Core.TT import Core.Evaluate import Core.CaseTree@@ -29,6 +31,7 @@         let tmnames = namesUsed (STerm tm)         used <- mapM (allNames []) tmnames         defsIn <- mkDecls tm (concat used)+        findUnusedArgs (concat used)         maindef <- irMain tm         objs <- getObjectFiles         libs <- getLibs@@ -43,10 +46,19 @@         iLOG "Inlining"         let defuns = inline defuns_in         logLvl 5 $ show defuns-+        iLOG "Resolving variables for CG"         -- iputStrLn $ showSep "\n" (map show (toAlist defuns))         let checked = checkDefs defuns (toAlist defuns)         dumpC <- getDumpC+        dumpCases <- getDumpCases+        dumpDefun <- getDumpDefun+        case dumpCases of+            Nothing -> return ()+            Just f -> liftIO $ writeFile f (showCaseTrees tagged)+        case dumpDefun of+            Nothing -> return ()+            Just f -> liftIO $ writeFile f (dumpDefuns defuns)+        iLOG "Building output"         case checked of             OK c -> case target of                          ViaC -> liftIO $ codegenC dumpC c f True hdrs @@ -64,6 +76,8 @@         mkObj f = f ++ " "         mkLib l = "-l" ++ l ++ " " ++ irMain :: TT Name -> Idris LDecl irMain tm = do i <- ir tm                return $ LFun (MN 0 "runMain") [] (LForce i)@@ -72,7 +86,7 @@ allNames ns n | n `elem` ns = return [] allNames ns n = do i <- get                    case lookupCtxt Nothing n (idris_callgraph i) of-                      [ns'] -> do more <- mapM (allNames (n:ns)) ns' +                      [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns'))                                    return (nub (n : concat more))                       _ -> return [n] @@ -80,9 +94,18 @@ mkDecls t used      = do i <- getIState          let ds = filter (\ (n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)+         mapM traceUnused used          decls <- mapM build ds          return decls +showCaseTrees :: [(Name, LDecl)] -> String+showCaseTrees ds = showSep "\n\n" (map showCT ds)+  where+    showCT (n, LFun f args lexp) +       = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t "+            ++ show lexp +    showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a + isCon (TyDecl _ _) = True isCon _ = False @@ -106,8 +129,8 @@  mkLDecl n (Function tm _) = do e <- ir tm                                return (declArgs [] n e)-mkLDecl n (CaseOp _ _ pats _ _ args sc) = do e <- ir (args, sc)-                                             return (declArgs [] n e)+mkLDecl n (CaseOp _ _ _ pats _ _ args sc) = do e <- ir (args, sc)+                                               return (declArgs [] n e) mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a mkLDecl n _ = return (LFun n [] (LError ("Impossible declaration " ++ show n)))@@ -141,10 +164,25 @@                    return t' -- TODO           | (P (DCon t a) n _, args) <- unApply tm               = irCon env t a n args+          | (P _ n _, args) <- unApply tm+              = do i <- get+                   let collapse = case lookupCtxt Nothing n (idris_optimisation i) of+                                    [oi] -> collapsible oi+                                    _ -> False+                   let unused = case lookupCtxt Nothing n (idris_callgraph i) of+                                    [CGInfo _ _ _ _ unusedpos] -> unusedpos+                                    _ -> []+                   args' <- mapM (ir' env) args+                   if collapse then return LNothing+                               else return (LApp False (LV (Glob n)) +                                                 (mkUnused unused 0 args'))           | (f, args) <- unApply tm               = do f' <- ir' env f                    args' <- mapM (ir' env) args                    return (LApp False f' args')+        where mkUnused u i [] = []+              mkUnused u i (x : xs) | i `elem` u = LNothing : mkUnused u (i + 1) xs+                                    | otherwise = x : mkUnused u (i + 1) xs       ir' env (P _ n _) = return $ LV (Glob n)       ir' env (V i)     | i < length env = return $ LV (Glob (env!!i))                         | otherwise = error $ "IR fail " ++ show i ++ " " ++ show tm@@ -156,9 +194,14 @@           = do sc' <- ir' (n : env) sc                v' <- ir' env v                return $ LLet n v' sc'-      ir' env (Bind _ _ _) = return $ LConst (I 424242)+      ir' env (Bind _ _ _) = return $ LNothing+      ir' env (Proj t i) = do t' <- ir' env t+                              return $ LProj t' i       ir' env (Constant c) = return $ LConst c-      ir' env _ = return $ LError "Impossible"+      ir' env (Set _) = return $ LNothing+      ir' env Erased = return $ LNothing+      ir' env Impossible = return $ LNothing+--       ir' env _ = return $ LError "Impossible"        irCon env t arity n args         | length args == arity = buildApp env (LV (Glob n)) args@@ -207,11 +250,17 @@                          return $ LLam args tree'  instance ToIR SC where-    ir (STerm t) = ir t-    ir (UnmatchedCase str) = return $ LError str-    ir (Case n alts) = do alts' <- mapM mkIRAlt alts-                          return $ LCase (LV (Glob n)) alts'-      where+    ir t = ir' t where++        ir' (STerm t) = ir t+        ir' (UnmatchedCase str) = return $ LError str+        ir' (ProjCase tm alts) = do alts' <- mapM mkIRAlt alts+                                    tm' <- ir tm+                                    return $ LCase tm' alts'+        ir' (Case n alts) = do alts' <- mapM mkIRAlt alts+                               return $ LCase (LV (Glob n)) alts'+        ir' ImpossibleCase = return LNothing+         mkIRAlt (ConCase n t args rhs)               = do rhs' <- ir rhs                   return $ LConCase (-1) n args rhs'@@ -226,8 +275,4 @@         mkIRAlt (DefaultCase rhs)            = do rhs' <- ir rhs                 return $ LDefaultCase rhs'----
src/IRTS/Defunctionalise.hs view
@@ -11,12 +11,14 @@ data DExp = DV LVar           | DApp Bool Name [DExp] -- True = tail call           | DLet Name DExp DExp -- name just for pretty printing-          | DLam [Name] DExp -- lambda, lifted out before compiling+          | DProj DExp Int           | DC Int Name [DExp]           | DCase DExp [DAlt]           | DConst Const           | DForeign FLang FType String [(FType, DExp)]           | DOp PrimFn [DExp]+          | DNothing -- erased value, can be compiled to anything since it'll never+                     -- be inspected           | DError String   deriving Eq @@ -85,11 +87,13 @@     aa env (LForce e) = eEVAL (aa env e)     aa env (LLet n v sc) = DLet n (aa env v) (aa (n : env) sc)     aa env (LCon i n args) = DC i n (map (aa env) args)+    aa env (LProj t i) = DProj (eEVAL (aa env t)) i     aa env (LCase e alts) = DCase (eEVAL (aa env e)) (map (aaAlt env) alts)     aa env (LConst c) = DConst c     aa env (LForeign l t n args) = DForeign l t n (map (aaF env) args)     aa env (LOp LFork args) = DOp LFork (map (aa env) args)     aa env (LOp f args) = DOp f (map (eEVAL . (aa env)) args)+    aa env LNothing = DNothing     aa env (LError e) = DError e      aaF env (t, e) = (t, eEVAL (aa env e))@@ -170,15 +174,14 @@  instance Show DExp where    show e = show' [] e where-     show' env (DV (Loc i)) = env!!i+     show' env (DV (Loc i)) = "var " ++ env!!i      show' env (DV (Glob n)) = show n      show' env (DApp _ e args) = show e ++ "(" ++                                    showSep ", " (map (show' env) args) ++")"      show' env (DLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++                                show' (env ++ [show n]) e-     show' env (DLam args e) = "\\ " ++ showSep "," (map show args) ++ " => " ++-                                 show' (env ++ (map show args)) e      show' env (DC i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"+     show' env (DProj t i) = show t ++ "!" ++ show i      show' env (DCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++                                     showSep "\n\t| " (map (showAlt env) alts)      show' env (DConst c) = show c@@ -186,6 +189,7 @@            = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"      show' env (DOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"      show' env (DError str) = "error " ++ show str+     show' env DNothing = "____"       showAlt env (DConCase _ n args e)            = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "@@ -233,4 +237,12 @@         tagLT i (DConstCase (I j) _) = i < j         tagLT i (DConCase j _ _ _) = i < j         tagLT i (DDefaultCase _) = False++dumpDefuns :: DDefs -> String+dumpDefuns ds = showSep "\n" $ map showDef (toAlist ds)+  where showDef (x, DFun fn args exp) +            = show fn ++ "(" ++ showSep ", " (map show args) ++ ") = \n\t" +++              show exp ++ "\n"+        showDef (x, DConstructor n t a) = "Constructor " ++ show n ++ " " ++ show t+
src/IRTS/Inliner.hs view
@@ -5,5 +5,18 @@ import IRTS.Defunctionalise  inline :: DDefs -> DDefs -inline xs = xs+inline xs = let sep = toAlist xs+                inls = map (inl xs) sep in+                addAlist inls emptyContext++inl :: DDefs -> (Name, DDecl) -> (Name, DDecl)+inl ds d@(n, DFun n' args exp) +    = case evalD ds exp of+           Just exp' -> (n, DFun n' args exp')+           _ -> d+inl ds d = d++evalD _ e = ev e+  where+    ev e = Just e
src/IRTS/Lang.hs view
@@ -15,11 +15,13 @@           | LForce LExp -- make sure Exp is evaluted           | LLet Name LExp LExp -- name just for pretty printing           | LLam [Name] LExp -- lambda, lifted out before compiling+          | LProj LExp Int -- projection           | LCon Int Name [LExp]           | LCase LExp [LAlt]           | LConst Const           | LForeign FLang FType String [(FType, LExp)]           | LOp PrimFn [LExp]+          | LNothing           | LError String   deriving Eq @@ -118,6 +120,8 @@                             fn <- getNextName                             addFn fn (LFun fn (usedArgs ++ args) e')                             return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs))+lift env (LProj t i) = do t' <- lift env t+                          return (LProj t' i) lift env (LCon i n args) = do args' <- mapM (lift env) args                               return (LCon i n args') lift env (LCase e alts) = do alts' <- mapM liftA alts@@ -139,7 +143,7 @@ lift env (LOp f args) = do args' <- mapM (lift env) args                            return (LOp f args') lift env (LError str) = return $ LError str-+lift env LNothing = return $ LNothing  -- Return variables in list which are used in the expression @@ -155,7 +159,8 @@ usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e usedIn env (LLam ns e) = usedIn (env \\ ns) e usedIn env (LCon i n args) = concatMap (usedIn env) args-usedIn env (LCase e alts) = concatMap (usedInA env) alts+usedIn env (LProj t i) = usedIn env t+usedIn env (LCase e alts) = usedIn env e ++ concatMap (usedInA env) alts   where usedInA env (LConCase i n ns e) = usedIn env e         usedInA env (LConstCase c e) = usedIn env e         usedInA env (LDefaultCase e) = usedIn env e@@ -167,6 +172,8 @@    show e = show' [] e where      show' env (LV (Loc i)) = env!!i      show' env (LV (Glob n)) = show n+     show' env (LLazyApp e args) = show e ++ "|(" +++                                     showSep ", " (map (show' env) args) ++")"      show' env (LApp _ e args) = show' env e ++ "(" ++                                    showSep ", " (map (show' env) args) ++")"      show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")" @@ -175,6 +182,7 @@                                show' (env ++ [show n]) e      show' env (LLam args e) = "\\ " ++ showSep "," (map show args) ++ " => " ++                                  show' (env ++ (map show args)) e+     show' env (LProj t i) = show t ++ "!" ++ show i      show' env (LCon i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"      show' env (LCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++                                     showSep "\n\t| " (map (showAlt env) alts)@@ -183,6 +191,7 @@            = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"      show' env (LOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"      show' env (LError str) = "error " ++ show str+     show' env LNothing = "____"       showAlt env (LConCase _ n args e)            = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "
src/IRTS/Simplified.hs view
@@ -5,6 +5,8 @@ import Data.Maybe import Control.Monad.State +import Debug.Trace+ -- Simplified expressions, where functions/constructors can only be applied  -- to variables @@ -13,9 +15,11 @@           | SLet LVar SExp SExp           | SCon Int Name [LVar]           | SCase LVar [SAlt]+          | SProj LVar Int           | SConst Const           | SForeign FLang FType String [(FType, LVar)]           | SOp PrimFn [LVar]+          | SNothing -- erased value, will never be inspected           | SError String   deriving Show @@ -54,6 +58,11 @@                               return (SLet (Glob n) v' e') simplify tl (DC i n args) = do args' <- mapM sVar args                                mkapp (SCon i n) args'+simplify tl (DProj t i) = do v <- sVar t+                             case v of+                                (x, Nothing) -> return (SProj x i)+                                (Glob x, Just e) ->+                                    return (SLet (Glob x) e (SProj (Glob x) i)) simplify tl (DCase e alts) = do v <- sVar e                                 alts' <- mapM (sAlt tl) alts                                 case v of @@ -63,6 +72,7 @@ simplify tl (DConst c) = return (SConst c) simplify tl (DOp p args) = do args' <- mapM sVar args                               mkapp (SOp p) args'+simplify tl DNothing = return SNothing  simplify tl (DError str) = return $ SError str  sVar (DV (Glob x))@@ -111,7 +121,7 @@             put (max i v)  scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp -scopecheck ctxt env tm = sc env tm where+scopecheck ctxt envTop tm = sc envTop tm where     sc env (SV (Glob n)) =        case lookup n (reverse env) of -- most recent first               Just i -> do lvar i; return (SV (Loc i))@@ -146,6 +156,9 @@                        else fail $ "Codegen error: Constructor " ++ show f ++                                     " has arity " ++ show ar                 _ -> fail $ "Codegen error: No such constructor " ++ show f+    sc env (SProj e i)+       = do e' <- scVar env e+            return (SProj e' i)     sc env (SCase e alts)        = do e' <- scVar env e             alts' <- mapM (scalt env) alts@@ -168,7 +181,8 @@                               [DConstructor _ i ar] ->                                   fail $ "Codegen error : can't pass constructor here"                               [_] -> return (Glob n)-                              [] -> fail $ "Codegen error: No such variable " ++ show n+                              [] -> fail $ "Codegen error: No such variable " ++ show n ++ +                                           " in " ++ show tm ++ " " ++ show envTop     scVar _ x = return x      scalt env (SConCase _ i n args e)
src/Idris/AbsSyntax.hs view
@@ -43,7 +43,7 @@ addHdr f = do i <- get; put (i { idris_hdrs = f : idris_hdrs i })  totcheck :: (FC, Name) -> Idris ()-totcheck n = do i <- get; put (i { idris_totcheck = n : idris_totcheck i })+totcheck n = do i <- get; put (i { idris_totcheck = idris_totcheck i ++ [n] })  setFlags :: Name -> [FnOpt] -> Idris () setFlags n fs = do i <- get; put (i { idris_flags = addDef n fs (idris_flags i) }) @@ -67,15 +67,16 @@                 [t] -> return t                 _ -> return (Total []) -addToCG :: Name -> [Name] -> Idris ()-addToCG n ns = do i <- get-                  put (i { idris_callgraph = addDef n ns (idris_callgraph i) })+addToCG :: Name -> CGInfo -> Idris ()+addToCG n cg = do i <- get+                  put (i { idris_callgraph = addDef n cg (idris_callgraph i) })  addToCalledG :: Name -> [Name] -> Idris () addToCalledG n ns = return () -- TODO  -- Add a class instance function. Dodgy hack: Put integer instances first in the -- list so they are resolved by default.+-- Dodgy hack 2: put constraint chasers (@@) last  addInstance :: Bool -> Name -> Name -> Idris () addInstance int n i @@ -87,8 +88,16 @@                 _ -> do let cs = addDef n (CI (MN 0 "none") [] [] [] [i]) (idris_classes ist)                         put (ist { idris_classes = cs })   where addI i ins | int = i : ins-                   | otherwise = ins ++ [i]+                   | chaser n = ins ++ [i]+                   | otherwise = insI i ins+        insI i [] = [i]+        insI i (n : ns) | chaser n = i : n : ns+                        | otherwise = n : insI i ns +        chaser (UN ('@':'@':_)) = True+        chaser (NS n _) = chaser n+        chaser _ = False+ addClass :: Name -> ClassInfo -> Idris () addClass n i     = do ist <- get@@ -206,6 +215,20 @@           findC (DumpC x : _) = Just x           findC (_ : xs) = findC xs +getDumpDefun :: Idris (Maybe FilePath)+getDumpDefun = do i <- get+                  return $ findC (opt_cmdline (idris_options i))+    where findC [] = Nothing+          findC (DumpDefun x : _) = Just x+          findC (_ : xs) = findC xs++getDumpCases :: Idris (Maybe FilePath)+getDumpCases = do i <- get+                  return $ findC (opt_cmdline (idris_options i))+    where findC [] = Nothing+          findC (DumpCases x : _) = Just x+          findC (_ : xs) = findC xs+ logLevel :: Idris Int logLevel = do i <- get               return (opt_logLevel (idris_options i))@@ -302,6 +325,10 @@                       $ do liftIO (putStrLn str)                            put (i { idris_log = idris_log i ++ str ++ "\n" } ) +cmdOptSet :: Opt -> Idris Bool+cmdOptSet x = do i <- get+                 return $ x `elem` opt_cmdline (idris_options i)+ iLOG :: String -> Idris () iLOG = logLvl 1 @@ -384,13 +411,12 @@ existsCon = UN "Ex_intro"  piBind :: [(Name, PTerm)] -> PTerm -> PTerm-piBind [] t = t-piBind ((n, ty):ns) t = PPi expl n ty (piBind ns t)-    -tcname (UN ('@':_)) = True-tcname (NS n _) = tcname n-tcname _ = False+piBind = piBindp expl +piBindp :: Plicity -> [(Name, PTerm)] -> PTerm -> PTerm+piBindp p [] t = t+piBindp p ((n, ty):ns) t = PPi p n ty (piBind ns t)+     -- Dealing with parameters  expandParams :: (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PTerm -> PTerm@@ -432,17 +458,23 @@     en (PTactics ts) = PTactics (map (fmap en) ts)      en (PQuote (Var n)) -        | n `elem` ns = PQuote (Var (dec n))+        | n `nselem` ns = PQuote (Var (dec n))     en (PApp fc (PRef fc' n) as)-        | n `elem` ns = PApp fc (PRef fc' (dec n)) +        | n `nselem` ns = PApp fc (PRef fc' (dec n))                             (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as))     en (PRef fc n)-        | n `elem` ns = PApp fc (PRef fc (dec n)) +        | n `nselem` ns = PApp fc (PRef fc (dec n))                             (map (pexp . (PRef fc)) (map fst ps))     en (PApp fc f as) = PApp fc (en f) (map (fmap en) as)     en (PCase fc c os) = PCase fc (en c) (map (pmap en) os)     en t = t +    nselem x [] = False+    nselem x (y : xs) | nseq x y = True+                      | otherwise = nselem x xs++    nseq x y = nsroot x == nsroot y+ expandParamsD :: IState ->                   (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl expandParamsD ist dec ps ns (PTy syn fc o n ty) @@ -473,9 +505,36 @@     updateps yn nm (((a, t), i):as)         | (a `elem` nm) == yn = (a, t) : updateps yn nm as         | otherwise = (MN i (show n ++ "_u"), t) : updateps yn nm as-+expandParamsD ist dec ps ns (PData syn fc co pd) = PData syn fc co (expandPData pd)+  where+    -- just do the type decl, leave constructors alone (parameters will be+    -- added implicitly)+    expandPData (PDatadecl n ty cons) +       = if n `elem` ns+            then PDatadecl (dec n) (piBind ps (expandParams dec ps ns ty)) (map econ cons)+            else PDatadecl n (expandParams dec ps ns ty) (map econ cons)+    econ (n, t, fc) = (dec n, piBindp expl ps (expandParams dec ps ns t), fc)+expandParamsD ist dec ps ns (PParams f params pds)+   = PParams f (map (mapsnd (expandParams dec ps ns)) params) +               (map (expandParamsD ist dec ps ns) pds) +expandParamsD ist dec ps ns (PClass info f cs n params decls)+   = PClass info f +           (map (expandParams dec ps ns) cs)+           n+           (map (mapsnd (expandParams dec ps ns)) params)+           (map (expandParamsD ist dec ps ns) decls)+expandParamsD ist dec ps ns (PInstance info f cs n params ty cn decls)+   = PInstance info f +           (map (expandParams dec ps ns) cs)+           n+           (map (expandParams dec ps ns) params)+           (expandParams dec ps ns ty)+           cn+           (map (expandParamsD ist dec ps ns) decls) expandParamsD ist dec ps ns d = d +mapsnd f (x, t) = (x, f t)+ -- Calculate a priority for a type, for deciding elaboration order -- * if it's just a type variable or concrete type, do it early (0) -- * if there's only type variables and injective constructors, do it next (1)@@ -494,7 +553,7 @@     pri (PPi _ _ x y) = max 5 (max (pri x) (pri y))     pri (PTrue _) = 0     pri (PFalse _) = 0-    pri (PRefl _) = 1+    pri (PRefl _ _) = 1     pri (PEq _ l r) = max 1 (max (pri l) (pri r))     pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))      pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as))) @@ -705,13 +764,24 @@  aiFn :: Bool -> Bool -> IState -> FC -> Name -> [PArg] -> Either Err PTerm aiFn inpat True ist fc f []-  = case lookupCtxt Nothing f (idris_implicits ist) of-        [] -> Right $ PRef fc f-        alts -> if (any (all imp) alts)+  = case lookupDef Nothing f (tt_ctxt ist) of+        [] -> Right $ PPatvar fc f+        alts -> let ialts = lookupCtxt Nothing f (idris_implicits ist) in+                    -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $ +                    if (not (vname f) || tcname f +                           || any constructor alts || any allImp ialts)                         then aiFn inpat False ist fc f [] -- use it as a constructor-                        else Right $ PRef fc f+                        else Right $ PPatvar fc f     where imp (PExp _ _ _) = False           imp _ = True+          allImp [] = False+          allImp xs = all imp xs+          constructor (TyDecl (DCon _ _) _) = True+          constructor _ = False++          vname (UN n) = True -- non qualified+          vname _ = False+ aiFn inpat expat ist fc f as     | f `elem` primNames = Right $ PApp fc (PRef fc f) as aiFn inpat expat ist fc f as@@ -799,7 +869,7 @@ dumpDecl (PFix _ f ops) = show f ++ " " ++ showSep ", " ops  dumpDecl (PTy _ _ _ n t) = "tydecl " ++ show n ++ " : " ++ showImp True t dumpDecl (PClauses _ _ n cs) = "pat " ++ show n ++ "\t" ++ showSep "\n\t" (map (showCImp True) cs)-dumpDecl (PData _ _ d) = showDImp True d+dumpDecl (PData _ _ _ d) = showDImp True d dumpDecl (PParams _ ns ps) = "params {" ++ show ns ++ "\n" ++ dumpDecls ps ++ "}\n" dumpDecl (PNamespace n ps) = "namespace {" ++ n ++ "\n" ++ dumpDecls ps ++ "}\n" dumpDecl (PSyntax _ syn) = "syntax " ++ show syn@@ -883,7 +953,7 @@     match (PQuote _) _ = return []     match (PProof _) _ = return []     match (PTactics _) _ = return []-    match (PRefl _) (PRefl _) = return []+    match (PRefl _ _) (PRefl _ _) = return []     match (PResolveTC _) (PResolveTC _) = return []     match (PTrue _) (PTrue _) = return []     match (PFalse _) (PFalse _) = return []@@ -900,7 +970,7 @@                                                   return (mt ++ mty ++ ms)     match (PHidden x) (PHidden y) = match' x y     match Placeholder _ = return []---     match _ Placeholder = return []+    match _ Placeholder = return []     match (PResolveTC _) _ = return []     match a b | a == b = return []               | otherwise = LeftErr (a, b)
src/Idris/AbsSyntaxTree.hs view
@@ -14,7 +14,7 @@  import System.Console.Haskeline -import Control.Monad.State+import Control.Monad.Trans.State.Strict  import Data.List import Data.Char@@ -43,42 +43,62 @@ -- This will include all the functions and data declarations, plus fixity declarations -- and syntax macros. -data IState = IState { tt_ctxt :: Context,-                       idris_constraints :: [(UConstraint, FC)],-                       idris_infixes :: [FixDecl],-                       idris_implicits :: Ctxt [PArg],-                       idris_statics :: Ctxt [Bool],-                       idris_classes :: Ctxt ClassInfo,-                       idris_dsls :: Ctxt DSL,-                       idris_optimisation :: Ctxt OptInfo, -                       idris_datatypes :: Ctxt TypeInfo,-                       idris_patdefs :: Ctxt [([Name], Term, Term)], -- not exported-                       idris_flags :: Ctxt [FnOpt],-                       idris_callgraph :: Ctxt [Name],-                       idris_calledgraph :: Ctxt [Name],-                       idris_totcheck :: [(FC, Name)],-                       idris_log :: String,-                       idris_options :: IOption,-                       idris_name :: Int,-                       idris_metavars :: [Name],-                       syntax_rules :: [Syntax],-                       syntax_keywords :: [String],-                       imported :: [FilePath],-                       idris_scprims :: [(Name, (Int, PrimFn))],-                       idris_objs :: [FilePath],-                       idris_libs :: [String],-                       idris_hdrs :: [String],-                       proof_list :: [(Name, [String])],-                       errLine :: Maybe Int,-                       lastParse :: Maybe Name, -                       indent_stack :: [Int],-                       brace_stack :: [Maybe Int],-                       hide_list :: [(Name, Maybe Accessibility)],-                       default_access :: Accessibility,-                       ibc_write :: [IBCWrite],-                       compiled_so :: Maybe String-                     }+data IState = IState {+    tt_ctxt :: Context,+    idris_constraints :: [(UConstraint, FC)],+    idris_infixes :: [FixDecl],+    idris_implicits :: Ctxt [PArg],+    idris_statics :: Ctxt [Bool],+    idris_classes :: Ctxt ClassInfo,+    idris_dsls :: Ctxt DSL,+    idris_optimisation :: Ctxt OptInfo, +    idris_datatypes :: Ctxt TypeInfo,+    idris_patdefs :: Ctxt [([Name], Term, Term)], -- not exported+    idris_flags :: Ctxt [FnOpt],+    idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos+    idris_calledgraph :: Ctxt [Name],+    idris_totcheck :: [(FC, Name)],+    idris_log :: String,+    idris_options :: IOption,+    idris_name :: Int,+    idris_metavars :: [Name],+    syntax_rules :: [Syntax],+    syntax_keywords :: [String],+    imported :: [FilePath],+    idris_scprims :: [(Name, (Int, PrimFn))],+    idris_objs :: [FilePath],+    idris_libs :: [String],+    idris_hdrs :: [String],+    proof_list :: [(Name, [String])],+    errLine :: Maybe Int,+    lastParse :: Maybe Name, +    indent_stack :: [Int],+    brace_stack :: [Maybe Int],+    hide_list :: [(Name, Maybe Accessibility)],+    default_access :: Accessibility,+    default_total :: Bool,+    ibc_write :: [IBCWrite],+    compiled_so :: Maybe String+   } +data SizeChange = Smaller | Same | Bigger | Unknown+    deriving (Show, Eq)+{-! +deriving instance Binary SizeChange+!-}++type SCGEntry = (Name, [Maybe (Int, SizeChange)])++data CGInfo = CGInfo { argsdef :: [Name],+                       calls :: [(Name, [[Name]])],+                       scg :: [SCGEntry],+                       argsused :: [Name],+                       unusedpos :: [Int] }+    deriving Show+{-! +deriving instance Binary CGInfo +!-}+ primDefs = [UN "unsafePerformIO", UN "mkLazyForeign", UN "mkForeign", UN "FalseElim"]               -- information that needs writing for the current module's .ibc file@@ -107,7 +127,7 @@                    emptyContext emptyContext emptyContext emptyContext                     emptyContext emptyContext emptyContext                    [] "" defaultOpts 6 [] [] [] [] [] [] [] []-                   [] Nothing Nothing [] [] [] Hidden [] Nothing+                   [] Nothing Nothing [] [] [] Hidden False [] Nothing  -- The monad for the main REPL - reading and processing files and updating  -- global state (hence the IO inner monad).@@ -123,6 +143,8 @@              | Check PTerm              | TotCheck Name              | Reload+             | Load FilePath +             | ModImport String               | Edit              | Compile Target String              | Execute@@ -130,7 +152,7 @@              | NewCompile String              | Metavars              | Prove Name-             | AddProof Name+             | AddProof (Maybe Name)              | RmProof Name              | ShowProof Name              | Proofs@@ -141,6 +163,8 @@              | HNF PTerm              | Defn Name              | Info Name+             | Missing Name+             | Pattelab PTerm              | DebugInfo Name              | Search PTerm              | SetOpt Opt@@ -160,6 +184,9 @@          | NewOutput String          | TypeCase          | TypeInType+         | DefaultTotal+         | DefaultPartial+         | WarnPartial          | NoCoverage           | ErrContext           | ShowImpl@@ -173,6 +200,8 @@          | Pkg String          | BCAsm String          | DumpC String+         | DumpDefun String+         | DumpCases String          | FOVM String     deriving (Show, Eq) @@ -231,7 +260,8 @@ constraint = Constraint False Dynamic tacimpl = TacImp False Dynamic -data FnOpt = Inlinable | TotalFn | AssertTotal | TCGen+data FnOpt = Inlinable | TotalFn | PartialFn+           | Coinductive | AssertTotal | TCGen            | CExport String    -- export, with a C name            | Specialise [Name] -- specialise it, freeze these names     deriving (Show, Eq)@@ -248,7 +278,8 @@               | PTy      SyntaxInfo FC FnOpts Name t   -- type declaration               | PClauses FC FnOpts Name [PClause' t]   -- pattern clause               | PCAF     FC Name t -- top level constant-              | PData    SyntaxInfo FC (PData' t)      -- data declaration+              | PData    SyntaxInfo FC Bool -- codata+                                       (PData' t)  -- data declaration               | PParams  FC [(Name, t)] [PDecl' t] -- params block               | PNamespace String [PDecl' t] -- new namespace               | PRecord  SyntaxInfo FC Name t Name t     -- record declaration@@ -301,7 +332,7 @@ declared (PFix _ _ _) = [] declared (PTy _ _ _ n t) = [n] declared (PClauses _ _ n _) = [] -- not a declaration-declared (PData _ _ (PDatadecl n _ ts)) = n : map fstt ts+declared (PData _ _ _ (PDatadecl n _ ts)) = n : map fstt ts    where fstt (a, _, _) = a declared (PParams _ _ ds) = concatMap declared ds declared (PNamespace _ ds) = concatMap declared ds@@ -311,7 +342,7 @@ defined (PFix _ _ _) = [] defined (PTy _ _ _ n t) = [] defined (PClauses _ _ n _) = [n] -- not a declaration-defined (PData _ _ (PDatadecl n _ ts)) = n : map fstt ts+defined (PData _ _ _ (PDatadecl n _ ts)) = n : map fstt ts    where fstt (a, _, _) = a defined (PParams _ _ ds) = concatMap defined ds defined (PNamespace _ ds) = concatMap defined ds@@ -342,6 +373,7 @@  data PTerm = PQuote Raw            | PRef FC Name+           | PPatvar FC Name            | PLam Name PTerm PTerm            | PPi  Plicity Name PTerm PTerm            | PLet Name PTerm PTerm PTerm @@ -350,7 +382,7 @@            | PCase FC PTerm [(PTerm, PTerm)]            | PTrue FC            | PFalse FC-           | PRefl FC+           | PRefl FC PTerm            | PResolveTC FC            | PEq FC PTerm PTerm            | PPair FC PTerm PTerm@@ -501,7 +533,7 @@ !-}  -data TypeInfo = TI { con_names :: [Name] }+data TypeInfo = TI { con_names :: [Name], codata :: Bool }     deriving Show {-! deriving instance Binary TypeInfo@@ -601,8 +633,11 @@ showDeclImp _ (PFix _ f ops) = show f ++ " " ++ showSep ", " ops showDeclImp t (PTy _ _ _ n ty) = show n ++ " : " ++ showImp t ty showDeclImp _ (PClauses _ _ n c) = showSep "\n" (map show c)-showDeclImp _ (PData _ _ d) = show d+showDeclImp _ (PData _ _ _ d) = show d+showDeclImp _ (PParams f ns ps) = "parameters " ++ show ns ++ "\n" ++ +                                    showSep "\n" (map show ps) + showCImp :: Bool -> PClause -> String showCImp impl (PClause _ n l ws r w)     = showImp impl l ++ showWs ws ++ " = " ++ showImp impl r@@ -650,6 +685,7 @@         text "![" $$ pretty r <> text "]"       else         text "![" <> pretty r <> text "]"+    prettySe p (PPatvar fc n) = pretty n     prettySe p (PRef fc n) =       if impl then         pretty n@@ -763,7 +799,7 @@          sc (l, r) = prettySe 10 l <+> text "=>" <+> prettySe 10 r     prettySe p (PHidden tm) = text "." <> prettySe 0 tm-    prettySe p (PRefl _) = text "refl"+    prettySe p (PRefl _ _) = text "refl"     prettySe p (PResolveTC _) = text "resolvetc"     prettySe p (PTrue _) = text "()"     prettySe p (PFalse _) = text "_|_"@@ -825,6 +861,7 @@ showImp :: Bool -> PTerm -> String showImp impl tm = se 10 tm where     se p (PQuote r) = "![" ++ show r ++ "]"+    se p (PPatvar fc n) = show n     se p (PRef fc n) = if impl then show n -- ++ "[" ++ show fc ++ "]"                                else showbasic n       where showbasic n@(UN _) = show n@@ -871,7 +908,9 @@     se p (PCase _ scr opts) = "case " ++ se 10 scr ++ " of " ++ showSep " | " (map sc opts)        where sc (l, r) = se 10 l ++ " => " ++ se 10 r     se p (PHidden tm) = "." ++ se 0 tm-    se p (PRefl _) = "refl"+    se p (PRefl _ t) +        | not impl = "refl"+        | otherwise = "refl {" ++ se 10 t ++ "}"     se p (PResolveTC _) = "resolvetc"     se p (PTrue _) = "()"     se p (PFalse _) = "_|_"@@ -905,36 +944,6 @@     bracket outer inner str | inner > outer = "(" ++ str ++ ")"                             | otherwise = str -{-- PQuote Raw-           | PRef FC Name-           | PLam Name PTerm PTerm-           | PPi  Plicity Name PTerm PTerm-           | PLet Name PTerm PTerm PTerm -           | PTyped PTerm PTerm -- term with explicit type-           | PApp FC PTerm [PArg]-           | PCase FC PTerm [(PTerm, PTerm)]-           | PTrue FC-           | PFalse FC-           | PRefl FC-           | PResolveTC FC-           | PEq FC PTerm PTerm-           | PPair FC PTerm PTerm-           | PDPair FC PTerm PTerm PTerm-           | PAlternative [PTerm]-           | PHidden PTerm -- irrelevant or hidden pattern-           | PSet-           | PConstant Const-           | Placeholder-           | PDoBlock [PDo]-           | PIdiom FC PTerm-           | PReturn FC-           | PMetavar Name-           | PProof [PTactic]-           | PTactics [PTactic] -- as PProof, but no auto solving-           | PElabError Err -- error to report on elaboration-           | PImpossible -- special case for declaring when an LHS can't typecheck--}  instance Sized PTerm where   size (PQuote rawTerm) = size rawTerm@@ -947,7 +956,7 @@   size (PCase fc trm bdy) = 1 + size trm + size bdy   size (PTrue fc) = 1   size (PFalse fc) = 1-  size (PRefl fc) = 1+  size (PRefl fc _) = 1   size (PResolveTC fc) = 1   size (PEq fc left right) = 1 + size left + size right   size (PPair fc left right) = 1 + size left + size right
src/Idris/Coverage.hs view
@@ -12,8 +12,137 @@  import Data.List import Data.Either+import Data.Maybe import Debug.Trace +import Control.Monad.State++-- Generate the LHSes which are missing from a case tree+-- Eliminate the ones which cannot be well typed++genMissing :: Name -> [Name] -> SC -> Idris [PTerm] +genMissing fn args sc +   = do sc' <- expandTree sc+        logLvl 5 $ "Checking missing cases for " ++ +                     show fn ++ "\n" ++ (show sc')+        (got, missing) <- gm fn (map (\x -> P Bound x Erased) args) sc'+        return $ filter (\x -> not (x `elem` got)) missing++-- Make a term to feed to the pattern matcher from a LHS declared impossible+-- (we can't type check it, but we need the case analysis to check for +-- covering...)++mkPatTm :: PTerm -> Idris Term+mkPatTm t = do i <- get+               let timp = addImpl' True [] i t+               evalStateT (toTT timp) 0+  where+    toTT (PRef _ n) = do i <- lift $ get+                         case lookupDef Nothing n (tt_ctxt i) of+                              [TyDecl nt _] -> return $ P nt n Erased+                              _ -> return $ P Ref n Erased+    toTT (PApp _ t args) = do t' <- toTT t+                              args' <- mapM (toTT . getTm) args+                              return $ mkApp t' args'+    toTT _ = do v <- get +                put (v + 1)+                return (P Bound (MN v "imp") Erased) ++mkPTerm :: Name -> [TT Name] -> Idris PTerm+mkPTerm f args = do i <- get+                    let fapp = mkApp (P Bound f Erased) (map eraseName args)+                    return $ delab i fapp+  where eraseName (App f a) = App (eraseName f) (eraseName a)+        eraseName (P _ (MN _ _) _) = Erased+        eraseName t                = t++gm :: Name -> [TT Name] -> SC -> Idris ([PTerm], [PTerm])+gm fn args (Case n alts) = do m <- mapM (gmAlt fn args n) alts+                              let (got, missing) = unzip m+                              return (concat got, concat missing)+gm fn args (STerm tm)    = do logLvl 3 ("Covered: " ++ show args)+                              t <- mkPTerm fn args+                              return ([t], [])+gm fn args ImpossibleCase = do logLvl 3 ("Impossible: " ++ show args)+                               t <- mkPTerm fn args+                               return ([], [])+gm fn args (UnmatchedCase _) = do logLvl 3 ("Missing: " ++ show args)+                                  t <- mkPTerm fn args+                                  return ([], [t])++gmAlt fn args n (ConCase cn t cargs sc)+   = do let args' = map (subst n (mkApp (P Bound cn Erased)+                                        (map (\x -> P Bound x Erased) cargs))) +                        args+        gm fn args' sc+gmAlt fn args n (ConstCase c sc)+   = do let args' = map (subst n (Constant c)) args+        gm fn args' sc+gmAlt fn args n (DefaultCase sc)+   = do gm fn args sc++getDefault (DefaultCase sc : _) = sc+getDefault (_ : cs) = getDefault cs+getDefault [] = UnmatchedCase ""++dropDefault (DefaultCase sc : rest) = dropDefault rest+dropDefault (c : cs) = c : dropDefault cs+dropDefault [] = [] ++expandTree :: SC -> Idris SC+expandTree (Case n alts) = do i <- get+                              as <- expandAlts i (dropDefault alts) +                                                 (getDefault alts)+                              alts' <- mapM expandTreeA as+                              return (Case n alts')+    where expandTreeA (ConCase n i ns sc) = do sc' <- expandTree sc+                                               return (ConCase n i ns sc')+          expandTreeA (ConstCase i sc) = do sc' <- expandTree sc+                                            return (ConstCase i sc')+          expandTreeA (DefaultCase sc) = do sc' <- expandTree sc+                                            return (DefaultCase sc')+expandTree t = return t++expandAlts :: IState -> [CaseAlt] -> SC -> Idris [CaseAlt]+expandAlts i all@(ConstCase c _ : alts) def+    = return $ all ++ [DefaultCase def]+expandAlts i all@(ConCase n _ _ _ : alts) def+    | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef Nothing n (tt_ctxt i)+         = do let tyn = getTy n (tt_ctxt i)+              case lookupCtxt Nothing tyn (idris_datatypes i) of+                  (TI ns _ : _) -> do let ps = map mkPat ns+                                      return $ addAlts ps (altsFor all) all+                  _ -> return all+  where+    altsFor [] = []+    altsFor (ConCase n _ _ _ : alts) = n : altsFor alts+    altsFor (_ : alts) = altsFor alts++    addAlts [] got alts = alts+    addAlts ((n, arity) : ps) got alts+        | n `elem` got = addAlts ps got alts+        | otherwise = addAlts ps got (alts ++ +                             [ConCase n (-1) (argList arity) def])++    argList i = take i (map (\x -> (MN x "ign")) [0..])++    getTy n ctxt +      = case lookupTy Nothing n ctxt of+            (t : _) -> case unApply (getRetTy t) of+                        (P _ tyn _, _) -> tyn+                        x -> error $ "Can't happen getTy 1 " ++ show (n, x)+            _ -> error "Can't happen getTy 2"++    mkPat x = case lookupCtxt Nothing x (idris_implicits i) of+                    (pargs : _)+                       -> (x, length pargs)  +                    _ -> error "Can't happen - genAll"+expandAlts i alts def = return alts +        +++-- OLD STUFF: probably broken...+ -- Given a list of LHSs, generate a extra clauses which cover the remaining -- cases. The ones which haven't been provided are marked 'absurd' so that the -- checker will make sure they can't happen.@@ -30,14 +159,14 @@         logLvl 7 $ "COVERAGE of " ++ show n         logLvl 10 $ show argss ++ "\n" ++ show all_args         logLvl 10 $ "Original: \n" ++ -                        showSep "\n" (map (\t -> showImp True (delab' i t True)) xs)+             showSep "\n" (map (\t -> showImp True (delab' i t True)) xs)         let parg = case lookupCtxt Nothing n (idris_implicits i) of                         (p : _) -> p                         _ -> repeat (pexp Placeholder)         let tryclauses = mkClauses parg all_args         let new = mnub i $ filter (noMatch i) tryclauses          logLvl 7 $ "New clauses: \n" ++ showSep "\n" (map (showImp True) new)---                     ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses) +--           ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)          return new --         return (map (\t -> PClause n t [] PImpossible []) new)   where getLHS i term @@ -73,8 +202,8 @@                                 as' <- mkArg as                                 return (a':as') --- FIXME: Just look for which one is the deepest, then generate all possibilities--- up to that depth.+-- FIXME: Just look for which one is the deepest, then generate all +-- possibilities up to that depth.  genAll :: IState -> [PTerm] -> [PTerm] genAll i args = case filter (/=Placeholder) $ concatMap otherPats (nub args) of@@ -96,7 +225,7 @@                  let p = PApp fc (PRef fc n) (zipWith upd xs' xs)                  let tyn = getTy n (tt_ctxt i)                  case lookupCtxt Nothing tyn (idris_datatypes i) of-                         (TI ns : _) -> p : map (mkPat fc) (ns \\ [n])+                         (TI ns _ : _) -> p : map (mkPat fc) (ns \\ [n])                          _ -> [p]     ops fc n arg o = return Placeholder @@ -123,6 +252,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          addIBC (IBCTotal cn tot)   where     args t = [0..length (getArgTys t)-1]@@ -135,94 +265,71 @@             = n /= n' && posArg sc     posArg t = True --- Totality checking - check for structural recursion (no mutual definitions yet)+-- Totality checking - check for structural recursion +-- (no mutual definitions yet)  data LexOrder = LexXX | LexEQ | LexLT     deriving (Show, Eq, Ord) -calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality-calcTotality path fc n pats -    = do orders <- mapM ctot pats -         let order = sortBy cmpOrd $ concat orders-         let (errs, valid) = partitionEithers order-         let lex = stripNoLT (stripXX valid)-         case errs of-            [] -> do logLvl 3 $ show n ++ ":\n" ++ showSep "\n" (map show lex) -                     logLvl 10 $ show pats-                     checkDecreasing lex-            (e : _) -> return e -- FIXME: should probably combine them-  where-    cmpOrd (Left _) (Left _) = EQ-    cmpOrd (Left _) (Right _) = LT-    cmpOrd (Right _) (Left _) = GT-    cmpOrd (Right x) (Right y) = compare x y--    checkDecreasing [] = return (Total [])-    checkDecreasing (c : cs) | dec c = checkDecreasing cs-                             | otherwise = return (Partial Itself)-    -    dec [] = False-    dec (LexLT : _) = True-    dec (LexEQ : xs) = dec xs-    dec (LexXX : xs) = False--    stripXX [] = []-    stripXX v@(c : cs) -        = case span (==LexXX) c of-               (ns, rest) -> map (drop (length ns)) v--    -- argument positions which are never LT are no use to us-    stripNoLT [] = [] -- no recursive calls-    stripNoLT xs = case transpose (filter (any (==LexLT)) (transpose xs)) of-                        [] -> [[]] -- recursive calls are all useless...-                        xs -> xs--    ctot (_, lhs, rhs) -        | (_, args) <- unApply lhs-            = do -- check lhs doesn't use any dodgy names-                    lhsOK <- mapM (chkOrd [] []) args-                    chkOrd (filter isLeft (concat lhsOK)) args rhs+calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality+calcProd i fc n pats = do patsprod <- mapM prodRec pats+                          if (and patsprod) +                             then return Productive+                             else return (Partial NotProductive)+   where+     -- every application of n must be in an argument of a coinductive +     -- constructor -    isLeft (Left _) = True-    isLeft _ = False+     prodRec :: ([Name], Term, Term) -> Idris Bool+     prodRec (_, _, tm) = prod False tm  -    chkOrd ords args (Bind n (Let t v) sc) -        = do ov <- chkOrd ords args v-             chkOrd ov args sc-    chkOrd ords args (Bind n b sc) = chkOrd ords (args ++ [P Ref n Erased]) sc-    chkOrd ords args ap@(App f a)-        | (P _ fn _, args') <- unApply ap-            = if fn == n && length args == length args'-                 then do orf <- chkOrd (Right (zipWith lexOrd args args') : ords) args f-                         chkOrd orf args a-                 else do orf <- chkOrd ords args f-                         chkOrd orf args a-        | otherwise = do orf <- chkOrd ords args f-                         chkOrd orf args a-    chkOrd ords args (P _ fn _)-        | n /= fn-            = do tf <- checkTotality (n : path) fc fn-                 case tf of-                    Total _ -> return ords-                    p@(Partial (Mutual x)) -> return ((Left p) : ords)-                    _ -> return (Left (Partial (Other [fn])) : ords)-        | null args = return (Left (Partial Itself) : ords)-    chkOrd ords args _ = return ords+     prod ok ap@(App _ _)+        | (P _ (UN "lazy") _, [_, arg]) <- unApply ap = prod ok arg+        | (P _ f ty, args) <- unApply ap+            = let co = cotype ty in+                  if f == n +                     then do argsprod <- mapM (prod co) args+                             return (and (ok : argsprod) )+                     else do argsprod <- mapM (prod co) args+                             return (and argsprod)+     prod ok (App f a) = liftM2 (&&) (prod False f) (prod False a)+     prod ok (Bind _ (Let t v) sc) = liftM2 (&&) (prod False v) (prod False v)+     prod ok (Bind _ b sc) = prod ok sc+     prod ok t = return True +    +     cotype ty +        | (P _ t _, _) <- unApply (getRetTy ty)+            = case lookupCtxt Nothing t (idris_datatypes i) of+                   [TI _ True] -> True+                   _ -> False+        | otherwise = False -    lexOrd x y | x == y = LexEQ-    lexOrd f@(App _ _) x -        | (f', args) <- unApply f-            = let ords = map (\x' -> lexOrd x' x) args in-                if any (\o -> o == LexEQ || o == LexLT) ords-                    then LexLT-                    else LexXX-    lexOrd _ _ = LexXX+calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]+                -> Idris Totality+calcTotality path fc n pats +    = do i <- get+         let opts = case lookupCtxt Nothing n (idris_flags i) of+                            [fs] -> fs+                            _ -> []+         case mapMaybe (checkLHS i) (map (\ (_, l, r) -> l) pats) of+            (failure : _) -> return failure+            _ -> if (Coinductive `elem` opts) +                      then calcProd i fc n pats+                      else checkSizeChange n+  where+    checkLHS i (P _ fn _) +        = case lookupTotal fn (tt_ctxt i) of+               [Partial _] -> return (Partial (Other [fn]))                +               _ -> Nothing+    checkLHS i (App f a) = mplus (checkLHS i f) (checkLHS i a)+    checkLHS _ _ = Nothing  checkTotality :: [Name] -> FC -> Name -> Idris Totality checkTotality path fc n      | n `elem` path = return (Partial (Mutual (n : path)))     | otherwise = do         t <- getTotality n+        updateContext (simplifyCasedef n)         ctxt <- getContext         i <- getIState         let opts = case lookupCtxt Nothing n (idris_flags i) of@@ -231,7 +338,7 @@         t' <- case t of                  Unchecked ->                      case lookupDef Nothing n ctxt of-                        [CaseOp _ _ pats _ _ _ _] -> +                        [CaseOp _ _ _ pats _ _ _ _] ->                              do t' <- if AssertTotal `elem` opts                                         then return $ Total []                                         else calcTotality path fc n pats@@ -241,24 +348,244 @@                             -- typechecking decidable                                case t' of -- FIXME: Put this back when we can handle mutually recursive things---                                            p@(Partial _) -> ---                                                 do setAccessibility n Frozen ---                                                    addIBC (IBCAccess n Frozen)---                                                    iputStrLn $ "HIDDEN: " ++ show n ++ show p-                                           _ -> return ()+--                                  p@(Partial _) -> +--                                      do setAccessibility n Frozen +--                                         addIBC (IBCAccess n Frozen)+--                                         logLvl 5 $ "HIDDEN: " +--                                               ++ show n ++ show p+                                 _ -> return ()                                return t'                         _ -> return $ Total []                 x -> return x-        if TotalFn `elem` opts-            then case t' of-                    Total _ -> return t'-                    e -> totalityError t'-            else return t'+        case t' of+            Total _ -> return t'+            Productive -> return t'+            e -> do w <- cmdOptSet WarnPartial+                    if TotalFn `elem` opts+                       then totalityError t'+                       else do when (w && not (PartialFn `elem` opts)) $ +                                   warnPartial n t'+                               return t'   where     totalityError t = tclift $ tfail (At fc (Msg (show n ++ " is " ++ show t))) +    warnPartial n t+       = do i <- get+            case lookupDef Nothing n (tt_ctxt i) of+               [x] -> do+                  iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t +--                                ++ "\n" ++ show x+--                   let cg = lookupCtxtName Nothing n (idris_callgraph i)+--                   iputStrLn (show cg)++ checkDeclTotality :: (FC, Name) -> Idris Totality checkDeclTotality (fc, n)      = do logLvl 2 $ "Checking " ++ show n ++ " for totality"+         buildSCG (fc, n)          checkTotality [] fc n++-- Calculate the size change graph for this definition++-- SCG for a function f consists of a list of:+--    (g, [(a1, sizechange1), (a2, sizechange2), ..., (an, sizechangen)])++-- where g is a function called+-- a1 ... an are the arguments of f in positions 1..n of g+-- sizechange1 ... sizechange2 is how their size has changed wrt the input +-- to f+--    Nothing, if the argument is unrelated to the input++buildSCG :: (FC, Name) -> Idris ()+buildSCG (_, n) = do+   ist <- get+   case lookupCtxt Nothing n (idris_callgraph ist) of+       [cg] -> case lookupDef Nothing n (tt_ctxt ist) of+           [CaseOp _ _ _ _ args sc _ _] -> +               do logLvl 5 $ "Building SCG for " ++ show n ++ " from\n" +                                ++ show sc+                  let newscg = buildSCG' ist sc args+                  logLvl 5 $ show newscg+                  addToCG n ( cg { scg = newscg } )++buildSCG' :: IState -> SC -> [Name] -> [SCGEntry] +buildSCG' ist sc args = nub $ scg sc (zip args args) +                              (zip args (zip args (repeat Same)))+   where+      scg :: SC -> [(Name, Name)] -> -- local var, originating top level var+             [(Name, (Name, SizeChange))] -> -- orig to new,  and relationship+             [SCGEntry]+      scg (Case x alts) vars szs +          = let x' = findTL x vars in+                concatMap (scgAlt x' vars szs) alts+        where+          findTL x vars +            | Just x' <- lookup x vars+               = if x' `elem`  args then x'+                    else findTL x' vars+            | otherwise = x++      scg (STerm tm) vars szs = scgTerm tm vars szs+      scg _ _ _ = []++      -- how the arguments relate - either Smaller or Unknown+      argRels :: Name -> [(Name, SizeChange)]+      argRels n = let ctxt = tt_ctxt ist+                      [ty] = lookupTy Nothing n ctxt -- must exist!+                      P _ nty _ = fst (unApply (getRetTy ty))+                      args = map snd (getArgTys ty) in+                      map (getRel nty) (map (fst . unApply . getRetTy) args)+        where+          getRel ty (P _ n' _) | n' == ty = (n, Smaller)+          getRel ty _ = (n, Unknown)++      scgAlt x vars szs (ConCase n _ args sc)+           -- all args smaller than top variable of x in sc+           -- (as long as they are in the same type family)+         | Just tvar <- lookup x vars+              = let arel = argRels n+                    szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel +                                                       ++ szs+                    vars' = zip args (repeat tvar) ++ vars in+                    scg sc vars' szs'+         | otherwise = scg sc vars szs+      scgAlt x vars szs (ConstCase _ sc) = scg sc vars szs+      scgAlt x vars szs (DefaultCase sc) = scg sc vars szs++      scgTerm f@(App _ _) vars szs+         | (P _ (UN "lazy") _, [_, arg]) <- unApply f+             = scgTerm arg vars szs+         | (P _ fn _, args) <- unApply f+            = let rest = concatMap (\x -> scgTerm x vars szs) args in+                  case lookup fn vars of+                       Just _ -> rest+                       Nothing -> (fn, map (mkChange szs) args) : rest +      scgTerm (App f a) vars szs+            = scgTerm f vars szs ++ scgTerm a vars szs+      scgTerm (Bind n (Let t v) e) vars szs+            = scgTerm v vars szs ++ scgTerm e vars szs+      scgTerm (Bind n _ e) vars szs+            = scgTerm e ((n, n) : vars) szs+      scgTerm (P _ fn _) vars szs+            = case lookup fn vars of+                   Just _ -> []+                   Nothing -> [(fn, [])]+      scgTerm _ _ _ = []++      mkChange :: [(Name, (Name, SizeChange))] -> Term +                   -> Maybe (Int, SizeChange)+      mkChange szs tm+         | (P _ (UN "lazy") _, [_, arg]) <- unApply tm = mkChange szs arg+         | (P _ n ty, _) <- unApply tm -- get higher order args too+          = do sc <- lookup n szs+               case sc of+                  (_, Unknown) -> Nothing+                  (o, sc) -> do i <- getArgPos 0 o args+                                return (i, sc)+      mkChange _ _ = Nothing++      getArgPos :: Int -> Name -> [Name] -> Maybe Int+      getArgPos i n [] = Nothing+      getArgPos i n (x : xs) | n == x = Just i+                             | otherwise = getArgPos (i + 1) n xs++checkSizeChange :: Name -> Idris Totality+checkSizeChange n = do+   ist <- get+   case lookupCtxt Nothing n (idris_callgraph ist) of+       [cg] -> do let ms = mkMultiPaths ist [] (scg cg)+                  logLvl 6 ("Multipath for " ++ show n ++ ":\n" +++                            "from " ++ show (scg cg) ++ "\n" +++                            showSep "\n" (map show ms))+                  logLvl 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 (length (argsdef cg))) ms+                  logLvl 3 $ "Paths for " ++ show n ++ " yield " ++ (show tot)+                  return (noPartial tot)++type MultiPath = [SCGEntry]++mkMultiPaths :: IState -> MultiPath -> [SCGEntry] -> [MultiPath]+mkMultiPaths ist path [] = [reverse path]+mkMultiPaths ist path cg+    = concat (map extend cg)+  where extend (nextf, args) +           | (nextf, args) `elem` path = [ reverse ((nextf, args) : path) ]+           | otherwise +               = case lookupCtxt Nothing nextf (idris_callgraph ist) of+                    [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg) +                    _ -> [ reverse ((nextf, args) : path) ]++--     do (nextf, args) <- cg+--          if ((nextf, args) `elem` path)+--             then return (reverse ((nextf, args) : path))+--             else case lookupCtxt Nothing nextf (idris_callgraph ist) of+--                     [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg) +--                     _ -> return (reverse ((nextf, args) : path))++-- If any route along the multipath leads to infinite descent, we're fine.+-- Try a route beginning with every argument.+--   If we reach a point we've been to before, but with a smaller value,+--   that means there is an infinitely descending path.++checkMP :: IState -> Int -> MultiPath -> Totality+checkMP ist i mp = if i > 0 +                     then collapse (map (tryPath 0 [] mp) [0..i-1])+                     else tryPath 0 [] mp 0+  where+    tryPath :: Int -> [(SCGEntry, Int)] -> MultiPath -> Int -> Totality+    tryPath desc path [] _ = Total []+    -- if we get to a constructor, it's fine as long as it's strictly positive+    tryPath desc path ((f, _) :es) arg+        | [TyDecl (DCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist)+            = case lookupTotal f (tt_ctxt ist) of+                   [Total _] -> Total []+                   [Partial _] -> Partial (Other [f])+                   x -> error (show x)+        | [TyDecl (TCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist)+            = Total []+--     tryPath desc path (e@(f, []) : es) arg+--         | [Unchecked] <- lookupTotal f (tt_ctxt ist) =+--              tryPath (-10000) ((e, desc) : path) es 0+    tryPath desc path (e@(f, nextargs) : es) arg+        | Just d <- lookup e path+            = if (desc - d) > 0 +                   then Total []+                   else Partial (Mutual (map (fst . fst) path ++ [f]))+        | [Unchecked] <- lookupTotal f (tt_ctxt ist) =+            let argspos = zip nextargs [0..] in+                collapse' (Partial (Mutual (map (fst . fst) path ++ [f]))) $ +                  do (arg, pos) <- argspos+                     case arg of+                        Nothing -> -- don't know, but it's okay if the+                                   -- rest definitely terminates without+                                   -- any cycles with route so far+                            map (tryPath (-10000) ((e, desc):path) es)+                                [0..length nextargs - 1]+                        Just (nextarg, sc) ->+                          case sc of+                            Same -> return $ tryPath desc ((e, desc):path) +                                                     es+                                                     nextarg+                            Smaller -> return $ tryPath (desc+1) +                                                        ((e, desc):path) +                                                        es+                                                        nextarg+                            _ -> trace ("Shouldn't happen " ++ show e) $ +                                    return (Partial Itself)+        | [Total _] <- lookupTotal f (tt_ctxt ist) = Total []+        | [Partial _] <- lookupTotal f (tt_ctxt ist) = Partial (Other [f])+        | otherwise = Total []++noPartial (Partial p : xs) = Partial p+noPartial (_ : xs)         = noPartial xs+noPartial []               = Total [] ++collapse xs = collapse' (Partial Itself) xs+collapse' def (Total r  : xs)  = Total r+collapse' def (d : xs)         = collapse' d xs+collapse' def []               = def
src/Idris/DataOpts.hs view
@@ -15,8 +15,8 @@ -- optimisations  forceArgs :: Name -> Type -> Idris ()-forceArgs n t = do let fargs = force 0 t-                   i <- getIState+forceArgs n t = do i <- getIState+                   let fargs = force i 0 t                    copt <- case lookupCtxt Nothing n (idris_optimisation i) of                                  []     -> return $ Optimise False [] []                                  (op:_) -> return op@@ -26,14 +26,23 @@                    iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n   from " ++                           show t   where-    force :: Int -> Term -> [Int]-    force i (Bind _ (Pi _) sc) -        = force (i + 1) $ instantiate (P Bound (MN i "?") Erased) sc-    force _ sc@(App f a) +    force :: IState -> Int -> Term -> [Int]+    force ist i (Bind _ (Pi ty) sc)+        | collapsibleIn ist ty +            = nub $ i : (force ist (i + 1) $ instantiate (P Bound (MN i "?") Erased) sc)+        | otherwise = force ist (i + 1) $ instantiate (P Bound (MN i "?") Erased) sc+    force _ _ sc@(App f a)          | (_, args) <- unApply sc              = nub $ concatMap guarded args-    force _ _ = []+    force _ _ _ = [] +    collapsibleIn i t+        | (P _ tn _, _) <- unApply t+           = case lookupCtxt Nothing tn (idris_optimisation i) of+                [oi] -> collapsible oi+                _ -> False+        | otherwise = False+     isF (P _ (MN force "?") _) = Just force     isF _ = Nothing @@ -49,25 +58,99 @@  collapseCons :: Name -> [(Name, Type)] -> Idris () collapseCons ty cons = -                do i <- getIState-                   return ()+     do i <- getIState+        let cons' = map (\ (n, t) -> (n, map snd (getArgTys t))) cons+        allFR <- mapM (forceRec i) cons'+        if and allFR then detaggable (map getRetTy (map snd cons))+                     else return () -- not collapsible as not detaggable+  where+    setCollapsible :: Name -> Idris ()+    setCollapsible n+       = do i <- getIState+            iLOG $ show n ++ " collapsible"+            case lookupCtxt Nothing n (idris_optimisation i) of+               (oi:_) -> do let oi' = oi { collapsible = True }+                            let opts = addDef n oi' (idris_optimisation i)+                            putIState (i { idris_optimisation = opts })+               [] -> do let oi = Optimise True [] []+                        let opts = addDef n oi (idris_optimisation i)+                        putIState (i { idris_optimisation = opts })+                        addIBC (IBCOpt n) +    forceRec :: IState -> (Name, [Type]) -> Idris Bool+    forceRec i (n, ts)+       = case lookupCtxt Nothing n (idris_optimisation i) of+            (oi:_) -> checkFR (forceable oi) 0 ts+            _ -> return False+    checkFR fs i [] = return True+    checkFR fs i (_ : xs) | i `elem` fs = checkFR fs (i + 1) xs+    checkFR fs i (t : xs)+        -- must be recursive or type is not collapsible+        = do let rt = getRetTy t+             if (ty `elem` freeNames rt) +               then checkFR fs (i+1) xs+               else return False++    detaggable :: [Type] -> Idris ()+    detaggable rtys +        = do let rtyArgs = map (snd . unApply) rtys+             -- if every rtyArgs is disjoint with every other, it's detaggable,+             -- therefore also collapsible given forceable/recursive check+             if disjoint rtyArgs+                then mapM_ setCollapsible (ty : map fst cons)+                else return ()++    disjoint :: [[Term]] -> Bool+    disjoint []       = True+    disjoint [x]      = True+    disjoint (x : xs) = anyDisjoint x xs && disjoint xs++    anyDisjoint x [] = True+    anyDisjoint x (y : ys) = disjointCons x y++    disjointCons [] [] = False+    disjointCons [] y  = False+    disjointCons x  [] = False+    disjointCons (x : xs) (y : ys)+        = disjointCon x y || disjointCons xs ys++    disjointCon x y = let (cx, _) = unApply x+                          (cy, _) = unApply y in+                          case (cx, cy) of+                               (P (DCon _ _) nx _, P (DCon _ _) ny _) -> nx /= ny+                               _ -> False+ class Optimisable term where     applyOpts :: term -> Idris term+    stripCollapsed :: term -> Idris term  instance (Optimisable a, Optimisable b) => Optimisable (a, b) where     applyOpts (x, y) = do x' <- applyOpts x                           y' <- applyOpts y                           return (x', y')+    stripCollapsed (x, y) = do x' <- stripCollapsed x+                               y' <- stripCollapsed y+                               return (x', y') + instance (Optimisable a, Optimisable b) => Optimisable (vs, a, b) where     applyOpts (v, x, y) = do x' <- applyOpts x                              y' <- applyOpts y                              return (v, x', y')+    stripCollapsed (v, x, y) = do x' <- stripCollapsed x+                                  y' <- stripCollapsed y+                                  return (v, x', y')  instance Optimisable a => Optimisable [a] where     applyOpts = mapM applyOpts+    stripCollapsed = mapM stripCollapsed +instance Optimisable a => Optimisable (Either a (a, a)) where+    applyOpts (Left t) = do t' <- applyOpts t; return $ Left t'+    applyOpts (Right t) = do t' <- applyOpts t; return $ Right t'+    stripCollapsed (Left t) = do t' <- stripCollapsed t; return $ Left t'+    stripCollapsed (Right t) = do t' <- stripCollapsed t; return $ Right t'+ -- Raw is for compile time optimisation (before type checking) -- Term is for run time optimisation (after type checking, collapsing allowed) @@ -90,12 +173,19 @@     applyOpts (RForce t) = applyOpts t     applyOpts t = return t +    stripCollapsed t = return t+ instance Optimisable t => Optimisable (Binder t) where     applyOpts (Let t v) = do t' <- applyOpts t                              v' <- applyOpts v                              return (Let t' v')     applyOpts b = do t' <- applyOpts (binderTy b)                      return (b { binderTy = t' })+    stripCollapsed (Let t v) = do t' <- stripCollapsed t+                                  v' <- stripCollapsed v+                                  return (Let t' v')+    stripCollapsed b = do t' <- stripCollapsed (binderTy b)+                          return (b { binderTy = t' })   applyDataOpt :: OptInfo -> Name -> [Raw] -> Raw@@ -110,6 +200,11 @@ -- Run-time: do everything  instance Optimisable (TT Name) where+    applyOpts c@(P (DCon t arity) n _)+        = do i <- getIState+             case lookupCtxt Nothing n (idris_optimisation i) of+                 (oi:_) -> return $ applyDataOptRT oi n t arity []+                 _ -> return c     applyOpts t@(App f a)         | (c@(P (DCon t arity) n _), args) <- unApply t -- MAGIC HERE             = do args' <- mapM applyOpts args@@ -123,8 +218,25 @@     applyOpts (Bind n b t) = do b' <- applyOpts b                                 t' <- applyOpts t                                 return (Bind n b' t')+    applyOpts (Proj t i) = do t' <- applyOpts t+                              return (Proj t' i)     applyOpts t = return t +    stripCollapsed (Bind n (PVar x) t) | (P _ ty _, _) <- unApply x+           = do i <- getIState+                case lookupCtxt Nothing ty (idris_optimisation i) of+                  [oi] -> if collapsible oi+                             then do t' <- stripCollapsed t+                                     return (Bind n (PVar x) (instantiate Erased t'))+                             else do t' <- stripCollapsed t+                                     return (Bind n (PVar x) t')+                  _ -> do t' <- stripCollapsed t+                          return (Bind n (PVar x) t')+    stripCollapsed (Bind n (PVar x) t)+                  = do t' <- stripCollapsed t+                       return (Bind n (PVar x) t')+    stripCollapsed t = return t+ -- Need to saturate arguments first to ensure that erasure happens uniformly  applyDataOptRT :: OptInfo -> Name -> Int -> Int -> [Term] -> Term@@ -147,4 +259,5 @@               mkApp (P (DCon tag (arity - length forced)) n Erased) (map snd args')      keep (forced, _) = not forced+
src/Idris/Delaborate.hs view
@@ -37,6 +37,7 @@     de env (Bind n _ sc) = de ((n,n):env) sc     de env (Constant i) = PConstant i     de env Erased = Placeholder+    de env Impossible = Placeholder     de env (Set i) = PSet       dens x | fullname = x@@ -47,7 +48,7 @@      deFn env (App f a) args = deFn env f (a:args)     deFn env (P _ n _) [l,r]     | n == pairTy  = PPair un (de env l) (de env r)-                                 | n == eqCon   = PRefl un+                                 | n == eqCon   = PRefl un (de env r)                                  | n == UN "lazy" = de env r     deFn env (P _ n _) [ty, Bind x (Lam _) r]                                  | n == UN "Exists" @@ -82,13 +83,14 @@         case e of             Msg "" -> ""             _ -> "\n\nSpecifically:\n\t" ++ pshow i e ++ -                 if (opt_errContext (idris_options i)) then showSc sc else ""-    where showSc [] = ""-          showSc xs = "\n\nIn context:\n" ++ showSep "\n" (map showVar (reverse xs))-          showVar (x, y) = "\t" ++ showbasic x ++ " : " ++ show (delab i y)-          showbasic n@(UN _) = show n-          showbasic (MN _ s) = s-          showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n+                 if (opt_errContext (idris_options i)) then showSc i sc else ""+pshow i (CantConvert x y env) +    = "Can't unify " ++ show (delab i x) ++ " with " ++ show (delab i y) +++                 if (opt_errContext (idris_options i)) then showSc i env else ""+pshow i (InfiniteUnify x tm env)+    = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++ +      " would lead to infinite value" +++                 if (opt_errContext (idris_options i)) then showSc i env else "" pshow i (NotInjective p x y) = "Can't verify injectivity of " ++ show (delab i p) ++                                " when unifying " ++ show (delab i x) ++ " and " ++                                                      show (delab i y)@@ -96,9 +98,16 @@ pshow i (CantResolveAlts as) = "Can't disambiguate name: " ++ showSep ", " as pshow i (NoTypeDecl n) = "No type declaration for " ++ show n pshow i (NoSuchVariable n) = "No such variable " ++ show n-pshow i (IncompleteTerm t) = "Incomplete term " ++ show (delab i t)+pshow i (IncompleteTerm t) = "Incomplete term " ++ showImp True (delab i t) pshow i UniverseError = "Universe inconsistency" pshow i ProgramLineComment = "Program line next to comment" pshow i (Inaccessible n) = show n ++ " is not an accessible pattern variable" pshow i (At f e) = show f ++ ":" ++ pshow i e +showSc i [] = ""+showSc i xs = "\n\nIn context:\n" ++ showSep "\n" (map showVar (reverse xs))+  where showVar (x, y) = "\t" ++ showbasic x ++ " : " ++ show (delab i y)++showbasic n@(UN _) = show n+showbasic (MN _ s) = s+showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n
src/Idris/ElabDecls.hs view
@@ -58,14 +58,25 @@          addStatics n cty ty'          logLvl 2 $ "---> " ++ show cty          let nty = cty -- normalise ctxt [] cty+         -- if the return type is something coinductive, freeze the definition+         let nty' = normalise ctxt [] nty+         let (t, _) = unApply (getRetTy nty')+         let corec = case t of+                        P _ rcty _ -> case lookupCtxt Nothing rcty (idris_datatypes i) of+                                        [TI _ True] -> True+                                        _ -> False+                        _ -> False+         let opts' = if corec then (Coinductive : opts) else opts          ds <- checkDef fc [(n, nty)]          addIBC (IBCDef n)          addDeferred ds-         setFlags n opts-         addIBC (IBCFlags n opts)+         setFlags n opts'+         addIBC (IBCFlags n opts')+         when corec $ do setAccessibility n Frozen+                         addIBC (IBCAccess n Frozen) -elabData :: ElabInfo -> SyntaxInfo -> FC -> PData -> Idris ()-elabData info syn fc (PDatadecl n t_in dcons)+elabData :: ElabInfo -> SyntaxInfo -> FC -> Bool -> PData -> Idris ()+elabData info syn fc codata (PDatadecl n t_in dcons)     = do iLOG (show fc)          checkUndefined fc n          ctxt <- getContext@@ -80,11 +91,11 @@          (cty, _)  <- recheckC fc [] t'          logLvl 2 $ "---> " ++ show cty          updateContext (addTyDecl n cty) -- temporary, to check cons-         cons <- mapM (elabCon info syn n) dcons+         cons <- mapM (elabCon info syn n codata) dcons          ttag <- getName          i <- get-         put (i { idris_datatypes = addDef n (TI (map fst cons)) -                                            (idris_datatypes i) })+         put (i { idris_datatypes = addDef n (TI (map fst cons) codata)+                                             (idris_datatypes i) })          addIBC (IBCDef n)          addIBC (IBCData n)          collapseCons n cons@@ -94,7 +105,7 @@ elabRecord :: ElabInfo -> SyntaxInfo -> FC -> Name ->                PTerm -> Name -> PTerm -> Idris () elabRecord info syn fc tyn ty cn cty-    = do elabData info syn fc (PDatadecl tyn ty [(cn, cty, fc)]) +    = do elabData info syn fc False (PDatadecl tyn ty [(cn, cty, fc)])           cty' <- implicit syn cn cty          i <- get          cty <- case lookupTy Nothing cn (tt_ctxt i) of@@ -112,13 +123,23 @@          let nonImp = mapMaybe isNonImp (zip cimp ptys_u)          let implBinds = getImplB id cty'          update_decls <- mapM (mkUpdate recty implBinds (length nonImp)) (zip nonImp [0..])-         mapM_ (elabDecl info) (concat (proj_decls ++ update_decls))+         mapM_ (elabDecl info) (concat proj_decls)+         mapM_ (tryElabDecl info) (update_decls)   where --     syn = syn_in { syn_namespace = show (nsroot tyn) : syn_namespace syn_in }      isNonImp (PExp _ _ _, a) = Just a     isNonImp _ = Nothing +    tryElabDecl info (fn, ty, val)+        = do i <- get+             idrisCatch (do elabDecl' EAll info ty+                            elabDecl' EAll info val)+                        (\v -> do iputStrLn $ show fc ++ +                                      ":Warning - can't generate setter for " ++ +                                      show fn ++ " (" ++ show ty ++ ")"+                                  put i)+     getImplB k (PPi (Imp l s) n Placeholder sc)         = getImplB k sc     getImplB k (PPi (Imp l s) n ty sc)@@ -188,14 +209,14 @@                                              []                                              (PApp fc (PRef fc cn)                                                       (map pexp rhsArgs)) []-            return [pfnTy, PClauses fc [] setname [pclause]]+            return (pn, pfnTy, PClauses fc [] setname [pclause]) -elabCon :: ElabInfo -> SyntaxInfo -> Name -> (Name, PTerm, FC) -> Idris (Name, Type)-elabCon info syn tn (n, t_in, fc)+elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool -> (Name, PTerm, FC) -> Idris (Name, Type)+elabCon info syn tn codata (n, t_in, fc)     = do checkUndefined fc n          ctxt <- getContext          i <- get-         t_in <- implicit syn n t_in+         t_in <- implicit syn n (if codata then mkLazy t_in else t_in)          let t = addImpl i t_in          logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ showImp True t          ((t', defer, is), log) <- tclift $ elaborate ctxt n (Set (UVal 0)) []@@ -219,56 +240,77 @@              else return ()     tyIs t = tclift $ tfail (At fc (Msg (show t ++ " is not " ++ show tn))) +    mkLazy (PPi pl n ty sc) = PPi (pl { plazy = True }) n ty (mkLazy sc)+    mkLazy t = t+ elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris () elabClauses info fc opts n_in cs = let n = liftname info n_in in         do ctxt <- getContext          -- Check n actually exists-         case lookupTy Nothing n ctxt of+         fty <- case lookupTy Nothing n ctxt of             [] -> -- TODO: turn into a CAF if there's no arguments                   -- question: CAFs in where blocks?                   tclift $ tfail $ (At fc (NoTypeDecl n))-            _ -> return ()+            [ty] -> return ty          pats_in <- mapM (elabClause info (TCGen `elem` opts)) cs-         -         +         -- if the return type of 'ty' is collapsible, the optimised version should+         -- just do nothing+         ist <- get+         let (ap, _) = unApply (getRetTy fty)+         logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)+         -- FIXME: Really ought to only do this for total functions!+         let doNothing = case ap of+                            P _ tn _ -> case lookupCtxt Nothing tn+                                                (idris_optimisation ist) of+                                            [oi] -> collapsible oi+                                            _ -> False+                            _ -> False          solveDeferred n-         let pats = mapMaybe id pats_in-         logLvl 3 (showSep "\n" (map (\ (l,r) -> -                                        show l ++ " = " ++ -                                        show r) pats))          ist <- get+         when doNothing $ +            case lookupCtxt Nothing n (idris_optimisation ist) of+               [oi] -> do let opts = addDef n (oi { collapsible = True }) +                                         (idris_optimisation ist)+                          put (ist { idris_optimisation = opts })+               _ -> do let opts = addDef n (Optimise True [] [])+                                         (idris_optimisation ist)+                       put (ist { idris_optimisation = opts })+                       addIBC (IBCOpt n)+         ist <- get+         let pats = pats_in+--          logLvl 3 (showSep "\n" (map (\ (l,r) -> +--                                         show l ++ " = " ++ +--                                         show r) pats))          let tcase = opt_typecase (idris_options ist)          let pdef = map debind $ map (simpl (tt_ctxt ist)) pats+         +         numArgs <- tclift $ sameLength pdef++         optpats <- if doNothing +                       then return $ [Right (mkApp (P Bound n Erased)+                                                  (take numArgs (repeat Erased)), Erased)]+                       else stripCollapsed pats++         logLvl 5 $ "Patterns:\n" ++ show pats+         logLvl 5 $ "Optimised patterns:\n" ++ show optpats++         let optpdef = map debind $ map (simpl (tt_ctxt ist)) optpats+         tree@(CaseDef scargs sc _) <- tclift $ +                 simpleCase tcase False CompileTime fc pdef          cov <- coverage-         pcover <-+         pmissing <-                  if cov                       then do missing <- genClauses fc n (map getLHS pdef) cs+                            -- missing <- genMissing n scargs sc                               missing' <- filterM (checkPossible info fc True n) missing---                             let missing' = mapMaybe (\x -> case x of---                                                                 Nothing -> Nothing---                                                                 Just t -> Just $ delab ist t) ---                                                     poss                             logLvl 3 $ "Must be unreachable:\n" ++                                          showSep "\n" (map (showImp True) missing') ++                                        "\nAgainst: " ++                                         showSep "\n" (map (\t -> showImp True (delab ist t)) (map getLHS pdef))-                            if null missing'-                              then return True-                              else return False ---                                -- if there's missing cases, add a catch all case. If it's---                                -- unreachable, we're still covering---                                do let mrhs = P Ref (MN 0 "reach?") undefined---                                   let (f,as) = unApply $ depat (head missing')---                                   let arity = length as---                                   let mlhs = mkApp f (map (\a -> P Bound (MN a "v") undefined)---                                                         [0..arity-1]) ---                                   let untree@(CaseDef _ sc _) = simpleCase tcase True ---                                                                  (pdef ++ [(mlhs, mrhs)])---                                   logLvl 5 $ "Tree is " ++ show sc---                                   return False-                    else return False-         pdef' <- applyOpts pdef -         tree@(CaseDef _ sc _) <- tclift $ simpleCase tcase pcover fc pdef+                            return missing'+                    else return []+         let pcover = null pmissing+         pdef' <- applyOpts optpdef           ist <- get --          let wf = wellFounded ist n sc          let tot = if pcover || AssertTotal `elem` opts@@ -284,11 +326,10 @@          case tree of              CaseDef _ _ [] -> return ()              CaseDef _ _ xs -> mapM_ (\x ->-                                        iputStrLn $ show fc ++-                                                    ":warning - Unreachable case: " ++ -                                                    show (delab ist x)) xs-         tree' <- tclift $ simpleCase tcase pcover fc pdef'-         tclift $ sameLength pdef+                 iputStrLn $ show fc +++                              ":warning - Unreachable case: " ++ +                                 show (delab ist x)) xs+         tree' <- tclift $ simpleCase tcase pcover RunTime fc pdef'          logLvl 3 (show tree)          logLvl 3 $ "Optimised: " ++ show tree'          ctxt <- getContext@@ -296,32 +337,41 @@          put (ist { idris_patdefs = addDef n pdef' (idris_patdefs ist) })          case lookupTy (namespace info) n ctxt of              [ty] -> do updateContext (addCasedef n (inlinable opts)-                                                     tcase pcover pdef pdef' ty)+                                                     tcase pcover pats+                                                     pdef pdef' ty)                         addIBC (IBCDef n)                         setTotality n tot                         totcheck (fc, n)                         when (tot /= Unchecked) $ addIBC (IBCTotal n tot)                         i <- get                         case lookupDef Nothing n (tt_ctxt i) of-                            (CaseOp _ _ _ scargs sc _ _ : _) ->-                                do let ns = namesUsed sc \\ scargs-                                   logLvl 2 $ "Called names: " ++ show ns-                                   addToCG n ns-                                   addToCalledG n ns -- plus names in type!+                            (CaseOp _ _ _ _ scargs sc scargs' sc' : _) ->+                                do let calls = findCalls sc' scargs'+                                   let used = findUsedArgs sc' scargs'+                                   -- let scg = buildSCG i sc scargs+                                   -- add SCG later, when checking totality+                                   let cg = CGInfo scargs' calls [] used []+                                   logLvl 2 $ "Called names: " ++ show cg+                                   addToCG n cg+                                   addToCalledG n (nub (map fst calls)) -- plus names in type!                                    addIBC (IBCCG n)                             _ -> return () --                         addIBC (IBCTotal n tot)              [] -> return ()   where-    debind (x, y) = let (vs, x') = depat [] x -                        (_, y') = depat [] y in-                        (vs, x', y')+    debind (Right (x, y)) = let (vs, x') = depat [] x +                                (_, y') = depat [] y in+                                (vs, x', y')+    debind (Left x)       = let (vs, x') = depat [] x in+                                (vs, x', Impossible)+     depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)     depat acc x = (acc, x)          getLHS (_, l, _) = l -    simpl ctxt (x, y) = (x, simplify ctxt [] y)+    simpl ctxt (Right (x, y)) = Right (x, simplify ctxt [] y)+    simpl ctxt t = t      sameLength ((_, x, _) : xs)          = do l <- sameLength xs@@ -356,17 +406,21 @@                             (erun fc (buildTC i info True tcgen fname (infTerm lhs))) of             OK ((lhs', _, _), _) ->                do let lhs_tm = orderPats (getInferTerm lhs')-                  b <- inferredDiff fc (delab' i lhs_tm True) lhs-                  return (not b) -- then return (Just lhs_tm) else return Nothing+                  case recheck ctxt [] (forget lhs_tm) lhs_tm of+                       OK _ -> return True+                       _ -> return False+--                   b <- inferredDiff fc (delab' i lhs_tm True) lhs+--                   return (not b) -- then return (Just lhs_tm) else return Nothing --                   trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b)             Error _ -> return False -elabClause :: ElabInfo -> Bool -> PClause -> Idris (Maybe (Term, Term))+elabClause :: ElabInfo -> Bool -> PClause -> Idris (Either Term (Term, Term)) elabClause info tcgen (PClause fc fname lhs_in [] PImpossible [])    = do b <- checkPossible info fc tcgen fname lhs_in         case b of             True -> fail $ show fc ++ ":" ++ show lhs_in ++ " is a possible case"-            False -> return Nothing+            False -> do ptm <- mkPatTm lhs_in+                        return (Left ptm) elabClause info tcgen (PClause fc fname lhs_in withs rhs_in whereblock)     = do ctxt <- getContext         -- Build the LHS as an "Infer", and pull out its type and@@ -379,7 +433,7 @@                      (erun fc (buildTC i info True tcgen fname (infTerm lhs)))         let lhs_tm = orderPats (getInferTerm lhs')         let lhs_ty = getInferType lhs'-        logLvl 3 (show lhs_tm)+        logLvl 3 ("Elaborated: " ++ show lhs_tm)         (clhs, clhsty) <- recheckC fc [] lhs_tm         logLvl 5 ("Checked " ++ show clhs)         -- Elaborate where block@@ -390,13 +444,13 @@         let newargs = pvars ist lhs_tm         let wb = map (expandParamsD ist decorate newargs decls) whereblock         logLvl 5 $ "Where block: " ++ show wb-        mapM_ (elabDecl' info) wb+        mapM_ (elabDecl' EAll info) wb         -- Now build the RHS, using the type of the LHS as the goal.         i <- get -- new implicits from where block         logLvl 5 (showImp True (expandParams decorate newargs decls rhs_in))         let rhs = addImplBound i (map fst newargs)                                   (expandParams decorate newargs decls rhs_in)-        logLvl 2 (showImp True rhs)+        logLvl 2 $ "RHS: " ++ showImp True rhs         ctxt <- getContext -- new context with where block added         logLvl 5 "STARTING CHECK"         ((rhs', defer, is), _) <- @@ -416,11 +470,15 @@         ctxt <- getContext         logLvl 5 $ "Rechecking"         (crhs, crhsty) <- recheckC fc [] rhs'+        logLvl 6 $ " ==> " ++ show crhsty ++ "   against   " ++ show clhsty+        case  converts ctxt [] clhsty crhsty of+            OK _ -> return ()+            Error _ -> ierror (At fc (CantUnify False clhsty crhsty (Msg "") [] 0))         i <- get         checkInferred fc (delab' i crhs True) rhs-        return $ Just (clhs, crhs)+        return $ Right (clhs, crhs)   where-    decorate x = UN (show fname ++ "#" ++ show x)+    decorate x = UN (show x ++ "#" ++ show fname)     pinfo ns ps i            = let ds = concatMap declared ps                 newps = params info ++ ns@@ -503,7 +561,7 @@         addDeferred def'         mapM_ (elabCaseBlock info) is         (crhs, crhsty) <- recheckC fc [] rhs'-        return $ Just (clhs, crhs)+        return $ Right (clhs, crhs)   where     getImps (Bind n (Pi _) t) = pexp Placeholder : getImps t     getImps _ = []@@ -565,7 +623,7 @@          let cons = [(cn, cty, fc)]          let ddecl = PDatadecl tn tty cons          logLvl 5 $ "Class data " ++ showDImp True ddecl-         elabData info (syn { no_imp = no_imp syn ++ mnames }) fc ddecl+         elabData info (syn { no_imp = no_imp syn ++ mnames }) fc False ddecl          -- for each constraint, build a top level function to chase it          logLvl 5 $ "Building functions"          let usyn = syn { using = ps ++ using syn }@@ -710,16 +768,20 @@                     _ -> []          let mtys = map (\ (n, (op, t)) ->                                  let t' = substMatches ips t in-                                    (decorate ns n, op, coninsert cs t', t'))+                                    (decorate ns iname n, +                                        op, coninsert cs t', t'))                         (class_methods ci)          logLvl 3 (show (mtys, ips))-         let ds' = insertDefaults i (class_defaults ci) ns ds+         let ds' = insertDefaults i iname (class_defaults ci) ns ds          iLOG ("Defaults inserted: " ++ show ds' ++ "\n" ++ show ci)-         mapM_ (warnMissing ds' ns) (map fst (class_methods ci))+         mapM_ (warnMissing ds' ns iname) (map fst (class_methods ci))          mapM_ (checkInClass (map fst (class_methods ci))) (concatMap defined ds')-         let wb = map mkTyDecl mtys ++ map (decorateid (decorate ns)) 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 (showDeclImp True . mkTyDecl) mtys)-         -- get the implicit parameters that need passing through to the where block+         -- get the implicit parameters that need passing through to the +         -- where block          wparams <- mapM (\p -> case p of                                   PApp _ _ args -> getWParams args                                   _ -> return []) ps@@ -730,10 +792,10 @@                         as -> PApp fc (PRef fc iname) as          let rhs = PApp fc (PRef fc (instanceName ci))                            (map (pexp . mkMethApp) mtys)-         let idecl = PClauses fc [Inlinable, TCGen] iname -                                 [PClause fc iname lhs [] rhs wb]-         iLOG (show idecl)-         elabDecl info idecl+         let idecls = [PClauses fc [Inlinable, TCGen] iname +                                 [PClause fc iname lhs [] rhs wb]]+         iLOG (show idecls)+         mapM (elabDecl info) idecls          addIBC (IBCInstance intInst n iname)   where     intInst = case ps of@@ -783,8 +845,8 @@                 _ -> return ps'     getWParams (_ : ps) = getWParams ps -    decorate ns (UN n) = NS (UN ('!':n)) ns-    decorate ns (NS (UN n) s) = NS (UN ('!':n)) ns+    decorate ns iname (UN n) = NS (UN ('!':n)) ns+    decorate ns iname (NS (UN n) s) = NS (UN ('!':n)) ns      mkTyDecl (n, op, t, _) = PTy syn fc op n t @@ -794,20 +856,22 @@     coninsert cs (PPi p@(Imp _ _) n t sc) = PPi p n t (coninsert cs sc)     coninsert cs sc = conbind cs sc -    insertDefaults :: IState -> [(Name, (Name, PDecl))] -> [String] -> [PDecl] -> [PDecl]-    insertDefaults i [] ns ds = ds-    insertDefaults i ((n,(dn, clauses)) : defs) ns ds -       = insertDefaults i defs ns (insertDef i n dn clauses ns ds)+    insertDefaults :: IState -> Name ->+                      [(Name, (Name, PDecl))] -> [String] -> +                      [PDecl] -> [PDecl]+    insertDefaults i iname [] ns ds = ds+    insertDefaults i iname ((n,(dn, clauses)) : defs) ns ds +       = insertDefaults i iname defs ns (insertDef i n dn clauses ns iname ds) -    insertDef i meth def clauses ns decls-        | null $ filter (clauseFor meth ns) decls+    insertDef i meth def clauses ns iname decls+        | null $ filter (clauseFor meth iname ns) decls             = let newd = expandParamsD i (\n -> meth) [] [def] clauses in                   -- trace (show newd) $                    decls ++ [newd]         | otherwise = decls -    warnMissing decls ns meth-        | null $ filter (clauseFor meth ns) decls+    warnMissing decls ns iname meth+        | null $ filter (clauseFor meth iname ns) decls             = iWarn fc $ "method " ++ show meth ++ " not defined"         | otherwise = return () @@ -818,8 +882,9 @@      eqRoot x y = nsroot x == nsroot y -    clauseFor m ns (PClauses _ _ m' _) = decorate ns m == decorate ns m'-    clauseFor m ns _ = False+    clauseFor m iname ns (PClauses _ _ m' _) +       = decorate ns iname m == decorate ns iname m'+    clauseFor m iname ns _ = False  decorateid decorate (PTy s f o n t) = PTy s f o (decorate n) t decorateid decorate (PClauses f o n cs) @@ -847,27 +912,40 @@ pvars ist (Bind n (PVar t) sc) = (n, delab ist t) : pvars ist sc pvars ist _ = [] --- TODO: Also build a 'binary' version of each declaration for fast reloading+data ElabWhat = ETypes | EDefns | EAll+  deriving (Show, Eq)  elabDecl :: ElabInfo -> PDecl -> Idris ()-elabDecl info d = idrisCatch (elabDecl' info d) +elabDecl info d = idrisCatch (elabDecl' EAll info d)                               (\e -> do let msg = show e                                        setErrLine (getErrLine msg)                                        iputStrLn msg) -elabDecl' info (PFix _ _ _)      = return () -- nothing to elaborate-elabDecl' info (PSyntax _ p) = return () -- nothing to elaborate-elabDecl' info (PTy s f o n ty)    = do iLOG $ "Elaborating type decl " ++ show n-                                        elabType info s f o n ty-elabDecl' info (PData s f d)     = do iLOG $ "Elaborating " ++ show (d_name d)-                                      elabData info s f d-elabDecl' info d@(PClauses f o n ps) = do iLOG $ "Elaborating clause " ++ show n-                                          i <- get -- get the type options too-                                          let o' = case lookupCtxt Nothing n (idris_flags i) of-                                                    [fs] -> fs-                                                    [] -> []-                                          elabClauses info f (o ++ o') n ps-elabDecl' info (PParams f ns ps) = mapM_ (elabDecl' pinfo) ps+elabDecl' _ info (PFix _ _ _)+     = return () -- nothing to elaborate+elabDecl' _ info (PSyntax _ p) +     = return () -- nothing to elaborate+elabDecl' what info (PTy s f o n ty)    +  | what /= EDefns+    = do iLOG $ "Elaborating type decl " ++ show n ++ show o+         elabType info s f o n ty+elabDecl' what info (PData s f co d)    +  | what /= EDefns+    = do iLOG $ "Elaborating " ++ show (d_name d)+         elabData info s f co d+elabDecl' what info d@(PClauses f o n ps) +  | what /= ETypes+    = do iLOG $ "Elaborating clause " ++ show n+         i <- get -- get the type options too+         let o' = case lookupCtxt Nothing n (idris_flags i) of+                    [fs] -> fs+                    [] -> []+         elabClauses info f (o ++ o') n ps+elabDecl' what info (PParams f ns ps) +    = do i <- get+         iLOG $ "Expanding params block with " ++ show (concatMap declared ps)+         let nblock = pblock i+         mapM_ (elabDecl' what info) nblock    where     pinfo = let ds = concatMap declared ps                 newps = params info ++ ns@@ -875,29 +953,37 @@                 newb = addAlist dsParams (inblock info) in                  info { params = newps,                        inblock = newb }-elabDecl' info (PNamespace n ps) = mapM_ (elabDecl' ninfo) ps+    pblock i = map (expandParamsD i id ns (concatMap declared ps)) ps++elabDecl' what info (PNamespace n ps) = mapM_ (elabDecl' what ninfo) ps   where     ninfo = case namespace info of                 Nothing -> info { namespace = Just [n] }                 Just ns -> info { namespace = Just (n:ns) } -elabDecl' info (PClass s f cs n ps ds) = do iLOG $ "Elaborating class " ++ show n-                                            elabClass info s f cs n ps ds-elabDecl' info (PInstance s f cs n ps t expn ds) +elabDecl' what info (PClass s f cs n ps ds) +  | what /= EDefns+    = do iLOG $ "Elaborating class " ++ show n+         elabClass info s f cs n ps ds+elabDecl' what info (PInstance s f cs n ps t expn ds) +  | what /= EDefns     = do iLOG $ "Elaborating instance " ++ show n          elabInstance info s f cs n ps t expn ds-elabDecl' info (PRecord s f tyn ty cn cty)+elabDecl' what info (PRecord s f tyn ty cn cty)+  | what /= EDefns     = do iLOG $ "Elaborating record " ++ show tyn          elabRecord info s f tyn ty cn cty-elabDecl' info (PDSL n dsl)+elabDecl' _ info (PDSL n dsl)     = do i <- get          put (i { idris_dsls = addDef n dsl (idris_dsls i) })           addIBC (IBCDSL n)-elabDecl' info (PDirective i) = i+elabDecl' what info (PDirective i) +  | what /= EDefns = i+elabDecl' _ _ _ = return () -- skipped this time   elabCaseBlock info d@(PClauses f o n ps)          = do addIBC (IBCDef n) --              iputStrLn $ "CASE BLOCK: " ++ show (n, d)-             elabDecl' info d +             elabDecl' EAll info d   -- elabDecl' info (PImport i) = loadModule i
src/Idris/ElabTerm.hs view
@@ -112,8 +112,8 @@         | otherwise = try (resolveTC 2 fn ist)                           (do c <- unique_hole (MN 0 "c")                               instanceArg c)-    elab' ina (PRefl fc)     = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder,-                                                           pimp (MN 0 "x") Placeholder])+    elab' ina (PRefl fc t)   = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder,+                                                           pimp (MN 0 "x") t])     elab' ina (PEq fc l r)   = elab' ina (PApp fc (PRef fc eqTy) [pimp (MN 0 "a") Placeholder,                                                           pimp (MN 0 "b") Placeholder,                                                           pexp l, pexp r])@@ -153,6 +153,7 @@         = trySeq as         where trySeq [] = fail "All alternatives fail to elaborate"               trySeq (x : xs) = try (elab' ina x) (trySeq xs)+    elab' ina (PPatvar fc n) | pattern = patvar n     elab' (ina, guarded) (PRef fc n) | pattern && not (inparamBlock n)                          = do ctxt <- get_context                               let iscon = isConName Nothing n ctxt@@ -171,14 +172,26 @@                                 _ -> True     elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve     elab' ina@(_, a) (PLam n Placeholder sc)-          = do attack; intro (Just n); elabE (True, a) sc; solve+          = do -- n' <- unique_hole n+               -- let sc' = mapPT (repN n n') sc+               attack; intro (Just n); elabE (True, a) sc; solve+       where repN n n' (PRef fc x) | x == n' = PRef fc n'+             repN _ _ t = t     elab' ina@(_, a) (PLam n ty sc)-          = do tyn <- unique_hole (MN 0 "lamty")+          = do hsin <- get_holes+               ptmin <- get_term+               tyn <- unique_hole (MN 0 "lamty")                claim tyn RSet                attack+               ptm <- get_term+               hs <- get_holes+               -- trace ("BEFORE:\n" ++ show hsin ++ "\n" ++ show ptmin +++               --       "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $                 introTy (Var tyn) (Just n)                -- end_unify                focus tyn+               ptm <- get_term+               hs <- get_holes                elabE (True, a) ty                elabE (True, a) sc                solve@@ -210,19 +223,6 @@                elabE (True, a) val                elabE (True, a) sc                solve---     elab' ina (PTyped val ty)---           = do tyn <- unique_hole (MN 0 "castty")---                claim tyn RSet---                valn <- unique_hole (MN 0 "castval")---                claim valn (Var tyn)---                focus tyn---                elabE True ty---                focus valn---                elabE True val---     elab' ina (PApp fc (PRef _ dsl) [arg])---        | [d] <- lookupCtxt Nothing dsl (idris_dsls ist)---                 = let dsl' = expandDo d (getTm arg) in---                       trace (show dsl') $ elab' ina dsl'     elab' (ina, g) tm@(PApp fc (PRef _ f) args')         = do let args = {- case lookupCtxt f (inblock info) of                           Just ps -> (map (pexp . (PRef fc)) ps ++ args')@@ -241,7 +241,8 @@                          = unzip $                              sortBy (\(_,x) (_,y) -> compare (priority x) (priority y))                                     (zip ns args)-                    try (elabArgs (ina || not isinf, guarded)+                    try +                        (elabArgs (ina || not isinf, guarded)                              [] False ns' (map (\x -> (lazyarg x, getTm x)) eargs))                         (elabArgs (ina || not isinf, guarded)                              [] False (reverse ns') @@ -251,6 +252,8 @@                 (do apply_elab f (map (toElab (ina || not isinf, guarded)) args)                     mkSpecialised ist fc f (map getTm args') tm                     solve)+--             ptm <- get_term+--             elog (show ptm)             ivs' <- get_instances             when (not pattern || (ina && not tcgen)) $                 mapM_ (\n -> do focus n@@ -315,8 +318,8 @@                                      (map pexp args ++ [pexp l])) [] r []      elabArgs ina failed retry [] _-        | retry = let (ns, ts) = unzip (reverse failed) in-                      elabArgs ina [] False ns ts+--         | retry = let (ns, ts) = unzip (reverse failed) in+--                       elabArgs ina [] False ns ts         | otherwise = return ()     elabArgs ina failed r (n:ns) ((_, Placeholder) : args)          = elabArgs ina failed r ns args@@ -386,7 +389,8 @@ pruneByType t _ as = as  trivial :: IState -> ElabD ()-trivial ist = try (do elab ist toplevel False False (MN 0 "tac") (PRefl (FC "prf" 0))+trivial ist = try (do elab ist toplevel False False (MN 0 "tac") +                                    (PRefl (FC "prf" 0) Placeholder)                       return ())                   (do env <- get_env                       tryAll (map fst env)
src/Idris/Error.hs view
@@ -45,6 +45,10 @@ ifail :: String -> Idris () ifail str = throwIO (IErr str) +ierror :: Err -> Idris ()+ierror err = do i <- get+                throwIO (IErr $ pshow i err)+ tclift :: TC a -> Idris a tclift tc = case tc of                OK v -> return v
src/Idris/IBC.hs view
@@ -21,7 +21,7 @@ import Paths_idris  ibcVersion :: Word8-ibcVersion = 19+ibcVersion = 22  data IBCFile = IBCFile { ver :: Word8,                          sourcefile :: FilePath,@@ -42,7 +42,7 @@                          ibc_access :: [(Name, Accessibility)],                          ibc_total :: [(Name, Totality)],                          ibc_flags :: [(Name, [FnOpt])],-                         ibc_cg :: [(Name, [Name])],+                         ibc_cg :: [(Name, CGInfo)],                          ibc_defs :: [(Name, Def)] } {-!  deriving instance Binary IBCFile @@ -258,12 +258,42 @@                          putIState (i { tt_ctxt = setTotal n a (tt_ctxt i) }))                    ds -pCG :: [(Name, [Name])] -> Idris ()+pCG :: [(Name, CGInfo)] -> Idris () pCG ds = mapM_ (\ (n, a) -> addToCG n a) ds  ----- Generated by 'derive' - +instance Binary SizeChange where+        put x+          = case x of+                Smaller -> putWord8 0+                Same -> putWord8 1+                Bigger -> putWord8 2+                Unknown -> putWord8 3+        get+          = do i <- getWord8+               case i of+                   0 -> return Smaller+                   1 -> return Same+                   2 -> return Bigger+                   3 -> return Unknown+                   _ -> error "Corrupted binary data for SizeChange"++instance Binary CGInfo where+        put (CGInfo x1 x2 x3 x4 x5)+          = do put x1+               put x2+               put x3+               put x4+               put x5+        get+          = do x1 <- get+               x2 <- get+               x3 <- get+               x4 <- get+               x5 <- get+               return (CGInfo x1 x2 x3 x4 x5)+ instance Binary FC where         put (FC x1 x2)           = do put x1@@ -285,6 +315,7 @@                 MN x1 x2 -> do putWord8 2                                put x1                                put x2+                NErased -> putWord8 3         get           = do i <- getWord8                case i of@@ -296,6 +327,7 @@                    2 -> do x1 <- get                            x2 <- get                            return (MN x1 x2)+                   3 -> return NErased                    _ -> error "Corrupted binary data for Name"   @@ -454,7 +486,7 @@                            return (TCon x1 x2)                    _ -> error "Corrupted binary data for NameType" - + instance (Binary n) => Binary (TT n) where         put x           = case x of@@ -473,9 +505,13 @@                                 put x2                 Constant x1 -> do putWord8 4                                   put x1-                Set x1 -> do putWord8 5+                Proj x1 x2 -> do putWord8 5+                                 put x1+                                 put x2+                Erased -> putWord8 6+                Set x1 -> do putWord8 7                              put x1-                Erased -> do putWord8 6+                Impossible -> putWord8 8         get           = do i <- getWord8                case i of@@ -495,21 +531,28 @@                    4 -> do x1 <- get                            return (Constant x1)                    5 -> do x1 <- get-                           return (Set x1)+                           x2 <- get+                           return (Proj x1 x2)                    6 -> return Erased+                   7 -> do x1 <- get+                           return (Set x1)+                   8 -> return Impossible                    _ -> error "Corrupted binary data for TT" -  instance Binary SC where         put x           = case x of                 Case x1 x2 -> do putWord8 0                                  put x1                                  put x2-                STerm x1 -> do putWord8 1+                ProjCase x1 x2 -> do putWord8 1+                                     put x1+                                     put x2+                STerm x1 -> do putWord8 2                                put x1-                UnmatchedCase x1 -> do putWord8 2+                UnmatchedCase x1 -> do putWord8 3                                        put x1+                ImpossibleCase -> do putWord8 4         get           = do i <- getWord8                case i of@@ -517,10 +560,14 @@                            x2 <- get                            return (Case x1 x2)                    1 -> do x1 <- get-                           return (STerm x1)+                           x2 <- get+                           return (ProjCase x1 x2)                    2 -> do x1 <- get+                           return (STerm x1)+                   3 -> do x1 <- get                            return (UnmatchedCase x1)-                   _ -> error "Corrupted binary data for SC"+                   4 -> return ImpossibleCase+                   _ -> error "Corrupted binary data for SC"     instance Binary CaseAlt where@@ -565,7 +612,8 @@                                         put x1                                         put x2                                         put x3-                CaseOp x1 x2 x3 x4 x5 x6 x7 -> do putWord8 3+                CaseOp x1 x2 x3 x4 x5 x6 x7 x8 -> +                                               do putWord8 3                                                   put x1                                                   put x2                                                   put x3@@ -573,6 +621,7 @@                                                   put x5                                                   put x6                                                   put x7+                                                  put x8         get           = do i <- getWord8                case i of@@ -593,7 +642,8 @@                            x5 <- get                            x6 <- get                            x7 <- get-                           return (CaseOp x1 x2 x3 x4 x5 x6 x7)+                           x8 <- get+                           return (CaseOp x1 x2 x3 x4 x5 x6 x7 x8)                    _ -> error "Corrupted binary data for Def"  instance Binary Accessibility where@@ -620,6 +670,7 @@                 NotPositive -> putWord8 3                 Mutual x1 -> do putWord8 4                                 put x1+                NotProductive -> putWord8 5         get           = do i <- getWord8                case i of@@ -630,6 +681,7 @@                    3 -> return NotPositive                    4 -> do x1 <- get                            return (Mutual x1)+                   5 -> return NotProductive                    _ -> error "Corrupted binary data for PReason"  instance Binary Totality where@@ -640,6 +692,7 @@                 Partial x1 -> do putWord8 1                                  put x1                 Unchecked -> do putWord8 2+                Productive -> do putWord8 3         get           = do i <- getWord8                case i of@@ -648,6 +701,7 @@                    1 -> do x1 <- get                            return (Partial x1)                    2 -> return Unchecked+                   3 -> return Productive                    _ -> error "Corrupted binary data for Totality"  instance Binary IBCFile where@@ -708,6 +762,8 @@                 AssertTotal -> putWord8 3                 Specialise x -> do putWord8 4                                    put x+                Coinductive -> putWord8 5+                PartialFn -> putWord8 6         get           = do i <- getWord8                case i of@@ -717,6 +773,8 @@                    3 -> return AssertTotal                    4 -> do x <- get                            return (Specialise x)+                   5 -> return Coinductive+                   6 -> return PartialFn                    _ -> error "Corrupted binary data for FnOpt"  instance Binary Fixity where@@ -820,10 +878,11 @@                                            put x2                                            put x3                                            put x4-                PData x1 x2 x3 -> do putWord8 3-                                     put x1-                                     put x2-                                     put x3+                PData x1 x2 x3 x4 -> do putWord8 3+                                        put x1+                                        put x2+                                        put x3+                                        put x4                 PParams x1 x2 x3 -> do putWord8 4                                        put x1                                        put x2@@ -882,7 +941,8 @@                    3 -> do x1 <- get                            x2 <- get                            x3 <- get-                           return (PData x1 x2 x3)+                           x4 <- get+                           return (PData x1 x2 x3 x4)                    4 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -1047,8 +1107,9 @@                                put x1                 PFalse x1 -> do putWord8 9                                 put x1-                PRefl x1 -> do putWord8 10-                               put x1+                PRefl x1 x2 -> do putWord8 10+                                  put x1+                                  put x2                 PResolveTC x1 -> do putWord8 11                                     put x1                 PEq x1 x2 x3 -> do putWord8 12@@ -1087,6 +1148,9 @@                 PTactics x1 -> do putWord8 25                                   put x1                 PImpossible -> putWord8 27+                PPatvar x1 x2 -> do putWord8 28+                                    put x1+                                    put x2         get           = do i <- getWord8                case i of@@ -1125,7 +1189,8 @@                    9 -> do x1 <- get                            return (PFalse x1)                    10 -> do x1 <- get-                            return (PRefl x1)+                            x2 <- get+                            return (PRefl x1 x2)                    11 -> do x1 <- get                             return (PResolveTC x1)                    12 -> do x1 <- get@@ -1164,6 +1229,9 @@                    25 -> do x1 <- get                             return (PTactics x1)                    27 -> return PImpossible+                   28 -> do x1 <- get+                            x2 <- get+                            return (PPatvar x1 x2)                    _ -> error "Corrupted binary data for PTerm"   instance (Binary t) => Binary (PTactic' t) where@@ -1352,9 +1420,11 @@                return (Optimise x1 x2 x3)  instance Binary TypeInfo where-        put (TI x1) = put x1+        put (TI x1 x2) = do put x1+                            put x2         get = do x1 <- get-                 return (TI x1)+                 x2 <- get+                 return (TI x1 x2)  instance Binary SynContext where         put x
src/Idris/Parser.hs view
@@ -84,6 +84,8 @@ loadSource :: Bool -> FilePath -> Idris ()  loadSource lidr f               = do iLOG ("Reading " ++ f)+                  i <- getIState+                  let def_total = default_total i                   file_in <- liftIO $ readFile f                   file <- if lidr then tclift $ unlit f file_in else return file_in                   (mname, modules, rest, pos) <- parseImports f file@@ -104,6 +106,15 @@                   when v $ iputStrLn $ "Type checking " ++ f                   mapM_ (elabDecl toplevel) ds                   i <- get+                  -- simplify every definition do give the totality checker+                  -- a better chance+                  mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n+                                  updateContext (simplifyCasedef n))+                           (map snd (idris_totcheck i))+                  -- build size change graph from simplified definitions+                  iLOG "Totality checking"+                  i <- get+--                   mapM_ buildSCG (idris_totcheck i)                   mapM_ checkDeclTotality (idris_totcheck i)                   iLOG ("Finished " ++ f)                   ibcsd <- valIBCSubDir i@@ -117,7 +128,8 @@                     idrisCatch (do writeIBC f ibc; clearIBC)                                (\c -> return ()) -- failure is harmless                   i <- getIState-                  putIState (i { hide_list = [] })+                  putIState (i { default_total = def_total,+                                 hide_list = [] })                   return ()   where     namespaces []     ds = ds@@ -279,14 +291,18 @@ collect :: [PDecl] -> [PDecl] collect (c@(PClauses _ o _ _) : ds)      = clauses (cname c) [] (c : ds)-  where clauses n acc (PClauses fc _ _ [PClause fc' n' l ws r w] : ds)-           | n == n' = clauses n (PClause fc' n' l ws r (collect w) : acc) ds-        clauses n acc (PClauses fc _ _ [PWith fc' n' l ws r w] : ds)-           | n == n' = clauses n (PWith fc' n' l ws r (collect w) : acc) ds-        clauses n acc xs = PClauses (getfc c) o n (reverse acc) : collect xs+  where clauses j@(Just n) acc (PClauses fc _ _ [PClause fc' n' l ws r w] : ds)+           | n == n' = clauses j (PClause fc' n' l ws r (collect w) : acc) ds+        clauses j@(Just n) acc (PClauses fc _ _ [PWith fc' n' l ws r w] : ds)+           | n == n' = clauses j (PWith fc' n' l ws r (collect w) : acc) ds+        clauses (Just n) acc xs = PClauses (getfc c) o n (reverse acc) : collect xs+        clauses Nothing acc (x:xs) = collect xs+        clauses Nothing acc [] = [] -        cname (PClauses fc _ _ [PClause _ n _ _ _ _]) = n-        cname (PClauses fc _ _ [PWith   _ n _ _ _ _]) = n+        cname (PClauses fc _ _ [PClause _ n _ _ _ _]) = Just n+        cname (PClauses fc _ _ [PWith   _ n _ _ _ _]) = Just n+        cname (PClauses fc _ _ [PClauseR _ _ _ _]) = Nothing+        cname (PClauses fc _ _ [PWithR _ _ _ _]) = Nothing         getfc (PClauses fc _ _ _) = fc  collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds@@ -401,9 +417,13 @@  pFunDecl' :: SyntaxInfo -> IParser PDecl pFunDecl' syn = try (do pushIndent-                        opts <- pFnOpts+                        ist <- getState+                        let initOpts = if default_total ist+                                          then [TotalFn]+                                          else []+                        opts <- pFnOpts initOpts                         acc <- pAccessibility-                        opts' <- pFnOpts+                        opts' <- pFnOpts opts                         n_in <- pfName                         let n = expandNS syn n_in                         ty <- pTSig (impOK syn)@@ -411,7 +431,7 @@                         pTerminator  --                         ty' <- implicit syn n ty                         addAcc n acc-                        return (PTy syn fc (opts ++ opts') n ty))+                        return (PTy syn fc opts' n ty))             <|> try (pPattern syn)             <|> try (pCAF syn) @@ -426,11 +446,11 @@  pParams :: SyntaxInfo -> IParser [PDecl] pParams syn = -    do reserved "params"; lchar '('; ns <- tyDeclList syn; lchar ')'-       lchar '{'+    do reserved "parameters"; lchar '('; ns <- tyDeclList syn; lchar ')'+       openBlock         let pvars = syn_params syn        ds <- many1 (pDecl syn { syn_params = pvars ++ ns })-       lchar '}'+       closeBlock         fc <- pfc        return [PParams fc ns (concat ds)] @@ -608,6 +628,11 @@ pfName = try pOpFront          <|> pName +pTotality :: IParser Bool+pTotality+        = do reserved "total";   return True+      <|> do reserved "partial"; return False+ pAccessibility' :: IParser Accessibility pAccessibility'         = do reserved "public";   return Public@@ -619,16 +644,17 @@         = do acc <- pAccessibility'; return (Just acc)       <|> return Nothing -pFnOpts :: IParser [FnOpt]-pFnOpts = do reserved "total"; xs <- pFnOpts; return (TotalFn : xs)-      <|> try (do lchar '%'; reserved "export"; c <- strlit; xs <- pFnOpts-                  return (CExport c : xs))-      <|> do lchar '%'; reserved "assert_total"; xs <- pFnOpts; return (AssertTotal : xs)+pFnOpts :: [FnOpt] -> IParser [FnOpt]+pFnOpts opts+        = do reserved "total"; pFnOpts (TotalFn : opts)+      <|> do reserved "partial"; pFnOpts (PartialFn : (opts \\ [TotalFn]))+      <|> try (do lchar '%'; reserved "export"; c <- strlit; +                  pFnOpts (CExport c : opts))+      <|> do lchar '%'; reserved "assert_total"; pFnOpts (AssertTotal : opts)       <|> do lchar '%'; reserved "specialise";               lchar '['; ns <- sepBy pfName (lchar ','); lchar ']'-             xs <- pFnOpts-             return (Specialise ns : xs)-      <|> return []+             pFnOpts (Specialise ns : opts)+      <|> return opts  addAcc :: Name -> Maybe Accessibility -> IParser () addAcc n a = do i <- getState@@ -661,7 +687,10 @@ pSimpleExpr syn =          try (do symbol "!["; t <- pTerm; lchar ']'; return $ PQuote t)         <|> do lchar '?'; x <- pName; return (PMetavar x)-        <|> do reserved "refl"; fc <- pfc; return (PRefl fc)+        <|> do reserved "refl"; fc <- pfc; +               tm <- option Placeholder (do lchar '{'; t <- pExpr syn; lchar '}';+                                            return t)+               return (PRefl fc tm) --         <|> do reserved "return"; fc <- pfc; return (PReturn fc)         <|> pProofExpr syn          <|> pTacticsExpr syn@@ -694,13 +723,13 @@ --                     e <- pExpr syn; symbol ":"; t <- pExpr syn; lchar ')' --                     return (PTyped e t))         <|> try (do fc <- pfc; o <- operator; e <- pExpr syn; lchar ')'-                    return $ PLam (MN 0 "x") Placeholder-                                  (PApp fc (PRef fc (UN o)) [pexp (PRef fc (MN 0 "x")), +                    return $ PLam (MN 1000 "ARG") Placeholder+                                  (PApp fc (PRef fc (UN o)) [pexp (PRef fc (MN 1000 "ARG")),                                                               pexp e]))         <|> try (do fc <- pfc; e <- pSimpleExpr syn; o <- operator; lchar ')'-                    return $ PLam (MN 0 "x") Placeholder+                    return $ PLam (MN 1000 "ARG") Placeholder                                   (PApp fc (PRef fc (UN o)) [pexp e,-                                                             pexp (PRef fc (MN 0 "x"))]))+                                                             pexp (PRef fc (MN 1000 "ARG"))]))  pCaseOpt :: SyntaxInfo -> IParser (PTerm, PTerm) pCaseOpt syn = do lhs <- pExpr syn; symbol "=>"; rhs <- pExpr syn@@ -1072,9 +1101,12 @@     toFreeze (Just Frozen) = Just Hidden     toFreeze x = x +pDataI = do reserved "data"; return False+     <|> do reserved "codata"; return True+ pData :: SyntaxInfo -> IParser PDecl pData syn = try (do acc <- pAccessibility-                    reserved "data"+                    co <- pDataI                     fc <- pfc                     tyn_in <- pfName                     ty <- pTSig (impOK syn)@@ -1089,10 +1121,10 @@                     popIndent                     closeBlock                      accData acc tyn (map (\ (n, _, _) -> n) cons)-                    return $ PData syn fc (PDatadecl tyn ty cons))+                    return $ PData syn fc co (PDatadecl tyn ty cons))         <|> try (do pushIndent                     acc <- pAccessibility-                    reserved "data"+                    co <- pDataI                     fc <- pfc                     tyn_in <- pfName                     args <- many pName@@ -1106,7 +1138,7 @@                                  do let cty = bindArgs cargs conty                                     return (x, cty, cfc)) cons                     accData acc tyn (map (\ (n, _, _) -> n) cons')-                    return $ PData syn fc (PDatadecl tyn ty cons'))+                    return $ PData syn fc co (PDatadecl tyn ty cons'))   where     mkPApp fc t [] = t     mkPApp fc t xs = PApp fc t (map pexp xs)@@ -1330,7 +1362,7 @@ pWhereblock :: Name -> SyntaxInfo -> IParser ([PDecl], [(Name, Name)]) pWhereblock n syn      = do reserved "where"; openBlock-         ds <- many1 $ pFunDecl syn+         ds <- many1 $ pDecl syn          let dns = concatMap (concatMap declared) ds          closeBlock          return (concat ds, map (\x -> (x, decoration syn x)) dns)@@ -1356,6 +1388,11 @@          <|> try (do lchar '%'; reserved "access"; acc <- pAccessibility'                      return [PDirective (do i <- getIState                                             putIState (i { default_access = acc }))])+         <|> try (do lchar '%'; reserved "default"; tot <- pTotality+                     i <- getState+                     setState (i { default_total = tot } )+                     return [PDirective (do i <- getIState+                                            putIState (i { default_total = tot }))])          <|> try (do lchar '%'; reserved "logging"; i <- natural;                      return [PDirective (setLogLevel (fromInteger i))])
src/Idris/Primitives.hs view
@@ -169,7 +169,7 @@    Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)     (0, LStdIn) partial,    Prim (UN "prim__believe_me") believeTy 3 (p_believeMe)-    (1, LNoOp) total -- ahem+    (3, LNoOp) total -- ahem   ]  p_believeMe [_,_,x] = Just x@@ -281,7 +281,7 @@  elabPrims :: Idris () elabPrims = do mapM_ (elabDecl toplevel) -                     (map (PData defaultSyntax (FC "builtin" 0))+                     (map (PData defaultSyntax (FC "builtin" 0) False)                          [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl])                mapM_ elabPrim primitives
src/Idris/Prover.hs view
@@ -46,12 +46,14 @@          i <- get          let proofs = proof_list i          put (i { proof_list = (n, prf) : proofs })-         let tree = simpleCase False True (FC "proof" 0) [([], P Ref n ty, tm)]+         let tree = simpleCase False True CompileTime (FC "proof" 0) [([], P Ref n ty, tm)]          logLvl 3 (show tree)          (ptm, pty) <- recheckC (FC "proof" 0) [] tm          ptm' <- applyOpts ptm-         updateContext (addCasedef n True False True [([], P Ref n ty, ptm)] -                                                [([], P Ref n ty, ptm')] ty)+         updateContext (addCasedef n True False True +                                 [Right (P Ref n ty, ptm)]+                                 [([], P Ref n ty, ptm)] +                                 [([], P Ref n ty, ptm')] ty)          solveDeferred n elabStep :: ElabState [PDecl] -> ElabD a -> Idris (a, ElabState [PDecl]) elabStep st e = do case runStateT e st of@@ -60,9 +62,9 @@                                    fail (pshow i a)  dumpState :: IState -> ProofState -> IO ()-dumpState ist (PS nm [] _ tm _ _ _ _ _ _ _ _ _ _ _) =+dumpState ist (PS nm [] _ tm _ _ _ _ _ _ _ _ _ _ _ _) =   putStrLn . render $ pretty nm <> colon <+> text "No more goals."-dumpState ist ps@(PS nm (h:hs) _ tm _ _ _ _ problems i _ _ ctxy _ _) = do+dumpState ist ps@(PS nm (h:hs) _ tm _ _ _ _ _ problems i _ _ ctxy _ _) = do   let OK ty  = goalAtFocus ps   let OK env = envAtFocus ps   putStrLn . render $
src/Idris/REPL.hs view
@@ -14,6 +14,8 @@ import Idris.Parser import Idris.Primitives import Idris.Coverage+import Idris.UnusedArgs+ import Paths_idris import Util.System @@ -38,7 +40,8 @@ import System.Directory import System.IO import Control.Monad-import Control.Monad.State+import Control.Monad.Trans.State.Strict ( StateT, execStateT, get, put )+import Control.Monad.Trans ( liftIO, lift ) import Data.Maybe import Data.List import Data.Char@@ -78,21 +81,31 @@                         (f:_) -> f                         _ -> ""          case parseCmd i cmd of-                Left err ->   do liftIO $ print err-                                 return (Just inputs)-                Right Reload -> do put (orig { idris_options = idris_options i })-                                   clearErr-                                   mods <- mapM loadModule inputs  -                                   return (Just inputs)-                Right Edit -> do edit fn orig-                                 return (Just inputs)-                Right Proofs -> do proofs orig-                                   return (Just inputs)-                Right Quit -> do iputStrLn "Bye bye"-                                 return Nothing-                Right cmd  -> do idrisCatch (process fn cmd)-                                            (\e -> iputStrLn (show e))-                                 return (Just inputs)+            Left err ->   do liftIO $ print err+                             return (Just inputs)+            Right Reload -> +                do put (orig { idris_options = idris_options i })+                   clearErr+                   mods <- mapM loadModule inputs  +                   return (Just inputs)+            Right (Load f) -> +                do put (orig { idris_options = idris_options i })+                   clearErr+                   mod <- loadModule f+                   return (Just [f])+            Right (ModImport f) -> +                do clearErr+                   fmod <- loadModule f+                   return (Just (inputs ++ [fmod]))+            Right Edit -> do edit fn orig+                             return (Just inputs)+            Right Proofs -> do proofs orig+                               return (Just inputs)+            Right Quit -> do iputStrLn "Bye bye"+                             return Nothing+            Right cmd  -> do idrisCatch (process fn cmd)+                                        (\e -> iputStrLn (show e))+                             return (Just inputs)  resolveProof :: Name -> Idris Name resolveProof n'@@ -160,7 +173,7 @@                                  showImp imp (delab ist ty')) process fn (ExecVal t)                      = do (tm, ty) <- elabVal toplevel False t ---                                         (PApp fc (PRef fc (NS (UN "print") ["prelude"]))+--                                         (PApp fc (PRef fc (NS (UN "print") ["Prelude"])) --                                                           [pexp t])                          (tmpn, tmph) <- liftIO tempfile                          liftIO $ hClose tmph@@ -202,22 +215,31 @@                          case lookupTotal n (tt_ctxt i) of                             [t] -> iputStrLn (showTotal t i)                             _ -> return ()-    where printCase i (_, lhs, rhs) = do liftIO $ putStr $ showImp True (delab i lhs)-                                         liftIO $ putStr " = "-                                         liftIO $ putStrLn $ showImp True (delab i rhs)+    where printCase i (_, lhs, rhs) +             = do liftIO $ putStr $ showImp True (delab i lhs)+                  liftIO $ putStr " = "+                  liftIO $ putStrLn $ showImp True (delab i rhs) process fn (TotCheck n) = do i <- get                              case lookupTotal n (tt_ctxt i) of                                 [t] -> iputStrLn (showTotal t i)                                 _ -> return () process fn (DebugInfo n) -                    = do i <- get-                         let oi = lookupCtxtName Nothing n (idris_optimisation i)-                         when (not (null oi)) $ iputStrLn (show oi)-                         let si = lookupCtxt Nothing n (idris_statics i)-                         when (not (null si)) $ iputStrLn (show si)-                         let d = lookupDef Nothing n (tt_ctxt i)-                         when (not (null d)) $ liftIO $-                            do print (head d)+   = do i <- get+        let oi = lookupCtxtName Nothing n (idris_optimisation i)+        when (not (null oi)) $ iputStrLn (show oi)+        let si = lookupCtxt Nothing n (idris_statics i)+        when (not (null si)) $ iputStrLn (show si)+        let d = lookupDef Nothing n (tt_ctxt i)+        when (not (null d)) $ liftIO $+           do print (head d)+        let cg = lookupCtxtName Nothing n (idris_callgraph i)+        findUnusedArgs (map fst cg)+        i <- get+        let cg' = lookupCtxtName Nothing n (idris_callgraph i)+        sc <- checkSizeChange n+        iputStrLn $ "Size change: " ++ show sc+        when (not (null cg')) $ do iputStrLn "Call graph:\n"+                                   iputStrLn (show cg') process fn (Info n) = do i <- get                          case lookupCtxt Nothing n (idris_classes i) of                               [c] -> classInfo c@@ -245,13 +267,18 @@                                  let ms = idris_metavars i                                  put $ i { idris_metavars = n : ms } -process fn (AddProof n')+process fn (AddProof prf)   = do let fb = fn ++ "~"        liftIO $ copyFile fn fb -- make a backup in case something goes wrong!        prog <- liftIO $ readFile fb        i <- get-       n <- resolveProof n'        let proofs = proof_list i+       n' <- case prf of+                Nothing -> case proofs of+                             [] -> fail "No proof to add"+                             ((x, p) : _) -> return x+                Just nm -> return nm+       n <- resolveProof n'        case lookup n proofs of             Nothing -> iputStrLn "No proof to add"             Just p  -> do let prog' = insertScript (showProof (lit fn) n p) ls@@ -294,7 +321,7 @@ process fn Execute = do (m, _) <- elabVal toplevel False                                          (PApp fc                                             (PRef fc (UN "run__IO"))-                                           [pexp $ PRef fc (NS (UN "main") ["main"])])+                                           [pexp $ PRef fc (NS (UN "main") ["Main"])]) --                                      (PRef (FC "main" 0) (NS (UN "main") ["main"]))                         (tmpn, tmph) <- liftIO tempfile                         liftIO $ hClose tmph@@ -305,16 +332,28 @@ process fn (NewCompile f)       = do (m, _) <- elabVal toplevel False                       (PApp fc (PRef fc (UN "run__IO"))-                          [pexp $ PRef fc (NS (UN "main") ["main"])])+                          [pexp $ PRef fc (NS (UN "main") ["Main"])])           compileEpic f m   where fc = FC "main" 0                      process fn (Compile target f)        = do (m, _) <- elabVal toplevel False                        (PApp fc (PRef fc (UN "run__IO"))-                       [pexp $ PRef fc (NS (UN "main") ["main"])])+                       [pexp $ PRef fc (NS (UN "main") ["Main"])])            compile target f m   where fc = FC "main" 0                      process fn (LogLvl i) = setLogLevel i +-- Elaborate as if LHS of a pattern (debug command)+process fn (Pattelab t) +     = do (tm, ty) <- elabVal toplevel True t+          iputStrLn $ show tm ++ "\n\n : " ++ show ty++process fn (Missing n) = do i <- get+                            case lookupDef Nothing n (tt_ctxt i) of+                                [CaseOp _ _ _ _ args t _ _]+                                    -> do tms <- genMissing n args t+                                          iputStrLn (showSep "\n" (map (showImp True) tms))+                                [] -> iputStrLn $ show n ++ " undefined"+                                _ -> iputStrLn $ "Ambiguous name" process fn Metavars                   = do ist <- get                       let mvs = idris_metavars ist \\ primDefs@@ -374,6 +413,9 @@ parseArgs ("-no":n:ns)          = NoREPL : NewOutput n : (parseArgs ns) parseArgs ("--typecase":ns)     = TypeCase : (parseArgs ns) parseArgs ("--typeintype":ns)   = TypeInType : (parseArgs ns)+parseArgs ("--total":ns)        = DefaultTotal : (parseArgs ns)+parseArgs ("--partial":ns)      = DefaultPartial : (parseArgs ns)+parseArgs ("--warnpartial":ns)  = WarnPartial : (parseArgs ns) parseArgs ("--nocoverage":ns)   = NoCoverage : (parseArgs ns) parseArgs ("--errorcontext":ns) = ErrContext : (parseArgs ns) parseArgs ("--help":ns)         = Usage : (parseArgs ns)@@ -393,6 +435,8 @@ parseArgs ("--bytecode":n:ns)   = NoREPL : BCAsm n : (parseArgs ns) parseArgs ("--fovm":n:ns)       = NoREPL : FOVM n : (parseArgs ns) parseArgs ("--dumpc":n:ns)      = DumpC n : (parseArgs ns)+parseArgs ("--dumpdefuns":n:ns) = DumpDefun n : (parseArgs ns)+parseArgs ("--dumpcases":n:ns)  = DumpCases n : (parseArgs ns) parseArgs (n:ns)                = Filename n : (parseArgs ns)  help =@@ -400,9 +444,12 @@     ([""], "", ""),     (["<expr>"], "", "Evaluate an expression"),     ([":t"], "<expr>", "Check the type of an expression"),+    ([":miss", ":missing"], "<name>", "Show missing clauses"),     ([":i", ":info"], "<name>", "Display information about a type class"),     ([":total"], "<name>", "Check the totality of a name"),     ([":r",":reload"], "", "Reload current file"),+    ([":l",":load"], "<filename>", "Load a new file"),+    ([":m",":module"], "<module>", "Import an extra module"),     ([":e",":edit"], "", "Edit current file using $EDITOR or $VISUAL"),     ([":m",":metavars"], "", "Show remaining proof obligations (metavariables)"),     ([":p",":prove"], "<name>", "Prove a metavariable"),@@ -433,6 +480,8 @@        let bcs = opt getBC opts        let vm = opt getFOVM opts        let pkgdirs = opt getPkgDir opts+       when (DefaultTotal `elem` opts) $ do i <- get+                                            put (i { default_total = True })        setREPL runrepl        setVerbose runrepl        setCmdLine opts@@ -453,7 +502,7 @@        addPkgDir "base"        mapM_ addPkgDir pkgdirs        elabPrims-       when (not (NoPrelude `elem` opts)) $ do x <- loadModule "prelude"+       when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude"                                                return ()        when runrepl $ iputStrLn banner         ist <- get
src/Idris/REPLParser.hs view
@@ -23,6 +23,8 @@ pCmd = try (do cmd ["q", "quit"]; eof; return Quit)    <|> try (do cmd ["h", "?", "help"]; eof; return Help)    <|> try (do cmd ["r", "reload"]; eof; return Reload)+   <|> try (do cmd ["m", "module"]; f <- identifier; eof;+               return (ModImport (map dot f)))    <|> try (do cmd ["e", "edit"]; eof; return Edit)    <|> try (do cmd ["exec", "execute"]; eof; return Execute)    <|> try (do cmd ["ttshell"]; eof; return TTShell)@@ -32,24 +34,32 @@    <|> try (do cmd ["m", "metavars"]; eof; return Metavars)    <|> try (do cmd ["proofs"]; eof; return Proofs)    <|> try (do cmd ["p", "prove"]; n <- pName; eof; return (Prove n))-   <|> try (do cmd ["a", "addproof"]; n <- pName; eof; return (AddProof n))+   <|> try (do cmd ["a", "addproof"]; do n <- option Nothing (do x <- pName;+                                                                 return (Just x))+                                         eof; return (AddProof n))    <|> try (do cmd ["rmproof"]; n <- pName; eof; return (RmProof n))    <|> try (do cmd ["showproof"]; n <- pName; eof; return (ShowProof n))    <|> try (do cmd ["log"]; i <- natural; eof; return (LogLvl (fromIntegral i)))+   <|> try (do cmd ["l", "load"]; f <- getInput; return (Load f))    <|> try (do cmd ["spec"]; t <- pFullExpr defaultSyntax; return (Spec t))    <|> try (do cmd ["hnf"]; t <- pFullExpr defaultSyntax; return (HNF t))-   <|> try (do cmd ["d", "def"]; n <- pName; eof; return (Defn n))-   <|> try (do cmd ["total"]; do n <- pName; eof; return (TotCheck n))+   <|> try (do cmd ["d", "def"]; n <- pfName; eof; return (Defn n))+   <|> try (do cmd ["total"]; do n <- pfName; eof; return (TotCheck n))    <|> try (do cmd ["t", "type"]; do t <- pFullExpr defaultSyntax; return (Check t))    <|> try (do cmd ["u", "universes"]; eof; return Universes)    <|> try (do cmd ["di", "dbginfo"]; n <- pfName; eof; return (DebugInfo n))    <|> try (do cmd ["i", "info"]; n <- pfName; eof; return (Info n))+   <|> try (do cmd ["miss", "missing"]; n <- pfName; eof; return (Missing n))    <|> try (do cmd ["set"]; o <-pOption; return (SetOpt o))    <|> try (do cmd ["unset"]; o <-pOption; return (UnsetOpt o))    <|> try (do cmd ["s", "search"]; t <- pFullExpr defaultSyntax; return (Search t))    <|> try (do cmd ["x"]; t <- pFullExpr defaultSyntax; return (ExecVal t))+   <|> try (do cmd ["patt"]; t <- pFullExpr defaultSyntax; return (Pattelab t))    <|> do t <- pFullExpr defaultSyntax; return (Eval t)    <|> do eof; return NOP++ where dot '.' = '/'+       dot c = c  pOption :: IParser Opt pOption = do discard (symbol "errorcontext"); return ErrContext
src/Idris/Transforms.hs view
@@ -39,8 +39,8 @@  natTrans = [TermTrans zero, TermTrans suc, CaseTrans natcase] -zname = NS (UN "O") ["nat","prelude"] -sname = NS (UN "S") ["nat","prelude"] +zname = NS (UN "O") ["Nat","Prelude"] +sname = NS (UN "S") ["Nat","Prelude"]   zero :: TT Name -> TT Name zero (P _ n _) | n == zname
+ src/Idris/UnusedArgs.hs view
@@ -0,0 +1,64 @@+module Idris.UnusedArgs where++import Idris.AbsSyntax++import Core.CaseTree+import Core.TT++import Control.Monad.State+import Data.Maybe+import Data.List++findUnusedArgs :: [Name] -> Idris ()+findUnusedArgs ns = mapM_ traceUnused ns++traceUnused :: Name -> Idris ()+traceUnused n +   = do i <- get+        case lookupCtxt Nothing n (idris_callgraph i) of +          [CGInfo args calls scg usedns _] ->+                do let argpos = zip args [0..]+                   let fargs = concatMap (getFargpos calls) argpos+                   logLvl 3 $ show n ++ " used TRACE: " ++ show fargs+                   recused <- mapM (\ (argn, i, (g, j)) -> +                                        do u <- used [(n, i)] g j+                                           return (argn, u)) fargs+                   let fused = nub $ usedns ++ map fst (filter snd recused)+                   logLvl 1 $ show n ++ " used args: " ++ show fused +                   let unusedpos = mapMaybe (getUnused fused) (zip [0..] args)+                   logLvl 1 $ show n ++ " unused args: " ++ show (args, unusedpos)+                   addToCG n (CGInfo args calls scg usedns unusedpos) -- updates+          _ -> return ()+  where+    getUnused fused (i,n) | n `elem` fused = Nothing+                          | otherwise = Just i++used :: [(Name, Int)] -> Name -> Int -> Idris Bool+used path g j +   | (g, j) `elem` path = return False -- cycle, never used on the way+   | otherwise +       = do logLvl 5 $ (show ((g, j) : path)) +            i <- get+            case lookupCtxt Nothing g (idris_callgraph i) of+               [CGInfo args calls scg usedns unused] ->+                  if (j >= length args) +                    then -- overapplied, assume used+                         return True+                    else do let directuse = args!!j `elem` usedns+                            let garg = getFargpos calls (args!!j, j)+                            logLvl 5 $ show (g, j, garg)+                            recused <- mapM (\ (argn, j, (g', j')) ->+                                           used ((g,j):path) g' j') garg+                            -- used on any route from here, or not used recursively+                            return (directuse || null recused || or recused) +               _ -> return True -- no definition, assume used++getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))]+getFargpos calls (n, i) = concatMap (getCallArgpos n i) calls+   where getCallArgpos :: Name -> Int -> (Name, [[Name]]) ->+                          [(Name, Int, (Name, Int))]+         getCallArgpos n i (g, args)+               = let argpos = zip [0..] args in+                     mapMaybe (\ (j, xs) -> if n `elem` xs then Just (n, i, (g, j))+                                                           else Nothing) argpos+
src/Main.hs view
@@ -7,7 +7,9 @@  import Data.Maybe import Data.Version-import Control.Monad.State+import Control.Monad.Trans.State.Strict ( execStateT, get, put )+import Control.Monad.Trans ( liftIO )+import Control.Monad ( when )  import Core.CoreParser import Core.ShellParser@@ -78,6 +80,8 @@            "\t-i [dir]          Add directory to the list of import paths\n" ++            "\t--ibcsubdir [dir] Write IBC files into sub directory\n" ++            "\t--noprelude       Don't import the prelude\n" +++           "\t--total           Require functions to be total by default\n" +++           "\t--warnpartial     Warn about undeclared partial functions\n" ++            "\t--typeintype      Disable universe checking\n" ++            "\t--log [level]     Set debugging log level\n" ++            "\t--dumpc [file]    Dump generated C code\n" ++
tutorial/examples/binary.idr view
@@ -1,4 +1,4 @@-module main+module Main  data Binary : Nat -> Set where     bEnd : Binary O@@ -6,9 +6,11 @@     bI : Binary n -> Binary (S (n + n))  instance Show (Binary n) where-    show (bO x) = show x ++ "0"-    show (bI x) = show x ++ "1"-    show bEnd = ""+    show = show' where+      show' : Binary n' -> String+      show' (bO x) = show x ++ "0"+      show' (bI x) = show x ++ "1"+      show' bEnd = ""  data Parity : Nat -> Set where    even : Parity (n + n)@@ -38,25 +40,25 @@  ---------- Proofs ---------- -natToBin_lemma_1 = proof {-    intro;-    intro;+parity_lemma_1 = proof {+    intros;     rewrite sym (plusSuccRightSucc j j);     trivial; } -parity_lemma_2 = proof {+natToBin_lemma_1 = proof {     intro;     intro;     rewrite sym (plusSuccRightSucc j j);     trivial; } -parity_lemma_1 = proof {-    intro j;+parity_lemma_2 = proof {     intro;+    intro;     rewrite sym (plusSuccRightSucc j j);     trivial; }+
tutorial/examples/bmain.idr view
@@ -1,4 +1,4 @@-module main+module Main  import btree
tutorial/examples/hello.idr view
@@ -1,4 +1,4 @@-module main+module Main  main : IO () main = putStrLn "Hello world"
tutorial/examples/interp.idr view
@@ -1,4 +1,4 @@-module main+module Main  data Ty = TyInt | TyBool| TyFun Ty Ty