diff --git a/idris.cabal b/idris.cabal --- a/idris.cabal +++ b/idris.cabal @@ -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 diff --git a/lib/Builtins.idr b/lib/Builtins.idr new file mode 100644 --- /dev/null +++ b/lib/Builtins.idr @@ -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 + +} + diff --git a/lib/Control/Monad/Identity.idr b/lib/Control/Monad/Identity.idr new file mode 100644 --- /dev/null +++ b/lib/Control/Monad/Identity.idr @@ -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 diff --git a/lib/Control/Monad/State.idr b/lib/Control/Monad/State.idr new file mode 100644 --- /dev/null +++ b/lib/Control/Monad/State.idr @@ -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 + diff --git a/lib/IO.idr b/lib/IO.idr new file mode 100644 --- /dev/null +++ b/lib/IO.idr @@ -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 + + diff --git a/lib/Language/Reflection.idr b/lib/Language/Reflection.idr new file mode 100644 --- /dev/null +++ b/lib/Language/Reflection.idr @@ -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 + diff --git a/lib/Makefile b/lib/Makefile --- a/lib/Makefile +++ b/lib/Makefile @@ -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: diff --git a/lib/Network/Cgi.idr b/lib/Network/Cgi.idr new file mode 100644 --- /dev/null +++ b/lib/Network/Cgi.idr @@ -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 + + diff --git a/lib/Prelude.idr b/lib/Prelude.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude.idr @@ -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 + diff --git a/lib/Prelude/Algebra.idr b/lib/Prelude/Algebra.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Algebra.idr @@ -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? diff --git a/lib/Prelude/Applicative.idr b/lib/Prelude/Applicative.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Applicative.idr @@ -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 + + diff --git a/lib/Prelude/Cast.idr b/lib/Prelude/Cast.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Cast.idr @@ -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 + + diff --git a/lib/Prelude/Chars.idr b/lib/Prelude/Chars.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Chars.idr @@ -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 + diff --git a/lib/Prelude/Complex.idr b/lib/Prelude/Complex.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Complex.idr @@ -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) diff --git a/lib/Prelude/Either.idr b/lib/Prelude/Either.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Either.idr @@ -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 diff --git a/lib/Prelude/Fin.idr b/lib/Prelude/Fin.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Fin.idr @@ -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) + diff --git a/lib/Prelude/Heap.idr b/lib/Prelude/Heap.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Heap.idr @@ -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 () +-} diff --git a/lib/Prelude/List.idr b/lib/Prelude/List.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/List.idr @@ -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; +} + diff --git a/lib/Prelude/Maybe.idr b/lib/Prelude/Maybe.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Maybe.idr @@ -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 diff --git a/lib/Prelude/Monad.idr b/lib/Prelude/Monad.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Monad.idr @@ -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) + + diff --git a/lib/Prelude/Morphisms.idr b/lib/Prelude/Morphisms.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Morphisms.idr @@ -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 diff --git a/lib/Prelude/Nat.idr b/lib/Prelude/Nat.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Nat.idr @@ -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; +} diff --git a/lib/Prelude/Strings.idr b/lib/Prelude/Strings.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Strings.idr @@ -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 + diff --git a/lib/Prelude/Vect.idr b/lib/Prelude/Vect.idr new file mode 100644 --- /dev/null +++ b/lib/Prelude/Vect.idr @@ -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; +} + diff --git a/lib/System.idr b/lib/System.idr new file mode 100644 --- /dev/null +++ b/lib/System.idr @@ -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 + diff --git a/lib/base.ipkg b/lib/base.ipkg --- a/lib/base.ipkg +++ b/lib/base.ipkg @@ -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 diff --git a/lib/builtins.idr b/lib/builtins.idr deleted file mode 100644 --- a/lib/builtins.idr +++ /dev/null @@ -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 - -} - diff --git a/lib/checkall.idr b/lib/checkall.idr deleted file mode 100644 --- a/lib/checkall.idr +++ /dev/null @@ -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 diff --git a/lib/control/monad/identity.idr b/lib/control/monad/identity.idr deleted file mode 100644 --- a/lib/control/monad/identity.idr +++ /dev/null @@ -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 diff --git a/lib/control/monad/state.idr b/lib/control/monad/state.idr deleted file mode 100644 --- a/lib/control/monad/state.idr +++ /dev/null @@ -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 - diff --git a/lib/io.idr b/lib/io.idr deleted file mode 100644 --- a/lib/io.idr +++ /dev/null @@ -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 - - diff --git a/lib/language/reflection.idr b/lib/language/reflection.idr deleted file mode 100644 --- a/lib/language/reflection.idr +++ /dev/null @@ -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 - diff --git a/lib/network/cgi.idr b/lib/network/cgi.idr deleted file mode 100644 --- a/lib/network/cgi.idr +++ /dev/null @@ -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 - - diff --git a/lib/prelude.idr b/lib/prelude.idr deleted file mode 100644 --- a/lib/prelude.idr +++ /dev/null @@ -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 - diff --git a/lib/prelude/algebra.idr b/lib/prelude/algebra.idr deleted file mode 100644 --- a/lib/prelude/algebra.idr +++ /dev/null @@ -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? diff --git a/lib/prelude/applicative.idr b/lib/prelude/applicative.idr deleted file mode 100644 --- a/lib/prelude/applicative.idr +++ /dev/null @@ -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 - - diff --git a/lib/prelude/cast.idr b/lib/prelude/cast.idr deleted file mode 100644 --- a/lib/prelude/cast.idr +++ /dev/null @@ -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 - - diff --git a/lib/prelude/char.idr b/lib/prelude/char.idr deleted file mode 100644 --- a/lib/prelude/char.idr +++ /dev/null @@ -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 - diff --git a/lib/prelude/complex.idr b/lib/prelude/complex.idr deleted file mode 100644 --- a/lib/prelude/complex.idr +++ /dev/null @@ -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) diff --git a/lib/prelude/either.idr b/lib/prelude/either.idr deleted file mode 100644 --- a/lib/prelude/either.idr +++ /dev/null @@ -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 diff --git a/lib/prelude/fin.idr b/lib/prelude/fin.idr deleted file mode 100644 --- a/lib/prelude/fin.idr +++ /dev/null @@ -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) - diff --git a/lib/prelude/heap.idr b/lib/prelude/heap.idr deleted file mode 100644 --- a/lib/prelude/heap.idr +++ /dev/null @@ -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 () --} diff --git a/lib/prelude/list.idr b/lib/prelude/list.idr deleted file mode 100644 --- a/lib/prelude/list.idr +++ /dev/null @@ -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; -} - diff --git a/lib/prelude/maybe.idr b/lib/prelude/maybe.idr deleted file mode 100644 --- a/lib/prelude/maybe.idr +++ /dev/null @@ -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 diff --git a/lib/prelude/monad.idr b/lib/prelude/monad.idr deleted file mode 100644 --- a/lib/prelude/monad.idr +++ /dev/null @@ -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) - - diff --git a/lib/prelude/nat.idr b/lib/prelude/nat.idr deleted file mode 100644 --- a/lib/prelude/nat.idr +++ /dev/null @@ -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; -} diff --git a/lib/prelude/strings.idr b/lib/prelude/strings.idr deleted file mode 100644 --- a/lib/prelude/strings.idr +++ /dev/null @@ -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 - diff --git a/lib/prelude/vect.idr b/lib/prelude/vect.idr deleted file mode 100644 --- a/lib/prelude/vect.idr +++ /dev/null @@ -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; -} - diff --git a/lib/system.idr b/lib/system.idr deleted file mode 100644 --- a/lib/system.idr +++ /dev/null @@ -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 - diff --git a/rts/idris_rts.c b/rts/idris_rts.c --- a/rts/idris_rts.c +++ b/rts/idris_rts.c @@ -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); diff --git a/rts/idris_rts.h b/rts/idris_rts.h --- a/rts/idris_rts.h +++ b/rts/idris_rts.h @@ -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); diff --git a/rts/libidris_rts.a b/rts/libidris_rts.a Binary files a/rts/libidris_rts.a and b/rts/libidris_rts.a differ diff --git a/src/Core/CaseTree.hs b/src/Core/CaseTree.hs --- a/src/Core/CaseTree.hs +++ b/src/Core/CaseTree.hs @@ -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 + + diff --git a/src/Core/CoreParser.hs b/src/Core/CoreParser.hs --- a/src/Core/CoreParser.hs +++ b/src/Core/CoreParser.hs @@ -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", diff --git a/src/Core/Elaborate.hs b/src/Core/Elaborate.hs --- a/src/Core/Elaborate.hs +++ b/src/Core/Elaborate.hs @@ -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 diff --git a/src/Core/Evaluate.hs b/src/Core/Evaluate.hs --- a/src/Core/Evaluate.hs +++ b/src/Core/Evaluate.hs @@ -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) diff --git a/src/Core/ProofState.hs b/src/Core/ProofState.hs --- a/src/Core/ProofState.hs +++ b/src/Core/ProofState.hs @@ -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 diff --git a/src/Core/TT.hs b/src/Core/TT.hs --- a/src/Core/TT.hs +++ b/src/Core/TT.hs @@ -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 diff --git a/src/Core/Typecheck.hs b/src/Core/Typecheck.hs --- a/src/Core/Typecheck.hs +++ b/src/Core/Typecheck.hs @@ -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) diff --git a/src/Core/Unify.hs b/src/Core/Unify.hs --- a/src/Core/Unify.hs +++ b/src/Core/Unify.hs @@ -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. diff --git a/src/IRTS/Bytecode.hs b/src/IRTS/Bytecode.hs --- a/src/IRTS/Bytecode.hs +++ b/src/IRTS/Bytecode.hs @@ -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 diff --git a/src/IRTS/CodegenC.hs b/src/IRTS/CodegenC.hs --- a/src/IRTS/CodegenC.hs +++ b/src/IRTS/CodegenC.hs @@ -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" diff --git a/src/IRTS/Compiler.hs b/src/IRTS/Compiler.hs --- a/src/IRTS/Compiler.hs +++ b/src/IRTS/Compiler.hs @@ -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' - - - - diff --git a/src/IRTS/Defunctionalise.hs b/src/IRTS/Defunctionalise.hs --- a/src/IRTS/Defunctionalise.hs +++ b/src/IRTS/Defunctionalise.hs @@ -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 + diff --git a/src/IRTS/Inliner.hs b/src/IRTS/Inliner.hs --- a/src/IRTS/Inliner.hs +++ b/src/IRTS/Inliner.hs @@ -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 diff --git a/src/IRTS/Lang.hs b/src/IRTS/Lang.hs --- a/src/IRTS/Lang.hs +++ b/src/IRTS/Lang.hs @@ -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) ++ ") => " diff --git a/src/IRTS/Simplified.hs b/src/IRTS/Simplified.hs --- a/src/IRTS/Simplified.hs +++ b/src/IRTS/Simplified.hs @@ -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) diff --git a/src/Idris/AbsSyntax.hs b/src/Idris/AbsSyntax.hs --- a/src/Idris/AbsSyntax.hs +++ b/src/Idris/AbsSyntax.hs @@ -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) diff --git a/src/Idris/AbsSyntaxTree.hs b/src/Idris/AbsSyntaxTree.hs --- a/src/Idris/AbsSyntaxTree.hs +++ b/src/Idris/AbsSyntaxTree.hs @@ -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 diff --git a/src/Idris/Coverage.hs b/src/Idris/Coverage.hs --- a/src/Idris/Coverage.hs +++ b/src/Idris/Coverage.hs @@ -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 diff --git a/src/Idris/DataOpts.hs b/src/Idris/DataOpts.hs --- a/src/Idris/DataOpts.hs +++ b/src/Idris/DataOpts.hs @@ -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 + diff --git a/src/Idris/Delaborate.hs b/src/Idris/Delaborate.hs --- a/src/Idris/Delaborate.hs +++ b/src/Idris/Delaborate.hs @@ -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 diff --git a/src/Idris/ElabDecls.hs b/src/Idris/ElabDecls.hs --- a/src/Idris/ElabDecls.hs +++ b/src/Idris/ElabDecls.hs @@ -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 diff --git a/src/Idris/ElabTerm.hs b/src/Idris/ElabTerm.hs --- a/src/Idris/ElabTerm.hs +++ b/src/Idris/ElabTerm.hs @@ -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) diff --git a/src/Idris/Error.hs b/src/Idris/Error.hs --- a/src/Idris/Error.hs +++ b/src/Idris/Error.hs @@ -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 diff --git a/src/Idris/IBC.hs b/src/Idris/IBC.hs --- a/src/Idris/IBC.hs +++ b/src/Idris/IBC.hs @@ -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 diff --git a/src/Idris/Parser.hs b/src/Idris/Parser.hs --- a/src/Idris/Parser.hs +++ b/src/Idris/Parser.hs @@ -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))]) diff --git a/src/Idris/Primitives.hs b/src/Idris/Primitives.hs --- a/src/Idris/Primitives.hs +++ b/src/Idris/Primitives.hs @@ -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 diff --git a/src/Idris/Prover.hs b/src/Idris/Prover.hs --- a/src/Idris/Prover.hs +++ b/src/Idris/Prover.hs @@ -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 $ diff --git a/src/Idris/REPL.hs b/src/Idris/REPL.hs --- a/src/Idris/REPL.hs +++ b/src/Idris/REPL.hs @@ -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 @@ ([""], "", ""), ([""], "", "Evaluate an expression"), ([":t"], "", "Check the type of an expression"), + ([":miss", ":missing"], "", "Show missing clauses"), ([":i", ":info"], "", "Display information about a type class"), ([":total"], "", "Check the totality of a name"), ([":r",":reload"], "", "Reload current file"), + ([":l",":load"], "", "Load a new file"), + ([":m",":module"], "", "Import an extra module"), ([":e",":edit"], "", "Edit current file using $EDITOR or $VISUAL"), ([":m",":metavars"], "", "Show remaining proof obligations (metavariables)"), ([":p",":prove"], "", "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 diff --git a/src/Idris/REPLParser.hs b/src/Idris/REPLParser.hs --- a/src/Idris/REPLParser.hs +++ b/src/Idris/REPLParser.hs @@ -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 diff --git a/src/Idris/Transforms.hs b/src/Idris/Transforms.hs --- a/src/Idris/Transforms.hs +++ b/src/Idris/Transforms.hs @@ -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 diff --git a/src/Idris/UnusedArgs.hs b/src/Idris/UnusedArgs.hs new file mode 100644 --- /dev/null +++ b/src/Idris/UnusedArgs.hs @@ -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 + diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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" ++ diff --git a/tutorial/examples/binary.idr b/tutorial/examples/binary.idr --- a/tutorial/examples/binary.idr +++ b/tutorial/examples/binary.idr @@ -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; } + diff --git a/tutorial/examples/bmain.idr b/tutorial/examples/bmain.idr --- a/tutorial/examples/bmain.idr +++ b/tutorial/examples/bmain.idr @@ -1,4 +1,4 @@ -module main +module Main import btree diff --git a/tutorial/examples/hello.idr b/tutorial/examples/hello.idr --- a/tutorial/examples/hello.idr +++ b/tutorial/examples/hello.idr @@ -1,4 +1,4 @@ -module main +module Main main : IO () main = putStrLn "Hello world" diff --git a/tutorial/examples/interp.idr b/tutorial/examples/interp.idr --- a/tutorial/examples/interp.idr +++ b/tutorial/examples/interp.idr @@ -1,4 +1,4 @@ -module main +module Main data Ty = TyInt | TyBool| TyFun Ty Ty