diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -.PHONY: build configure doc install linecount nodefault pinstall relib test +.PHONY: build configure doc install linecount nodefault pinstall lib_clean relib test include config.mk -include custom.mk @@ -22,10 +22,15 @@ test_llvm: $(MAKE) -C test IDRIS=../dist/build/idris test_llvm -relib: - $(MAKE) -C lib IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts clean - $(MAKE) -C effects IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts DIST=../dist/build clean - $(MAKE) -C javascript IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts DIST=../dist/build clean +test_all: + $(MAKE) test + $(MAKE) test_llvm + $(MAKE) test_java + +lib_clean: + $(MAKE) -C libs IDRIS=../../dist/build/idris/idris RTS=../../dist/build/rts/libidris_rts clean + +relib: lib_clean $(CABAL) install $(CABALFLAGS) linecount: diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -26,16 +26,22 @@ -- make on mingw32 exepects unix style separators #ifdef mingw32_HOST_OS () = (Px.) -idrisCmd local = Px.joinPath $ splitDirectories $ ".." buildDir local "idris" "idris" +idrisCmd local = Px.joinPath $ splitDirectories $ ".." ".." buildDir local "idris" "idris" #else -idrisCmd local = ".." buildDir local "idris" "idris" +idrisCmd local = ".." ".." buildDir local "idris" "idris" #endif -- ----------------------------------------------------------------------------- -- Make Commands +-- use GNU make on FreeBSD +#ifdef freebsd_HOST_OS +mymake = "gmake" +#else +mymake = "make" +#endif make verbosity = - P.runProgramInvocation verbosity . P.simpleProgramInvocation "make" + P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake -- ----------------------------------------------------------------------------- -- Flags @@ -47,12 +53,12 @@ Just False -> False Nothing -> True -usesEffects :: S.ConfigFlags -> Bool -usesEffects flags = - case lookup (FlagName "effects") (S.configConfigurationsFlags flags) of - Just True -> True - Just False -> False - Nothing -> True +usesGMP :: S.ConfigFlags -> Bool +usesGMP flags = + case lookup (FlagName "gmp") (S.configConfigurationsFlags flags) of + Just True -> True + Just False -> False + Nothing -> True -- ----------------------------------------------------------------------------- -- Clean @@ -64,9 +70,7 @@ verbosity = S.fromFlag $ S.cleanVerbosity flags cleanStdLib = do - makeClean "lib" - makeClean "effects" - makeClean "javascript" + makeClean "libs" cleanLLVM = makeClean "llvm" @@ -100,16 +104,18 @@ buildStdLib = do putStrLn "Building libraries..." - makeBuild "lib" - when (usesEffects $ configFlags local) $ makeBuild "effects" - makeBuild "javascript" + makeBuild "libs" where makeBuild dir = make verbosity [ "-C", dir, "build" , "IDRIS=" ++ idrisCmd local] - buildRTS = make verbosity ["-C", "rts", "build"] + buildRTS = make verbosity (["-C", "rts", "build"] ++ + gmpflag (usesGMP (configFlags local))) buildLLVM = make verbosity ["-C", "llvm", "build"] + gmpflag False = [] + gmpflag True = ["GMP=-DIDRIS_GMP"] + -- ----------------------------------------------------------------------------- -- Copy/Install @@ -122,9 +128,7 @@ installStdLib = do putStrLn $ "Installing libraries in " ++ target - makeInstall "lib" target - when (usesEffects $ configFlags local) $ makeInstall "effects" target - makeInstall "javascript" target + makeInstall "libs" target installRTS = do let target' = target "rts" diff --git a/config.mk b/config.mk --- a/config.mk +++ b/config.mk @@ -1,11 +1,15 @@ -GMP_INCLUDE_DIR := -CC :=gcc +CC :=cc CABAL :=cabal CFLAGS :=-O2 -Wall $(CFLAGS) #CABALFLAGS := ## Disable building of Effects #CABALFLAGS :=-f NoEffects +ifneq (, $(findstring bsd, $(MACHINE))) + GMP_INCLUDE_DIR := +else + GMP_INCLUDE_DIR :=-I/usr/local/include +endif MACHINE := $(shell $(CC) -dumpmachine) ifneq (, $(findstring darwin, $(MACHINE))) diff --git a/effects/Effect/Exception.idr b/effects/Effect/Exception.idr deleted file mode 100644 --- a/effects/Effect/Exception.idr +++ /dev/null @@ -1,40 +0,0 @@ -module Effect.Exception - -import Effects -import System -import Control.IOExcept - -data Exception : Type -> Type -> Type -> Type -> Type where - Raise : a -> Exception a () () b - -instance Handler (Exception a) Maybe where - handle _ (Raise e) k = Nothing - -instance Show a => Handler (Exception a) IO where - handle _ (Raise e) k = do print e - believe_me (exit 1) - -instance Handler (Exception a) (IOExcept a) where - handle _ (Raise e) k = ioM (return (Left e)) - -instance Handler (Exception a) (Either a) where - handle _ (Raise e) k = Left e - -EXCEPTION : Type -> EFFECT -EXCEPTION t = MkEff () (Exception t) - -raise : a -> Eff m [EXCEPTION a] b -raise err = Raise err - - - - - - - --- TODO: Catching exceptions mid program? --- probably need to invoke a new interpreter - --- possibly add a 'handle' to the Eff language so that an alternative --- handler can be introduced mid interpretation? - diff --git a/effects/Effect/File.idr b/effects/Effect/File.idr deleted file mode 100644 --- a/effects/Effect/File.idr +++ /dev/null @@ -1,65 +0,0 @@ -module Effect.File - -import Effects -import Control.IOExcept - -data OpenFile : Mode -> Type where - FH : File -> OpenFile m - -data FileIO : Effect where - Open : String -> (m : Mode) -> FileIO () (OpenFile m) () - Close : FileIO (OpenFile m) () () - - ReadLine : FileIO (OpenFile Read) (OpenFile Read) String - WriteLine : String -> FileIO (OpenFile Write) (OpenFile Write) () - EOF : FileIO (OpenFile Read) (OpenFile Read) Bool - -instance Handler FileIO IO where - handle () (Open fname m) k = do h <- openFile fname m - k (FH h) () - handle (FH h) Close k = do closeFile h - k () () - handle (FH h) ReadLine k = do str <- fread h - k (FH h) str - handle (FH h) (WriteLine str) k = do fwrite h str - k (FH h) () - handle (FH h) EOF k = do e <- feof h - k (FH h) e - -instance Handler FileIO (IOExcept String) where - handle () (Open fname m) k - = do h <- ioe_lift (openFile fname m) - valid <- ioe_lift (validFile h) - if valid then k (FH h) () - else ioe_fail "File open failed" - handle (FH h) Close k = do ioe_lift (closeFile h); k () () - handle (FH h) ReadLine k = do str <- ioe_lift (fread h) - k (FH h) str - handle (FH h) (WriteLine str) k = do ioe_lift (fwrite h str) - k (FH h) () - handle (FH h) EOF k = do e <- ioe_lift (feof h) - k (FH h) e - -FILE_IO : Type -> EFFECT -FILE_IO t = MkEff t FileIO - -open : Handler FileIO e => - String -> (m : Mode) -> EffM e [FILE_IO ()] [FILE_IO (OpenFile m)] () -open f m = Open f m - -close : Handler FileIO e => - EffM e [FILE_IO (OpenFile m)] [FILE_IO ()] () -close = Close - -readLine : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] String -readLine = ReadLine - -writeLine : Handler FileIO e => String -> Eff e [FILE_IO (OpenFile Write)] () -writeLine str = WriteLine str - -eof : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] Bool -eof = EOF - - - - diff --git a/effects/Effect/Memory.idr b/effects/Effect/Memory.idr deleted file mode 100644 --- a/effects/Effect/Memory.idr +++ /dev/null @@ -1,168 +0,0 @@ -module Effect.Memory - -import Effects -import Control.IOExcept - -%access public - -abstract -data MemoryChunk : Nat -> Nat -> Type where - CH : Ptr -> MemoryChunk size initialized - -abstract -data RawMemory : Effect where - Allocate : (n : Nat) -> - RawMemory () (MemoryChunk n 0) () - Free : RawMemory (MemoryChunk n i) () () - Initialize : Bits8 -> - (size : Nat) -> - so (i + size <= n) -> - RawMemory (MemoryChunk n i) (MemoryChunk n (i + size)) () - Peek : (offset : Nat) -> - (size : Nat) -> - so (offset + size <= i) -> - RawMemory (MemoryChunk n i) (MemoryChunk n i) (Vect size Bits8) - Poke : (offset : Nat) -> - (Vect size Bits8) -> - so (offset <= i && offset + size <= n) -> - RawMemory (MemoryChunk n i) (MemoryChunk n (max i (offset + size))) () - Move : (src : MemoryChunk src_size src_init) -> - (dst_offset : Nat) -> - (src_offset : Nat) -> - (size : Nat) -> - so (dst_offset <= dst_init && dst_offset + size <= dst_size) -> - so (src_offset + size <= src_init) -> - RawMemory (MemoryChunk dst_size dst_init) - (MemoryChunk dst_size (max dst_init (dst_offset + size))) () - GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (MemoryChunk n i) - -private -do_malloc : Nat -> IOExcept String Ptr -do_malloc size with (fromInteger (cast size) == size) - | True = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (fromInteger $ cast size) - fail <- ioe_lift $ nullPtr ptr - if fail then ioe_fail "Cannot allocate memory" - else return ptr - | False = ioe_fail "The target architecture does not support adressing enough memory" - -private -do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO () -do_memset ptr offset c size - = mkForeign (FFun "idris_memset" [FPtr, FInt, FByte, FInt] FUnit) - ptr (fromInteger $ cast offset) c (fromInteger $ cast size) - -private -do_free : Ptr -> IO () -do_free ptr = mkForeign (FFun "free" [FPtr] FUnit) ptr - -private -do_memmove : Ptr -> Ptr -> Nat -> Nat -> Nat -> IO () -do_memmove dest src dest_offset src_offset size - = mkForeign (FFun "idris_memmove" [FPtr, FPtr, FInt, FInt, FInt] FUnit) - dest src (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size) - -private -do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8) -do_peek _ _ Z = return (Prelude.Vect.Nil) -do_peek ptr offset (S n) - = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FByte) ptr (fromInteger $ cast offset) - bs <- do_peek ptr (S offset) n - Prelude.Monad.return (Prelude.Vect.(::) b bs) - -private -do_poke : Ptr -> Nat -> Vect size Bits8 -> IO () -do_poke _ _ [] = return () -do_poke ptr offset (b::bs) - = do mkForeign (FFun "idris_poke" [FPtr, FInt, FByte] FUnit) ptr (fromInteger $ cast offset) b - do_poke ptr (S offset) bs - -instance Handler RawMemory (IOExcept String) where - handle () (Allocate n) k - = do ptr <- do_malloc n - k (CH ptr) () - handle {res = MemoryChunk _ offset} (CH ptr) (Initialize c size _) k - = ioe_lift (do_memset ptr offset c size) $> k (CH ptr) () - handle (CH ptr) (Free) k - = ioe_lift (do_free ptr) $> k () () - handle (CH ptr) (Peek offset size _) k - = do res <- ioe_lift (do_peek ptr offset size) - k (CH ptr) res - handle (CH ptr) (Poke offset content _) k - = do ioe_lift (do_poke ptr offset content) - k (CH ptr) () - handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k - = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size) - k (CH dest_ptr) () - handle chunk (GetRawPtr) k - = k chunk chunk - -RAW_MEMORY : Type -> EFFECT -RAW_MEMORY t = MkEff t RawMemory - -allocate : (n : Nat) -> EffM m [RAW_MEMORY ()] [RAW_MEMORY (MemoryChunk n 0)] () -allocate size = Allocate size - -initialize : {i : Nat} -> - {n : Nat} -> - Bits8 -> - (size : Nat) -> - so (i + size <= n) -> - EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (i + size))] () -initialize c size prf = Initialize c size prf - -free : EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY ()] () -free = Free - -peek : {i : Nat} -> - (offset : Nat) -> - (size : Nat) -> - so (offset + size <= i) -> - Eff m [RAW_MEMORY (MemoryChunk n i)] (Vect size Bits8) -peek offset size prf = Peek offset size prf - -poke : {n : Nat} -> - {i : Nat} -> - (offset : Nat) -> - Vect size Bits8 -> - so (offset <= i && offset + size <= n) -> - EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (max i (offset + size)))] () -poke offset content prf = Poke offset content prf - -private -getRawPtr : Eff m [RAW_MEMORY (MemoryChunk n i)] (MemoryChunk n i) -getRawPtr = GetRawPtr - -private -move' : {dst_size : Nat} -> - {dst_init : Nat} -> - {src_init : Nat} -> - (src_ptr : MemoryChunk src_size src_init) -> - (dst_offset : Nat) -> - (src_offset : Nat) -> - (size : Nat) -> - so (dst_offset <= dst_init && dst_offset + size <= dst_size) -> - so (src_offset + size <= src_init) -> - EffM m [RAW_MEMORY (MemoryChunk dst_size dst_init)] - [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))] () -move' src_ptr dst_offset src_offset size dst_bounds src_bounds - = Move src_ptr dst_offset src_offset size dst_bounds src_bounds - -data MoveDescriptor = Dst | Src - -move : {dst_size : Nat} -> - {dst_init : Nat} -> - {src_size : Nat} -> - {src_init : Nat} -> - (dst_offset : Nat) -> - (src_offset : Nat) -> - (size : Nat) -> - so (dst_offset <= dst_init && dst_offset + size <= dst_size) -> - so (src_offset + size <= src_init) -> - EffM m [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init) - , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] - [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size))) - , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] () -move dst_offset src_offset size dst_bounds src_bounds - = do src_ptr <- Src :- getRawPtr - Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds - return () diff --git a/effects/Effect/Random.idr b/effects/Effect/Random.idr deleted file mode 100644 --- a/effects/Effect/Random.idr +++ /dev/null @@ -1,21 +0,0 @@ -module Effect.Random - -import Effects - -data Random : Type -> Type -> Type -> Type where - getRandom : Random Integer Integer Integer - -using (m : Type -> Type) - instance Handler Random m where - handle seed getRandom k - = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in - k seed' seed' - -RND : EFFECT -RND = MkEff Integer Random - -rndInt : Integer -> Integer -> Eff m [RND] Integer -rndInt lower upper = do v <- getRandom - return (v `prim__sremBigInt` (upper - lower) + lower) - - diff --git a/effects/Effect/Select.idr b/effects/Effect/Select.idr deleted file mode 100644 --- a/effects/Effect/Select.idr +++ /dev/null @@ -1,23 +0,0 @@ -module Effect.Select - -import Effects - -data Selection : Effect where - Select : List a -> Selection () () a - -instance Handler Selection Maybe where - handle _ (Select xs) k = tryAll xs where - tryAll [] = Nothing - tryAll (x :: xs) = case k () x of - Nothing => tryAll xs - Just v => Just v - -instance Handler Selection List where - handle r (Select xs) k = concatMap (k r) xs - -SELECT : EFFECT -SELECT = MkEff () Selection - -select : List a -> Eff m [SELECT] a -select xs = Select xs - diff --git a/effects/Effect/State.idr b/effects/Effect/State.idr deleted file mode 100644 --- a/effects/Effect/State.idr +++ /dev/null @@ -1,42 +0,0 @@ -module Effect.State - -import Effects - -%access public - -data State : Effect where - Get : State a a a - Put : b -> State a b () - -using (m : Type -> Type) - instance Handler State m where - handle st Get k = k st st - handle st (Put n) k = k n () - -STATE : Type -> EFFECT -STATE t = MkEff t State - -get : Eff m [STATE x] x -get = Get - -put : x -> Eff m [STATE x] () -put val = Put val - -putM : y -> EffM m [STATE x] [STATE y] () -putM val = Put val - -update : (x -> x) -> Eff m [STATE x] () -update f = do val <- get - put (f val) - -updateM : (x -> y) -> EffM m [STATE x] [STATE y] () -updateM f = do val <- get - putM (f val) - -locally : x -> Eff m [STATE x] t -> Eff m [STATE y] t -locally newst prog = do st <- get - putM newst - val <- prog - putM st - return val - diff --git a/effects/Effect/StdIO.idr b/effects/Effect/StdIO.idr deleted file mode 100644 --- a/effects/Effect/StdIO.idr +++ /dev/null @@ -1,60 +0,0 @@ -module Effect.StdIO - -import Effects -import Control.IOExcept - -data StdIO : Effect where - PutStr : String -> StdIO () () () - GetStr : StdIO () () String - -instance Handler StdIO IO where - handle () (PutStr s) k = do putStr s; k () () - handle () GetStr k = do x <- getLine; k () x - -instance Handler StdIO (IOExcept a) where - handle () (PutStr s) k = do ioe_lift (putStr s); k () () - handle () GetStr k = do x <- ioe_lift getLine; k () x - --- Handle effects in a pure way, for simulating IO for unit testing/proof - -data IOStream a = MkStream (List String -> (a, List String)) - -instance Handler StdIO IOStream where - handle () (PutStr s) k - = MkStream (\x => case k () () of - MkStream f => let (res, str) = f x in - (res, s :: str)) - handle {a} () GetStr k - = MkStream (\x => case x of - [] => cont "" [] - (t :: ts) => cont t ts) - where - cont : String -> List String -> (a, List String) - cont t ts = case k () t of - MkStream f => f ts - ---- The Effect and associated functions - -STDIO : EFFECT -STDIO = MkEff () StdIO - -putStr : Handler StdIO e => String -> Eff e [STDIO] () -putStr s = PutStr s - -putStrLn : Handler StdIO e => String -> Eff e [STDIO] () -putStrLn s = putStr (s ++ "\n") - -getStr : Handler StdIO e => Eff e [STDIO] String -getStr = GetStr - -mkStrFn : Env IOStream xs -> - Eff IOStream xs a -> - List String -> (a, List String) -mkStrFn {a} env p input = case mkStrFn' of - MkStream f => f input - where injStream : a -> IOStream a - injStream v = MkStream (\x => (v, [])) - mkStrFn' : IOStream a - mkStrFn' = runWith injStream env p - - diff --git a/effects/Effects.idr b/effects/Effects.idr deleted file mode 100644 --- a/effects/Effects.idr +++ /dev/null @@ -1,280 +0,0 @@ -module Effects - -import Language.Reflection -import Control.Catchable - -%access public - ----- Effects - -Effect : Type -Effect = Type -> Type -> Type -> Type - -data EFFECT : Type where - MkEff : Type -> Effect -> EFFECT - -class Handler (e : Effect) (m : Type -> Type) where - handle : res -> (eff : e res res' t) -> (res' -> t -> m a) -> m a - ----- Properties and proof construction - -using (xs : List a, ys : List a) - data SubList : List a -> List a -> Type where - SubNil : SubList {a} [] [] - Keep : SubList xs ys -> SubList (x :: xs) (x :: ys) - Drop : SubList xs ys -> SubList xs (x :: ys) - - subListId : SubList xs xs - subListId {xs = Nil} = SubNil - subListId {xs = x :: xs} = Keep subListId - -data Env : (m : Type -> Type) -> List EFFECT -> Type where - Nil : Env m Nil - (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs) - -data EffElem : (Type -> Type -> Type -> Type) -> Type -> - List EFFECT -> Type where - Here : EffElem x a (MkEff a x :: xs) - There : EffElem x a xs -> EffElem x a (y :: xs) - --- make an environment corresponding to a sub-list -dropEnv : Env m ys -> SubList xs ys -> Env m xs -dropEnv [] SubNil = [] -dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest -dropEnv (v :: vs) (Drop rest) = dropEnv vs rest - -updateWith : (ys' : List a) -> (xs : List a) -> - SubList ys xs -> List a -updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest -updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest -updateWith [] [] SubNil = [] -updateWith (y :: ys) [] SubNil = y :: ys -updateWith [] (x :: xs) (Keep rest) = [] - --- put things back, replacing old with new in the sub-environment -rebuildEnv : Env m ys' -> (prf : SubList ys xs) -> - Env m xs -> Env m (updateWith ys' xs prf) -rebuildEnv [] SubNil env = env -rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env -rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env -rebuildEnv (x :: xs) SubNil [] = x :: xs - ----- The Effect EDSL itself ---- - --- some proof automation -findEffElem : Nat -> List (TTName, Binder TT) -> TT -> Tactic -- Nat is maximum search depth -findEffElem Z ctxt goal = Refine "Here" `Seq` Solve -findEffElem (S n) ctxt goal = GoalType "EffElem" - (Try (Refine "Here" `Seq` Solve) - (Refine "There" `Seq` (Solve `Seq` findEffElem n ctxt goal))) - -findSubList : Nat -> List (TTName, Binder TT) -> TT -> Tactic -findSubList Z ctxt goal = Refine "SubNil" `Seq` Solve -findSubList (S n) ctxt goal - = GoalType "SubList" - (Try (Refine "subListId" `Seq` Solve) - ((Try (Refine "Keep" `Seq` Solve) - (Refine "Drop" `Seq` Solve)) `Seq` findSubList n ctxt goal)) - -updateResTy : (xs : List EFFECT) -> EffElem e a xs -> e a b t -> - List EFFECT -updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs -updateResTy (x :: xs) (There p) n = x :: updateResTy xs p n - -updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type -> - List EFFECT -updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs -updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b - -infix 5 :::, :-, := - -data LRes : lbl -> Type -> Type where - (:=) : (x : lbl) -> res -> LRes x res - -(:::) : lbl -> EFFECT -> EFFECT -(:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff - -private -unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x] -unlabel {m} {x = MkEff a eff} [l := v] = [v] - -private -relabel : (l : ty) -> Env m [x] -> Env m [l ::: x] -relabel {x = MkEff a eff} l [v] = [l := v] - --- the language of Effects - -data EffM : (m : Type -> Type) -> - List EFFECT -> List EFFECT -> Type -> Type where - value : a -> EffM m xs xs a - ebind : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b - effect : (prf : EffElem e a xs) -> - (eff : e a b t) -> - EffM m xs (updateResTy xs prf eff) t - lift : (prf : SubList ys xs) -> - EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t - new : Handler e m => - res -> EffM m (MkEff res e :: xs) (MkEff res' e :: xs') a -> - EffM m xs xs' a - test : (prf : EffElem e (Either l r) xs) -> - EffM m (updateResTyImm xs prf l) xs' t -> - EffM m (updateResTyImm xs prf r) xs' t -> - EffM m xs xs' t - test_lbl : {x : lbl} -> - (prf : EffElem e (LRes x (Either l r)) xs) -> - EffM m (updateResTyImm xs prf (LRes x l)) xs' t -> - EffM m (updateResTyImm xs prf (LRes x r)) xs' t -> - EffM m xs xs' t - catch : Catchable m err => - EffM m xs xs' a -> (err -> EffM m xs xs' a) -> - EffM m xs xs' a - (:-) : (l : ty) -> EffM m [x] [y] t -> EffM m [l ::: x] [l ::: y] t - --- Eff : List (EFFECT m) -> Type -> Type - -implicit -lift' : {default tactics { applyTactic findSubList 20; solve; } - prf : SubList ys xs} -> - EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t -lift' {prf} e = lift prf e - -implicit -effect' : {a, b: _} -> {e : Effect} -> - {default tactics { applyTactic findEffElem 20; solve; } - prf : EffElem e a xs} -> - (eff : e a b t) -> - EffM m xs (updateResTy xs prf eff) t -effect' {prf} e = effect prf e - -data WrapEffM : (m : Type -> Type) -> - List EFFECT -> List EFFECT -> Type -> Type where - WEffM : EffM m xs xs' t -> WrapEffM m xs xs' t - --- wrap subprograms to prevent lifting (need to guarantee same effects as --- parent!) - -test_lbl' : {x : lbl} -> - {default tactics { applyTactic findEffElem 20; solve; } - prf : EffElem e (LRes x (Either l r)) xs} -> - WrapEffM m (updateResTyImm xs prf (LRes x l)) xs' t -> - WrapEffM m (updateResTyImm xs prf (LRes x r)) xs' t -> - EffM m xs xs' t -test_lbl' {prf} (WEffM l) (WEffM r) = test_lbl prf l r - -test' : {default tactics { applyTactic findEffElem 20; solve; } - prf : EffElem e (Either l r) xs} -> - EffM m (updateResTyImm xs prf l) xs' t -> - EffM m (updateResTyImm xs prf r) xs' t -> - EffM m xs xs' t -test' {prf} l r = test prf l r - --- for 'do' notation - -return : a -> EffM m xs xs a -return x = value x - -(>>=) : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b -(>>=) = ebind - --- for idiom brackets - -infixl 2 <$> - -pure : a -> EffM m xs xs a -pure = value - -(<$>) : EffM m xs xs (a -> b) -> EffM m xs xs a -> EffM m xs xs b -(<$>) prog v = do fn <- prog - arg <- v - return (fn arg) - --- an interpreter - -private -execEff : Env m xs -> (p : EffElem e res xs) -> - (eff : e res b a) -> - (Env m (updateResTy xs p eff) -> a -> m t) -> m t -execEff (val :: env) Here eff' k - = handle val eff' (\res, v => k (res :: env) v) -execEff (val :: env) (There p) eff k - = execEff env p eff (\env', v => k (val :: env') v) - -private -testEff : Env m xs -> (p : EffElem e (Either l r) xs) -> - (Env m (updateResTyImm xs p l) -> m b) -> - (Env m (updateResTyImm xs p r) -> m b) -> - m b -testEff (Left err :: env) Here lk rk = lk (err :: env) -testEff (Right ok :: env) Here lk rk = rk (ok :: env) -testEff (val :: env) (There p) lk rk - = testEff env p (\envk => lk (val :: envk)) - (\envk => rk (val :: envk)) - -private -testEffLbl : {x : lbl} -> - Env m xs -> (p : EffElem e (LRes x (Either l r)) xs) -> - (Env m (updateResTyImm xs p (LRes x l)) -> m b) -> - (Env m (updateResTyImm xs p (LRes x r)) -> m b) -> - m b -testEffLbl ((lbl := Left err) :: env) Here lk rk = lk ((lbl := err) :: env) -testEffLbl ((lbl := Right ok) :: env) Here lk rk = rk ((lbl := ok) :: env) -testEffLbl (val :: env) (There p) lk rk - = testEffLbl env p (\envk => lk (val :: envk)) - (\envk => rk (val :: envk)) - --- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state --- updates can be propagated even through failing computations? - -eff : Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b -eff env (value x) k = k env x -eff env (prog `ebind` c) k - = eff env prog (\env', p' => eff env' (c p') k) -eff env (effect prf effP) k = execEff env prf effP k -eff env (lift prf effP) k - = let env' = dropEnv env prf in - eff env' effP (\envk, p' => k (rebuildEnv envk prf env) p') -eff env (new r prog) k - = let env' = r :: env in - eff env' prog (\(v :: envk), p' => k envk p') -eff env (test prf l r) k - = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k) -eff env (test_lbl prf l r) k - = testEffLbl env prf (\envk => eff envk l k) (\envk => eff envk r k) -eff env (catch prog handler) k - = catch (eff env prog k) - (\e => eff env (handler e) k) --- FIXME: --- xs is needed explicitly because otherwise the pattern binding for --- 'l' appears too late. Solution seems to be to reorder patterns at the --- end so that everything is in scope when it needs to be. -eff {xs = [l ::: x]} env (l :- prog) k - = let env' = unlabel env in - eff env' prog (\envk, p' => k (relabel l envk) p') - -run : Applicative m => Env m xs -> EffM m xs xs' a -> m a -run env prog = eff env prog (\env, r => pure r) - -runEnv : Applicative m => Env m xs -> EffM m xs xs' a -> m (Env m xs', a) -runEnv env prog = eff env prog (\env, r => pure (env, r)) - -runPure : Env id xs -> EffM id xs xs' a -> a -runPure env prog = eff env prog (\env, r => r) - -runPureEnv : Env id xs -> EffM id xs xs' a -> (Env id xs', a) -runPureEnv env prog = eff env prog (\env, r => (env, r)) - -runWith : (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a -runWith inj env prog = eff env prog (\env, r => inj r) - -Eff : (Type -> Type) -> List EFFECT -> Type -> Type -Eff m xs t = EffM m xs xs t - --- some higher order things - -mapE : Applicative m => (a -> Eff m xs b) -> List a -> Eff m xs (List b) -mapE f [] = pure [] -mapE f (x :: xs) = [| f x :: mapE f xs |] - -when : Applicative m => Bool -> Eff m xs () -> Eff m xs () -when True e = e -when False e = pure () diff --git a/effects/Makefile b/effects/Makefile deleted file mode 100644 --- a/effects/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -IDRIS := idris - -build: .PHONY - $(IDRIS) --build effects.ipkg - -clean: .PHONY - $(IDRIS) --clean effects.ipkg - -install: - $(IDRIS) --install effects.ipkg - -rebuild: clean build - -.PHONY: diff --git a/effects/effects.ipkg b/effects/effects.ipkg deleted file mode 100644 --- a/effects/effects.ipkg +++ /dev/null @@ -1,8 +0,0 @@ -package effects - -opts = "-i ../lib" -modules = Effects, - Effect.Exception, Effect.File, Effect.State, - Effect.Random, Effect.StdIO, Effect.Select, - Effect.Memory - diff --git a/idris.cabal b/idris.cabal --- a/idris.cabal +++ b/idris.cabal @@ -1,5 +1,5 @@ Name: idris -Version: 0.9.9.3 +Version: 0.9.10 License: BSD3 License-file: LICENSE Author: Edwin Brady @@ -66,33 +66,39 @@ rts/*.h rts/Makefile - lib/base.ipkg - lib/*.idr - lib/Control/*.idr - lib/Control/Monad/*.idr - lib/Data/*.idr - lib/Data/Vect/*.idr - lib/Debug/*.idr - lib/Decidable/*.idr - lib/Language/*.idr - lib/Language/Reflection/*.idr - lib/Makefile - lib/Network/*.idr - lib/Prelude/*.idr - lib/System/Concurrency/*.idr + libs/Makefile - effects/Makefile - effects/effects.ipkg - effects/Effect/*.idr - effects/*.idr + libs/prelude/prelude.ipkg + libs/prelude/Prelude/*.idr + libs/prelude/Decidable/*.idr + libs/prelude/Makefile + libs/prelude/*.idr - java/*.xml + libs/base/base.ipkg + libs/base/*.idr + libs/base/Control/*.idr + libs/base/Control/Monad/*.idr + libs/base/Data/*.idr + libs/base/Data/Vect/*.idr + libs/base/Debug/*.idr + libs/base/Decidable/*.idr + libs/base/Language/*.idr + libs/base/Language/Reflection/*.idr + libs/base/Makefile + libs/base/Network/*.idr + libs/base/System/Concurrency/*.idr - javascript/*.idr - javascript/JavaScript/*.idr - javascript/Makefile - javascript/javascript.ipkg + libs/effects/Makefile + libs/effects/effects.ipkg + libs/effects/Effect/*.idr + libs/effects/*.idr + + libs/javascript/*.idr + libs/javascript/JavaScript/*.idr + libs/javascript/Makefile + libs/javascript/javascript.ipkg + llvm/*.c llvm/Makefile @@ -271,45 +277,59 @@ test/test031/run test/test031/*.idr test/test031/expected + test/test032/run + test/test032/*.idr + test/test032/input + test/test032/expected + test/test033/run + test/test033/*.idr + test/test033/expected + test/test034/run + test/test034/expected source-repository head type: git - location: git://github.com/edwinb/Idris-dev.git - -Flag Effects - Description: Build the effects package - Default: True + location: git://github.com/idris-lang/Idris-dev.git Flag LLVM Description: Build the LLVM backend - Default: True + Default: False manual: True +Flag FFI + Description: Build support for libffi + Default: False + manual: True + +Flag GMP + Description: Use GMP for Integers + Default: False + manual: True + Executable idris Main-is: Main.hs hs-source-dirs: src Other-modules: Core.CaseTree , Core.Constraints - , Core.CoreParser , Core.Elaborate , Core.Evaluate , Core.Execute - , Core.ProofShell , Core.ProofState - , Core.ShellParser , Core.TT , Core.Typecheck , Core.Unify , Idris.AbsSyntax , Idris.AbsSyntaxTree + , Idris.CaseSplit , Idris.Chaser , Idris.Colours , Idris.Completion , Idris.Coverage , Idris.DSL , Idris.DataOpts + , Idris.DeepSeq , Idris.Delaborate , Idris.Docs , Idris.ElabDecls @@ -327,6 +347,7 @@ , Idris.ParseData , Idris.PartialEval , Idris.Primitives + , Idris.ProofSearch , Idris.Prover , Idris.Providers , Idris.REPL @@ -348,13 +369,14 @@ , IRTS.Java.ASTBuilding , IRTS.Java.JTypes , IRTS.Java.Mangling - , IRTS.LParser + , IRTS.Java.Pom , IRTS.Lang , IRTS.Simplified , Util.Pretty , Util.System , Util.DynamicLinker + , Util.Net , Pkg.Package , Pkg.PParser @@ -373,10 +395,9 @@ , directory >= 1.2 , filepath , haskeline >= 0.7 - , language-java >= 0.2.2 - , libffi + , language-java >= 0.2.6 , mtl - , parsec >= 3 + --, parsec >= 3 , parsers == 0.9 , pretty , process @@ -389,6 +410,9 @@ , utf8-string , vector , vector-binary-instances + , network + , xml + , deepseq Extensions: MultiParamTypeClasses , FunctionalDependencies @@ -396,11 +420,14 @@ , TemplateHaskell ghc-prof-options: -auto-all -caf-all - ghc-options: -rtsopts + ghc-options: -threaded -rtsopts if os(linux) cpp-options: -DLINUX build-depends: unix + if os(freebsd) + cpp-options: -DFREEBSD + build-depends: unix if os(darwin) cpp-options: -DMACOSX build-depends: unix @@ -414,3 +441,10 @@ , llvm-general-pure == 3.3.8.* else other-modules: Util.LLVMStubs + if flag(FFI) + build-depends: libffi + cpp-options: -DIDRIS_FFI + if flag(GMP) + build-depends: libffi + cpp-options: -DIDRIS_GMP + diff --git a/java/executable_pom.xml b/java/executable_pom.xml deleted file mode 100644 --- a/java/executable_pom.xml +++ /dev/null @@ -1,66 +0,0 @@ - - 4.0.0 - org.idris-lang - $ARTIFACT-NAME$ - jar - 1.0 - $ARTIFACT-NAME$ - - - UTF-8 - true - - - - org.idris-lang - idris - 0.9.10-alpha-1 - -$DEPENDENCIES$ - - - - - $ARTIFACT-NAME$ - - - org.apache.maven.plugins - maven-compiler-plugin - 3.0 - - 1.7 - 1.7 - - - - org.apache.maven.plugins - maven-surefire-plugin - 2.14 - - ${skipTests} - - - - org.apache.maven.plugins - maven-shade-plugin - 2.1 - - - package - - shade - - - - - $MAIN-CLASS$ - - - - - - - - - diff --git a/java/executable_pom_template.xml b/java/executable_pom_template.xml deleted file mode 100644 --- a/java/executable_pom_template.xml +++ /dev/null @@ -1,66 +0,0 @@ - - 4.0.0 - org.idris-lang - $ARTIFACT-NAME$ - jar - 1.0 - $ARTIFACT-NAME$ - - - UTF-8 - true - - - - org.idris-lang - idris - 0.9.10-alpha-1 - -$DEPENDENCIES$ - - - - - $ARTIFACT-NAME$ - - - org.apache.maven.plugins - maven-compiler-plugin - 3.0 - - 1.7 - 1.7 - - - - org.apache.maven.plugins - maven-surefire-plugin - 2.14 - - ${skipTests} - - - - org.apache.maven.plugins - maven-shade-plugin - 2.1 - - - package - - shade - - - - - $MAIN-CLASS$ - - - - - - - - - diff --git a/javascript/JavaScript.idr b/javascript/JavaScript.idr deleted file mode 100644 --- a/javascript/JavaScript.idr +++ /dev/null @@ -1,104 +0,0 @@ -module JavaScript - -%access public - -private -isUndefined : Ptr -> IO Bool -isUndefined p = do - res <- mkForeign ( - FFun "%0 === undefined" [FPtr] FString) p - if res == "false" - then (return False) - else (return True) - --------------------------------------------------------------------------------- --- Events --------------------------------------------------------------------------------- -abstract -data Event : Type where - MkEvent : Ptr -> Event - --------------------------------------------------------------------------------- --- Elements --------------------------------------------------------------------------------- -abstract -data Element : Type where - MkElem : Ptr -> Element - -setText : Element -> String -> IO () -setText (MkElem p) s = - mkForeign (FFun "%0.textContent=%1" [FPtr, FString] FUnit) p s - - -setOnClick : Element -> (Event -> IO Bool) -> IO () -setOnClick (MkElem e) f = - mkForeign ( - FFun "%0['onclick']=%1" [ FPtr - , FFunction (FAny Event) (FAny (IO Bool)) - ] FUnit) e f --------------------------------------------------------------------------------- --- Nodelists --------------------------------------------------------------------------------- -abstract -data NodeList : Type where - MkNodeList : Ptr -> NodeList - -elemAt : NodeList -> Nat -> IO (Maybe Element) -elemAt (MkNodeList p) i = do - e <- mkForeign (FFun "%0.item(%1)" [FPtr, FInt] FPtr) p ( - prim__truncBigInt_Int (cast i) - ) - d <- isUndefined e - if d - then return $ Just (MkElem e) - else return Nothing - --------------------------------------------------------------------------------- --- Intervals --------------------------------------------------------------------------------- -abstract -data Interval : Type where - MkInterval : Ptr -> Interval - -setInterval : (() -> IO ()) -> Float -> IO Interval -setInterval f t = do - e <- mkForeign ( - FFun "setInterval(%0,%1)" [FFunction FUnit (FAny (IO ())), FFloat] FPtr - ) f t - return (MkInterval e) - -clearInterval : Interval -> IO () -clearInterval (MkInterval p) = - mkForeign (FFun "clearInterval(%0)" [FPtr] FUnit) p - --------------------------------------------------------------------------------- --- Timeouts --------------------------------------------------------------------------------- -data Timeout : Type where - MkTimeout : Ptr -> Timeout - -setTimeout : (() -> IO ()) -> Float -> IO Timeout -setTimeout f t = do - e <- mkForeign ( - FFun "setTimeout(%0,%1)" [FFunction FUnit (FAny (IO ())), FFloat] FPtr - ) f t - return (MkTimeout e) - -clearTimeout : Timeout -> IO () -clearTimeout (MkTimeout p) = - mkForeign (FFun "clearTimeout(%0)" [FPtr] FUnit) p - --------------------------------------------------------------------------------- --- Basic IO --------------------------------------------------------------------------------- -alert : String -> IO () -alert msg = - mkForeign (FFun "alert(%0)" [FString] FUnit) msg - --------------------------------------------------------------------------------- --- DOM --------------------------------------------------------------------------------- -query : String -> IO NodeList -query q = do - e <- mkForeign (FFun "document.querySelectorAll(%0)" [FString] FPtr) q - return (MkNodeList e) diff --git a/javascript/JavaScript/JSON.idr b/javascript/JavaScript/JSON.idr deleted file mode 100644 --- a/javascript/JavaScript/JSON.idr +++ /dev/null @@ -1,46 +0,0 @@ -module JSON - -import Data.SortedMap - -data JSONType : Type where - JSONArray : (n : Nat) -> Vect n JSONType -> JSONType - JSONString : JSONType - JSONNumber : JSONType - JSONBool : JSONType - JSONObject : SortedMap String JSONType -> JSONType - JSONNull : JSONType - -mutual - using (ts : Vect n JSONType, fs : SortedMap String JSONType) - namespace JArray - data JArray : (n : Nat) -> Vect n JSONType -> Type where - Nil : JArray 0 [] - (::) : JSON t -> JArray n ts -> JArray (S n) (t :: ts) - - namespace JObject - data JObject : SortedMap String JSONType -> Type where - Nil : JObject empty - (::) : (f : (String, JSON t)) -> - JObject fs -> - JObject (insert (fst f) t fs) - - data JSON : JSONType -> Type where - JSString : String -> JSON JSONString - JSNumber : Float -> JSON JSONNumber - JSBool : Bool -> JSON JSONBool - JSNull : JSON JSONNull - JSArray : JArray n ts -> JSON (JSONArray n ts) - JSObject : JObject fs -> JSON (JSONObject fs) - -index : (i : Fin n) -> JSON (JSONArray n ts) -> JSON (index i ts) -index fZ (JSArray (x :: xs)) = x -index (fS i) (JSArray (x :: xs)) = index i (JSArray xs) - -infixl 8 ++ - -(++) : JSON (JSONArray m ts1) -> - JSON (JSONArray n ts2) -> - JSON (JSONArray (m + n) (ts1 ++ ts2)) -(++) (JSArray []) ys = ys -(++) (JSArray (x :: xs)) ys with ((JSArray xs) ++ ys) - | (JSArray as) = JSArray (x :: as) diff --git a/javascript/Makefile b/javascript/Makefile deleted file mode 100644 --- a/javascript/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -IDRIS := idris - -build: .PHONY - $(IDRIS) --build javascript.ipkg - -install: - $(IDRIS) --install javascript.ipkg - -clean: .PHONY - $(IDRIS) --clean javascript.ipkg - -rebuild: clean build - -.PHONY: diff --git a/javascript/javascript.ipkg b/javascript/javascript.ipkg deleted file mode 100644 --- a/javascript/javascript.ipkg +++ /dev/null @@ -1,5 +0,0 @@ -package javascript - -opts = "-i ../lib" -modules = JavaScript, JavaScript.JSON - diff --git a/lib/Builtins.idr b/lib/Builtins.idr deleted file mode 100644 --- a/lib/Builtins.idr +++ /dev/null @@ -1,373 +0,0 @@ -%access public -%default total - -data Exists : (a : Type) -> (P : a -> Type) -> Type where - Ex_intro : {P : a -> Type} -> (x : a) -> P x -> Exists a P - -getWitness : {P : a -> Type} -> Exists a P -> a -getWitness (a ** v) = a - -getProof : {P : a -> Type} -> (s : Exists a P) -> P (getWitness s) -getProof (a ** v) = v - -FalseElim : _|_ -> a - --- For rewrite tactic -replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y -replace refl prf = prf - -sym : {l:a} -> {r:a} -> l = r -> r = l -sym refl = refl - -trans : {a:x} -> {b:x} -> {c:x} -> a = b -> b = c -> a = c -trans refl refl = refl - -lazy : a -> a -lazy x = x -- compiled specially - -par : |(thunk:a) -> a -par x = x -- compiled specially - -malloc : Int -> a -> a -malloc size x = x -- compiled specially - -trace_malloc : a -> a -trace_malloc x = x -- compiled specially - -abstract %assert_total -- need to pretend -believe_me : a -> b -- compiled specially as id, use with care! -believe_me x = prim__believe_me _ _ x - -public %assert_total -- reduces at compile time, use with extreme care! -really_believe_me : a -> b -really_believe_me x = prim__believe_me _ _ x - -namespace Builtins { - -Not : Type -> Type -Not a = a -> _|_ - -id : a -> a -id x = x - -the : (a : Type) -> a -> a -the _ = id - -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 Dec : Type -> Type where - Yes : {A : Type} -> A -> Dec A - No : {A : Type} -> (A -> _|_) -> Dec A - -data Bool = False | True - -boolElim : Bool -> |(t : a) -> |(f : a) -> a -boolElim True t e = t -boolElim False t e = e - -data so : Bool -> Type 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 Bool where - True == True = True - True == False = False - False == True = False - False == False = True - -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__sltInt x y) then LT else - GT - - -instance Ord Integer where - compare x y = if (x == y) then EQ else - if (boolOp prim__sltBigInt x y) then LT else - GT - - -instance Ord Float where - compare x y = if (x == y) then EQ else - if (boolOp prim__sltFloat x y) then LT else - GT - - -instance Ord Char where - compare x y = if (x == y) then EQ else - if (boolOp prim__sltChar x y) then LT else - GT - - -instance Ord String where - 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 : Integer -> a - -instance Num Integer where - (+) = prim__addBigInt - (-) = prim__subBigInt - (*) = prim__mulBigInt - - abs x = if x < 0 then -x else x - fromInteger = id - -instance Num Int where - (+) = prim__addInt - (-) = prim__subInt - (*) = prim__mulInt - - fromInteger = prim__truncBigInt_Int - abs x = if x < (prim__truncBigInt_Int 0) then -x else x - - -instance Num Float where - (+) = prim__addFloat - (-) = prim__subFloat - (*) = prim__mulFloat - - abs x = if x < (prim__toFloatBigInt 0) then -x else x - fromInteger = prim__toFloatBigInt - -instance Num Bits8 where - (+) = prim__addB8 - (-) = prim__subB8 - (*) = prim__mulB8 - abs = id - fromInteger = prim__truncBigInt_B8 - -instance Num Bits16 where - (+) = prim__addB16 - (-) = prim__subB16 - (*) = prim__mulB16 - abs = id - fromInteger = prim__truncBigInt_B16 - -instance Num Bits32 where - (+) = prim__addB32 - (-) = prim__subB32 - (*) = prim__mulB32 - abs = id - fromInteger = prim__truncBigInt_B32 - -instance Num Bits64 where - (+) = prim__addB64 - (-) = prim__subB64 - (*) = prim__mulB64 - abs = id - fromInteger = prim__truncBigInt_B64 - -instance Eq Bits8 where - x == y = intToBool (prim__eqB8 x y) - -instance Eq Bits16 where - x == y = intToBool (prim__eqB16 x y) - -instance Eq Bits32 where - x == y = intToBool (prim__eqB32 x y) - -instance Eq Bits64 where - x == y = intToBool (prim__eqB64 x y) - -instance Ord Bits8 where - (<) = boolOp prim__ltB8 - (>) = boolOp prim__gtB8 - (<=) = boolOp prim__lteB8 - (>=) = boolOp prim__gteB8 - compare l r = if l < r then LT - else if l > r then GT - else EQ - -instance Ord Bits16 where - (<) = boolOp prim__ltB16 - (>) = boolOp prim__gtB16 - (<=) = boolOp prim__lteB16 - (>=) = boolOp prim__gteB16 - compare l r = if l < r then LT - else if l > r then GT - else EQ - -instance Ord Bits32 where - (<) = boolOp prim__ltB32 - (>) = boolOp prim__gtB32 - (<=) = boolOp prim__lteB32 - (>=) = boolOp prim__gteB32 - compare l r = if l < r then LT - else if l > r then GT - else EQ - -instance Ord Bits64 where - (<) = boolOp prim__ltB64 - (>) = boolOp prim__gtB64 - (<=) = boolOp prim__lteB64 - (>=) = boolOp prim__gteB64 - compare l r = if l < r then LT - else if l > r then GT - else EQ - -partial -div : Integer -> Integer -> Integer -div = prim__sdivBigInt - -partial -mod : Integer -> Integer -> Integer -mod = prim__sremBigInt - - -(/) : 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/Arrow.idr b/lib/Control/Arrow.idr deleted file mode 100644 --- a/lib/Control/Arrow.idr +++ /dev/null @@ -1,40 +0,0 @@ -module Category.Arrow - -import Data.Morphisms -import Control.Category - -%access public - -infixr 3 *** -infixr 3 &&& - -class Category arr => Arrow (arr : Type -> Type -> Type) where - arrow : (a -> b) -> arr a b - first : arr a b -> arr (a, c) (b, c) - second : arr a b -> arr (c, a) (c, b) - (***) : arr a b -> arr a' b' -> arr (a, a') (b, b') - (&&&) : arr a b -> arr a b' -> arr a (b, b') - -instance Arrow Morphism where - arrow f = Mor f - first (Mor f) = Mor $ \(a, b) => (f a, b) - second (Mor f) = Mor $ \(a, b) => (a, f b) - (Mor f) *** (Mor g) = Mor $ \(a, b) => (f a, g b) - (Mor f) &&& (Mor g) = Mor $ \a => (f a, g a) - -instance Monad m => Arrow (Kleislimorphism m) where - arrow f = Kleisli (return . f) - first (Kleisli f) = Kleisli $ \(a, b) => do x <- f a - return (x, b) - - second (Kleisli f) = Kleisli $ \(a, b) => do x <- f b - return (a, x) - - (Kleisli f) *** (Kleisli g) = Kleisli $ \(a, b) => do x <- f a - y <- g b - return (x, y) - - (Kleisli f) &&& (Kleisli g) = Kleisli $ \a => do x <- f a - y <- g a - return (x, y) - diff --git a/lib/Control/Catchable.idr b/lib/Control/Catchable.idr deleted file mode 100644 --- a/lib/Control/Catchable.idr +++ /dev/null @@ -1,35 +0,0 @@ -module Prelude.Catchable - -import Prelude.List -import Prelude.Maybe -import Prelude.Either -import Control.IOExcept - -class Catchable (m : Type -> Type) t where - throw : t -> m a - catch : m a -> (t -> m a) -> m a - -instance Catchable Maybe () where - catch Nothing h = h () - catch (Just x) h = Just x - - throw () = Nothing - -instance Catchable (Either a) a where - catch (Left err) h = h err - catch (Right x) h = (Right x) - - throw x = Left x - -instance Catchable (IOExcept err) err where - catch (ioM prog) h = ioM (do p' <- prog - case p' of - Left e => let ioM he = h e in he - Right val => return (Right val)) - throw x = ioM (return (Left x)) - -instance Catchable List () where - catch [] h = h () - catch xs h = xs - - throw () = [] diff --git a/lib/Control/Category.idr b/lib/Control/Category.idr deleted file mode 100644 --- a/lib/Control/Category.idr +++ /dev/null @@ -1,21 +0,0 @@ -module Control.Category - -import Data.Morphisms - -%access public - -class Category (cat : Type -> Type -> Type) where - id : cat a a - (.) : cat b c -> cat a b -> cat a c - -instance Category Morphism where - id = Mor Builtins.id - (Mor f) . (Mor g) = Mor (f . g) - -instance Monad m => Category (Kleislimorphism m) where - id = Kleisli (return . id) - (Kleisli f) . (Kleisli g) = Kleisli $ \a => g a >>= f - -infixr 1 >>> -(>>>) : Category cat => cat a b -> cat b c -> cat a c -f >>> g = g . f diff --git a/lib/Control/IOExcept.idr b/lib/Control/IOExcept.idr deleted file mode 100644 --- a/lib/Control/IOExcept.idr +++ /dev/null @@ -1,37 +0,0 @@ -module Control.IOExcept - -import Prelude - --- An IO monad with exception handling - -data IOExcept : Type -> Type -> Type where - ioM : IO (Either err a) -> IOExcept err a - -instance Functor (IOExcept e) where - map f (ioM fn) = ioM (map (map f) fn) - -instance Applicative (IOExcept e) where - pure x = ioM (pure (pure x)) - (ioM f) <$> (ioM a) = ioM (do f' <- f; a' <- a - return (f' <$> a')) - -instance Monad (IOExcept e) where - (ioM x) >>= k = ioM (do x' <- x; - case x' of - Right a => let (ioM ka) = k a in - ka - Left err => return (Left err)) - -ioe_lift : IO a -> IOExcept err a -ioe_lift op = ioM (do op' <- op - return (Right op')) - -ioe_fail : err -> IOExcept err a -ioe_fail e = ioM (return (Left e)) - -ioe_run : IOExcept err a -> (err -> IO b) -> (a -> IO b) -> IO b -ioe_run (ioM act) err ok = do act' <- act - case act' of - Left e => err e - Right v => ok v - 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,19 +0,0 @@ -module Control.Monad.Identity - -import Prelude.Functor -import Prelude.Applicative -import Prelude.Monad - -public record Identity : Type -> Type where - Id : (runIdentity : a) -> Identity a - -instance Functor Identity where - map fn (Id a) = Id (fn a) - -instance Applicative Identity where - pure x = Id x - - (Id f) <$> (Id g) = Id (f g) - -instance Monad Identity where - (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,40 +0,0 @@ -module Control.Monad.State - -import Control.Monad.Identity -import Prelude.Monad -import Prelude.Functor - -%access public - -class Monad m => MonadState s (m : Type -> Type) where - get : m s - put : s -> m () - -record StateT : Type -> (Type -> Type) -> Type -> Type where - ST : {m : Type -> Type} -> - (runStateT : s -> m (a, s)) -> StateT s m a - -instance Functor f => Functor (StateT s f) where - map f (ST g) = ST (\st => map (mapFst f) (g st)) where - mapFst : (a -> x) -> (a, b) -> (x, b) - mapFst fn (a, b) = (fn a, b) - -instance Monad f => Applicative (StateT s f) where - pure x = ST (\st => pure (x, st)) - - (ST f) <$> (ST a) = ST (\st => do (g, r) <- f st - (b, t) <- a r - return (g b, t)) - -instance Monad m => Monad (StateT s m) where - (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 : Type -> Type -> Type -State s a = StateT s Identity a - diff --git a/lib/Data/Bits.idr b/lib/Data/Bits.idr deleted file mode 100644 --- a/lib/Data/Bits.idr +++ /dev/null @@ -1,447 +0,0 @@ -module Data.Bits - -import Prelude - -%default total - -divCeil : Nat -> Nat -> Nat -divCeil x y = case x `mod` y of - Z => x `div` y - S _ => S (x `div` y) - -nextPow2 : Nat -> Nat -nextPow2 Z = Z -nextPow2 x = if x == (2 `power` l2x) - then l2x - else S l2x - where - l2x = log2 x - -nextBytes : Nat -> Nat -nextBytes bits = (nextPow2 (bits `divCeil` 8)) - -machineTy : Nat -> Type -machineTy Z = Bits8 -machineTy (S Z) = Bits16 -machineTy (S (S Z)) = Bits32 -machineTy (S (S (S _))) = Bits64 - -bitsUsed : Nat -> Nat -bitsUsed n = 8 * (2 `power` n) - -%assert_total -natToBits' : machineTy n -> Nat -> machineTy n -natToBits' a Z = a -natToBits' {n=n} a x with (n) - -- it seems I have to manually recover the value of n here, instead of being able to reference it - natToBits' a (S x') | Z = natToBits' {n=0} (prim__addB8 a (prim__truncInt_B8 1)) x' - natToBits' a (S x') | S Z = natToBits' {n=1} (prim__addB16 a (prim__truncInt_B16 1)) x' - natToBits' a (S x') | S (S Z) = natToBits' {n=2} (prim__addB32 a (prim__truncInt_B32 1)) x' - natToBits' a (S x') | S (S (S _)) = natToBits' {n=3} (prim__addB64 a (prim__truncInt_B64 1)) x' - -natToBits : Nat -> machineTy n -natToBits {n=n} x with (n) - | Z = natToBits' {n=0} (prim__truncInt_B8 0) x - | S Z = natToBits' {n=1} (prim__truncInt_B16 0) x - | S (S Z) = natToBits' {n=2} (prim__truncInt_B32 0) x - | S (S (S _)) = natToBits' {n=3} (prim__truncInt_B64 0) x - -getPad : Nat -> machineTy n -getPad n = natToBits ((bitsUsed (nextBytes n)) - n) - -public -data Bits : Nat -> Type where - MkBits : machineTy (nextBytes n) -> Bits n - -pad8 : Nat -> (Bits8 -> Bits8 -> Bits8) -> Bits8 -> Bits8 -> Bits8 -pad8 n f x y = prim__lshrB8 (f (prim__shlB8 x pad) (prim__shlB8 y pad)) pad - where - pad = getPad {n=0} n - -pad16 : Nat -> (Bits16 -> Bits16 -> Bits16) -> Bits16 -> Bits16 -> Bits16 -pad16 n f x y = prim__lshrB16 (f (prim__shlB16 x pad) (prim__shlB16 y pad)) pad - where - pad = getPad {n=1} n - -pad32 : Nat -> (Bits32 -> Bits32 -> Bits32) -> Bits32 -> Bits32 -> Bits32 -pad32 n f x y = prim__lshrB32 (f (prim__shlB32 x pad) (prim__shlB32 y pad)) pad - where - pad = getPad {n=2} n - -pad64 : Nat -> (Bits64 -> Bits64 -> Bits64) -> Bits64 -> Bits64 -> Bits64 -pad64 n f x y = prim__lshrB64 (f (prim__shlB64 x pad) (prim__shlB64 y pad)) pad - where - pad = getPad {n=3} n - --- These versions only pad the first operand -pad8' : Nat -> (Bits8 -> Bits8 -> Bits8) -> Bits8 -> Bits8 -> Bits8 -pad8' n f x y = prim__lshrB8 (f (prim__shlB8 x pad) y) pad - where - pad = getPad {n=0} n - -pad16' : Nat -> (Bits16 -> Bits16 -> Bits16) -> Bits16 -> Bits16 -> Bits16 -pad16' n f x y = prim__lshrB16 (f (prim__shlB16 x pad) y) pad - where - pad = getPad {n=1} n - -pad32' : Nat -> (Bits32 -> Bits32 -> Bits32) -> Bits32 -> Bits32 -> Bits32 -pad32' n f x y = prim__lshrB32 (f (prim__shlB32 x pad) y) pad - where - pad = getPad {n=2} n - -pad64' : Nat -> (Bits64 -> Bits64 -> Bits64) -> Bits64 -> Bits64 -> Bits64 -pad64' n f x y = prim__lshrB64 (f (prim__shlB64 x pad) y) pad - where - pad = getPad {n=3} n - -shiftLeft' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) -shiftLeft' {n=n} x c with (nextBytes n) - | Z = pad8' n prim__shlB8 x c - | S Z = pad16' n prim__shlB16 x c - | S (S Z) = pad32' n prim__shlB32 x c - | S (S (S _)) = pad64' n prim__shlB64 x c - -public -shiftLeft : Bits n -> Bits n -> Bits n -shiftLeft (MkBits x) (MkBits y) = MkBits (shiftLeft' x y) - -shiftRightLogical' : machineTy n -> machineTy n -> machineTy n -shiftRightLogical' {n=n} x c with (n) - | Z = prim__lshrB8 x c - | S Z = prim__lshrB16 x c - | S (S Z) = prim__lshrB32 x c - | S (S (S _)) = prim__lshrB64 x c - -public -shiftRightLogical : Bits n -> Bits n -> Bits n -shiftRightLogical {n} (MkBits x) (MkBits y) - = MkBits {n} (shiftRightLogical' {n=nextBytes n} x y) - -shiftRightArithmetic' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) -shiftRightArithmetic' {n=n} x c with (nextBytes n) - | Z = pad8' n prim__ashrB8 x c - | S Z = pad16' n prim__ashrB16 x c - | S (S Z) = pad32' n prim__ashrB32 x c - | S (S (S _)) = pad64' n prim__ashrB64 x c - -public -shiftRightArithmetic : Bits n -> Bits n -> Bits n -shiftRightArithmetic (MkBits x) (MkBits y) = MkBits (shiftRightArithmetic' x y) - -and' : machineTy n -> machineTy n -> machineTy n -and' {n=n} x y with (n) - | Z = prim__andB8 x y - | S Z = prim__andB16 x y - | S (S Z) = prim__andB32 x y - | S (S (S _)) = prim__andB64 x y - -public -and : Bits n -> Bits n -> Bits n -and {n} (MkBits x) (MkBits y) = MkBits (and' {n=nextBytes n} x y) - -or' : machineTy n -> machineTy n -> machineTy n -or' {n=n} x y with (n) - | Z = prim__orB8 x y - | S Z = prim__orB16 x y - | S (S Z) = prim__orB32 x y - | S (S (S _)) = prim__orB64 x y - -public -or : Bits n -> Bits n -> Bits n -or {n} (MkBits x) (MkBits y) = MkBits (or' {n=nextBytes n} x y) - -xor' : machineTy n -> machineTy n -> machineTy n -xor' {n=n} x y with (n) - | Z = prim__xorB8 x y - | S Z = prim__xorB16 x y - | S (S Z) = prim__xorB32 x y - | S (S (S _)) = prim__xorB64 x y - -public -xor : Bits n -> Bits n -> Bits n -xor {n} (MkBits x) (MkBits y) = MkBits {n} (xor' {n=nextBytes n} x y) - -plus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) -plus' {n=n} x y with (nextBytes n) - | Z = pad8 n prim__addB8 x y - | S Z = pad16 n prim__addB16 x y - | S (S Z) = pad32 n prim__addB32 x y - | S (S (S _)) = pad64 n prim__addB64 x y - -public -plus : Bits n -> Bits n -> Bits n -plus (MkBits x) (MkBits y) = MkBits (plus' x y) - -minus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) -minus' {n=n} x y with (nextBytes n) - | Z = pad8 n prim__subB8 x y - | S Z = pad16 n prim__subB16 x y - | S (S Z) = pad32 n prim__subB32 x y - | S (S (S _)) = pad64 n prim__subB64 x y - -public -minus : Bits n -> Bits n -> Bits n -minus (MkBits x) (MkBits y) = MkBits (minus' x y) - -times' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) -times' {n=n} x y with (nextBytes n) - | Z = pad8 n prim__mulB8 x y - | S Z = pad16 n prim__mulB16 x y - | S (S Z) = pad32 n prim__mulB32 x y - | S (S (S _)) = pad64 n prim__mulB64 x y - -public -times : Bits n -> Bits n -> Bits n -times (MkBits x) (MkBits y) = MkBits (times' x y) - -partial -sdiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) -sdiv' {n=n} x y with (nextBytes n) - | Z = prim__sdivB8 x y - | S Z = prim__sdivB16 x y - | S (S Z) = prim__sdivB32 x y - | S (S (S _)) = prim__sdivB64 x y - -public partial -sdiv : Bits n -> Bits n -> Bits n -sdiv (MkBits x) (MkBits y) = MkBits (sdiv' x y) - -partial -udiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) -udiv' {n=n} x y with (nextBytes n) - | Z = prim__udivB8 x y - | S Z = prim__udivB16 x y - | S (S Z) = prim__udivB32 x y - | S (S (S _)) = prim__udivB64 x y - -public partial -udiv : Bits n -> Bits n -> Bits n -udiv (MkBits x) (MkBits y) = MkBits (udiv' x y) - -partial -srem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) -srem' {n=n} x y with (nextBytes n) - | Z = prim__sremB8 x y - | S Z = prim__sremB16 x y - | S (S Z) = prim__sremB32 x y - | S (S (S _)) = prim__sremB64 x y - -public partial -srem : Bits n -> Bits n -> Bits n -srem (MkBits x) (MkBits y) = MkBits (srem' x y) - -partial -urem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) -urem' {n=n} x y with (nextBytes n) - | Z = prim__uremB8 x y - | S Z = prim__uremB16 x y - | S (S Z) = prim__uremB32 x y - | S (S (S _)) = prim__uremB64 x y - -public partial -urem : Bits n -> Bits n -> Bits n -urem (MkBits x) (MkBits y) = MkBits (urem' x y) - --- TODO: Proofy comparisons via postulates -lt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int -lt {n=n} x y with (nextBytes n) - | Z = prim__ltB8 x y - | S Z = prim__ltB16 x y - | S (S Z) = prim__ltB32 x y - | S (S (S _)) = prim__ltB64 x y - -lte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int -lte {n=n} x y with (nextBytes n) - | Z = prim__lteB8 x y - | S Z = prim__lteB16 x y - | S (S Z) = prim__lteB32 x y - | S (S (S _)) = prim__lteB64 x y - -eq : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int -eq {n=n} x y with (nextBytes n) - | Z = prim__eqB8 x y - | S Z = prim__eqB16 x y - | S (S Z) = prim__eqB32 x y - | S (S (S _)) = prim__eqB64 x y - -gte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int -gte {n=n} x y with (nextBytes n) - | Z = prim__gteB8 x y - | S Z = prim__gteB16 x y - | S (S Z) = prim__gteB32 x y - | S (S (S _)) = prim__gteB64 x y - -gt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int -gt {n=n} x y with (nextBytes n) - | Z = prim__gtB8 x y - | S Z = prim__gtB16 x y - | S (S Z) = prim__gtB32 x y - | S (S (S _)) = prim__gtB64 x y - -instance Eq (Bits n) where - (MkBits x) == (MkBits y) = boolOp eq x y - -instance Ord (Bits n) where - (MkBits x) < (MkBits y) = boolOp lt x y - (MkBits x) <= (MkBits y) = boolOp lte x y - (MkBits x) >= (MkBits y) = boolOp gte x y - (MkBits x) > (MkBits y) = boolOp gt x y - compare (MkBits x) (MkBits y) = - if boolOp lt x y - then LT - else if boolOp eq x y - then EQ - else GT - -complement' : machineTy (nextBytes n) -> machineTy (nextBytes n) -complement' {n=n} x with (nextBytes n) - | Z = let pad = getPad {n=0} n in - prim__complB8 (x `prim__shlB8` pad) `prim__lshrB8` pad - | S Z = let pad = getPad {n=1} n in - prim__complB16 (x `prim__shlB16` pad) `prim__lshrB16` pad - | S (S Z) = let pad = getPad {n=2} n in - prim__complB32 (x `prim__shlB32` pad) `prim__lshrB32` pad - | S (S (S _)) = let pad = getPad {n=3} n in - prim__complB64 (x `prim__shlB64` pad) `prim__lshrB64` pad - -public -complement : Bits n -> Bits n -complement (MkBits x) = MkBits (complement' x) - --- TODO: Prove -%assert_total -- can't verify coverage of with block -zext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) -zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) - | (Z, Z) = believe_me x - | (Z, S Z) = believe_me (prim__zextB8_B16 (believe_me x)) - | (Z, S (S Z)) = believe_me (prim__zextB8_B32 (believe_me x)) - | (Z, S (S (S _))) = believe_me (prim__zextB8_B64 (believe_me x)) - | (S Z, S Z) = believe_me x - | (S Z, S (S Z)) = believe_me (prim__zextB16_B32 (believe_me x)) - | (S Z, S (S (S _))) = believe_me (prim__zextB16_B64 (believe_me x)) - | (S (S Z), S (S Z)) = believe_me x - | (S (S Z), S (S (S _))) = believe_me (prim__zextB32_B64 (believe_me x)) - | (S (S (S _)), S (S (S _))) = believe_me x - -public -zeroExtend : Bits n -> Bits (n+m) -zeroExtend (MkBits x) = MkBits (zext' x) - -%assert_total -intToBits' : Integer -> machineTy (nextBytes n) -intToBits' {n=n} x with (nextBytes n) - | Z = let pad = getPad {n=0} n in - prim__lshrB8 (prim__shlB8 (prim__truncBigInt_B8 x) pad) pad - | S Z = let pad = getPad {n=1} n in - prim__lshrB16 (prim__shlB16 (prim__truncBigInt_B16 x) pad) pad - | S (S Z) = let pad = getPad {n=2} n in - prim__lshrB32 (prim__shlB32 (prim__truncBigInt_B32 x) pad) pad - | S (S (S _)) = let pad = getPad {n=3} n in - prim__lshrB64 (prim__shlB64 (prim__truncBigInt_B64 x) pad) pad - -public -intToBits : Integer -> Bits n -intToBits n = MkBits (intToBits' n) - -instance Cast Integer (Bits n) where - cast = intToBits - -bitsToInt' : machineTy (nextBytes n) -> Integer -bitsToInt' {n=n} x with (nextBytes n) - | Z = prim__zextB8_BigInt x - | S Z = prim__zextB16_BigInt x - | S (S Z) = prim__zextB32_BigInt x - | S (S (S _)) = prim__zextB64_BigInt x - -public -bitsToInt : Bits n -> Integer -bitsToInt (MkBits x) = bitsToInt' x - --- Zero out the high bits of a truncated bitstring ---zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n) ---zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0) - ---instance Cast Nat (Bits n) where --- cast x = MkBits (zeroUnused (natToBits n)) - --- TODO: Prove -%assert_total -- can't verify coverage of with block -sext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) -sext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) - | (Z, Z) = let pad = getPad {n=0} n in - believe_me (prim__ashrB8 (prim__shlB8 (believe_me x) pad) pad) - | (Z, S Z) = let pad = getPad {n=0} n in - believe_me (prim__ashrB16 (prim__sextB8_B16 (prim__shlB8 (believe_me x) pad)) - (prim__zextB8_B16 pad)) - | (Z, S (S Z)) = let pad = getPad {n=0} n in - believe_me (prim__ashrB32 (prim__sextB8_B32 (prim__shlB8 (believe_me x) pad)) - (prim__zextB8_B32 pad)) - | (Z, S (S (S _))) = let pad = getPad {n=0} n in - believe_me (prim__ashrB64 (prim__sextB8_B64 (prim__shlB8 (believe_me x) pad)) - (prim__zextB8_B64 pad)) - | (S Z, S Z) = let pad = getPad {n=1} n in - believe_me (prim__ashrB16 (prim__shlB16 (believe_me x) pad) pad) - | (S Z, S (S Z)) = let pad = getPad {n=1} n in - believe_me (prim__ashrB32 (prim__sextB16_B32 (prim__shlB16 (believe_me x) pad)) - (prim__zextB16_B32 pad)) - | (S Z, S (S (S _))) = let pad = getPad {n=1} n in - believe_me (prim__ashrB64 (prim__sextB16_B64 (prim__shlB16 (believe_me x) pad)) - (prim__zextB16_B64 pad)) - | (S (S Z), S (S Z)) = let pad = getPad {n=2} n in - believe_me (prim__ashrB32 (prim__shlB32 (believe_me x) pad) pad) - | (S (S Z), S (S (S _))) = let pad = getPad {n=2} n in - believe_me (prim__ashrB64 (prim__sextB32_B64 (prim__shlB32 (believe_me x) pad)) - (prim__zextB32_B64 pad)) - | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in - believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad) - ---public ---signExtend : Bits n -> Bits (n+m) ---signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x)) - --- TODO: Prove -%assert_total -- can't verify coverage of with block -trunc' : machineTy (nextBytes (n+m)) -> machineTy (nextBytes n) -trunc' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) - | (Z, Z) = believe_me x - | (Z, S Z) = believe_me (prim__truncB16_B8 (believe_me x)) - | (Z, S (S Z)) = believe_me (prim__truncB32_B8 (believe_me x)) - | (Z, S (S (S _))) = believe_me (prim__truncB64_B8 (believe_me x)) - | (S Z, S Z) = believe_me x - | (S Z, S (S Z)) = believe_me (prim__truncB32_B16 (believe_me x)) - | (S Z, S (S (S _))) = believe_me (prim__truncB64_B16 (believe_me x)) - | (S (S Z), S (S Z)) = believe_me x - | (S (S Z), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x)) - | (S (S (S _)), S (S (S _))) = believe_me x - ---public ---truncate : Bits (n+m) -> Bits n ---truncate (MkBits x) = MkBits (zeroUnused (trunc' x)) - -public -bitAt : Fin n -> Bits n -bitAt n = intToBits 1 `shiftLeft` intToBits (cast n) - -public -getBit : Fin n -> Bits n -> Bool -getBit n x = (x `and` (bitAt n)) /= intToBits 0 - -public -setBit : Fin n -> Bits n -> Bits n -setBit n x = x `or` (bitAt n) - -public -unsetBit : Fin n -> Bits n -> Bits n -unsetBit n x = x `and` complement (bitAt n) - -bitsToStr : Bits n -> String -bitsToStr x = pack (helper last x) - where - %assert_total - helper : Fin (S n) -> Bits n -> List Char - helper fZ _ = [] - helper (fS x) b = (if getBit x b then '1' else '0') :: helper (weaken x) b - -instance Show (Bits n) where - show = bitsToStr - diff --git a/lib/Data/BoundedList.idr b/lib/Data/BoundedList.idr deleted file mode 100644 --- a/lib/Data/BoundedList.idr +++ /dev/null @@ -1,95 +0,0 @@ -module Data.BoundedList - -import Prelude - -%access public -%default total - -data BoundedList : Type -> Nat -> Type where - Nil : BoundedList a n - (::) : a -> BoundedList a n -> BoundedList a (S n) - -length : BoundedList a n -> Fin (S n) -length [] = fZ -length (x :: xs) = fS (length xs) - --------------------------------------------------------------------------------- --- Indexing into bounded lists --------------------------------------------------------------------------------- - -index : Fin (S n) -> BoundedList a n -> Maybe a -index _ [] = Nothing -index fZ (x :: _) = Just x -index (fS f) (_ :: xs) = index f xs - --------------------------------------------------------------------------------- --- Adjusting bounds --------------------------------------------------------------------------------- - -weaken : BoundedList a n -> BoundedList a (n + m) -weaken [] = [] -weaken (x :: xs) = x :: weaken xs - --------------------------------------------------------------------------------- --- Conversions to and from list --------------------------------------------------------------------------------- - -take : (n : Nat) -> List a -> BoundedList a n -take _ [] = [] -take Z _ = [] -take (S n') (x :: xs) = x :: take n' xs - -toList : BoundedList a n -> List a -toList [] = [] -toList (x :: xs) = x :: toList xs - -fromList : (xs : List a) -> BoundedList a (length xs) -fromList [] = [] -fromList (x :: xs) = x :: fromList xs - --------------------------------------------------------------------------------- --- Building (bigger) bounded lists --------------------------------------------------------------------------------- - -replicate : (n : Nat) -> a -> BoundedList a n -replicate Z _ = [] -replicate (S n) x = x :: replicate n x - --------------------------------------------------------------------------------- --- Folds --------------------------------------------------------------------------------- - -foldl : (a -> b -> a) -> a -> BoundedList b n -> a -foldl f e [] = e -foldl f e (x::xs) = foldl f (f e x) xs - -foldr : (a -> b -> b) -> b -> BoundedList a n -> b -foldr f e [] = e -foldr f e (x::xs) = f x (foldr f e xs) - --------------------------------------------------------------------------------- --- Maps --------------------------------------------------------------------------------- - -map : (a -> b) -> BoundedList a n -> BoundedList b n -map f [] = [] -map f (x :: xs) = f x :: map f xs - --------------------------------------------------------------------------------- --- Misc --------------------------------------------------------------------------------- - -%assert_total -- not sure why this isn't accepted - clearly decreasing on n -pad : (xs : BoundedList a n) -> (padding : a) -> BoundedList a n -pad {n=Z} [] _ = [] -pad {n=S n'} [] padding = padding :: (pad {n=n'} [] padding) -pad {n=S n'} (x :: xs) padding = x :: pad {n=n'} xs padding - - --------------------------------------------------------------------------------- --- Simple properties --------------------------------------------------------------------------------- - -zeroBoundIsEmpty : (xs : BoundedList a 0) -> xs = the (BoundedList a 0) [] -zeroBoundIsEmpty [] = refl -zeroBoundIsEmpty (_ :: _) impossible diff --git a/lib/Data/HVect.idr b/lib/Data/HVect.idr deleted file mode 100644 --- a/lib/Data/HVect.idr +++ /dev/null @@ -1,63 +0,0 @@ -module Data.HVect - -import Data.Vect - -%access public -%default total - -using (k : Nat, ts : Vect k Type) - data HVect : Vect k Type -> Type where - Nil : HVect [] - (::) : t -> HVect ts -> HVect (t::ts) - - index : (i : Fin k) -> HVect ts -> index i ts - index fZ (x::xs) = x - index (fS j) (x::xs) = index j xs - - deleteAt : {us : Vect (S l) Type} -> (i : Fin (S l)) -> HVect us -> HVect (deleteAt i us) - deleteAt fZ (x::xs) = xs - deleteAt {l = S m} (fS j) (x::xs) = x :: deleteAt j xs - deleteAt _ [] impossible - - replaceAt : (i : Fin k) -> t -> HVect ts -> HVect (replaceAt i t ts) - replaceAt fZ y (x::xs) = y::xs - replaceAt (fS j) y (x::xs) = x :: replaceAt j y xs - - updateAt : (i : Fin k) -> (index i ts -> t) -> HVect ts -> HVect (replaceAt i t ts) - updateAt fZ f (x::xs) = f x :: xs - updateAt (fS j) f (x::xs) = x :: updateAt j f xs - - (++) : {us : Vect l Type} -> HVect ts -> HVect us -> HVect (ts ++ us) - (++) [] ys = ys - (++) (x::xs) ys = x :: (xs ++ ys) - - instance Eq (HVect []) where - [] == [] = True - - instance (Eq t, Eq (HVect ts)) => Eq (HVect (t::ts)) where - (x::xs) == (y::ys) = x == y && xs == ys - - class Shows (k : Nat) (ts : Vect k Type) where - shows : HVect ts -> Vect k String - - instance Shows Z [] where - shows [] = [] - - instance (Show t, Shows k ts) => Shows (S k) (t::ts) where - shows (x::xs) = show x :: shows xs - - instance (Shows k ts) => Show (HVect ts) where - show xs = show (shows xs) - - get : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> HVect ts -> t - get {p = Here} (x::xs) = x - get {p = There p'} (x::xs) = get {p = p'} xs - - put : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> t -> HVect ts -> HVect ts - put {p = Here} y (x::xs) = y :: xs - put {p = There p'} y (x::xs) = x :: put {p = p'} y xs - - update : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> (t -> u) -> HVect ts -> HVect (replaceByElem ts p u) - update {p = Here} f (x::xs) = f x :: xs - update {p = There p'} f (x::xs) = x :: update {p = p'} f xs - diff --git a/lib/Data/Mod2.idr b/lib/Data/Mod2.idr deleted file mode 100644 --- a/lib/Data/Mod2.idr +++ /dev/null @@ -1,64 +0,0 @@ -module Data.Mod2 - -import Data.Bits - -%default total - --- Integers modulo 2^n -public -data Mod2 : Nat -> Type where - MkMod2 : {n : Nat} -> Bits n -> Mod2 n - -modBin : (Bits n -> Bits n -> Bits n) -> Mod2 n -> Mod2 n -> Mod2 n -modBin f (MkMod2 x) (MkMod2 y) = MkMod2 (f x y) - -modComp : (Bits n -> Bits n -> a) -> Mod2 n -> Mod2 n -> a -modComp f (MkMod2 x) (MkMod2 y) = f x y - -public partial -div : Mod2 n -> Mod2 n -> Mod2 n -div = modBin udiv - -public partial -rem : Mod2 n -> Mod2 n -> Mod2 n -rem = modBin urem - -%assert_total -public -intToMod : {n : Nat} -> Integer -> Mod2 n -intToMod {n=n} x = MkMod2 (intToBits x) - -instance Eq (Mod2 n) where - (==) = modComp (==) - -instance Ord (Mod2 n) where - (<) = modComp (<) - (<=) = modComp (<=) - (>=) = modComp (>=) - (>) = modComp (>) - compare = modComp compare - -instance Num (Mod2 n) where - (+) = modBin plus - (-) = modBin minus - (*) = modBin times - abs = id - fromInteger = intToMod - -instance Cast (Mod2 n) (Bits n) where - cast (MkMod2 x) = x - -instance Cast (Bits n) (Mod2 n) where - cast x = MkMod2 x - -modToStr : Mod2 n -> String -modToStr x = pack (reverse (helper x)) - where - %assert_total - helper : Mod2 n -> List Char - helper x = strIndex "0123456789" (prim__truncBigInt_Int (bitsToInt (cast (x `rem` 10)))) - :: (if x < 10 then [] else helper (x `div` 10)) - - -instance Show (Mod2 n) where - show = modToStr diff --git a/lib/Data/Morphisms.idr b/lib/Data/Morphisms.idr deleted file mode 100644 --- a/lib/Data/Morphisms.idr +++ /dev/null @@ -1,44 +0,0 @@ -module Data.Morphisms - -import Prelude - -%access public - -data Morphism : Type -> Type -> Type where - Mor : (a -> b) -> Morphism a b - -data Endomorphism : Type -> Type where - Endo : (a -> a) -> Endomorphism a - -data Kleislimorphism : (Type -> Type) -> Type -> Type -> Type where - Kleisli : Monad m => (a -> m b) -> Kleislimorphism m a b - -applyKleisli : Monad m => (Kleislimorphism m a b) -> a -> m b -applyKleisli (Kleisli f) a = f a - -applyMor : Morphism a b -> a -> b -applyMor (Mor f) a = f a - -applyEndo : Endomorphism a -> a -> a -applyEndo (Endo f) a = f a - -instance Functor (Morphism r) where - map f (Mor a) = Mor (f . a) - -instance Applicative (Morphism r) where - pure a = Mor $ const a - (Mor f) <$> (Mor a) = Mor $ \r => f r $ a r - -instance Monad (Morphism r) where - (Mor h) >>= f = Mor $ \r => applyMor (f $ h r) r - -instance Semigroup (Endomorphism a) where - (Endo f) <+> (Endo g) = Endo $ g . f - -instance Monoid (Endomorphism a) where - neutral = Endo id - -infixr 1 ~> - -(~>) : Type -> Type -> Type -a ~> b = Morphism a b diff --git a/lib/Data/Sign.idr b/lib/Data/Sign.idr deleted file mode 100644 --- a/lib/Data/Sign.idr +++ /dev/null @@ -1,6 +0,0 @@ -module Data.Sign - -data Sign = Plus | Minus - -class Signed t where - total sign : t -> Sign diff --git a/lib/Data/SortedMap.idr b/lib/Data/SortedMap.idr deleted file mode 100644 --- a/lib/Data/SortedMap.idr +++ /dev/null @@ -1,236 +0,0 @@ -module Data.SortedMap - -import Prelude --- TODO: write merge and split - -data Tree : Nat -> Type -> Type -> Type where - Leaf : k -> v -> Tree Z k v - Branch2 : Tree n k v -> k -> Tree n k v -> Tree (S n) k v - Branch3 : Tree n k v -> k -> Tree n k v -> k -> Tree n k v -> Tree (S n) k v - -branch4 : - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> - Tree (S (S n)) k v -branch4 a b c d e f g = - Branch2 (Branch2 a b c) d (Branch2 e f g) - -branch5 : - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> - Tree (S (S n)) k v -branch5 a b c d e f g h i = - Branch2 (Branch2 a b c) d (Branch3 e f g h i) - -branch6 : - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> - Tree (S (S n)) k v -branch6 a b c d e f g h i j k = - Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k) - -branch7 : - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> k -> - Tree n k v -> - Tree (S (S n)) k v -branch7 a b c d e f g h i j k l m = - Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m) - -merge1 : Tree n k v -> k -> Tree (S n) k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v -merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i -merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k -merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k -merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m - -merge2 : Tree (S n) k v -> k -> Tree n k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v -merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i -merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k -merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k -merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m - -merge3 : Tree (S n) k v -> k -> Tree (S n) k v -> k -> Tree n k v -> Tree (S (S n)) k v -merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i -merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k -merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k -merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m - -treeLookup : Ord k => k -> Tree n k v -> Maybe v -treeLookup k (Leaf k' v) = - if k == k' then - Just v - else - Nothing -treeLookup k (Branch2 t1 k' t2) = - if k <= k' then - treeLookup k t1 - else - treeLookup k t2 -treeLookup k (Branch3 t1 k1 t2 k2 t3) = - if k <= k1 then - treeLookup k t1 - else if k <= k2 then - treeLookup k t2 - else - treeLookup k t3 - -treeInsert' : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree n k v, k, Tree n k v) -treeInsert' k v (Leaf k' v') = - case compare k k' of - LT => Right (Leaf k v, k, Leaf k' v') - EQ => Left (Leaf k v) - GT => Right (Leaf k' v', k', Leaf k v) -treeInsert' k v (Branch2 t1 k' t2) = - if k <= k' then - case treeInsert' k v t1 of - Left t1' => Left (Branch2 t1' k' t2) - Right (a, b, c) => Left (Branch3 a b c k' t2) - else - case treeInsert' k v t2 of - Left t2' => Left (Branch2 t1 k' t2') - Right (a, b, c) => Left (Branch3 t1 k' a b c) -treeInsert' k v (Branch3 t1 k1 t2 k2 t3) = - if k <= k1 then - case treeInsert' k v t1 of - Left t1' => Left (Branch3 t1' k1 t2 k2 t3) - Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3) - else - if k <= k2 then - case treeInsert' k v t2 of - Left t2' => Left (Branch3 t1 k1 t2' k2 t3) - Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3) - else - case treeInsert' k v t3 of - Left t3' => Left (Branch3 t1 k1 t2 k2 t3') - Right (a, b, c) => Right (Branch2 t1 k2 t2, k2, Branch2 a b c) - -treeInsert : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree (S n) k v) -treeInsert k v t = - case treeInsert' k v t of - Left t' => Left t' - Right (a, b, c) => Right (Branch2 a b c) - -delType : Nat -> Type -> Type -> Type -delType Z k v = () -delType (S n) k v = Tree n k v - -treeDelete : Ord k => k -> Tree n k v -> Either (Tree n k v) (delType n k v) -treeDelete k (Leaf k' v) = - if k == k' then - Right () - else - Left (Leaf k' v) -treeDelete {n=S Z} k (Branch2 t1 k' t2) = - if k <= k' then - case treeDelete k t1 of - Left t1' => Left (Branch2 t1' k' t2) - Right () => Right t2 - else - case treeDelete k t2 of - Left t2' => Left (Branch2 t1 k' t2') - Right () => Right t1 -treeDelete {n=S Z} k (Branch3 t1 k1 t2 k2 t3) = - if k <= k1 then - case treeDelete k t1 of - Left t1' => Left (Branch3 t1' k1 t2 k2 t3) - Right () => Left (Branch2 t2 k2 t3) - else if k <= k2 then - case treeDelete k t2 of - Left t2' => Left (Branch3 t1 k1 t2' k2 t3) - Right () => Left (Branch2 t1 k1 t3) - else - case treeDelete k t3 of - Left t3' => Left (Branch3 t1 k1 t2 k2 t3') - Right () => Left (Branch2 t1 k1 t2) -treeDelete {n=S (S _)} k (Branch2 t1 k' t2) = - if k <= k' then - case treeDelete k t1 of - Left t1' => Left (Branch2 t1' k' t2) - Right t1' => - case t2 of - Branch2 a b c => Right (Branch3 t1' k' a b c) - Branch3 a b c d e => Left (branch4 t1' k' a b c d e) - else - case treeDelete k t2 of - Left t2' => Left (Branch2 t1 k' t2') - Right t2' => - case t1 of - Branch2 a b c => Right (Branch3 a b c k' t2') - Branch3 a b c d e => Left (branch4 a b c d e k' t2') -treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) = - if k <= k1 then - case treeDelete k t1 of - Left t1' => Left (Branch3 t1' k1 t2 k2 t3) - Right t1' => Left (merge1 t1' k1 t2 k2 t3) - else if k <= k2 then - case treeDelete k t2 of - Left t2' => Left (Branch3 t1 k1 t2' k2 t3) - Right t2' => Left (merge2 t1 k1 t2' k2 t3) - else - case treeDelete k t3 of - Left t3' => Left (Branch3 t1 k1 t2 k2 t3') - Right t3' => Left (merge3 t1 k1 t2 k2 t3') - --- FIXME: this is very inefficient -treeToList : Ord k => Tree n k v -> List (k, v) -treeToList (Leaf k v) = [(k, v)] -treeToList (Branch2 t1 _ t2) = treeToList t1 ++ treeToList t2 -treeToList (Branch3 t1 _ t2 _ t3) = treeToList t1 ++ treeToList t2 ++ treeToList t3 - -data SortedMap : Type -> Type -> Type where - Empty : SortedMap k v - M : (n:Nat) -> Tree n k v -> SortedMap k v - -empty : SortedMap k v -empty = Empty - -lookup : Ord k => k -> SortedMap k v -> Maybe v -lookup _ Empty = Nothing -lookup k (M _ t) = treeLookup k t - -insert : Ord k => k -> v -> SortedMap k v -> SortedMap k v -insert k v Empty = M Z (Leaf k v) -insert k v (M _ t) = - case treeInsert k v t of - Left t' => (M _ t') - Right t' => (M _ t') - -delete : Ord k => k -> SortedMap k v -> SortedMap k v -delete _ Empty = Empty -delete k (M Z t) = - case treeDelete k t of - Left t' => (M _ t') - Right () => Empty -delete k (M (S _) t) = - case treeDelete k t of - Left t' => (M _ t') - Right t' => (M _ t') - -fromList : Ord k => List (k, v) -> SortedMap k v -fromList l = foldl (flip (uncurry insert)) empty l - -toList : Ord k => SortedMap k v -> List (k, v) -toList Empty = [] -toList (M _ t) = treeToList t - -instance Functor (Tree n k) where - map f (Leaf k v) = Leaf k (f v) - map f (Branch2 t1 k t2) = Branch2 (map f t1) k (map f t2) - map f (Branch3 t1 k1 t2 k2 t3) = Branch3 (map f t1) k1 (map f t2) k2 (map f t3) - -instance Functor (SortedMap k) where - map _ Empty = Empty - map f (M n t) = M _ (map f t) diff --git a/lib/Data/SortedSet.idr b/lib/Data/SortedSet.idr deleted file mode 100644 --- a/lib/Data/SortedSet.idr +++ /dev/null @@ -1,26 +0,0 @@ -module Data.SortedSet - -import Prelude -import Data.SortedMap - --- TODO: add intersection, union, difference - -data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ()) - -empty : SortedSet k -empty = SetWrapper Data.SortedMap.empty - -insert : Ord k => k -> SortedSet k -> SortedSet k -insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m) - -delete : Ord k => k -> SortedSet k -> SortedSet k -delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m) - -contains : Ord k => k -> SortedSet k -> Bool -contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m) - -fromList : Ord k => List k -> SortedSet k -fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l)) - -toList : Ord k => SortedSet k -> List k -toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m) diff --git a/lib/Data/Vect.idr b/lib/Data/Vect.idr deleted file mode 100644 --- a/lib/Data/Vect.idr +++ /dev/null @@ -1,33 +0,0 @@ -module Data.Vect - -import Language.Reflection - -%access public -%default total - --------------------------------------------------------------------------------- --- Elem --------------------------------------------------------------------------------- - -using (xs : Vect k a) - data Elem : a -> Vect k a -> Type where - Here : Elem x (x::xs) - There : Elem x xs -> Elem x (y::xs) - -findElem : Nat -> List (TTName, Binder TT) -> TT -> Tactic -findElem Z ctxt goal = Refine "Here" `Seq` Solve -findElem (S n) ctxt goal = GoalType "Elem" (Try (Refine "Here" `Seq` Solve) (Refine "There" `Seq` (Solve `Seq` findElem n ctxt goal))) - -replaceElem : (xs : Vect k t) -> Elem x xs -> (y : t) -> (ys : Vect k t ** Elem y ys) -replaceElem (x::xs) Here y = (y :: xs ** Here) -replaceElem (x::xs) (There xinxs) y with (replaceElem xs xinxs y) - | (ys ** yinys) = (x :: ys ** There yinys) - -replaceByElem : (xs : Vect k t) -> Elem x xs -> t -> Vect k t -replaceByElem (x::xs) Here y = y :: xs -replaceByElem (x::xs) (There xinxs) y = x :: replaceByElem xs xinxs y - -mapElem : {xs : Vect k t} -> {f : t -> u} -> Elem x xs -> Elem (f x) (map f xs) -mapElem Here = Here -mapElem (There e) = There (mapElem e) - diff --git a/lib/Data/Vect/Quantifiers.idr b/lib/Data/Vect/Quantifiers.idr deleted file mode 100644 --- a/lib/Data/Vect/Quantifiers.idr +++ /dev/null @@ -1,49 +0,0 @@ -module Data.Vect.Quantifiers - -import Prelude - -data Any : (P : a -> Type) -> Vect n a -> Type where - Here : {P : a -> Type} -> {xs : Vect n a} -> P x -> Any P (x :: xs) - There : {P : a -> Type} -> {xs : Vect n a} -> Any P xs -> Any P (x :: xs) - -anyNilAbsurd : {P : a -> Type} -> Any P Nil -> _|_ -anyNilAbsurd Here impossible -anyNilAbsurd There impossible - -anyElim : {xs : Vect n a} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b -anyElim _ f (Here p) = f p -anyElim f _ (There p) = f p - -any : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a) -> Dec (Any P xs) -any _ Nil = No anyNilAbsurd -any p (x::xs) with (p x) - | Yes prf = Yes (Here prf) - | No prf = - case any p xs of - Yes prf' => Yes (There prf') - No prf' => No (anyElim prf' prf) - -data All : (P : a -> Type) -> Vect n a -> Type where - Nil : {P : a -> Type} -> All P Nil - (::) : {P : a -> Type} -> {xs : Vect n a} -> P x -> All P xs -> All P (x :: xs) - -negAnyAll : {P : a -> Type} -> {xs : Vect n a} -> Not (Any P xs) -> All (\x => Not (P x)) xs -negAnyAll {xs=Nil} _ = Nil -negAnyAll {xs=(x::xs)} f = (\x => f (Here x)) :: negAnyAll (\x => f (There x)) - -notAllHere : {P : a -> Type} -> {xs : Vect n a} -> Not (P x) -> All P (x :: xs) -> _|_ -notAllHere _ Nil impossible -notAllHere np (p :: _) = np p - -notAllThere : {P : a -> Type} -> {xs : Vect n a} -> Not (All P xs) -> All P (x :: xs) -> _|_ -notAllThere _ Nil impossible -notAllThere np (_ :: ps) = np ps - -all : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a) -> Dec (All P xs) -all _ Nil = Yes Nil -all d (x::xs) with (d x) - | No prf = No (notAllHere prf) - | Yes prf = - case all d xs of - Yes prf' => Yes (prf :: prf') - No prf' => No (notAllThere prf') diff --git a/lib/Data/ZZ.idr b/lib/Data/ZZ.idr deleted file mode 100644 --- a/lib/Data/ZZ.idr +++ /dev/null @@ -1,144 +0,0 @@ -module Data.ZZ - -import Decidable.Equality -import Data.Sign - -%default total -%access public - - --- | An integer is either a positive nat or the negated successor of a nat. --- Zero is chosen to be positive. -data ZZ = Pos Nat | NegS Nat - -instance Signed ZZ where - sign (Pos _) = Plus - sign (NegS _) = Minus - -absZ : ZZ -> Nat -absZ (Pos n) = n -absZ (NegS n) = S n - -instance Show ZZ where - show (Pos n) = show n - show (NegS n) = "-" ++ show (S n) - -negZ : ZZ -> ZZ -negZ (Pos Z) = Pos Z -negZ (Pos (S n)) = NegS n -negZ (NegS n) = Pos (S n) - -negNat : Nat -> ZZ -negNat Z = Pos Z -negNat (S n) = NegS n - -minusNatZ : Nat -> Nat -> ZZ -minusNatZ n Z = Pos n -minusNatZ Z (S m) = NegS m -minusNatZ (S n) (S m) = minusNatZ n m - -plusZ : ZZ -> ZZ -> ZZ -plusZ (Pos n) (Pos m) = Pos (n + m) -plusZ (NegS n) (NegS m) = NegS (S (n + m)) -plusZ (Pos n) (NegS m) = minusNatZ n (S m) -plusZ (NegS n) (Pos m) = minusNatZ m (S n) - -subZ : ZZ -> ZZ -> ZZ -subZ n m = plusZ n (negZ m) - -instance Eq ZZ where - (Pos n) == (Pos m) = n == m - (NegS n) == (NegS m) = n == m - _ == _ = False - - -instance Ord ZZ where - compare (Pos n) (Pos m) = compare n m - compare (NegS n) (NegS m) = compare m n - compare (Pos _) (NegS _) = GT - compare (NegS _) (Pos _) = LT - - -multZ : ZZ -> ZZ -> ZZ -multZ (Pos n) (Pos m) = Pos $ n * m -multZ (NegS n) (NegS m) = Pos $ (S n) * (S m) -multZ (NegS n) (Pos m) = negNat $ (S n) * m -multZ (Pos n) (NegS m) = negNat $ n * (S m) - -fromInt : Integer -> ZZ -fromInt n = if n < 0 - then NegS $ fromInteger {a=Nat} (-n - 1) - else Pos $ fromInteger {a=Nat} n - -instance Cast Nat ZZ where - cast n = Pos n - -instance Num ZZ where - (+) = plusZ - (-) = subZ - (*) = multZ - abs = cast . absZ - fromInteger = fromInt - -instance Cast ZZ Integer where - cast (Pos n) = cast n - cast (NegS n) = (-1) * (cast n + 1) - -instance Cast Integer ZZ where - cast = fromInteger - - --------------------------------------------------------------------------------- --- Properties --------------------------------------------------------------------------------- - -natPlusZPlus : (n : Nat) -> (m : Nat) -> (x : Nat) - -> n + m = x -> (Pos n) + (Pos m) = Pos x -natPlusZPlus n m x h = cong h - -natMultZMult : (n : Nat) -> (m : Nat) -> (x : Nat) - -> n * m = x -> (Pos n) * (Pos m) = Pos x -natMultZMult n m x h = cong h - -doubleNegElim : (z : ZZ) -> negZ (negZ z) = z -doubleNegElim (Pos Z) = refl -doubleNegElim (Pos (S n)) = refl -doubleNegElim (NegS Z) = refl -doubleNegElim (NegS (S n)) = refl - --- Injectivity -posInjective : Pos n = Pos m -> n = m -posInjective refl = refl - -negSInjective : NegS n = NegS m -> n = m -negSInjective refl = refl - -posNotNeg : Pos n = NegS m -> _|_ -posNotNeg refl impossible - --- Decidable equality -instance DecEq ZZ where - decEq (Pos n) (NegS m) = No posNotNeg - decEq (NegS n) (Pos m) = No $ negEqSym posNotNeg - decEq (Pos n) (Pos m) with (decEq n m) - | Yes p = Yes $ cong p - | No p = No $ \h => p $ posInjective h - decEq (NegS n) (NegS m) with (decEq n m) - | Yes p = Yes $ cong p - | No p = No $ \h => p $ negSInjective h - --- Plus -plusZeroLeftNeutralZ : (right : ZZ) -> 0 + right = right -plusZeroLeftNeutralZ (Pos n) = refl -plusZeroLeftNeutralZ (NegS n) = refl - -plusZeroRightNeutralZ : (left : ZZ) -> left + 0 = left -plusZeroRightNeutralZ (Pos n) = cong $ plusZeroRightNeutral n -plusZeroRightNeutralZ (NegS n) = refl - -plusCommutativeZ : (left : ZZ) -> (right : ZZ) -> (left + right = right + left) -plusCommutativeZ (Pos n) (Pos m) = cong $ plusCommutative n m -plusCommutativeZ (Pos n) (NegS m) = refl -plusCommutativeZ (NegS n) (Pos m) = refl -plusCommutativeZ (NegS n) (NegS m) = cong {f=NegS} $ cong {f=S} $ plusCommutative n m - diff --git a/lib/Debug/Trace.idr b/lib/Debug/Trace.idr deleted file mode 100644 --- a/lib/Debug/Trace.idr +++ /dev/null @@ -1,9 +0,0 @@ -module Debug.Trace - -import Prelude -import IO - -trace : String -> a -> a -trace x val = unsafePerformIO (do putStrLn x; return val) - - diff --git a/lib/Decidable/Decidable.idr b/lib/Decidable/Decidable.idr deleted file mode 100644 --- a/lib/Decidable/Decidable.idr +++ /dev/null @@ -1,24 +0,0 @@ -module Decidable.Decidable - -%access public - --------------------------------------------------------------------------------- --- Typeclass for decidable n-ary Relations --------------------------------------------------------------------------------- - -{- -This can't work yet! The class parameters must appear in the method type -signatures otherwise when defining the instances class resolution doesn't -have any clues... - -using (t : Type) - class Rel (p : t) where - total liftRel : (Type -> Type) -> Type - - class (Rel p) => Decidable (p : t) where - total decide : liftRel Dec - -using (P : Type, p : P) - data Given : Dec P -> Type where - always : Given (Yes p) --} diff --git a/lib/Decidable/Equality.idr b/lib/Decidable/Equality.idr deleted file mode 100644 --- a/lib/Decidable/Equality.idr +++ /dev/null @@ -1,174 +0,0 @@ -module Decidable.Equality - -import Prelude - --------------------------------------------------------------------------------- --- Utility lemmas --------------------------------------------------------------------------------- - -total negEqSym : {a : t} -> {b : t} -> (a = b -> _|_) -> (b = a -> _|_) -negEqSym p h = p (sym h) - - --------------------------------------------------------------------------------- --- Decidable equality --------------------------------------------------------------------------------- - -class DecEq t where - total decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2) - --------------------------------------------------------------------------------- ---- Unit --------------------------------------------------------------------------------- - -instance DecEq () where - decEq () () = Yes refl - --------------------------------------------------------------------------------- --- Booleans --------------------------------------------------------------------------------- - -total trueNotFalse : True = False -> _|_ -trueNotFalse refl impossible - -instance DecEq Bool where - decEq True True = Yes refl - decEq False False = Yes refl - decEq True False = No trueNotFalse - decEq False True = No (negEqSym trueNotFalse) - --------------------------------------------------------------------------------- --- Nat --------------------------------------------------------------------------------- - -total OnotS : Z = S n -> _|_ -OnotS refl impossible - -instance DecEq Nat where - decEq Z Z = Yes refl - decEq Z (S _) = No OnotS - decEq (S _) Z = No (negEqSym OnotS) - decEq (S n) (S m) with (decEq n m) - | Yes p = Yes $ cong p - | No p = No $ \h : (S n = S m) => p $ succInjective n m h - --------------------------------------------------------------------------------- --- Maybe --------------------------------------------------------------------------------- - -total nothingNotJust : {x : t} -> (Nothing {a = t} = Just x) -> _|_ -nothingNotJust refl impossible - -instance (DecEq t) => DecEq (Maybe t) where - decEq Nothing Nothing = Yes refl - decEq (Just x') (Just y') with (decEq x' y') - | Yes p = Yes $ cong p - | No p = No $ \h : Just x' = Just y' => p $ justInjective h - decEq Nothing (Just _) = No nothingNotJust - decEq (Just _) Nothing = No (negEqSym nothingNotJust) - --------------------------------------------------------------------------------- --- Either --------------------------------------------------------------------------------- - -total leftNotRight : {x : a} -> {y : b} -> Left {b = b} x = Right {a = a} y -> _|_ -leftNotRight refl impossible - -instance (DecEq a, DecEq b) => DecEq (Either a b) where - decEq (Left x') (Left y') with (decEq x' y') - | Yes p = Yes $ cong p - | No p = No $ \h : Left x' = Left y' => p $ leftInjective {b = b} h - decEq (Right x') (Right y') with (decEq x' y') - | Yes p = Yes $ cong p - | No p = No $ \h : Right x' = Right y' => p $ rightInjective {a = a} h - decEq (Left x') (Right y') = No leftNotRight - decEq (Right x') (Left y') = No $ negEqSym leftNotRight - --------------------------------------------------------------------------------- --- Fin --------------------------------------------------------------------------------- - -total fZNotfS : {f : Fin n} -> fZ {k = n} = fS f -> _|_ -fZNotfS refl impossible - -instance DecEq (Fin n) where - decEq fZ fZ = Yes refl - decEq fZ (fS f) = No fZNotfS - decEq (fS f) fZ = No $ negEqSym fZNotfS - decEq (fS f) (fS f') with (decEq f f') - | Yes p = Yes $ cong p - | No p = No $ \h => p $ fSinjective {f = f} {f' = f'} h - --------------------------------------------------------------------------------- --- Tuple --------------------------------------------------------------------------------- - -lemma_both_neq : {x : a, y : b, x' : c, y' : d} -> (x = x' -> _|_) -> (y = y' -> _|_) -> ((x, y) = (x', y') -> _|_) -lemma_both_neq p_x_not_x' p_y_not_y' refl = p_x_not_x' refl - -lemma_snd_neq : {x : a, y : b, y' : d} -> (x = x) -> (y = y' -> _|_) -> ((x, y) = (x, y') -> _|_) -lemma_snd_neq refl p refl = p refl - -lemma_fst_neq_snd_eq : {x : a, x' : b, y : c, y' : d} -> - (x = x' -> _|_) -> - (y = y') -> - ((x, y) = (x', y) -> _|_) -lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl - -instance (DecEq a, DecEq b) => DecEq (a, b) where - decEq (a, b) (a', b') with (decEq a a') - decEq (a, b) (a, b') | (Yes refl) with (decEq b b') - decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl - decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq) - decEq (a, b) (a', b') | (No p) with (decEq b b') - decEq (a, b) (a', b) | (No p) | (Yes refl) = No (\eq => lemma_fst_neq_snd_eq p refl eq) - decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq) - - --------------------------------------------------------------------------------- --- List --------------------------------------------------------------------------------- - -lemma_val_not_nil : {x : t, xs : List t} -> ((x :: xs) = Prelude.List.Nil {a = t} -> _|_) -lemma_val_not_nil refl impossible - -lemma_x_eq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y) -> (xs = ys -> _|_) -> ((x :: xs) = (y :: ys) -> _|_) -lemma_x_eq_xs_neq refl p refl = p refl - -lemma_x_neq_xs_eq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> _|_) -> (xs = ys) -> ((x :: xs) = (y :: ys) -> _|_) -lemma_x_neq_xs_eq p refl refl = p refl - -lemma_x_neq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> _|_) -> (xs = ys -> _|_) -> ((x :: xs) = (y :: ys) -> _|_) -lemma_x_neq_xs_neq p p' refl = p refl - -instance DecEq a => DecEq (List a) where - decEq [] [] = Yes refl - decEq (x :: xs) [] = No lemma_val_not_nil - decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil) - decEq (x :: xs) (y :: ys) with (decEq x y) - decEq (x :: xs) (x :: ys) | Yes refl with (decEq xs ys) - decEq (x :: xs) (x :: xs) | (Yes refl) | (Yes refl) = Yes refl -- maybe another yes refl - decEq (x :: xs) (x :: ys) | (Yes refl) | (No p) = No (\eq => lemma_x_eq_xs_neq refl p eq) - decEq (x :: xs) (y :: ys) | No p with (decEq xs ys) - decEq (x :: xs) (y :: xs) | (No p) | (Yes refl) = No (\eq => lemma_x_neq_xs_eq p refl eq) - decEq (x :: xs) (y :: ys) | (No p) | (No p') = No (\eq => lemma_x_neq_xs_neq p p' eq) - - --------------------------------------------------------------------------------- --- Vect --------------------------------------------------------------------------------- - -total -vectInjective1 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> x = y -vectInjective1 {x=x} {y=x} {xs=xs} {ys=xs} refl = refl - -total -vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys -vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} refl = refl - -instance DecEq a => DecEq (Vect n a) where - decEq [] [] = Yes refl - decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys) - decEq (x :: xs) (x :: xs) | (Yes refl, Yes refl) = Yes refl - decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p)) - decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p)) diff --git a/lib/Decidable/Order.idr b/lib/Decidable/Order.idr deleted file mode 100644 --- a/lib/Decidable/Order.idr +++ /dev/null @@ -1,87 +0,0 @@ -module Decidable.Order - -%access public - -{- -Doesn't work yet, see note in Decidable.idr - -import Decidable.Decidable -import Decidable.Equality - --------------------------------------------------------------------------------- --- Utility Lemmas --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- Preorders and Posets --------------------------------------------------------------------------------- - -class Preorder t (po : t -> t -> Type) where - total transitive : (a : t) -> (b : t) -> (c : t) -> po a b -> po b c -> po a c - total reflexive : (a : t) -> po a a - -class (Preorder t po) => Poset t (po : t -> t -> Type) where - total antisymmetric : (a : t) -> (b : t) -> po a b -> po b a -> a = b - --------------------------------------------------------------------------------- --- Natural numbers --------------------------------------------------------------------------------- - -data NatLTE : Nat -> Nat -> Type where - nEqn : NatLTE n n - nLTESm : NatLTE n m -> NatLTE n (S m) - -total NatLTEIsTransitive : (m : Nat) -> (n : Nat) -> (o : Nat) -> - NatLTE m n -> NatLTE n o -> - NatLTE m o -NatLTEIsTransitive m n n mLTEn (nEqn) = mLTEn -NatLTEIsTransitive m n (S o) mLTEn (nLTESm nLTEo) - = nLTESm (NatLTEIsTransitive m n o mLTEn nLTEo) - -total NatLTEIsReflexive : (n : Nat) -> NatLTE n n -NatLTEIsReflexive _ = nEqn - -instance Preorder Nat NatLTE where - transitive = NatLTEIsTransitive - reflexive = NatLTEIsReflexive - -total NatLTEIsAntisymmetric : (m : Nat) -> (n : Nat) -> - NatLTE m n -> NatLTE n m -> m = n -NatLTEIsAntisymmetric n n nEqn nEqn = refl -NatLTEIsAntisymmetric n m nEqn (nLTESm _) impossible -NatLTEIsAntisymmetric n m (nLTESm _) nEqn impossible -NatLTEIsAntisymmetric n m (nLTESm _) (nLTESm _) impossible - -instance Poset Nat NatLTE where - antisymmetric = NatLTEIsAntisymmetric - -total zeroNeverGreater : {n : Nat} -> NatLTE (S n) Z -> _|_ -zeroNeverGreater {n} (nLTESm _) impossible -zeroNeverGreater {n} nEqn impossible - -total -nGTSm : {n : Nat} -> {m : Nat} -> (NatLTE n m -> _|_) -> NatLTE n (S m) -> _|_ -nGTSm disprf (nLTESm nLTEm) = FalseElim (disprf nLTEm) -nGTSm {n} {m} disprf (nEqn) impossible - -total -decideNatLTE : (n : Nat) -> (m : Nat) -> Dec (NatLTE n m) -decideNatLTE Z Z = Yes nEqn -decideNatLTE (S x) Z = No zeroNeverGreater -decideNatLTE x (S y) with (decEq x (S y)) - | Yes eq = rewrite eq in Yes nEqn - | No _ with (decideNatLTE x y) - | Yes nLTEm = Yes (nLTESm nLTEm) - | No nGTm = No (nGTSm nGTm) - -instance Rel NatLTE where - liftRel P = (n : Nat) -> (m : Nat) -> P (NatLTE n m) - -instance Decidable NatLTE where - decide = decideNatLTE - -lte : (m : Nat) -> (n : Nat) -> Dec (NatLTE m n) -lte m n = decide {p = NatLTE} m n - --} - diff --git a/lib/IO.idr b/lib/IO.idr deleted file mode 100644 --- a/lib/IO.idr +++ /dev/null @@ -1,149 +0,0 @@ -import Prelude.List - -%access public - -abstract data PrimIO a = prim__IO a - -abstract data World = TheWorld - -abstract WorldRes : Type -> Type -WorldRes x = x - --- abstract data WorldRes a = MkWR a World - -abstract data IO a = MkIO (World -> PrimIO (WorldRes a)) - -abstract -prim_io_bind : PrimIO a -> (a -> PrimIO b) -> PrimIO b -prim_io_bind (prim__IO v) k = k v - -unsafePerformPrimIO : PrimIO a -> a --- compiled as primitive - -abstract -prim_io_return : a -> PrimIO a -prim_io_return x = prim__IO x - -data IntTy = ITChar | ITNative | IT8 | IT16 | IT32 | IT64 | IT8x16 | IT16x8 | IT32x4 | IT64x2 -data FTy = FIntT IntTy - | FFunction FTy FTy - | FFloat - | FString - | FPtr - | FAny Type - | FUnit - -FInt : FTy -FInt = FIntT ITNative - -FChar : FTy -FChar = FIntT ITChar - -FByte : FTy -FByte = FIntT IT8 - -FShort : FTy -FShort = FIntT IT16 - -FLong : FTy -FLong = FIntT IT64 - -FBits8 : FTy -FBits8 = FIntT IT8 - -FBits16 : FTy -FBits16 = FIntT IT16 - -FBits32 : FTy -FBits32 = FIntT IT32 - -FBits64 : FTy -FBits64 = FIntT IT64 - -FBits8x16 : FTy -FBits8x16 = FIntT IT8x16 - -FBits16x8 : FTy -FBits16x8 = FIntT IT16x8 - -FBits32x4 : FTy -FBits32x4 = FIntT IT32x4 - -FBits64x2 : FTy -FBits64x2 = FIntT IT64x2 - -interpFTy : FTy -> Type -interpFTy (FIntT ITNative) = Int -interpFTy (FIntT ITChar) = Char -interpFTy (FIntT IT8) = Bits8 -interpFTy (FIntT IT16) = Bits16 -interpFTy (FIntT IT32) = Bits32 -interpFTy (FIntT IT64) = Bits64 -interpFTy (FAny t) = t -interpFTy FFloat = Float -interpFTy FString = String -interpFTy FPtr = Ptr -interpFTy (FIntT IT8x16) = Bits8x16 -interpFTy (FIntT IT16x8) = Bits16x8 -interpFTy (FIntT IT32x4) = Bits32x4 -interpFTy (FIntT IT64x2) = Bits64x2 -interpFTy FUnit = () - -interpFTy (FFunction a b) = interpFTy a -> interpFTy b - -ForeignTy : (xs:List FTy) -> (t:FTy) -> Type -ForeignTy Nil rt = World -> PrimIO (interpFTy rt) -ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt - - -data Foreign : Type -> Type where - FFun : String -> (xs:List FTy) -> (t:FTy) -> - Foreign (ForeignTy xs t) - -mkForeignPrim : Foreign x -> x -mkLazyForeignPrim : Foreign x -> x --- mkForeign and mkLazyForeign compiled as primitives - -abstract -io_bind : IO a -> (a -> IO b) -> IO b -io_bind (MkIO fn) k - = MkIO (\w => prim_io_bind (fn w) - (\ b => case k b of - MkIO fkb => fkb w)) - -abstract -io_return : a -> IO a -io_return x = MkIO (\w => prim_io_return x) - -liftPrimIO : (World -> PrimIO a) -> IO a -liftPrimIO f = MkIO (\w => prim_io_bind (f w) - (\x => prim_io_return x)) - -run__IO : IO () -> PrimIO () -run__IO (MkIO f) = prim_io_bind (f TheWorld) - (\ b => prim_io_return b) - -run__provider : IO a -> PrimIO a -run__provider (MkIO f) = prim_io_bind (f TheWorld) - (\ b => prim_io_return b) - --- io_bind v (\v' => io_return v') - -prim_fork : |(thread:PrimIO ()) -> PrimIO Ptr -prim_fork x = prim_io_return prim__vm -- compiled specially - -fork : |(thread:IO ()) -> IO Ptr -fork (MkIO f) = MkIO (\w => prim_io_bind - (prim_fork (prim_io_bind (f w) - (\ x => prim_io_return x))) - (\x => prim_io_return x)) - -partial -prim_fread : Ptr -> IO String -prim_fread h = MkIO (\w => prim_io_return (prim__readString h)) - -unsafePerformIO : IO a -> a -unsafePerformIO (MkIO f) = unsafePerformPrimIO - (prim_io_bind (f TheWorld) (\ b => prim_io_return b)) - - diff --git a/lib/Language/Reflection.idr b/lib/Language/Reflection.idr deleted file mode 100644 --- a/lib/Language/Reflection.idr +++ /dev/null @@ -1,188 +0,0 @@ -module Language.Reflection - -import Prelude - -%access public - -data TTName = UN String - -- ^ User-provided name - | NS TTName (List String) - -- ^ Root, namespaces - | MN Int String - -- ^ Machine chosen names - | NErased - -- ^ Name of somethng which is never used in scope - -implicit -userSuppliedName : String -> TTName -userSuppliedName = UN - -data TTUExp = UVar Int - -- ^ universe variable - | UVal Int - -- ^ explicit universe variable - --- | Primitive constants -data Const = I Int | BI Nat | Fl Float | Ch Char | Str String - | IType | BIType | FlType | ChType | StrType - | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64 - | B8Type | B16Type | B32Type | B64Type - | PtrType | VoidType | Forgot - -abstract class ReflConst (a : Type) where - toConst : a -> Const - -instance ReflConst Int where - toConst x = I x - -instance ReflConst Nat where - toConst = BI - -instance ReflConst Float where - toConst = Fl - -instance ReflConst Char where - toConst = Ch - -instance ReflConst String where - toConst = Str - -instance ReflConst Bits8 where - toConst = B8 - -instance ReflConst Bits16 where - toConst = B16 - -instance ReflConst Bits32 where - toConst = B32 - -instance ReflConst Bits64 where - toConst = B64 - -implicit -reflectConstant: (ReflConst a) => a -> Const -reflectConstant = toConst - - --- | Types of named references -data NameType = Bound - -- ^ reference which is just bound, e.g. by intro - | Ref - -- ^ reference to a variable - | DCon Int Int - -- ^ constructor with tag and number - | TCon Int Int - -- ^ type constructor with tag and number - --- | Types annotations for bound variables in different --- binding contexts -data Binder a = Lam a - | Pi a - | Let a a - | NLet a a - | Hole a - | GHole a - | Guess a a - | PVar a - | PVTy a - - -instance Functor Binder where - map f (Lam x) = Lam (f x) - map f (Pi x) = Pi (f x) - map f (Let x y) = Let (f x) (f y) - map f (NLet x y) = NLet (f x) (f y) - map f (Hole x) = Hole (f x) - map f (GHole x) = GHole (f x) - map f (Guess x y) = Guess (f x) (f y) - map f (PVar x) = PVar (f x) - map f (PVTy x) = PVTy (f x) - -instance Foldable Binder where - foldr f z (Lam x) = f x z - foldr f z (Pi x) = f x z - foldr f z (Let x y) = f x (f y z) - foldr f z (NLet x y) = f x (f y z) - foldr f z (Hole x) = f x z - foldr f z (GHole x) = f x z - foldr f z (Guess x y) = f x (f y z) - foldr f z (PVar x) = f x z - foldr f z (PVTy x) = f x z - -instance Traversable Binder where - traverse f (Lam x) = [| Lam (f x) |] - traverse f (Pi x) = [| Pi (f x) |] - traverse f (Let x y) = [| Let (f x) (f y) |] - traverse f (NLet x y) = [| NLet (f x) (f y) |] - traverse f (Hole x) = [| Hole (f x) |] - traverse f (GHole x) = [| GHole (f x) |] - traverse f (Guess x y) = [| Guess (f x) (f y) |] - traverse f (PVar x) = [| PVar (f x) |] - traverse f (PVTy x) = [| PVTy (f x) |] - - --- | Reflection of the well typed core language -data TT = P NameType TTName TT - -- ^ named binders - | V Int - -- ^ variables - | Bind TTName (Binder TT) TT - -- ^ type annotated named bindings - | App TT TT - -- ^ (named) application of a function to a value - | TConst Const - -- ^ constants - | Proj TT Int - -- ^ argument projection; runtime only - | Erased - -- ^ erased terms - | Impossible - -- ^ impossible terms - | TType TTUExp - -- ^ types - --- | Raw terms without types -data Raw = Var TTName - | RBind TTName (Binder Raw) Raw - | RApp Raw Raw - | RType - | RForce Raw - | RConstant Const - -data Tactic = Try Tactic Tactic - -- ^ try the first tactic and resort to the second one on failure - | GoalType String Tactic - -- ^ only run if the goal has the right type - | Refine TTName - -- ^ resolve function name, find matching arguments in the - -- context and compute the proof target - | Seq Tactic Tactic - -- ^ apply both tactics in sequence - | Trivial - -- ^ intelligently construct the proof target from the context - | Solve - -- ^ infer the proof target from the context - | Intros - -- ^ introduce all variables into the context - | Intro TTName - -- ^ introduce a named variable into the context, use the - -- first one if the given name is not found - | ApplyTactic TT - -- ^ invoke the reflected rep. of another tactic - | Reflect TT - -- ^ turn a value into its reflected representation - | Fill Raw - -- ^ turn a raw value back into a term - | Exact TT - -- ^ use the given value to conclude the proof - | Focus TTName - -- ^ focus a named hole - | Rewrite TT - -- ^ rewrite using the reflected rep. of a equality proof - | LetTac TTName TT - -- ^ name a reflected term - | LetTacTy TTName TT TT - -- ^ name a reflected term and type it - | Compute - -- ^ normalise the context - diff --git a/lib/Language/Reflection/Errors.idr b/lib/Language/Reflection/Errors.idr deleted file mode 100644 --- a/lib/Language/Reflection/Errors.idr +++ /dev/null @@ -1,42 +0,0 @@ -module Language.Reflection.Errors - -import Language.Reflection - -data SourceLocation = FileLoc String Int - -data Err = Msg String - | InternalMsg String - | CantUnify Bool TT TT Err (List (TTName, TT)) Int - -- Int is 'score' - how much we did unify - -- Bool indicates recoverability, True indicates more info may make - -- unification succeed - | InfiniteUnify TTName TT (List (TTName, TT)) - | CantConvert TT TT (List (TTName, TT)) - | UnifyScope TTName TTName TT (List (TTName, TT)) - | CantInferType String - | NonFunctionType TT TT - | CantIntroduce TT - | NoSuchVariable TTName - | NoTypeDecl TTName - | NotInjective TT TT TT - | CantResolve TT - | CantResolveAlts (List String) - | IncompleteTT TT - | UniverseError - | ProgramLineComment - | Inaccessible TTName - | NonCollapsiblePostulate TTName - | AlreadyDefined TTName - | ProofSearchFail Err - | NoRewriting TT - | At SourceLocation Err - | Elaborating String TTName Err - | ProviderError String - --- | Error reports are a list of report parts -data ErrorReport = Message String - | Name TTName - | Term TT - - --- Error reports become functions in List (String, TT) -> Err -> ErrorReport diff --git a/lib/Language/Reflection/Utils.idr b/lib/Language/Reflection/Utils.idr deleted file mode 100644 --- a/lib/Language/Reflection/Utils.idr +++ /dev/null @@ -1,188 +0,0 @@ -module Language.Reflection.Utils - -import Prelude -import Language.Reflection - --------------------------------------------------------- --- Tactic construction conveniences --------------------------------------------------------- - -seq : List Tactic -> Tactic -seq [] = GoalType "This is an impossible case" Trivial -seq [t] = t -seq (t::ts) = t `Seq` seq ts - -try : List Tactic -> Tactic -try [] = GoalType "This is an impossible case" Trivial -try [t] = t -try (t::ts) = t `Try` seq ts - - --------------------------------------------------------- --- For use in tactic scripts --------------------------------------------------------- -mkPair : a -> b -> (a, b) -mkPair a b = (a, b) - - --------------------------------------------------------- --- Tools for constructing proof terms directly --------------------------------------------------------- - -getUName : TTName -> Maybe String -getUName (UN n) = Just n -getUName (NS n ns) = getUName n -getUName _ = Nothing - -unApply : TT -> (TT, List TT) -unApply t = unA t [] - where unA : TT -> List TT -> (TT, List TT) - unA (App fn arg) args = unA fn (arg::args) - unA tm args = (tm, args) - -mkApp : TT -> List TT -> TT -mkApp tm [] = tm -mkApp tm (a::as) = mkApp (App tm a) as - -binderTy : (Eq t) => Binder t -> t -binderTy (Lam t) = t -binderTy (Pi t) = t -binderTy (Let t1 t2) = t1 -binderTy (NLet t1 t2) = t1 -binderTy (Hole t) = t -binderTy (GHole t) = t -binderTy (Guess t1 t2) = t1 -binderTy (PVar t) = t -binderTy (PVTy t) = t - -instance Show TTName where - show (UN str) = "(UN " ++ str ++ ")" - show (NS n ns) = "(NS " ++ show n ++ " " ++ show ns ++ ")" - show (MN i str) = "(MN " ++ show i ++ " " ++ show str ++ ")" - show NErased = "NErased" - -instance Eq TTName where - (UN str1) == (UN str2) = str1 == str2 - (NS n ns) == (NS n' ns') = n == n' && ns == ns' - (MN i str) == (MN i' str') = i == i' && str == str' - NErased == NErased = True - x == y = False - -instance Show TTUExp where - show (UVar i) = "(UVar " ++ show i ++ ")" - show (UVal i) = "(UVal " ++ show i ++ ")" - -instance Eq TTUExp where - (UVar i) == (UVar j) = i == j - (UVal i) == (UVal j) = i == j - x == y = False - -instance Show Const where - show (I i) = "(I " ++ show i ++ ")" - show (BI n) = "(BI " ++ show n ++ ")" - show (Fl f) = "(Fl " ++ show f ++ ")" - show (Ch c) = "(Ch " ++ show c ++ ")" - show (Str str) = "(Str " ++ show str ++ ")" - show IType = "IType" - show BIType = "BIType" - show FlType = "FlType" - show ChType = "ChType" - show StrType = "StrType" - show (B8 b) = "(B8 ...)" - show (B16 b) = "(B16 ...)" - show (B32 b) = "(B32 ...)" - show (B64 b) = "(B64 ...)" - show B8Type = "B8Type" - show B16Type = "B16Type" - show B32Type = "B32Type" - show B64Type = "B64Type" - show PtrType = "PtrType" - show VoidType = "VoidType" - show Forgot = "Forgot" - -instance Eq Const where - (I i) == (I i') = i == i' - (BI n) == (BI n') = n == n' - (Fl f) == (Fl f') = f == f' - (Ch c) == (Ch c') = c == c' - (Str str) == (Str str') = str == str' - IType == IType = True - BIType == BIType = True - FlType == FlType = True - ChType == ChType = True - StrType == StrType = True - (B8 b) == (B8 b') = False -- FIXME: b == b' - (B16 b) == (B16 b') = False -- FIXME: b == b' - (B32 b) == (B32 b') = False -- FIXME: b == b' - (B64 b) == (B64 b') = False -- FIXME: b == b' - B8Type == B8Type = True - B16Type == B16Type = True - B32Type == B32Type = True - B64Type == B64Type = True - PtrType == PtrType = True - VoidType == VoidType = True - Forgot == Forgot = True - x == y = False - -instance Show NameType where - show Bound = "Bound" - show Ref = "Ref" - show (DCon t ar) = "(DCon " ++ show t ++ " " ++ show ar ++ ")" - show (TCon t ar) = "(TCon " ++ show t ++ " " ++ show ar ++ ")" - -instance Eq NameType where - Bound == Bound = True - Ref == Ref = True - (DCon t ar) == (DCon t' ar') = t == t' && ar == ar' - (TCon t ar) == (TCon t' ar') = t == t' && ar == ar' - x == y = False - -instance (Show a) => Show (Binder a) where - show (Lam t) = "(Lam " ++ show t ++ ")" - show (Pi t) = "(Pi " ++ show t ++ ")" - show (Let t1 t2) = "(Let " ++ show t1 ++ " " ++ show t2 ++ ")" - show (NLet t1 t2) = "(NLet " ++ show t1 ++ " " ++ show t2 ++ ")" - show (Hole t) = "(Hole " ++ show t ++ ")" - show (GHole t) = "(GHole " ++ show t ++ ")" - show (Guess t1 t2) = "(Guess " ++ show t1 ++ " " ++ show t2 ++ ")" - show (PVar t) = "(PVar " ++ show t ++ ")" - show (PVTy t) = "(PVTy " ++ show t ++ ")" - -instance (Eq a) => Eq (Binder a) where - (Lam t) == (Lam t') = t == t' - (Pi t) == (Pi t') = t == t' - (Let t1 t2) == (Let t1' t2') = t1 == t1' && t2 == t2' - (NLet t1 t2) == (NLet t1' t2') = t1 == t1' && t2 == t2' - (Hole t) == (Hole t') = t == t' - (GHole t) == (GHole t') = t == t' - (Guess t1 t2) == (Guess t1' t2') = t1 == t1' && t2 == t2' - (PVar t) == (PVar t') = t == t' - (PVTy t) == (PVTy t') = t == t' - x == y = False - -instance Show TT where - show = my_show - where %assert_total my_show : TT -> String - my_show (P nt n t) = "(P " ++ show nt ++ " " ++ show n ++ " " ++ show t ++ ")" - my_show (V i) = "(V " ++ show i ++ ")" - my_show (Bind n b t) = "(Bind " ++ show n ++ " " ++ show b ++ " " ++ show t ++ ")" - my_show (App t1 t2) = "(App " ++ show t1 ++ " " ++ show t2 ++ ")" - my_show (TConst c) = "(TConst " ++ show c ++ ")" - my_show (Proj tm i) = "(Proj " ++ show tm ++ " " ++ show i ++ ")" - my_show Erased = "Erased" - my_show Impossible = "Impossible" - my_show (TType u) = "(TType " ++ show u ++ ")" - -instance Eq TT where - a == b = equalp a b - where %assert_total equalp : TT -> TT -> Bool - equalp (P nt n t) (P nt' n' t') = nt == nt' && n == n' && t == t' - equalp (V i) (V i') = i == i' - equalp (Bind n b t) (Bind n' b' t') = n == n' && b == b' && t == t' - equalp (App t1 t2) (App t1' t2') = t1 == t1' && t2 == t2' - equalp (TConst c) (TConst c') = c == c' - equalp (Proj tm i) (Proj tm' i') = tm == tm' && i == i' - equalp Erased Erased = True - equalp Impossible Impossible = True - equalp (TType u) (TType u') = u == u' - equalp x y = False diff --git a/lib/Makefile b/lib/Makefile deleted file mode 100644 --- a/lib/Makefile +++ /dev/null @@ -1,17 +0,0 @@ -IDRIS := idris - -build: .PHONY - $(IDRIS) --build base.ipkg - -install: - $(IDRIS) --install base.ipkg - -clean: .PHONY - $(IDRIS) --clean base.ipkg - -rebuild: clean build - -linecount: .PHONY - find . -name '*.idr' | xargs wc -l - -.PHONY: diff --git a/lib/Network/Cgi.idr b/lib/Network/Cgi.idr deleted file mode 100644 --- a/lib/Network/Cgi.idr +++ /dev/null @@ -1,144 +0,0 @@ -module Network.Cgi - -import System - -public -Vars : Type -Vars = List (String, String) - -record CGIInfo : Type 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 : Type -> Type where - MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a - -getAction : CGI a -> CGIInfo -> IO (a, CGIInfo) -getAction (MkCGI act) = act - -instance Functor CGI where - map f (MkCGI c) = MkCGI (\s => do (a, i) <- c s - return (f a, i)) - -instance Applicative CGI where - pure v = MkCGI (\s => return (v, s)) - - (MkCGI a) <$> (MkCGI b) = MkCGI (\s => do (f, i) <- a s - (c, j) <- b i - return (f c, j)) - -instance Monad CGI where { - (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s - getAction (k (fst v)) (snd v)) -} - -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 "") - -getCgiEnv : String -> IO String -getCgiEnv key = do - val <- getEnv key - return $ maybe "" id val - -abstract -runCGI : CGI a -> IO a -runCGI prog = do - clen_in <- getCgiEnv "CONTENT_LENGTH" - let clen = prim__fromStrInt clen_in - content <- getContent clen - query <- getCgiEnv "QUERY_STRING" - cookie <- getCgiEnv "HTTP_COOKIE" - agent <- getCgiEnv "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,516 +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.Functor -import Prelude.Either -import Prelude.Vect -import Prelude.Strings -import Prelude.Chars -import Prelude.Traversable -import Prelude.Bits - -%access public -%default total - --- Show and instances - -class Show a where - partial show : a -> String - -instance Show Int where - show = prim__toStrInt - -instance Show Integer where - show = prim__toStrBigInt - -instance Show Float where - show = prim__floatToStr - -instance Show Char where - show x = strCons x "" - -instance Show String where - show = id - -instance Show Nat where - show n = show (the Integer (cast n)) - -instance Show Bool where - show True = "True" - show False = "False" - -instance Show () where - show () = "()" - -instance Show Bits8 where - show b = b8ToString b - -instance Show Bits16 where - show b = b16ToString b - -instance Show Bits32 where - show b = b32ToString b - -instance Show Bits64 where - show b = b64ToString b - -%assert_total -viewB8x16 : Bits8x16 -> (Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8) -viewB8x16 x = ( prim__indexB8x16 x (prim__truncBigInt_B32 0) - , prim__indexB8x16 x (prim__truncBigInt_B32 1) - , prim__indexB8x16 x (prim__truncBigInt_B32 2) - , prim__indexB8x16 x (prim__truncBigInt_B32 3) - , prim__indexB8x16 x (prim__truncBigInt_B32 4) - , prim__indexB8x16 x (prim__truncBigInt_B32 5) - , prim__indexB8x16 x (prim__truncBigInt_B32 6) - , prim__indexB8x16 x (prim__truncBigInt_B32 7) - , prim__indexB8x16 x (prim__truncBigInt_B32 8) - , prim__indexB8x16 x (prim__truncBigInt_B32 9) - , prim__indexB8x16 x (prim__truncBigInt_B32 10) - , prim__indexB8x16 x (prim__truncBigInt_B32 11) - , prim__indexB8x16 x (prim__truncBigInt_B32 12) - , prim__indexB8x16 x (prim__truncBigInt_B32 13) - , prim__indexB8x16 x (prim__truncBigInt_B32 14) - , prim__indexB8x16 x (prim__truncBigInt_B32 15) - ) - -instance Show Bits8x16 where - show x = - case viewB8x16 x of - (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) => - "<" ++ prim__toStrB8 a - ++ ", " ++ prim__toStrB8 b - ++ ", " ++ prim__toStrB8 c - ++ ", " ++ prim__toStrB8 d - ++ ", " ++ prim__toStrB8 e - ++ ", " ++ prim__toStrB8 f - ++ ", " ++ prim__toStrB8 g - ++ ", " ++ prim__toStrB8 h - ++ ", " ++ prim__toStrB8 i - ++ ", " ++ prim__toStrB8 j - ++ ", " ++ prim__toStrB8 k - ++ ", " ++ prim__toStrB8 l - ++ ", " ++ prim__toStrB8 m - ++ ", " ++ prim__toStrB8 n - ++ ", " ++ prim__toStrB8 o - ++ ", " ++ prim__toStrB8 p - ++ ">" - -%assert_total -viewB16x8 : Bits16x8 -> (Bits16, Bits16, Bits16, Bits16, Bits16, Bits16, Bits16, Bits16) -viewB16x8 x = ( prim__indexB16x8 x (prim__truncBigInt_B32 0) - , prim__indexB16x8 x (prim__truncBigInt_B32 1) - , prim__indexB16x8 x (prim__truncBigInt_B32 2) - , prim__indexB16x8 x (prim__truncBigInt_B32 3) - , prim__indexB16x8 x (prim__truncBigInt_B32 4) - , prim__indexB16x8 x (prim__truncBigInt_B32 5) - , prim__indexB16x8 x (prim__truncBigInt_B32 6) - , prim__indexB16x8 x (prim__truncBigInt_B32 7) - ) - -instance Show Bits16x8 where - show x = - case viewB16x8 x of - (a, b, c, d, e, f, g, h) => - "<" ++ prim__toStrB16 a - ++ ", " ++ prim__toStrB16 b - ++ ", " ++ prim__toStrB16 c - ++ ", " ++ prim__toStrB16 d - ++ ", " ++ prim__toStrB16 e - ++ ", " ++ prim__toStrB16 f - ++ ", " ++ prim__toStrB16 g - ++ ", " ++ prim__toStrB16 h - ++ ">" - -%assert_total -viewB32x4 : Bits32x4 -> (Bits32, Bits32, Bits32, Bits32) -viewB32x4 x = ( prim__indexB32x4 x (prim__truncBigInt_B32 0) - , prim__indexB32x4 x (prim__truncBigInt_B32 1) - , prim__indexB32x4 x (prim__truncBigInt_B32 2) - , prim__indexB32x4 x (prim__truncBigInt_B32 3) - ) - -instance Show Bits32x4 where - show x = - case viewB32x4 x of - (a, b, c, d) => - "<" ++ prim__toStrB32 a - ++ ", " ++ prim__toStrB32 b - ++ ", " ++ prim__toStrB32 c - ++ ", " ++ prim__toStrB32 d - ++ ">" - -%assert_total -viewB64x2 : Bits64x2 -> (Bits64, Bits64) -viewB64x2 x = ( prim__indexB64x2 x (prim__truncBigInt_B32 0) - , prim__indexB64x2 x (prim__truncBigInt_B32 1) - ) - -instance Show Bits64x2 where - show x = - case viewB64x2 x of - (a, b) => - "<" ++ prim__toStrB64 a - ++ ", " ++ prim__toStrB64 b - ++ ">" - -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' acc [] = acc - show' acc [x] = acc ++ show x - show' acc (x :: xs) = show' (acc ++ show x ++ ", ") xs - -instance Show a => Show (Vect n a) where - show xs = "[" ++ show' xs ++ "]" where - show' : Vect n a -> 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 - ----- Functor instances - -instance Functor PrimIO where - map f io = prim_io_bind io (prim_io_return . f) - -instance Functor IO where - map f io = io_bind io (\b => io_return (f b)) - -instance Functor Maybe where - map f (Just x) = Just (f x) - map f Nothing = Nothing - -instance Functor (Either e) where - map f (Left l) = Left l - map f (Right r) = Right (f r) - ----- Applicative instances - -instance Applicative PrimIO where - pure = prim_io_return - - am <$> bm = prim_io_bind am (\f => prim_io_bind bm (prim_io_return . f)) - -instance Applicative IO where - pure x = io_return x - f <$> a = io_bind f (\f' => - io_bind a (\a' => - io_return (f' a'))) - -instance Applicative Maybe where - pure = Just - - (Just f) <$> (Just a) = Just (f a) - _ <$> _ = Nothing - -instance Applicative (Either e) where - pure = Right - - (Left a) <$> _ = Left a - (Right f) <$> (Right r) = Right (f r) - (Right _) <$> (Left l) = Left l - -instance Applicative List where - pure x = [x] - - fs <$> vs = concatMap (\f => map f vs) fs - -instance Applicative (Vect k) where - pure = replicate _ - - fs <$> vs = zipWith ($) fs vs - ----- Alternative instances - -instance Alternative Maybe where - empty = Nothing - - (Just x) <|> _ = Just x - Nothing <|> v = v - -instance Alternative List where - empty = [] - - (<|>) = (++) - ----- Monad instances - -instance Monad PrimIO where - b >>= k = prim_io_bind b k - -instance Monad IO where - b >>= k = io_bind b k - -instance Monad Maybe where - Nothing >>= k = Nothing - (Just x) >>= k = k x - -instance Monad (Either e) where - (Left n) >>= _ = Left n - (Right r) >>= f = f r - -instance Monad List where - m >>= f = concatMap f m - -instance Monad (Vect n) where - m >>= f = diag (map f m) - ----- Traversable instances - -instance Traversable Maybe where - traverse f Nothing = pure Nothing - traverse f (Just x) = [| Just (f x) |] - -instance Traversable List where - traverse f [] = pure List.Nil - traverse f (x::xs) = [| List.(::) (f x) (traverse f xs) |] - -instance Traversable (Vect n) where - traverse f [] = pure Vect.Nil - traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |] - ----- some mathematical operations - -%include C "math.h" -%lib C "m" - -pow : (Num a) => a -> Nat -> a -pow x Z = 1 -pow x (S n) = x * (pow x n) - -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) - -sinh : Float -> Float -sinh x = (exp x - exp (-x)) / 2 - -cosh : Float -> Float -cosh x = (exp x + exp (-x)) / 2 - -tanh : Float -> Float -tanh x = sinh x / cosh 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 abstract -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 abstract -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 - -curry : ((a, b) -> c) -> a -> b -> c -curry f a b = f (a, b) - -uncurry : (a -> b -> c) -> (a, b) -> c -uncurry f (a, b) = f a b - -uniformB8x16 : Bits8 -> Bits8x16 -uniformB8x16 x = prim__mkB8x16 x x x x x x x x x x x x x x x x - -uniformB16x8 : Bits16 -> Bits16x8 -uniformB16x8 x = prim__mkB16x8 x x x x x x x x - -uniformB32x4 : Bits32 -> Bits32x4 -uniformB32x4 x = prim__mkB32x4 x x x x - -uniformB64x2 : Bits64 -> Bits64x2 -uniformB64x2 x = prim__mkB64x2 x x - ----- 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 = prim_fread prim__stdin - -partial -putChar : Char -> IO () -putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c) - -partial -getChar : IO Char -getChar = map cast $ mkForeign (FFun "getchar" [] FInt) - ----- some basic file handling - -abstract -data File = FHandle Ptr - -partial stdin : File -stdin = FHandle prim__stdin - -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 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 = prim_fread h - --- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String)) --- prim__vm 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 "fileEOF" [FPtr] FInt) h - -feof : File -> IO Bool -feof (FHandle h) = do eof <- do_feof h - return (not (eof == 0)) - -partial -do_ferror : Ptr -> IO Int -do_ferror h = mkForeign (FFun "fileError" [FPtr] FInt) h - -ferror : File -> IO Bool -ferror (FHandle h) = do err <- do_ferror h - return (not (err == 0)) - -partial -nullPtr : Ptr -> IO Bool -nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p - return (ok /= 0); - -partial -nullStr : String -> IO Bool -nullStr p = do ok <- mkForeign (FFun "isNull" [FString] 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 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,31 +0,0 @@ -module Prelude.Applicative - -import Builtins -import Prelude.Functor - ----- Applicative functors/Idioms - -infixl 2 <$> - -class Functor f => Applicative (f : Type -> Type) where - pure : a -> f a - (<$>) : f (a -> b) -> f a -> f b - -infixl 2 <$ -(<$) : Applicative f => f a -> f b -> f a -a <$ b = map const a <$> b - -infixl 2 $> -($>) : Applicative f => f a -> f b -> f b -a $> b = map (const id) a <$> b - -infixl 3 <|> -class Applicative f => Alternative (f : Type -> Type) where - empty : f a - (<|>) : f a -> f a -> f a - -guard : Alternative f => Bool -> f () -guard a = if a then pure () else empty - -when : Applicative f => Bool -> f () -> f () -when a f = if a then f else pure () diff --git a/lib/Prelude/Bits.idr b/lib/Prelude/Bits.idr deleted file mode 100644 --- a/lib/Prelude/Bits.idr +++ /dev/null @@ -1,56 +0,0 @@ -module Prelude.Bits - -import Prelude.Strings -import Prelude.Vect - -%access public -%default total - - -private -toHexDigit : Fin 16 -> Char -toHexDigit n = index n hexVect where - hexVect : Vect 16 Char - hexVect = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', - 'A', 'B', 'C', 'D', 'E', 'F'] - -b8ToString : Bits8 -> String -b8ToString c = pack [c1, c2] where - %assert_total -- We will only supply numbers that can fit in 4 bits - toFin16 : Bits8 -> Fin 16 - toFin16 n = if n == 0 - then fZ - else believe_me (fS (toFin16 (n-1))) - c1 = toHexDigit upper where - upper : Fin 16 - upper = toFin16 (prim__lshrB8 c 4) - c2 = toHexDigit lower where - lower : Fin 16 - lower = toFin16 (prim__andB8 c 0xf) - -b16ToString : Bits16 -> String -b16ToString c = c1 ++ c2 where - c1 = b8ToString upper where - upper : Bits8 - upper = prim__truncB16_B8 (prim__lshrB16 c 8) - c2 = b8ToString lower where - lower : Bits8 - lower = prim__truncB16_B8 c - -b32ToString : Bits32 -> String -b32ToString c = c1 ++ c2 where - c1 = b16ToString upper where - upper : Bits16 - upper = prim__truncB32_B16 (prim__lshrB32 c 16) - c2 = b16ToString lower where - lower : Bits16 - lower = prim__truncB32_B16 c - -b64ToString : Bits64 -> String -b64ToString c = c1 ++ c2 where - c1 = b32ToString upper where - upper : Bits32 - upper = prim__truncB64_B32 (prim__lshrB64 c 32) - c2 = b32ToString lower where - lower : Bits32 - lower = prim__truncB64_B32 c 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__fromStrInt - -instance Cast String Float where - cast = prim__strToFloat - -instance Cast String Integer where - cast = prim__fromStrBigInt - --- Int casts - -instance Cast Int String where - cast = prim__toStrInt - -instance Cast Int Float where - cast = prim__toFloatInt - -instance Cast Int Integer where - cast = prim__sextInt_BigInt - -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__fromFloatInt - --- Integer casts - -instance Cast Integer String where - cast = prim__toStrBigInt - --- Char casts - -instance Cast Char Int where - cast = prim__charToInt - - diff --git a/lib/Prelude/Chars.idr b/lib/Prelude/Chars.idr deleted file mode 100644 --- a/lib/Prelude/Chars.idr +++ /dev/null @@ -1,43 +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' - -isNL : Char -> Bool -isNL x = x == '\r' || x == '\n' - -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 - -isHexDigit : Char -> Bool -isHexDigit x = elem (toUpper x) hexChars where - hexChars : List Char - hexChars = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', - 'A', 'B', 'C', 'D', 'E', 'F'] - 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 @@ -{- - (c) 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,76 +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 - - --------------------------------------------------------------------------------- --- Injectivity of constructors --------------------------------------------------------------------------------- - -total leftInjective : {b : Type} -> {x : a} -> {y : a} - -> (Left {b = b} x = Left {b = b} y) -> (x = y) -leftInjective refl = refl - -total rightInjective : {a : Type} -> {x : b} -> {y : b} - -> (Right {a = a} x = Right {a = a} y) -> (x = y) -rightInjective refl = refl diff --git a/lib/Prelude/Fin.idr b/lib/Prelude/Fin.idr deleted file mode 100644 --- a/lib/Prelude/Fin.idr +++ /dev/null @@ -1,68 +0,0 @@ -module Prelude.Fin - -import Prelude.Nat -import Prelude.Either - -data Fin : Nat -> Type where - fZ : Fin (S k) - fS : Fin k -> Fin (S k) - -instance Eq (Fin n) where - (==) fZ fZ = True - (==) (fS k) (fS k') = k == k' - (==) _ _ = False - -finToNat : Fin n -> Nat -> Nat -finToNat fZ a = a -finToNat (fS x) a = finToNat x (S a) - -instance Cast (Fin n) Nat where - cast x = finToNat x Z - -finToInt : Fin n -> Integer -> Integer -finToInt fZ a = a -finToInt (fS x) a = finToInt x (a + 1) - -instance Cast (Fin n) Integer where - cast x = finToInt x 0 - -weaken : Fin n -> Fin (S n) -weaken fZ = fZ -weaken (fS k) = fS (weaken k) - -strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n) -strengthen {n = S k} fZ = Right fZ -strengthen {n = S k} (fS i) with (strengthen i) - strengthen (fS k) | Left x = Left (fS x) - strengthen (fS k) | Right x = Right (fS x) -strengthen f = Left f - -last : Fin (S n) -last {n=Z} = fZ -last {n=S _} = fS last - -total fSinjective : {f : Fin n} -> {f' : Fin n} -> (fS f = fS f') -> f = f' -fSinjective refl = refl - - --- Construct a Fin from an integer literal which must fit in the given Fin - -natToFin : Nat -> (n : Nat) -> Maybe (Fin n) -natToFin Z (S j) = Just fZ -natToFin (S k) (S j) with (natToFin k j) - | Just k' = Just (fS k') - | Nothing = Nothing -natToFin _ _ = Nothing - -integerToFin : Integer -> (n : Nat) -> Maybe (Fin n) -integerToFin x = natToFin (cast x) - -data IsJust : Maybe a -> Type where - ItIsJust : IsJust {a} (Just x) - -fromInteger : (x : Integer) -> - {default (ItIsJust _ _) - prf : (IsJust (integerToFin x n))} -> Fin n -fromInteger {n} x {prf} with (integerToFin x n) - fromInteger {n} x {prf = ItIsJust} | Just y = y - diff --git a/lib/Prelude/Foldable.idr b/lib/Prelude/Foldable.idr deleted file mode 100644 --- a/lib/Prelude/Foldable.idr +++ /dev/null @@ -1,38 +0,0 @@ -module Prelude.Foldable - -import Builtins -import Prelude.Algebra - -%access public -%default total - -class Foldable (t : Type -> Type) where - foldr : (elt -> acc -> acc) -> acc -> t elt -> acc - -foldl : Foldable t => (acc -> elt -> acc) -> acc -> t elt -> acc -foldl f z t = foldr (flip (.) . flip f) id t z - -concat : (Foldable t, Monoid a) => t a -> a -concat = foldr (<+>) neutral - -concatMap : (Foldable t, Monoid m) => (a -> m) -> t a -> m -concatMap f = foldr ((<+>) . f) neutral - -and : Foldable t => t Bool -> Bool -and = foldr (&&) True - -or : Foldable t => t Bool -> Bool -or = foldr (||) False - -any : Foldable t => (a -> Bool) -> t a -> Bool -any p = foldr ((||) . p) False - -all : Foldable t => (a -> Bool) -> t a -> Bool -all p = foldr ((&&) . p) True - -sum : (Foldable t, Num a) => t a -> a -sum = foldr (+) 0 - -product : (Foldable t, Num a) => t a -> a -product = foldr (*) 1 - diff --git a/lib/Prelude/Functor.idr b/lib/Prelude/Functor.idr deleted file mode 100644 --- a/lib/Prelude/Functor.idr +++ /dev/null @@ -1,4 +0,0 @@ -module Prelude.Functor - -class Functor (f : Type -> Type) where - map : (a -> b) -> f a -> f b diff --git a/lib/Prelude/Heap.idr b/lib/Prelude/Heap.idr deleted file mode 100644 --- a/lib/Prelude/Heap.idr +++ /dev/null @@ -1,211 +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 : Type -> Type 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 = Z -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) - -%assert_total -- relies on orderBySize doing the right thing -merge : Ord a => MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a -merge Empty right = right -merge left Empty = left -merge (Node ls ll le lr) (Node rs rl re rr) = - 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 - %assert_total -- relies on deleteMinimum making heap smaller - toList' : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> List a - toList' heap p = findMinimum heap p :: (Heap.toList (deleteMinimum heap p)) - -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 -> Type - disjointTy False = () - disjointTy True = _|_ - -total isEmptySizeZero : (h : MaxiphobicHeap a) -> (isEmpty h = True) -> size h = Z -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,620 +0,0 @@ -module Prelude.List - -import Builtins - -import Prelude.Algebra -import Prelude.Foldable -import Prelude.Functor -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 Z xs = [] -take (S n) [] = [] -take (S n) (x::xs) = x :: take n xs - -drop : Nat -> List a -> List a -drop Z 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 :: lazy (repeat x) - -replicate : Nat -> a -> List a -replicate Z x = [] -replicate (S n) x = x :: replicate n 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 - -instance Functor List where - map f [] = [] - map f (x::xs) = f x :: map f xs - --------------------------------------------------------------------------------- --- 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 --------------------------------------------------------------------------------- - -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 --------------------------------------------------------------------------------- - -instance Foldable List where - foldr f e [] = e - foldr f e (x::xs) = f x (foldr f e xs) - --------------------------------------------------------------------------------- --- Special folds --------------------------------------------------------------------------------- - -toList : Foldable t => t a -> List a -toList = foldr (::) [] - --------------------------------------------------------------------------------- --- 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' Z - 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' Z - 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) - -%assert_total -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) - -%assert_total -- can't work this out, because in the case which is lifted out - -- y::ys and x::xs are bigger than the inputs... -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 deleted file mode 100644 --- a/lib/Prelude/Maybe.idr +++ /dev/null @@ -1,88 +0,0 @@ -module Prelude.Maybe - -import Builtins -import Prelude.Algebra -import Prelude.Cast -import Prelude.Foldable - -%access public -%default total - -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 - -justInjective : {x : t} -> {y : t} -> (Just x = Just y) -> x = y -justInjective refl = refl - -lowerMaybe : Monoid a => Maybe a -> a -lowerMaybe Nothing = neutral -lowerMaybe (Just x) = x - -raiseToMaybe : (Monoid a, Eq a) => a -> Maybe a -raiseToMaybe x = if x == neutral then Nothing else Just x - --------------------------------------------------------------------------------- --- Class instances --------------------------------------------------------------------------------- - -maybe_bind : Maybe a -> (a -> Maybe b) -> Maybe b -maybe_bind Nothing k = Nothing -maybe_bind (Just x) k = k x - -instance (Eq a) => Eq (Maybe a) where - Nothing == Nothing = True - Nothing == (Just _) = False - (Just _) == Nothing = False - (Just a) == (Just b) = a == b - --- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to --- : "Any semigroup S may be --- turned into a monoid simply by adjoining an element i not in S --- and defining i+i = i and i+s = s = s+i for all s in S." - -instance (Semigroup a) => Semigroup (Maybe a) where - Nothing <+> m = m - m <+> Nothing = m - (Just m1) <+> (Just m2) = Just (m1 <+> m2) - -instance (Semigroup a) => Monoid (Maybe a) where - neutral = Nothing - -instance (Monoid a, Eq a) => Cast a (Maybe a) where - cast = raiseToMaybe - -instance (Monoid a) => Cast (Maybe a) a where - cast = lowerMaybe - -instance Foldable Maybe where - foldr _ z Nothing = z - foldr f z (Just x) = f x z diff --git a/lib/Prelude/Monad.idr b/lib/Prelude/Monad.idr deleted file mode 100644 --- a/lib/Prelude/Monad.idr +++ /dev/null @@ -1,20 +0,0 @@ -module Prelude.Monad - --- Monads and Functors - -import Builtins -import Prelude.List -import Prelude.Applicative - -%access public - -infixl 5 >>= - -class Applicative m => Monad (m : Type -> Type) where - (>>=) : m a -> (a -> m b) -> m b - -flatten : Monad m => m (m a) -> m a -flatten a = a >>= id - -return : Monad m => a -> m a -return = pure diff --git a/lib/Prelude/Nat.idr b/lib/Prelude/Nat.idr deleted file mode 100644 --- a/lib/Prelude/Nat.idr +++ /dev/null @@ -1,855 +0,0 @@ -module Prelude.Nat - -import Builtins - -import Prelude.Algebra -import Prelude.Cast - -%access public -%default total - -data Nat - = Z - | S Nat - --------------------------------------------------------------------------------- --- Syntactic tests --------------------------------------------------------------------------------- - -total isZero : Nat -> Bool -isZero Z = True -isZero (S n) = False - -total isSucc : Nat -> Bool -isSucc Z = False -isSucc (S n) = True - --------------------------------------------------------------------------------- --- Basic arithmetic functions --------------------------------------------------------------------------------- - -total plus : Nat -> Nat -> Nat -plus Z right = right -plus (S left) right = S (plus left right) - -total mult : Nat -> Nat -> Nat -mult Z right = Z -mult (S left) right = plus right $ mult left right - -%assert_total -fromIntegerNat : Integer -> Nat -fromIntegerNat 0 = Z -fromIntegerNat n = - if (n > 0) then - S (fromIntegerNat (n - 1)) - else - Z - -toIntegerNat : Nat -> Integer -toIntegerNat Z = 0 -toIntegerNat (S k) = 1 + toIntegerNat k - -total minus : Nat -> Nat -> Nat -minus Z right = Z -minus left Z = left -minus (S left) (S right) = minus left right - -total power : Nat -> Nat -> Nat -power base Z = S Z -power base (S exp) = mult base $ power base exp - -hyper : Nat -> Nat -> Nat -> Nat -hyper Z a b = S b -hyper (S Z) a Z = a -hyper (S(S Z)) a Z = Z -hyper n a Z = S Z -hyper (S pn) a (S pb) = hyper pn a (hyper (S pn) a pb) - - --------------------------------------------------------------------------------- --- Comparisons --------------------------------------------------------------------------------- - -data LTE : Nat -> Nat -> Type where - lteZero : LTE Z right - lteSucc : LTE left right -> LTE (S left) (S right) - -total GTE : Nat -> Nat -> Type -GTE left right = LTE right left - -total LT : Nat -> Nat -> Type -LT left right = LTE (S left) right - -total GT : Nat -> Nat -> Type -GT left right = LT right left - -total lte : Nat -> Nat -> Bool -lte Z right = True -lte left Z = 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 - Z == Z = True - (S l) == (S r) = l == r - _ == _ = False - -instance Cast Nat Integer where - cast = toIntegerNat - -instance Ord Nat where - compare Z Z = EQ - compare Z (S k) = LT - compare (S k) Z = GT - compare (S x) (S y) = compare x y - -instance Num Nat where - (+) = plus - (-) = minus - (*) = mult - - abs x = x - - fromInteger = fromIntegerNat - -instance Cast Integer Nat where - cast = fromInteger - -record Multiplicative : Type where - getMultiplicative : Nat -> Multiplicative - -record Additive : Type 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 Z - -instance Monoid Additive where - neutral = getAdditive Z - -instance MeetSemilattice Nat where - meet = minimum - -instance JoinSemilattice Nat where - join = maximum - -instance Lattice Nat where { } - -instance BoundedJoinSemilattice Nat where - bottom = Z - --------------------------------------------------------------------------------- --- Auxilliary notions --------------------------------------------------------------------------------- - -total pred : Nat -> Nat -pred Z = Z -pred (S n) = n - --------------------------------------------------------------------------------- --- Fibonacci and factorial --------------------------------------------------------------------------------- - -total fib : Nat -> Nat -fib Z = Z -fib (S Z) = S Z -fib (S (S n)) = fib (S n) + fib n - --------------------------------------------------------------------------------- --- GCD and LCM --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- Division and modulus --------------------------------------------------------------------------------- - -total mod : Nat -> Nat -> Nat -mod left Z = left -mod left (S right) = mod' left left right - where - total mod' : Nat -> Nat -> Nat -> Nat - mod' Z 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 Z = S left -- div by zero -div left (S right) = div' left left right - where - total div' : Nat -> Nat -> Nat -> Nat - div' Z centre right = Z - div' (S left) centre right = - if lte centre right then - Z - else - S (div' left (centre - (S right)) right) - -%assert_total -log2 : Nat -> Nat -log2 Z = Z -log2 (S Z) = Z -log2 n = S (log2 (n `div` 2)) - --------------------------------------------------------------------------------- --- 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 Z = refl -plusZeroRightNeutral (S n) = - let inductiveHypothesis = plusZeroRightNeutral n in - ?plusZeroRightNeutralStepCase - -total plusSuccRightSucc : (left : Nat) -> (right : Nat) -> - S (left + right) = left + (S right) -plusSuccRightSucc Z right = refl -plusSuccRightSucc (S left) right = - let inductiveHypothesis = plusSuccRightSucc left right in - ?plusSuccRightSuccStepCase - -total plusCommutative : (left : Nat) -> (right : Nat) -> - left + right = right + left -plusCommutative Z 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 Z 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 Z 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' Z 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 = Z -plusLeftLeftRightZero Z right p = ?plusLeftLeftRightZeroBaseCase -plusLeftLeftRightZero (S left) right p = - let inductiveHypothesis = plusLeftLeftRightZero left right in - ?plusLeftLeftRightZeroStepCase - --- Mult -total multZeroLeftZero : (right : Nat) -> Z * right = Z -multZeroLeftZero right = refl - -total multZeroRightZero : (left : Nat) -> left * Z = Z -multZeroRightZero Z = refl -multZeroRightZero (S left) = - let inductiveHypothesis = multZeroRightZero left in - ?multZeroRightZeroStepCase - -total multRightSuccPlus : (left : Nat) -> (right : Nat) -> - left * (S right) = left + (left * right) -multRightSuccPlus Z 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 Z 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 Z 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 Z 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 Z centre right = refl -multAssociative (S left) centre right = - let inductiveHypothesis = multAssociative left centre right in - ?multAssociativeStepCase - -total multOneLeftNeutral : (right : Nat) -> 1 * right = right -multOneLeftNeutral Z = refl -multOneLeftNeutral (S right) = - let inductiveHypothesis = multOneLeftNeutral right in - ?multOneLeftNeutralStepCase - -total multOneRightNeutral : (left : Nat) -> left * 1 = left -multOneRightNeutral Z = 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 = Z -minusZeroLeft right = refl - -total minusZeroRight : (left : Nat) -> left - 0 = left -minusZeroRight Z = refl -minusZeroRight (S left) = refl - -total minusZeroN : (n : Nat) -> Z = n - n -minusZeroN Z = refl -minusZeroN (S n) = minusZeroN n - -total minusOneSuccN : (n : Nat) -> S Z = (S n) - n -minusOneSuccN Z = refl -minusOneSuccN (S n) = minusOneSuccN n - -total minusSuccOne : (n : Nat) -> S n - 1 = n -minusSuccOne Z = refl -minusSuccOne (S n) = refl - -total minusPlusZero : (n : Nat) -> (m : Nat) -> n - (n + m) = Z -minusPlusZero Z m = refl -minusPlusZero (S n) m = minusPlusZero n m - -total minusMinusMinusPlus : (left : Nat) -> (centre : Nat) -> (right : Nat) -> - left - centre - right = left - (centre + right) -minusMinusMinusPlus Z Z right = refl -minusMinusMinusPlus (S left) Z right = refl -minusMinusMinusPlus Z (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 Z 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 Z Z right = refl -multDistributesOverMinusLeft (S left) Z right = - ?multDistributesOverMinusLeftBaseCase -multDistributesOverMinusLeft Z (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 Z exp' = ?multPowerPowerPlusBaseCase -multPowerPowerPlus base (S exp) exp' = - let inductiveHypothesis = multPowerPowerPlus base exp exp' in - ?multPowerPowerPlusStepCase - -total powerZeroOne : (base : Nat) -> power base 0 = S Z -powerZeroOne base = refl - -total powerOneNeutral : (base : Nat) -> power base 1 = base -powerOneNeutral Z = refl -powerOneNeutral (S base) = - let inductiveHypothesis = powerOneNeutral base in - ?powerOneNeutralStepCase - -total powerOneSuccOne : (exp : Nat) -> power 1 exp = S Z -powerOneSuccOne Z = refl -powerOneSuccOne (S exp) = - let inductiveHypothesis = powerOneSuccOne exp in - ?powerOneSuccOneStepCase - -total powerSuccSuccMult : (base : Nat) -> power base 2 = mult base base -powerSuccSuccMult Z = 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 Z = ?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 Z right = refl -minusSuccPred (S left) Z = - let inductiveHypothesis = minusSuccPred left Z 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 Z = refl -lteNTrue (S n) = lteNTrue n - -total lteSuccZeroFalse : (n : Nat) -> lte (S n) Z = False -lteSuccZeroFalse Z = refl -lteSuccZeroFalse (S n) = refl - --- Minimum and maximum -total minimumZeroZeroRight : (right : Nat) -> minimum 0 right = Z -minimumZeroZeroRight Z = refl -minimumZeroZeroRight (S right) = minimumZeroZeroRight right - -total minimumZeroZeroLeft : (left : Nat) -> minimum left 0 = Z -minimumZeroZeroLeft Z = refl -minimumZeroZeroLeft (S left) = refl - -total minimumSuccSucc : (left : Nat) -> (right : Nat) -> - minimum (S left) (S right) = S (minimum left right) -minimumSuccSucc Z Z = refl -minimumSuccSucc (S left) Z = refl -minimumSuccSucc Z (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 Z Z = refl -minimumCommutative Z (S right) = refl -minimumCommutative (S left) Z = refl -minimumCommutative (S left) (S right) = - let inductiveHypothesis = minimumCommutative left right in - ?minimumCommutativeStepCase - -total maximumZeroNRight : (right : Nat) -> maximum Z right = right -maximumZeroNRight Z = refl -maximumZeroNRight (S right) = refl - -total maximumZeroNLeft : (left : Nat) -> maximum left Z = left -maximumZeroNLeft Z = refl -maximumZeroNLeft (S left) = refl - -total maximumSuccSucc : (left : Nat) -> (right : Nat) -> - S (maximum left right) = maximum (S left) (S right) -maximumSuccSucc Z Z = refl -maximumSuccSucc (S left) Z = refl -maximumSuccSucc Z (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 Z Z = refl -maximumCommutative (S left) Z = refl -maximumCommutative Z (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 = Z -modZeroZero Z = 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 Z) 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,119 +0,0 @@ -module Prelude.Strings - -import Builtins -import Prelude.List -import Prelude.Chars -import Prelude.Cast -import Prelude.Either - --- Some more complex string operations - -data StrM : String -> Type 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) = really_believe_me $ StrCons (strHead' x p) (strTail' x p) - strM x | (Right p) = really_believe_me StrNil - --- annoyingly, we need these assert_totals because StrCons doesn't have --- a recursive argument, therefore the termination checker doesn't believe --- the string is guaranteed smaller. It makes a good point. - -%assert_total -unpack : String -> List Char -unpack s with (strM s) - unpack "" | StrNil = [] - unpack (strCons x xs) | (StrCons x xs) = 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 - -instance Semigroup String where - (<+>) = (++) - -instance Monoid String where - neutral = "" - -%assert_total -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)) - -%assert_total -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))) - -%assert_total -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 - -%assert_total -lines' : List Char -> List (List Char) -lines' s = case dropWhile isNL s of - [] => [] - s' => let (w, s'') = break isNL s' - in w :: lines' s'' - -lines : String -> List String -lines s = map pack $ lines' $ 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 - -length : String -> Nat -length = fromInteger . prim__zextInt_BigInt . prim_lenString diff --git a/lib/Prelude/Traversable.idr b/lib/Prelude/Traversable.idr deleted file mode 100644 --- a/lib/Prelude/Traversable.idr +++ /dev/null @@ -1,16 +0,0 @@ -module Prelude.Traversable - -import Prelude.Applicative -import Prelude.Foldable - -traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f () -traverse_ f = foldr (($>) . f) (pure ()) - -sequence_ : (Foldable t, Applicative f) => t (f a) -> f () -sequence_ = foldr ($>) (pure ()) - -class (Functor t, Foldable t) => Traversable (t : Type -> Type) where - traverse : Applicative f => (a -> f b) -> t a -> f (t b) - -sequence : (Traversable t, Applicative f) => t (f a) -> f (t a) -sequence = traverse id diff --git a/lib/Prelude/Vect.idr b/lib/Prelude/Vect.idr deleted file mode 100644 --- a/lib/Prelude/Vect.idr +++ /dev/null @@ -1,325 +0,0 @@ -module Prelude.Vect - -import Prelude.Fin -import Prelude.Foldable -import Prelude.Functor -import Prelude.List -import Prelude.Nat - -%access public -%default total - -infixr 7 :: - -data Vect : Nat -> Type -> Type where - Nil : Vect Z a - (::) : a -> Vect n a -> Vect (S n) a - --------------------------------------------------------------------------------- --- Indexing into vectors --------------------------------------------------------------------------------- - -tail : Vect (S n) a -> Vect n a -tail (x::xs) = xs - -head : Vect (S n) a -> a -head (x::xs) = x - -last : Vect (S n) a -> a -last (x::[]) = x -last (x::y::ys) = last $ y::ys - -init : Vect (S n) a -> Vect n a -init (x::[]) = [] -init (x::y::ys) = x :: init (y::ys) - -index : Fin n -> Vect n a -> a -index fZ (x::xs) = x -index (fS k) (x::xs) = index k xs -index fZ [] impossible - -deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a -deleteAt fZ (x::xs) = xs -deleteAt {n = S m} (fS k) (x::xs) = x :: deleteAt k xs -deleteAt _ [] impossible - -replaceAt : Fin n -> t -> Vect n t -> Vect n t -replaceAt fZ y (x::xs) = y::xs -replaceAt (fS k) y (x::xs) = x :: replaceAt k y xs - --------------------------------------------------------------------------------- --- Subvectors --------------------------------------------------------------------------------- - -take : Fin n -> Vect n a -> (p ** Vect p a) -take fZ xs = (_ ** []) -take (fS k) [] impossible -take (fS k) (x::xs) with (take k xs) - | (_ ** tail) = (_ ** x::tail) - -drop : Fin n -> Vect n a -> (p ** Vect p a) -drop fZ xs = (_ ** xs) -drop (fS k) [] impossible -drop (fS k) (x::xs) = drop k xs - --------------------------------------------------------------------------------- --- Conversion from list (toList is provided by Foldable) --------------------------------------------------------------------------------- - -fromList : (l : List a) -> Vect (length l) a -fromList [] = [] -fromList (x::xs) = x :: fromList xs - --------------------------------------------------------------------------------- --- Building (bigger) vectors --------------------------------------------------------------------------------- - -(++) : Vect m a -> Vect n a -> Vect (m + n) a -(++) [] ys = ys -(++) (x::xs) ys = x :: xs ++ ys - -replicate : (n : Nat) -> a -> Vect n a -replicate Z x = [] -replicate (S k) x = x :: replicate k x - --------------------------------------------------------------------------------- --- Zips and unzips --------------------------------------------------------------------------------- - -zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c -zipWith f [] [] = [] -zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys - -zip : Vect n a -> Vect n b -> Vect n (a, b) -zip = zipWith (\x => \y => (x,y)) - -unzip : Vect n (a, b) -> (Vect n a, Vect n b) -unzip [] = ([], []) -unzip ((l, r)::xs) with (unzip xs) - | (lefts, rights) = (l::lefts, r::rights) - --------------------------------------------------------------------------------- --- Maps --------------------------------------------------------------------------------- - -instance Functor (Vect n) where - 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 n a -> (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 --------------------------------------------------------------------------------- - -instance Foldable (Vect n) where - foldr f e [] = e - foldr f e (x::xs) = f x (foldr f e xs) - --------------------------------------------------------------------------------- --- Special folds --------------------------------------------------------------------------------- - -concat : Vect m (Vect n a) -> Vect (m * n) a -concat [] = [] -concat (v::vs) = v ++ concat vs - --------------------------------------------------------------------------------- --- Transformations --------------------------------------------------------------------------------- - -total reverse : Vect n a -> Vect n a -reverse = reverse' [] - where - total reverse' : Vect m a -> Vect n a -> Vect (m + n) a - reverse' acc [] ?= acc - reverse' acc (x::xs) ?= reverse' (x::acc) xs - -total intersperse' : a -> Vect m a -> (p ** Vect p a) -intersperse' sep [] = (_ ** []) -intersperse' sep (y::ys) with (intersperse' sep ys) - | (_ ** tail) = (_ ** sep::y::tail) - -total intersperse : a -> Vect m a -> (p ** Vect p a) -intersperse sep [] = (_ ** []) -intersperse sep (x::xs) with (intersperse' sep xs) - | (_ ** tail) = (_ ** x::tail) - --------------------------------------------------------------------------------- --- Membership tests --------------------------------------------------------------------------------- - -elemBy : (a -> a -> Bool) -> a -> Vect n a -> 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 n a -> Bool -elem = elemBy (==) - -lookupBy : (a -> a -> Bool) -> a -> Vect n (a, b) -> 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 n (a, b) -> Maybe b -lookup = lookupBy (==) - -hasAnyBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> 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 m a -> Vect n a -> Bool -hasAny = hasAnyBy (==) - --------------------------------------------------------------------------------- --- Searching with a predicate --------------------------------------------------------------------------------- - -find : (a -> Bool) -> Vect n a -> Maybe a -find p [] = Nothing -find p (x::xs) with (p x) - | True = Just x - | False = find p xs - -findIndex : (a -> Bool) -> Vect n a -> Maybe Nat -findIndex = findIndex' 0 - where - findIndex' : Nat -> (a -> Bool) -> Vect n a -> 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 m a -> (p ** Vect p Nat) -findIndices = findIndices' 0 - where - total findIndices' : Nat -> (a -> Bool) -> Vect m a -> (p ** Vect p Nat) - 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 m a -> Maybe Nat -elemIndexBy p e = findIndex $ p e - -elemIndex : Eq a => a -> Vect m a -> Maybe Nat -elemIndex = elemIndexBy (==) - -total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat) -elemIndicesBy p e = findIndices $ p e - -total elemIndices : Eq a => a -> Vect m a -> (p ** Vect p Nat) -elemIndices = elemIndicesBy (==) - --------------------------------------------------------------------------------- --- Filters --------------------------------------------------------------------------------- - -total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a) -filter p [] = ( _ ** [] ) -filter p (x::xs) with (filter p xs) - | (_ ** tail) = - if p x then - (_ ** x::tail) - else - (_ ** tail) - -nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) -nubBy = nubBy' [] - where - nubBy' : Vect m a -> (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) - 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 n a -> (p ** Vect p a) -nub = nubBy (==) - --------------------------------------------------------------------------------- --- Splitting and breaking lists --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- Predicates --------------------------------------------------------------------------------- - -isPrefixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> 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 m a -> Vect n a -> Bool -isPrefixOf = isPrefixOfBy (==) - -isSuffixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool -isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right) - -isSuffixOf : Eq a => Vect m a -> Vect n a -> Bool -isSuffixOf = isSuffixOfBy (==) - --------------------------------------------------------------------------------- --- Conversions --------------------------------------------------------------------------------- - -total maybeToVect : Maybe a -> (p ** Vect p a) -maybeToVect Nothing = (_ ** []) -maybeToVect (Just j) = (_ ** [j]) - -total vectToMaybe : Vect n a -> Maybe a -vectToMaybe [] = Nothing -vectToMaybe (x::xs) = Just x - --------------------------------------------------------------------------------- --- Misc --------------------------------------------------------------------------------- - -catMaybes : Vect n (Maybe a) -> (p ** Vect p a) -catMaybes [] = (_ ** []) -catMaybes (Nothing::xs) = catMaybes xs -catMaybes ((Just j)::xs) with (catMaybes xs) - | (_ ** tail) = (_ ** j::tail) - -diag : Vect n (Vect n a) -> Vect n a -diag [] = [] -diag ((x::xs)::xss) = x :: diag (map tail xss) - -range : Vect n (Fin n) -range {n=Z} = [] -range {n=S _} = fZ :: map fS range - --------------------------------------------------------------------------------- --- 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/Providers.idr b/lib/Providers.idr deleted file mode 100644 --- a/lib/Providers.idr +++ /dev/null @@ -1,5 +0,0 @@ -module Providers - -public -data Provider a = Provide a | Error String - diff --git a/lib/System.idr b/lib/System.idr deleted file mode 100644 --- a/lib/System.idr +++ /dev/null @@ -1,76 +0,0 @@ -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 - --- Retrieves an value from the environment, if the given key is present, --- otherwise it returns Nothing. -getEnv : String -> IO (Maybe String) -getEnv key = do - str_ptr <- getEnv' - is_nil <- nullStr str_ptr - if is_nil - then pure Nothing - else pure (Just str_ptr) - where - getEnv' : IO String - getEnv' = mkForeign (FFun "getenv" [FString] FString) key - --- Sets an environment variable with a given value. --- Returns true if the operation was successful. -setEnv : String -> String -> IO Bool -setEnv key value = do - ok <- mkForeign (FFun "setenv" [FString, FString, FInt] FInt) key value 1 - return (ok == 0) - --- Unsets an environment variable. --- Returns true if the variable was able to be unset. -unsetEnv : String -> IO Bool -unsetEnv key = do - ok <- mkForeign (FFun "unsetenv" [FString] FInt) key - return (ok == 0) - -getEnvironment : IO (List (String, String)) -getEnvironment = getAllPairs 0 [] - where - getEnvPair : Int -> IO String - getEnvPair i = mkForeign (FFun "getEnvPair" [FInt] FString) i - - splitEq : String -> (String, String) - splitEq str = - -- FIXME: There has to be a better way to split this up - let (k, v) = break (== '=') str in - let (_, v') = break (/= '=') v in - (k, v') - - getAllPairs : Int -> List String -> IO (List (String, String)) - getAllPairs n acc = do - envPair <- getEnvPair n - is_nil <- nullStr envPair - if is_nil - then return $ reverse $ map splitEq acc - else getAllPairs (n + 1) (envPair :: acc) - -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/System/Concurrency/Process.idr b/lib/System/Concurrency/Process.idr deleted file mode 100644 --- a/lib/System/Concurrency/Process.idr +++ /dev/null @@ -1,68 +0,0 @@ --- WARNING: No guarantees that this works properly yet! - -module System.Concurrency.Process - -import System.Concurrency.Raw - -%access public - -abstract -data ProcID msg = MkPID Ptr - --- Type safe message passing programs. Parameterised over the type of --- message which can be send, and the return type. - -data Process : (msgType : Type) -> Type -> Type where - lift : IO a -> Process msg a - -instance Functor (Process msg) where - map f (lift a) = lift (map f a) - -instance Applicative (Process msg) where - pure = lift . return - (lift f) <$> (lift a) = lift (f <$> a) - -instance Monad (Process msg) where - (lift io) >>= k = lift (do x <- io - case k x of - lift v => v) - -run : Process msg x -> IO x -run (lift prog) = prog - --- Get current process ID - -myID : Process msg (ProcID msg) -myID = lift (return (MkPID prim__vm)) - --- Send a message to another process - -send : ProcID msg -> msg -> Process msg () -send (MkPID p) m = lift (sendToThread p (prim__vm, m)) - --- Return whether a message is waiting in the queue - -msgWaiting : Process msg Bool -msgWaiting = lift checkMsgs - --- Receive a message - blocks if there is no message waiting - -recv : Process msg msg -recv {msg} = do (senderid, m) <- lift get - return m - where get : IO (Ptr, msg) - get = getMsg - --- receive a message, and return with the sender's process ID. - -recvWithSender : Process msg (ProcID msg, msg) -recvWithSender {msg} - = do (senderid, m) <- lift get - return (MkPID senderid, m) - where get : IO (Ptr, msg) - get = getMsg - -create : |(thread : Process msg ()) -> Process msg (ProcID msg) -create (lift p) = do ptr <- lift (fork p) - return (MkPID ptr) - diff --git a/lib/System/Concurrency/Raw.idr b/lib/System/Concurrency/Raw.idr deleted file mode 100644 --- a/lib/System/Concurrency/Raw.idr +++ /dev/null @@ -1,27 +0,0 @@ --- WARNING: No guarantees that this works properly yet! - -module System.Concurrency.Raw - --- Raw (i.e. not type safe) message passing - -import System - --- Send a message of any type to the thread with the given thread id - -sendToThread : (thread_id : Ptr) -> a -> IO () -sendToThread {a} dest val - = mkForeign (FFun "idris_sendMessage" - [FPtr, FPtr, FAny a] FUnit) prim__vm dest val - -checkMsgs : IO Bool -checkMsgs = do msgs <- mkForeign (FFun "idris_checkMessage" - [FPtr] FInt) prim__vm - return (intToBool msgs) - --- Check inbox for messages. If there are none, blocks until a message --- arrives. - -getMsg : IO a -getMsg {a} = mkForeign (FFun "idris_recvMessage" - [FPtr] (FAny a)) prim__vm - diff --git a/lib/Uninhabited.idr b/lib/Uninhabited.idr deleted file mode 100644 --- a/lib/Uninhabited.idr +++ /dev/null @@ -1,14 +0,0 @@ -module Uninhabited - -import Prelude - -class Uninhabited t where - total uninhabited : t -> _|_ - -instance Uninhabited (Fin Z) where - uninhabited fZ impossible - uninhabited (fS f) impossible - -instance Uninhabited (Z = S n) where - uninhabited refl impossible - diff --git a/lib/base.ipkg b/lib/base.ipkg deleted file mode 100644 --- a/lib/base.ipkg +++ /dev/null @@ -1,33 +0,0 @@ -package base - -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.Chars, - Prelude.Heap, Prelude.Complex, Prelude.Functor, Prelude.Foldable, - Prelude.Traversable, Prelude.Bits, - - Network.Cgi, - Debug.Trace, - - System.Concurrency.Raw, System.Concurrency.Process, - - Decidable.Equality, Decidable.Decidable, Decidable.Order, - - Uninhabited, - - Providers, - - Language.Reflection, Language.Reflection.Utils, Language.Reflection.Errors, - - Data.Morphisms, - Data.Bits, Data.Mod2, - Data.ZZ, Data.Sign, - Data.SortedMap, Data.SortedSet, Data.BoundedList, - Data.Vect, Data.HVect, Data.Vect.Quantifiers, - - Control.Monad.Identity, Control.Monad.State, Control.Category, - Control.Arrow, - Control.Catchable, Control.IOExcept diff --git a/libs/Makefile b/libs/Makefile new file mode 100644 --- /dev/null +++ b/libs/Makefile @@ -0,0 +1,20 @@ +build: .PHONY + $(MAKE) -C prelude build + $(MAKE) -C base build + $(MAKE) -C effects build + $(MAKE) -C javascript build + + +install: .PHONY + $(MAKE) -C prelude install + $(MAKE) -C base install + $(MAKE) -C effects install + $(MAKE) -C javascript install + +clean: .PHONY + $(MAKE) -C prelude clean + $(MAKE) -C base clean + $(MAKE) -C effects clean + $(MAKE) -C javascript clean + +.PHONY: diff --git a/libs/base/Control/Arrow.idr b/libs/base/Control/Arrow.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/Arrow.idr @@ -0,0 +1,40 @@ +module Category.Arrow + +import Data.Morphisms +import Control.Category + +%access public + +infixr 3 *** +infixr 3 &&& + +class Category arr => Arrow (arr : Type -> Type -> Type) where + arrow : (a -> b) -> arr a b + first : arr a b -> arr (a, c) (b, c) + second : arr a b -> arr (c, a) (c, b) + (***) : arr a b -> arr a' b' -> arr (a, a') (b, b') + (&&&) : arr a b -> arr a b' -> arr a (b, b') + +instance Arrow Morphism where + arrow f = Mor f + first (Mor f) = Mor $ \(a, b) => (f a, b) + second (Mor f) = Mor $ \(a, b) => (a, f b) + (Mor f) *** (Mor g) = Mor $ \(a, b) => (f a, g b) + (Mor f) &&& (Mor g) = Mor $ \a => (f a, g a) + +instance Monad m => Arrow (Kleislimorphism m) where + arrow f = Kleisli (return . f) + first (Kleisli f) = Kleisli $ \(a, b) => do x <- f a + return (x, b) + + second (Kleisli f) = Kleisli $ \(a, b) => do x <- f b + return (a, x) + + (Kleisli f) *** (Kleisli g) = Kleisli $ \(a, b) => do x <- f a + y <- g b + return (x, y) + + (Kleisli f) &&& (Kleisli g) = Kleisli $ \a => do x <- f a + y <- g a + return (x, y) + diff --git a/libs/base/Control/Catchable.idr b/libs/base/Control/Catchable.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/Catchable.idr @@ -0,0 +1,32 @@ +module Prelude.Catchable + +import Control.IOExcept + +class Catchable (m : Type -> Type) t where + throw : t -> m a + catch : m a -> (t -> m a) -> m a + +instance Catchable Maybe () where + catch Nothing h = h () + catch (Just x) h = Just x + + throw () = Nothing + +instance Catchable (Either a) a where + catch (Left err) h = h err + catch (Right x) h = (Right x) + + throw x = Left x + +instance Catchable (IOExcept err) err where + catch (ioM prog) h = ioM (do p' <- prog + case p' of + Left e => let ioM he = h e in he + Right val => return (Right val)) + throw x = ioM (return (Left x)) + +instance Catchable List () where + catch [] h = h () + catch xs h = xs + + throw () = [] diff --git a/libs/base/Control/Category.idr b/libs/base/Control/Category.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/Category.idr @@ -0,0 +1,21 @@ +module Control.Category + +import Data.Morphisms + +%access public + +class Category (cat : Type -> Type -> Type) where + id : cat a a + (.) : cat b c -> cat a b -> cat a c + +instance Category Morphism where + id = Mor id + (Mor f) . (Mor g) = Mor (f . g) + +instance Monad m => Category (Kleislimorphism m) where + id = Kleisli (return . id) + (Kleisli f) . (Kleisli g) = Kleisli $ \a => g a >>= f + +infixr 1 >>> +(>>>) : Category cat => cat a b -> cat b c -> cat a c +f >>> g = g . f diff --git a/libs/base/Control/IOExcept.idr b/libs/base/Control/IOExcept.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/IOExcept.idr @@ -0,0 +1,35 @@ +module Control.IOExcept + +-- An IO monad with exception handling + +data IOExcept : Type -> Type -> Type where + ioM : IO (Either err a) -> IOExcept err a + +instance Functor (IOExcept e) where + map f (ioM fn) = ioM (map (map f) fn) + +instance Applicative (IOExcept e) where + pure x = ioM (pure (pure x)) + (ioM f) <$> (ioM a) = ioM (do f' <- f; a' <- a + return (f' <$> a')) + +instance Monad (IOExcept e) where + (ioM x) >>= k = ioM (do x' <- x; + case x' of + Right a => let (ioM ka) = k a in + ka + Left err => return (Left err)) + +ioe_lift : IO a -> IOExcept err a +ioe_lift op = ioM (do op' <- op + return (Right op')) + +ioe_fail : err -> IOExcept err a +ioe_fail e = ioM (return (Left e)) + +ioe_run : IOExcept err a -> (err -> IO b) -> (a -> IO b) -> IO b +ioe_run (ioM act) err ok = do act' <- act + case act' of + Left e => err e + Right v => ok v + diff --git a/libs/base/Control/Monad/Identity.idr b/libs/base/Control/Monad/Identity.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/Monad/Identity.idr @@ -0,0 +1,15 @@ +module Control.Monad.Identity + +public record Identity : Type -> Type where + Id : (runIdentity : a) -> Identity a + +instance Functor Identity where + map fn (Id a) = Id (fn a) + +instance Applicative Identity where + pure x = Id x + + (Id f) <$> (Id g) = Id (f g) + +instance Monad Identity where + (Id x) >>= k = k x diff --git a/libs/base/Control/Monad/RWS.idr b/libs/base/Control/Monad/RWS.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/Monad/RWS.idr @@ -0,0 +1,50 @@ +module Control.Monad.RWS + +import Control.Monad.Identity +import Control.Monad.State +import Control.Monad.Writer +import Control.Monad.Reader + +%access public + +class (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m) => MonadRWS r w s (m : Type -> Type) where {} + +record RWST : Type -> Type -> Type -> (Type -> Type) -> Type -> Type where + MkRWST : {m : Type -> Type} -> + (runRWST : r -> s -> m (a, s, w)) -> RWST r w s m a + +instance Monad m => Functor (RWST r w s m) where + map f (MkRWST m) = MkRWST $ \r => \s => do (a, s', w) <- m r s + return (f a, s', w) + +instance (Monoid w, Monad m) => Applicative (RWST r w s m) where + pure a = MkRWST $ \_ => \s => return (a, s, neutral) + (MkRWST f) <$> (MkRWST v) = MkRWST $ \r => \s => do (a, s', w) <- v r s + (fn, ss, w') <- f r s + return (fn a, ss, w <+> w) + +instance (Monoid w, Monad m) => Monad (RWST r w s m) where + (MkRWST m) >>= k = MkRWST $ \r => \s => do (a, s', w) <- m r s + let MkRWST ka = k a + (b, ss, w') <- ka r s' + return (b, ss, w <+> w') + +instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where + ask = MkRWST $ \r => \s => return (r, s, neutral) + local f (MkRWST m) = MkRWST $ \r => \s => m (f r) s + +instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where + tell w = MkRWST $ \_ => \s => return ((), s, w) + listen (MkRWST m) = MkRWST $ \r => \s => do (a, s', w) <- m r s + return ((a, w), s', w) + pass (MkRWST m) = MkRWST $ \r => \s => do ((a, f), s', w) <- m r s + return (a, s', f w) + +instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where + get = MkRWST $ \_ => \s => return (s, s, neutral) + put s = MkRWST $ \_ => \_ => return ((), s, neutral) + +instance (Monoid w, Monad m) => MonadRWS r w s (RWST r w s m) where {} + +RWS : Type -> Type -> Type -> Type -> Type +RWS r w s a = RWST r w s Identity a diff --git a/libs/base/Control/Monad/Reader.idr b/libs/base/Control/Monad/Reader.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/Monad/Reader.idr @@ -0,0 +1,44 @@ +module Control.Monad.Reader + +import Builtins +import Control.Monad.Identity + +%access public + +class Monad m => MonadReader r (m : Type -> Type) where + ask : m r + local : (r -> r) -> m a -> m a + +record ReaderT : Type -> (Type -> Type) -> Type -> Type where + RD : {m : Type -> Type} -> + (runReaderT : r -> m a) -> ReaderT r m a + +liftReaderT : {m : Type -> Type} -> m a -> ReaderT r m a +liftReaderT m = RD $ const m + +instance Functor f => Functor (ReaderT r f) where + map f (RD g) = RD $ (map f) . g + +instance Applicative m => Applicative (ReaderT r m) where + pure = liftReaderT . pure + (RD f) <$> (RD v) = RD $ \r => f r <$> v r + +instance Alternative m => Alternative (ReaderT r m) where + empty = liftReaderT empty + (RD m) <|> (RD n) = RD $ \r => m r <|> n r + +instance Monad m => Monad (ReaderT r m) where + (RD f) >>= k = RD $ \r => do a <- f r + let RD ka = k a + ka r + +instance Monad m => MonadReader r (ReaderT r m) where + ask = RD return + local f (RD m) = RD $ m . f + +asks : MonadReader r m => (r -> a) -> m a +asks f = do r <- ask + return (f r) + +Reader : Type -> Type -> Type +Reader r a = ReaderT r Identity a diff --git a/libs/base/Control/Monad/State.idr b/libs/base/Control/Monad/State.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/Monad/State.idr @@ -0,0 +1,45 @@ +module Control.Monad.State + +import Control.Monad.Identity + +%access public + +class Monad m => MonadState s (m : Type -> Type) where + get : m s + put : s -> m () + +record StateT : Type -> (Type -> Type) -> Type -> Type where + ST : {m : Type -> Type} -> + (runStateT : s -> m (a, s)) -> StateT s m a + +instance Functor f => Functor (StateT s f) where + map f (ST g) = ST (\st => map (mapFst f) (g st)) where + mapFst : (a -> x) -> (a, b) -> (x, b) + mapFst fn (a, b) = (fn a, b) + +instance Monad f => Applicative (StateT s f) where + pure x = ST (\st => pure (x, st)) + + (ST f) <$> (ST a) = ST (\st => do (g, r) <- f st + (b, t) <- a r + return (g b, t)) + +instance Monad m => Monad (StateT s m) where + (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)) + +modify : MonadState s m => (s -> s) -> m () +modify f = do s <- get + put (f s) + +gets : MonadState s m => (s -> a) -> m a +gets f = do s <- get + return (f s) + +State : Type -> Type -> Type +State s a = StateT s Identity a diff --git a/libs/base/Control/Monad/Writer.idr b/libs/base/Control/Monad/Writer.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/Monad/Writer.idr @@ -0,0 +1,52 @@ +module Control.Monad.Writer + +import Builtins +import Control.Monad.Identity + +%access public + +class (Monoid w, Monad m) => MonadWriter w (m : Type -> Type) where + tell : w -> m () + listen : m a -> m (a, w) + pass : m (a, w -> w) -> m a + +record WriterT : Type -> (Type -> Type) -> Type -> Type where + WR : {m : Type -> Type} -> + (runWriterT : m (a, w)) -> WriterT w m a + +instance Functor f => Functor (WriterT w f) where + map f (WR g) = WR $ map (\w => (f . fst $ w, snd w)) g + +instance (Monoid w, Applicative m) => Applicative (WriterT w m) where + pure a = WR $ pure (a, neutral) + (WR f) <$> (WR v) = WR $ liftA2 merge f v where + merge (fn, w) (a, w') = (fn a, w <+> w') + +instance (Monoid w, Alternative m) => Alternative (WriterT w m) where + empty = WR empty + (WR m) <|> (WR n) = WR $ m <|> n + +instance (Monoid w, Monad m) => Monad (WriterT w m) where + (WR m) >>= k = WR $ do (a, w) <- m + let WR ka = k a + (b, w') <- ka + return (b, w <+> w') + +instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where + tell w = WR $ return ((), w) + listen (WR m) = WR $ do (a, w) <- m + return ((a, w), w) + pass (WR m) = WR $ do ((a, f), w) <- m + return (a, f w) + +listens : MonadWriter w m => (w -> b) -> m a -> m (a, b) +listens f m = listens' f (listen m) where + listens' f' ma = do (a, w) <- ma + return (a, f' w) + +censor : MonadWriter w m => (w -> w) -> m a -> m a +censor f m = pass $ do a <- m + return (a, f) + +Writer : Type -> Type -> Type +Writer w a = WriterT w Identity a diff --git a/libs/base/Data/Bits.idr b/libs/base/Data/Bits.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Bits.idr @@ -0,0 +1,445 @@ +module Data.Bits + +%default total + +divCeil : Nat -> Nat -> Nat +divCeil x y = case x `mod` y of + Z => x `div` y + S _ => S (x `div` y) + +nextPow2 : Nat -> Nat +nextPow2 Z = Z +nextPow2 x = if x == (2 `power` l2x) + then l2x + else S l2x + where + l2x = log2 x + +nextBytes : Nat -> Nat +nextBytes bits = (nextPow2 (bits `divCeil` 8)) + +machineTy : Nat -> Type +machineTy Z = Bits8 +machineTy (S Z) = Bits16 +machineTy (S (S Z)) = Bits32 +machineTy (S (S (S _))) = Bits64 + +bitsUsed : Nat -> Nat +bitsUsed n = 8 * (2 `power` n) + +%assert_total +natToBits' : machineTy n -> Nat -> machineTy n +natToBits' a Z = a +natToBits' {n=n} a x with (n) + -- it seems I have to manually recover the value of n here, instead of being able to reference it + natToBits' a (S x') | Z = natToBits' {n=0} (prim__addB8 a (prim__truncInt_B8 1)) x' + natToBits' a (S x') | S Z = natToBits' {n=1} (prim__addB16 a (prim__truncInt_B16 1)) x' + natToBits' a (S x') | S (S Z) = natToBits' {n=2} (prim__addB32 a (prim__truncInt_B32 1)) x' + natToBits' a (S x') | S (S (S _)) = natToBits' {n=3} (prim__addB64 a (prim__truncInt_B64 1)) x' + +natToBits : Nat -> machineTy n +natToBits {n=n} x with (n) + | Z = natToBits' {n=0} (prim__truncInt_B8 0) x + | S Z = natToBits' {n=1} (prim__truncInt_B16 0) x + | S (S Z) = natToBits' {n=2} (prim__truncInt_B32 0) x + | S (S (S _)) = natToBits' {n=3} (prim__truncInt_B64 0) x + +getPad : Nat -> machineTy n +getPad n = natToBits ((bitsUsed (nextBytes n)) - n) + +public +data Bits : Nat -> Type where + MkBits : machineTy (nextBytes n) -> Bits n + +pad8 : Nat -> (Bits8 -> Bits8 -> Bits8) -> Bits8 -> Bits8 -> Bits8 +pad8 n f x y = prim__lshrB8 (f (prim__shlB8 x pad) (prim__shlB8 y pad)) pad + where + pad = getPad {n=0} n + +pad16 : Nat -> (Bits16 -> Bits16 -> Bits16) -> Bits16 -> Bits16 -> Bits16 +pad16 n f x y = prim__lshrB16 (f (prim__shlB16 x pad) (prim__shlB16 y pad)) pad + where + pad = getPad {n=1} n + +pad32 : Nat -> (Bits32 -> Bits32 -> Bits32) -> Bits32 -> Bits32 -> Bits32 +pad32 n f x y = prim__lshrB32 (f (prim__shlB32 x pad) (prim__shlB32 y pad)) pad + where + pad = getPad {n=2} n + +pad64 : Nat -> (Bits64 -> Bits64 -> Bits64) -> Bits64 -> Bits64 -> Bits64 +pad64 n f x y = prim__lshrB64 (f (prim__shlB64 x pad) (prim__shlB64 y pad)) pad + where + pad = getPad {n=3} n + +-- These versions only pad the first operand +pad8' : Nat -> (Bits8 -> Bits8 -> Bits8) -> Bits8 -> Bits8 -> Bits8 +pad8' n f x y = prim__lshrB8 (f (prim__shlB8 x pad) y) pad + where + pad = getPad {n=0} n + +pad16' : Nat -> (Bits16 -> Bits16 -> Bits16) -> Bits16 -> Bits16 -> Bits16 +pad16' n f x y = prim__lshrB16 (f (prim__shlB16 x pad) y) pad + where + pad = getPad {n=1} n + +pad32' : Nat -> (Bits32 -> Bits32 -> Bits32) -> Bits32 -> Bits32 -> Bits32 +pad32' n f x y = prim__lshrB32 (f (prim__shlB32 x pad) y) pad + where + pad = getPad {n=2} n + +pad64' : Nat -> (Bits64 -> Bits64 -> Bits64) -> Bits64 -> Bits64 -> Bits64 +pad64' n f x y = prim__lshrB64 (f (prim__shlB64 x pad) y) pad + where + pad = getPad {n=3} n + +shiftLeft' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) +shiftLeft' {n=n} x c with (nextBytes n) + | Z = pad8' n prim__shlB8 x c + | S Z = pad16' n prim__shlB16 x c + | S (S Z) = pad32' n prim__shlB32 x c + | S (S (S _)) = pad64' n prim__shlB64 x c + +public +shiftLeft : Bits n -> Bits n -> Bits n +shiftLeft (MkBits x) (MkBits y) = MkBits (shiftLeft' x y) + +shiftRightLogical' : machineTy n -> machineTy n -> machineTy n +shiftRightLogical' {n=n} x c with (n) + | Z = prim__lshrB8 x c + | S Z = prim__lshrB16 x c + | S (S Z) = prim__lshrB32 x c + | S (S (S _)) = prim__lshrB64 x c + +public +shiftRightLogical : Bits n -> Bits n -> Bits n +shiftRightLogical {n} (MkBits x) (MkBits y) + = MkBits {n} (shiftRightLogical' {n=nextBytes n} x y) + +shiftRightArithmetic' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) +shiftRightArithmetic' {n=n} x c with (nextBytes n) + | Z = pad8' n prim__ashrB8 x c + | S Z = pad16' n prim__ashrB16 x c + | S (S Z) = pad32' n prim__ashrB32 x c + | S (S (S _)) = pad64' n prim__ashrB64 x c + +public +shiftRightArithmetic : Bits n -> Bits n -> Bits n +shiftRightArithmetic (MkBits x) (MkBits y) = MkBits (shiftRightArithmetic' x y) + +and' : machineTy n -> machineTy n -> machineTy n +and' {n=n} x y with (n) + | Z = prim__andB8 x y + | S Z = prim__andB16 x y + | S (S Z) = prim__andB32 x y + | S (S (S _)) = prim__andB64 x y + +public +and : Bits n -> Bits n -> Bits n +and {n} (MkBits x) (MkBits y) = MkBits (and' {n=nextBytes n} x y) + +or' : machineTy n -> machineTy n -> machineTy n +or' {n=n} x y with (n) + | Z = prim__orB8 x y + | S Z = prim__orB16 x y + | S (S Z) = prim__orB32 x y + | S (S (S _)) = prim__orB64 x y + +public +or : Bits n -> Bits n -> Bits n +or {n} (MkBits x) (MkBits y) = MkBits (or' {n=nextBytes n} x y) + +xor' : machineTy n -> machineTy n -> machineTy n +xor' {n=n} x y with (n) + | Z = prim__xorB8 x y + | S Z = prim__xorB16 x y + | S (S Z) = prim__xorB32 x y + | S (S (S _)) = prim__xorB64 x y + +public +xor : Bits n -> Bits n -> Bits n +xor {n} (MkBits x) (MkBits y) = MkBits {n} (xor' {n=nextBytes n} x y) + +plus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) +plus' {n=n} x y with (nextBytes n) + | Z = pad8 n prim__addB8 x y + | S Z = pad16 n prim__addB16 x y + | S (S Z) = pad32 n prim__addB32 x y + | S (S (S _)) = pad64 n prim__addB64 x y + +public +plus : Bits n -> Bits n -> Bits n +plus (MkBits x) (MkBits y) = MkBits (plus' x y) + +minus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) +minus' {n=n} x y with (nextBytes n) + | Z = pad8 n prim__subB8 x y + | S Z = pad16 n prim__subB16 x y + | S (S Z) = pad32 n prim__subB32 x y + | S (S (S _)) = pad64 n prim__subB64 x y + +public +minus : Bits n -> Bits n -> Bits n +minus (MkBits x) (MkBits y) = MkBits (minus' x y) + +times' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) +times' {n=n} x y with (nextBytes n) + | Z = pad8 n prim__mulB8 x y + | S Z = pad16 n prim__mulB16 x y + | S (S Z) = pad32 n prim__mulB32 x y + | S (S (S _)) = pad64 n prim__mulB64 x y + +public +times : Bits n -> Bits n -> Bits n +times (MkBits x) (MkBits y) = MkBits (times' x y) + +partial +sdiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) +sdiv' {n=n} x y with (nextBytes n) + | Z = prim__sdivB8 x y + | S Z = prim__sdivB16 x y + | S (S Z) = prim__sdivB32 x y + | S (S (S _)) = prim__sdivB64 x y + +public partial +sdiv : Bits n -> Bits n -> Bits n +sdiv (MkBits x) (MkBits y) = MkBits (sdiv' x y) + +partial +udiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) +udiv' {n=n} x y with (nextBytes n) + | Z = prim__udivB8 x y + | S Z = prim__udivB16 x y + | S (S Z) = prim__udivB32 x y + | S (S (S _)) = prim__udivB64 x y + +public partial +udiv : Bits n -> Bits n -> Bits n +udiv (MkBits x) (MkBits y) = MkBits (udiv' x y) + +partial +srem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) +srem' {n=n} x y with (nextBytes n) + | Z = prim__sremB8 x y + | S Z = prim__sremB16 x y + | S (S Z) = prim__sremB32 x y + | S (S (S _)) = prim__sremB64 x y + +public partial +srem : Bits n -> Bits n -> Bits n +srem (MkBits x) (MkBits y) = MkBits (srem' x y) + +partial +urem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n) +urem' {n=n} x y with (nextBytes n) + | Z = prim__uremB8 x y + | S Z = prim__uremB16 x y + | S (S Z) = prim__uremB32 x y + | S (S (S _)) = prim__uremB64 x y + +public partial +urem : Bits n -> Bits n -> Bits n +urem (MkBits x) (MkBits y) = MkBits (urem' x y) + +-- TODO: Proofy comparisons via postulates +lt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int +lt {n=n} x y with (nextBytes n) + | Z = prim__ltB8 x y + | S Z = prim__ltB16 x y + | S (S Z) = prim__ltB32 x y + | S (S (S _)) = prim__ltB64 x y + +lte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int +lte {n=n} x y with (nextBytes n) + | Z = prim__lteB8 x y + | S Z = prim__lteB16 x y + | S (S Z) = prim__lteB32 x y + | S (S (S _)) = prim__lteB64 x y + +eq : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int +eq {n=n} x y with (nextBytes n) + | Z = prim__eqB8 x y + | S Z = prim__eqB16 x y + | S (S Z) = prim__eqB32 x y + | S (S (S _)) = prim__eqB64 x y + +gte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int +gte {n=n} x y with (nextBytes n) + | Z = prim__gteB8 x y + | S Z = prim__gteB16 x y + | S (S Z) = prim__gteB32 x y + | S (S (S _)) = prim__gteB64 x y + +gt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int +gt {n=n} x y with (nextBytes n) + | Z = prim__gtB8 x y + | S Z = prim__gtB16 x y + | S (S Z) = prim__gtB32 x y + | S (S (S _)) = prim__gtB64 x y + +instance Eq (Bits n) where + (MkBits x) == (MkBits y) = boolOp eq x y + +instance Ord (Bits n) where + (MkBits x) < (MkBits y) = boolOp lt x y + (MkBits x) <= (MkBits y) = boolOp lte x y + (MkBits x) >= (MkBits y) = boolOp gte x y + (MkBits x) > (MkBits y) = boolOp gt x y + compare (MkBits x) (MkBits y) = + if boolOp lt x y + then LT + else if boolOp eq x y + then EQ + else GT + +complement' : machineTy (nextBytes n) -> machineTy (nextBytes n) +complement' {n=n} x with (nextBytes n) + | Z = let pad = getPad {n=0} n in + prim__complB8 (x `prim__shlB8` pad) `prim__lshrB8` pad + | S Z = let pad = getPad {n=1} n in + prim__complB16 (x `prim__shlB16` pad) `prim__lshrB16` pad + | S (S Z) = let pad = getPad {n=2} n in + prim__complB32 (x `prim__shlB32` pad) `prim__lshrB32` pad + | S (S (S _)) = let pad = getPad {n=3} n in + prim__complB64 (x `prim__shlB64` pad) `prim__lshrB64` pad + +public +complement : Bits n -> Bits n +complement (MkBits x) = MkBits (complement' x) + +-- TODO: Prove +%assert_total -- can't verify coverage of with block +zext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) +zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) + | (Z, Z) = believe_me x + | (Z, S Z) = believe_me (prim__zextB8_B16 (believe_me x)) + | (Z, S (S Z)) = believe_me (prim__zextB8_B32 (believe_me x)) + | (Z, S (S (S _))) = believe_me (prim__zextB8_B64 (believe_me x)) + | (S Z, S Z) = believe_me x + | (S Z, S (S Z)) = believe_me (prim__zextB16_B32 (believe_me x)) + | (S Z, S (S (S _))) = believe_me (prim__zextB16_B64 (believe_me x)) + | (S (S Z), S (S Z)) = believe_me x + | (S (S Z), S (S (S _))) = believe_me (prim__zextB32_B64 (believe_me x)) + | (S (S (S _)), S (S (S _))) = believe_me x + +public +zeroExtend : Bits n -> Bits (n+m) +zeroExtend (MkBits x) = MkBits (zext' x) + +%assert_total +intToBits' : Integer -> machineTy (nextBytes n) +intToBits' {n=n} x with (nextBytes n) + | Z = let pad = getPad {n=0} n in + prim__lshrB8 (prim__shlB8 (prim__truncBigInt_B8 x) pad) pad + | S Z = let pad = getPad {n=1} n in + prim__lshrB16 (prim__shlB16 (prim__truncBigInt_B16 x) pad) pad + | S (S Z) = let pad = getPad {n=2} n in + prim__lshrB32 (prim__shlB32 (prim__truncBigInt_B32 x) pad) pad + | S (S (S _)) = let pad = getPad {n=3} n in + prim__lshrB64 (prim__shlB64 (prim__truncBigInt_B64 x) pad) pad + +public +intToBits : Integer -> Bits n +intToBits n = MkBits (intToBits' n) + +instance Cast Integer (Bits n) where + cast = intToBits + +bitsToInt' : machineTy (nextBytes n) -> Integer +bitsToInt' {n=n} x with (nextBytes n) + | Z = prim__zextB8_BigInt x + | S Z = prim__zextB16_BigInt x + | S (S Z) = prim__zextB32_BigInt x + | S (S (S _)) = prim__zextB64_BigInt x + +public +bitsToInt : Bits n -> Integer +bitsToInt (MkBits x) = bitsToInt' x + +-- Zero out the high bits of a truncated bitstring +--zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n) +--zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0) + +--instance Cast Nat (Bits n) where +-- cast x = MkBits (zeroUnused (natToBits n)) + +-- TODO: Prove +%assert_total -- can't verify coverage of with block +sext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m)) +sext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) + | (Z, Z) = let pad = getPad {n=0} n in + believe_me (prim__ashrB8 (prim__shlB8 (believe_me x) pad) pad) + | (Z, S Z) = let pad = getPad {n=0} n in + believe_me (prim__ashrB16 (prim__sextB8_B16 (prim__shlB8 (believe_me x) pad)) + (prim__zextB8_B16 pad)) + | (Z, S (S Z)) = let pad = getPad {n=0} n in + believe_me (prim__ashrB32 (prim__sextB8_B32 (prim__shlB8 (believe_me x) pad)) + (prim__zextB8_B32 pad)) + | (Z, S (S (S _))) = let pad = getPad {n=0} n in + believe_me (prim__ashrB64 (prim__sextB8_B64 (prim__shlB8 (believe_me x) pad)) + (prim__zextB8_B64 pad)) + | (S Z, S Z) = let pad = getPad {n=1} n in + believe_me (prim__ashrB16 (prim__shlB16 (believe_me x) pad) pad) + | (S Z, S (S Z)) = let pad = getPad {n=1} n in + believe_me (prim__ashrB32 (prim__sextB16_B32 (prim__shlB16 (believe_me x) pad)) + (prim__zextB16_B32 pad)) + | (S Z, S (S (S _))) = let pad = getPad {n=1} n in + believe_me (prim__ashrB64 (prim__sextB16_B64 (prim__shlB16 (believe_me x) pad)) + (prim__zextB16_B64 pad)) + | (S (S Z), S (S Z)) = let pad = getPad {n=2} n in + believe_me (prim__ashrB32 (prim__shlB32 (believe_me x) pad) pad) + | (S (S Z), S (S (S _))) = let pad = getPad {n=2} n in + believe_me (prim__ashrB64 (prim__sextB32_B64 (prim__shlB32 (believe_me x) pad)) + (prim__zextB32_B64 pad)) + | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in + believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad) + +--public +--signExtend : Bits n -> Bits (n+m) +--signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x)) + +-- TODO: Prove +%assert_total -- can't verify coverage of with block +trunc' : machineTy (nextBytes (n+m)) -> machineTy (nextBytes n) +trunc' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m)) + | (Z, Z) = believe_me x + | (Z, S Z) = believe_me (prim__truncB16_B8 (believe_me x)) + | (Z, S (S Z)) = believe_me (prim__truncB32_B8 (believe_me x)) + | (Z, S (S (S _))) = believe_me (prim__truncB64_B8 (believe_me x)) + | (S Z, S Z) = believe_me x + | (S Z, S (S Z)) = believe_me (prim__truncB32_B16 (believe_me x)) + | (S Z, S (S (S _))) = believe_me (prim__truncB64_B16 (believe_me x)) + | (S (S Z), S (S Z)) = believe_me x + | (S (S Z), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x)) + | (S (S (S _)), S (S (S _))) = believe_me x + +--public +--truncate : Bits (n+m) -> Bits n +--truncate (MkBits x) = MkBits (zeroUnused (trunc' x)) + +public +bitAt : Fin n -> Bits n +bitAt n = intToBits 1 `shiftLeft` intToBits (cast n) + +public +getBit : Fin n -> Bits n -> Bool +getBit n x = (x `and` (bitAt n)) /= intToBits 0 + +public +setBit : Fin n -> Bits n -> Bits n +setBit n x = x `or` (bitAt n) + +public +unsetBit : Fin n -> Bits n -> Bits n +unsetBit n x = x `and` complement (bitAt n) + +bitsToStr : Bits n -> String +bitsToStr x = pack (helper last x) + where + %assert_total + helper : Fin (S n) -> Bits n -> List Char + helper fZ _ = [] + helper (fS x) b = (if getBit x b then '1' else '0') :: helper (weaken x) b + +instance Show (Bits n) where + show = bitsToStr + diff --git a/libs/base/Data/BoundedList.idr b/libs/base/Data/BoundedList.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/BoundedList.idr @@ -0,0 +1,92 @@ +module Data.BoundedList + +%access public +%default total + +data BoundedList : Type -> Nat -> Type where + Nil : BoundedList a n + (::) : a -> BoundedList a n -> BoundedList a (S n) + +length : BoundedList a n -> Fin (S n) +length [] = fZ +length (x :: xs) = fS (length xs) + +-------------------------------------------------------------------------------- +-- Indexing into bounded lists +-------------------------------------------------------------------------------- + +index : Fin (S n) -> BoundedList a n -> Maybe a +index _ [] = Nothing +index fZ (x :: _) = Just x +index (fS f) (_ :: xs) = index f xs + +-------------------------------------------------------------------------------- +-- Adjusting bounds +-------------------------------------------------------------------------------- + +weaken : BoundedList a n -> BoundedList a (n + m) +weaken [] = [] +weaken (x :: xs) = x :: weaken xs + +-------------------------------------------------------------------------------- +-- Conversions to and from list +-------------------------------------------------------------------------------- + +take : (n : Nat) -> List a -> BoundedList a n +take _ [] = [] +take Z _ = [] +take (S n') (x :: xs) = x :: take n' xs + +toList : BoundedList a n -> List a +toList [] = [] +toList (x :: xs) = x :: toList xs + +fromList : (xs : List a) -> BoundedList a (length xs) +fromList [] = [] +fromList (x :: xs) = x :: fromList xs + +-------------------------------------------------------------------------------- +-- Building (bigger) bounded lists +-------------------------------------------------------------------------------- + +replicate : (n : Nat) -> a -> BoundedList a n +replicate Z _ = [] +replicate (S n) x = x :: replicate n x + +-------------------------------------------------------------------------------- +-- Folds +-------------------------------------------------------------------------------- + +foldl : (a -> b -> a) -> a -> BoundedList b n -> a +foldl f e [] = e +foldl f e (x::xs) = foldl f (f e x) xs + +foldr : (a -> b -> b) -> b -> BoundedList a n -> b +foldr f e [] = e +foldr f e (x::xs) = f x (foldr f e xs) + +-------------------------------------------------------------------------------- +-- Maps +-------------------------------------------------------------------------------- + +map : (a -> b) -> BoundedList a n -> BoundedList b n +map f [] = [] +map f (x :: xs) = f x :: map f xs + +-------------------------------------------------------------------------------- +-- Misc +-------------------------------------------------------------------------------- + +pad : (xs : BoundedList a n) -> (padding : a) -> BoundedList a n +pad {n=Z} [] _ = [] +pad {n=S n'} [] padding = padding :: (pad {n=n'} [] padding) +pad {n=S n'} (x :: xs) padding = x :: pad {n=n'} xs padding + + +-------------------------------------------------------------------------------- +-- Simple properties +-------------------------------------------------------------------------------- + +zeroBoundIsEmpty : (xs : BoundedList a 0) -> xs = the (BoundedList a 0) [] +zeroBoundIsEmpty [] = refl +zeroBoundIsEmpty (_ :: _) impossible diff --git a/libs/base/Data/Complex.idr b/libs/base/Data/Complex.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Complex.idr @@ -0,0 +1,69 @@ +{- + (c) 2012 Copyright Mekeor Melire +-} + + +module Data.Complex + +import Data.Floats + +------------------------------ 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/libs/base/Data/Floats.idr b/libs/base/Data/Floats.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Floats.idr @@ -0,0 +1,59 @@ +module Data.Floats + +%access public +%default total + +%include C "math.h" +%lib C "m" + +pi : Float +pi = 3.14159265358979323846 + +euler : Float +euler = 2.7182818284590452354 + +exp : Float -> Float +exp x = prim__floatExp x + +log : Float -> Float +log x = prim__floatLog x + +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) + +sinh : Float -> Float +sinh x = (exp x - exp (-x)) / 2 + +cosh : Float -> Float +cosh x = (exp x + exp (-x)) / 2 + +tanh : Float -> Float +tanh x = sinh x / cosh 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 + diff --git a/libs/base/Data/HVect.idr b/libs/base/Data/HVect.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/HVect.idr @@ -0,0 +1,63 @@ +module Data.HVect + +import Data.Vect + +%access public +%default total + +using (k : Nat, ts : Vect k Type) + data HVect : Vect k Type -> Type where + Nil : HVect [] + (::) : t -> HVect ts -> HVect (t::ts) + + index : (i : Fin k) -> HVect ts -> index i ts + index fZ (x::xs) = x + index (fS j) (x::xs) = index j xs + + deleteAt : {us : Vect (S l) Type} -> (i : Fin (S l)) -> HVect us -> HVect (deleteAt i us) + deleteAt fZ (x::xs) = xs + deleteAt {l = S m} (fS j) (x::xs) = x :: deleteAt j xs + deleteAt _ [] impossible + + replaceAt : (i : Fin k) -> t -> HVect ts -> HVect (replaceAt i t ts) + replaceAt fZ y (x::xs) = y::xs + replaceAt (fS j) y (x::xs) = x :: replaceAt j y xs + + updateAt : (i : Fin k) -> (index i ts -> t) -> HVect ts -> HVect (replaceAt i t ts) + updateAt fZ f (x::xs) = f x :: xs + updateAt (fS j) f (x::xs) = x :: updateAt j f xs + + (++) : {us : Vect l Type} -> HVect ts -> HVect us -> HVect (ts ++ us) + (++) [] ys = ys + (++) (x::xs) ys = x :: (xs ++ ys) + + instance Eq (HVect []) where + [] == [] = True + + instance (Eq t, Eq (HVect ts)) => Eq (HVect (t::ts)) where + (x::xs) == (y::ys) = x == y && xs == ys + + class Shows (k : Nat) (ts : Vect k Type) where + shows : HVect ts -> Vect k String + + instance Shows Z [] where + shows [] = [] + + instance (Show t, Shows k ts) => Shows (S k) (t::ts) where + shows (x::xs) = show x :: shows xs + + instance (Shows k ts) => Show (HVect ts) where + show xs = show (shows xs) + + get : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> HVect ts -> t + get {p = Here} (x::xs) = x + get {p = There p'} (x::xs) = get {p = p'} xs + + put : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> t -> HVect ts -> HVect ts + put {p = Here} y (x::xs) = y :: xs + put {p = There p'} y (x::xs) = x :: put {p = p'} y xs + + update : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> (t -> u) -> HVect ts -> HVect (replaceByElem ts p u) + update {p = Here} f (x::xs) = f x :: xs + update {p = There p'} f (x::xs) = x :: update {p = p'} f xs + diff --git a/libs/base/Data/Heap.idr b/libs/base/Data/Heap.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Heap.idr @@ -0,0 +1,189 @@ +-------------------------------------------------------------------------------- +-- Okasaki-style maxiphobic heaps. See the paper: +-- ``Fun with binary heap trees'', Chris Okasaki, Fun of programming, 2003. +-------------------------------------------------------------------------------- + +module Data.Heap + +%default total +%access public + +abstract data MaxiphobicHeap : Type -> Type 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 = Z +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) + +%assert_total -- relies on orderBySize doing the right thing +merge : Ord a => MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a +merge Empty right = right +merge left Empty = left +merge (Node ls ll le lr) (Node rs rl re rr) = + 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 refl impossible +findMinimum (Node s l e r) p = e + +deleteMinimum : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> MaxiphobicHeap a +deleteMinimum Empty refl impossible +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 + %assert_total -- relies on deleteMinimum making heap smaller + toList' : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> List a + toList' heap p = findMinimum heap p :: (Heap.toList (deleteMinimum heap p)) + +fromList : Ord a => List a -> MaxiphobicHeap a +fromList = foldr insert empty + +sort : Ord a => List a -> List a +sort = Heap.toList . 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 -> Type + disjointTy False = () + disjointTy True = _|_ + +total isEmptySizeZero : (h : MaxiphobicHeap a) -> (isEmpty h = True) -> size h = Z +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; +} + +-------------------------------------------------------------------------------- +-- 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/libs/base/Data/Mod2.idr b/libs/base/Data/Mod2.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Mod2.idr @@ -0,0 +1,64 @@ +module Data.Mod2 + +import Data.Bits + +%default total + +-- Integers modulo 2^n +public +data Mod2 : Nat -> Type where + MkMod2 : {n : Nat} -> Bits n -> Mod2 n + +modBin : (Bits n -> Bits n -> Bits n) -> Mod2 n -> Mod2 n -> Mod2 n +modBin f (MkMod2 x) (MkMod2 y) = MkMod2 (f x y) + +modComp : (Bits n -> Bits n -> a) -> Mod2 n -> Mod2 n -> a +modComp f (MkMod2 x) (MkMod2 y) = f x y + +public partial +div : Mod2 n -> Mod2 n -> Mod2 n +div = modBin udiv + +public partial +rem : Mod2 n -> Mod2 n -> Mod2 n +rem = modBin urem + +%assert_total +public +intToMod : {n : Nat} -> Integer -> Mod2 n +intToMod {n=n} x = MkMod2 (intToBits x) + +instance Eq (Mod2 n) where + (==) = modComp (==) + +instance Ord (Mod2 n) where + (<) = modComp (<) + (<=) = modComp (<=) + (>=) = modComp (>=) + (>) = modComp (>) + compare = modComp compare + +instance Num (Mod2 n) where + (+) = modBin plus + (-) = modBin minus + (*) = modBin times + abs = id + fromInteger = intToMod + +instance Cast (Mod2 n) (Bits n) where + cast (MkMod2 x) = x + +instance Cast (Bits n) (Mod2 n) where + cast x = MkMod2 x + +modToStr : Mod2 n -> String +modToStr x = pack (reverse (helper x)) + where + %assert_total + helper : Mod2 n -> List Char + helper x = strIndex "0123456789" (prim__truncBigInt_Int (bitsToInt (cast (x `rem` 10)))) + :: (if x < 10 then [] else helper (x `div` 10)) + + +instance Show (Mod2 n) where + show = modToStr diff --git a/libs/base/Data/Morphisms.idr b/libs/base/Data/Morphisms.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Morphisms.idr @@ -0,0 +1,42 @@ +module Data.Morphisms + +%access public + +data Morphism : Type -> Type -> Type where + Mor : (a -> b) -> Morphism a b + +data Endomorphism : Type -> Type where + Endo : (a -> a) -> Endomorphism a + +data Kleislimorphism : (Type -> Type) -> Type -> Type -> Type where + Kleisli : Monad m => (a -> m b) -> Kleislimorphism m a b + +applyKleisli : Monad m => (Kleislimorphism m a b) -> a -> m b +applyKleisli (Kleisli f) a = f a + +applyMor : Morphism a b -> a -> b +applyMor (Mor f) a = f a + +applyEndo : Endomorphism a -> a -> a +applyEndo (Endo f) a = f a + +instance Functor (Morphism r) where + map f (Mor a) = Mor (f . a) + +instance Applicative (Morphism r) where + pure a = Mor $ const a + (Mor f) <$> (Mor a) = Mor $ \r => f r $ a r + +instance Monad (Morphism r) where + (Mor h) >>= f = Mor $ \r => applyMor (f $ h r) r + +instance Semigroup (Endomorphism a) where + (Endo f) <+> (Endo g) = Endo $ g . f + +instance Monoid (Endomorphism a) where + neutral = Endo id + +infixr 1 ~> + +(~>) : Type -> Type -> Type +a ~> b = Morphism a b diff --git a/libs/base/Data/Sign.idr b/libs/base/Data/Sign.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Sign.idr @@ -0,0 +1,6 @@ +module Data.Sign + +data Sign = Plus | Minus + +class Signed t where + total sign : t -> Sign diff --git a/libs/base/Data/SortedMap.idr b/libs/base/Data/SortedMap.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/SortedMap.idr @@ -0,0 +1,235 @@ +module Data.SortedMap + +-- TODO: write merge and split + +data Tree : Nat -> Type -> Type -> Type where + Leaf : k -> v -> Tree Z k v + Branch2 : Tree n k v -> k -> Tree n k v -> Tree (S n) k v + Branch3 : Tree n k v -> k -> Tree n k v -> k -> Tree n k v -> Tree (S n) k v + +branch4 : + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> + Tree (S (S n)) k v +branch4 a b c d e f g = + Branch2 (Branch2 a b c) d (Branch2 e f g) + +branch5 : + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> + Tree (S (S n)) k v +branch5 a b c d e f g h i = + Branch2 (Branch2 a b c) d (Branch3 e f g h i) + +branch6 : + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> + Tree (S (S n)) k v +branch6 a b c d e f g h i j k = + Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k) + +branch7 : + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> k -> + Tree n k v -> + Tree (S (S n)) k v +branch7 a b c d e f g h i j k l m = + Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m) + +merge1 : Tree n k v -> k -> Tree (S n) k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v +merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i +merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k +merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k +merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m + +merge2 : Tree (S n) k v -> k -> Tree n k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v +merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i +merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k +merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k +merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m + +merge3 : Tree (S n) k v -> k -> Tree (S n) k v -> k -> Tree n k v -> Tree (S (S n)) k v +merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i +merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k +merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k +merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m + +treeLookup : Ord k => k -> Tree n k v -> Maybe v +treeLookup k (Leaf k' v) = + if k == k' then + Just v + else + Nothing +treeLookup k (Branch2 t1 k' t2) = + if k <= k' then + treeLookup k t1 + else + treeLookup k t2 +treeLookup k (Branch3 t1 k1 t2 k2 t3) = + if k <= k1 then + treeLookup k t1 + else if k <= k2 then + treeLookup k t2 + else + treeLookup k t3 + +treeInsert' : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree n k v, k, Tree n k v) +treeInsert' k v (Leaf k' v') = + case compare k k' of + LT => Right (Leaf k v, k, Leaf k' v') + EQ => Left (Leaf k v) + GT => Right (Leaf k' v', k', Leaf k v) +treeInsert' k v (Branch2 t1 k' t2) = + if k <= k' then + case treeInsert' k v t1 of + Left t1' => Left (Branch2 t1' k' t2) + Right (a, b, c) => Left (Branch3 a b c k' t2) + else + case treeInsert' k v t2 of + Left t2' => Left (Branch2 t1 k' t2') + Right (a, b, c) => Left (Branch3 t1 k' a b c) +treeInsert' k v (Branch3 t1 k1 t2 k2 t3) = + if k <= k1 then + case treeInsert' k v t1 of + Left t1' => Left (Branch3 t1' k1 t2 k2 t3) + Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3) + else + if k <= k2 then + case treeInsert' k v t2 of + Left t2' => Left (Branch3 t1 k1 t2' k2 t3) + Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3) + else + case treeInsert' k v t3 of + Left t3' => Left (Branch3 t1 k1 t2 k2 t3') + Right (a, b, c) => Right (Branch2 t1 k2 t2, k2, Branch2 a b c) + +treeInsert : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree (S n) k v) +treeInsert k v t = + case treeInsert' k v t of + Left t' => Left t' + Right (a, b, c) => Right (Branch2 a b c) + +delType : Nat -> Type -> Type -> Type +delType Z k v = () +delType (S n) k v = Tree n k v + +treeDelete : Ord k => k -> Tree n k v -> Either (Tree n k v) (delType n k v) +treeDelete k (Leaf k' v) = + if k == k' then + Right () + else + Left (Leaf k' v) +treeDelete {n=S Z} k (Branch2 t1 k' t2) = + if k <= k' then + case treeDelete k t1 of + Left t1' => Left (Branch2 t1' k' t2) + Right () => Right t2 + else + case treeDelete k t2 of + Left t2' => Left (Branch2 t1 k' t2') + Right () => Right t1 +treeDelete {n=S Z} k (Branch3 t1 k1 t2 k2 t3) = + if k <= k1 then + case treeDelete k t1 of + Left t1' => Left (Branch3 t1' k1 t2 k2 t3) + Right () => Left (Branch2 t2 k2 t3) + else if k <= k2 then + case treeDelete k t2 of + Left t2' => Left (Branch3 t1 k1 t2' k2 t3) + Right () => Left (Branch2 t1 k1 t3) + else + case treeDelete k t3 of + Left t3' => Left (Branch3 t1 k1 t2 k2 t3') + Right () => Left (Branch2 t1 k1 t2) +treeDelete {n=S (S _)} k (Branch2 t1 k' t2) = + if k <= k' then + case treeDelete k t1 of + Left t1' => Left (Branch2 t1' k' t2) + Right t1' => + case t2 of + Branch2 a b c => Right (Branch3 t1' k' a b c) + Branch3 a b c d e => Left (branch4 t1' k' a b c d e) + else + case treeDelete k t2 of + Left t2' => Left (Branch2 t1 k' t2') + Right t2' => + case t1 of + Branch2 a b c => Right (Branch3 a b c k' t2') + Branch3 a b c d e => Left (branch4 a b c d e k' t2') +treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) = + if k <= k1 then + case treeDelete k t1 of + Left t1' => Left (Branch3 t1' k1 t2 k2 t3) + Right t1' => Left (merge1 t1' k1 t2 k2 t3) + else if k <= k2 then + case treeDelete k t2 of + Left t2' => Left (Branch3 t1 k1 t2' k2 t3) + Right t2' => Left (merge2 t1 k1 t2' k2 t3) + else + case treeDelete k t3 of + Left t3' => Left (Branch3 t1 k1 t2 k2 t3') + Right t3' => Left (merge3 t1 k1 t2 k2 t3') + +-- FIXME: this is very inefficient +treeToList : Ord k => Tree n k v -> List (k, v) +treeToList (Leaf k v) = [(k, v)] +treeToList (Branch2 t1 _ t2) = treeToList t1 ++ treeToList t2 +treeToList (Branch3 t1 _ t2 _ t3) = treeToList t1 ++ treeToList t2 ++ treeToList t3 + +data SortedMap : Type -> Type -> Type where + Empty : SortedMap k v + M : (n:Nat) -> Tree n k v -> SortedMap k v + +empty : SortedMap k v +empty = Empty + +lookup : Ord k => k -> SortedMap k v -> Maybe v +lookup _ Empty = Nothing +lookup k (M _ t) = treeLookup k t + +insert : Ord k => k -> v -> SortedMap k v -> SortedMap k v +insert k v Empty = M Z (Leaf k v) +insert k v (M _ t) = + case treeInsert k v t of + Left t' => (M _ t') + Right t' => (M _ t') + +delete : Ord k => k -> SortedMap k v -> SortedMap k v +delete _ Empty = Empty +delete k (M Z t) = + case treeDelete k t of + Left t' => (M _ t') + Right () => Empty +delete k (M (S _) t) = + case treeDelete k t of + Left t' => (M _ t') + Right t' => (M _ t') + +fromList : Ord k => List (k, v) -> SortedMap k v +fromList l = foldl (flip (uncurry insert)) empty l + +toList : Ord k => SortedMap k v -> List (k, v) +toList Empty = [] +toList (M _ t) = treeToList t + +instance Functor (Tree n k) where + map f (Leaf k v) = Leaf k (f v) + map f (Branch2 t1 k t2) = Branch2 (map f t1) k (map f t2) + map f (Branch3 t1 k1 t2 k2 t3) = Branch3 (map f t1) k1 (map f t2) k2 (map f t3) + +instance Functor (SortedMap k) where + map _ Empty = Empty + map f (M n t) = M _ (map f t) diff --git a/libs/base/Data/SortedSet.idr b/libs/base/Data/SortedSet.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/SortedSet.idr @@ -0,0 +1,25 @@ +module Data.SortedSet + +import Data.SortedMap + +-- TODO: add intersection, union, difference + +data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ()) + +empty : SortedSet k +empty = SetWrapper Data.SortedMap.empty + +insert : Ord k => k -> SortedSet k -> SortedSet k +insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m) + +delete : Ord k => k -> SortedSet k -> SortedSet k +delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m) + +contains : Ord k => k -> SortedSet k -> Bool +contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m) + +fromList : Ord k => List k -> SortedSet k +fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l)) + +toList : Ord k => SortedSet k -> List k +toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m) diff --git a/libs/base/Data/Vect.idr b/libs/base/Data/Vect.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Vect.idr @@ -0,0 +1,33 @@ +module Data.Vect + +import Language.Reflection + +%access public +%default total + +-------------------------------------------------------------------------------- +-- Elem +-------------------------------------------------------------------------------- + +using (xs : Vect k a) + data Elem : a -> Vect k a -> Type where + Here : Elem x (x::xs) + There : Elem x xs -> Elem x (y::xs) + +findElem : Nat -> List (TTName, Binder TT) -> TT -> Tactic +findElem Z ctxt goal = Refine "Here" `Seq` Solve +findElem (S n) ctxt goal = GoalType "Elem" (Try (Refine "Here" `Seq` Solve) (Refine "There" `Seq` (Solve `Seq` findElem n ctxt goal))) + +replaceElem : (xs : Vect k t) -> Elem x xs -> (y : t) -> (ys : Vect k t ** Elem y ys) +replaceElem (x::xs) Here y = (y :: xs ** Here) +replaceElem (x::xs) (There xinxs) y with (replaceElem xs xinxs y) + | (ys ** yinys) = (x :: ys ** There yinys) + +replaceByElem : (xs : Vect k t) -> Elem x xs -> t -> Vect k t +replaceByElem (x::xs) Here y = y :: xs +replaceByElem (x::xs) (There xinxs) y = x :: replaceByElem xs xinxs y + +mapElem : {xs : Vect k t} -> {f : t -> u} -> Elem x xs -> Elem (f x) (map f xs) +mapElem Here = Here +mapElem (There e) = There (mapElem e) + diff --git a/libs/base/Data/Vect/Quantifiers.idr b/libs/base/Data/Vect/Quantifiers.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Vect/Quantifiers.idr @@ -0,0 +1,47 @@ +module Data.Vect.Quantifiers + +data Any : (P : a -> Type) -> Vect n a -> Type where + Here : {P : a -> Type} -> {xs : Vect n a} -> P x -> Any P (x :: xs) + There : {P : a -> Type} -> {xs : Vect n a} -> Any P xs -> Any P (x :: xs) + +anyNilAbsurd : {P : a -> Type} -> Any P Nil -> _|_ +anyNilAbsurd Here impossible +anyNilAbsurd There impossible + +anyElim : {xs : Vect n a} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b +anyElim _ f (Here p) = f p +anyElim f _ (There p) = f p + +any : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a) -> Dec (Any P xs) +any _ Nil = No anyNilAbsurd +any p (x::xs) with (p x) + | Yes prf = Yes (Here prf) + | No prf = + case any p xs of + Yes prf' => Yes (There prf') + No prf' => No (anyElim prf' prf) + +data All : (P : a -> Type) -> Vect n a -> Type where + Nil : {P : a -> Type} -> All P Nil + (::) : {P : a -> Type} -> {xs : Vect n a} -> P x -> All P xs -> All P (x :: xs) + +negAnyAll : {P : a -> Type} -> {xs : Vect n a} -> Not (Any P xs) -> All (\x => Not (P x)) xs +negAnyAll {xs=Nil} _ = Nil +negAnyAll {xs=(x::xs)} f = (\x => f (Here x)) :: negAnyAll (\x => f (There x)) + +notAllHere : {P : a -> Type} -> {xs : Vect n a} -> Not (P x) -> All P (x :: xs) -> _|_ +notAllHere _ Nil impossible +notAllHere np (p :: _) = np p + +notAllThere : {P : a -> Type} -> {xs : Vect n a} -> Not (All P xs) -> All P (x :: xs) -> _|_ +notAllThere _ Nil impossible +notAllThere np (_ :: ps) = np ps + +all : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a) -> Dec (All P xs) +all _ Nil = Yes Nil +all d (x::xs) with (d x) + | No prf = No (notAllHere prf) + | Yes prf = + case all d xs of + Yes prf' => Yes (prf :: prf') + No prf' => No (notAllThere prf') diff --git a/libs/base/Data/ZZ.idr b/libs/base/Data/ZZ.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/ZZ.idr @@ -0,0 +1,144 @@ +module Data.ZZ + +import Decidable.Equality +import Data.Sign + +%default total +%access public + + +-- | An integer is either a positive nat or the negated successor of a nat. +-- Zero is chosen to be positive. +data ZZ = Pos Nat | NegS Nat + +instance Signed ZZ where + sign (Pos _) = Plus + sign (NegS _) = Minus + +absZ : ZZ -> Nat +absZ (Pos n) = n +absZ (NegS n) = S n + +instance Show ZZ where + show (Pos n) = show n + show (NegS n) = "-" ++ show (S n) + +negZ : ZZ -> ZZ +negZ (Pos Z) = Pos Z +negZ (Pos (S n)) = NegS n +negZ (NegS n) = Pos (S n) + +negNat : Nat -> ZZ +negNat Z = Pos Z +negNat (S n) = NegS n + +minusNatZ : Nat -> Nat -> ZZ +minusNatZ n Z = Pos n +minusNatZ Z (S m) = NegS m +minusNatZ (S n) (S m) = minusNatZ n m + +plusZ : ZZ -> ZZ -> ZZ +plusZ (Pos n) (Pos m) = Pos (n + m) +plusZ (NegS n) (NegS m) = NegS (S (n + m)) +plusZ (Pos n) (NegS m) = minusNatZ n (S m) +plusZ (NegS n) (Pos m) = minusNatZ m (S n) + +subZ : ZZ -> ZZ -> ZZ +subZ n m = plusZ n (negZ m) + +instance Eq ZZ where + (Pos n) == (Pos m) = n == m + (NegS n) == (NegS m) = n == m + _ == _ = False + + +instance Ord ZZ where + compare (Pos n) (Pos m) = compare n m + compare (NegS n) (NegS m) = compare m n + compare (Pos _) (NegS _) = GT + compare (NegS _) (Pos _) = LT + + +multZ : ZZ -> ZZ -> ZZ +multZ (Pos n) (Pos m) = Pos $ n * m +multZ (NegS n) (NegS m) = Pos $ (S n) * (S m) +multZ (NegS n) (Pos m) = negNat $ (S n) * m +multZ (Pos n) (NegS m) = negNat $ n * (S m) + +fromInt : Integer -> ZZ +fromInt n = if n < 0 + then NegS $ fromInteger {a=Nat} (-n - 1) + else Pos $ fromInteger {a=Nat} n + +instance Cast Nat ZZ where + cast n = Pos n + +instance Num ZZ where + (+) = plusZ + (-) = subZ + (*) = multZ + abs = cast . absZ + fromInteger = fromInt + +instance Cast ZZ Integer where + cast (Pos n) = cast n + cast (NegS n) = (-1) * (cast n + 1) + +instance Cast Integer ZZ where + cast = fromInteger + + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +natPlusZPlus : (n : Nat) -> (m : Nat) -> (x : Nat) + -> n + m = x -> (Pos n) + (Pos m) = Pos x +natPlusZPlus n m x h = cong h + +natMultZMult : (n : Nat) -> (m : Nat) -> (x : Nat) + -> n * m = x -> (Pos n) * (Pos m) = Pos x +natMultZMult n m x h = cong h + +doubleNegElim : (z : ZZ) -> negZ (negZ z) = z +doubleNegElim (Pos Z) = refl +doubleNegElim (Pos (S n)) = refl +doubleNegElim (NegS Z) = refl +doubleNegElim (NegS (S n)) = refl + +-- Injectivity +posInjective : Pos n = Pos m -> n = m +posInjective refl = refl + +negSInjective : NegS n = NegS m -> n = m +negSInjective refl = refl + +posNotNeg : Pos n = NegS m -> _|_ +posNotNeg refl impossible + +-- Decidable equality +instance DecEq ZZ where + decEq (Pos n) (NegS m) = No posNotNeg + decEq (NegS n) (Pos m) = No $ negEqSym posNotNeg + decEq (Pos n) (Pos m) with (decEq n m) + | Yes p = Yes $ cong p + | No p = No $ \h => p $ posInjective h + decEq (NegS n) (NegS m) with (decEq n m) + | Yes p = Yes $ cong p + | No p = No $ \h => p $ negSInjective h + +-- Plus +plusZeroLeftNeutralZ : (right : ZZ) -> 0 + right = right +plusZeroLeftNeutralZ (Pos n) = refl +plusZeroLeftNeutralZ (NegS n) = refl + +plusZeroRightNeutralZ : (left : ZZ) -> left + 0 = left +plusZeroRightNeutralZ (Pos n) = cong $ plusZeroRightNeutral n +plusZeroRightNeutralZ (NegS n) = refl + +plusCommutativeZ : (left : ZZ) -> (right : ZZ) -> (left + right = right + left) +plusCommutativeZ (Pos n) (Pos m) = cong $ plusCommutative n m +plusCommutativeZ (Pos n) (NegS m) = refl +plusCommutativeZ (NegS n) (Pos m) = refl +plusCommutativeZ (NegS n) (NegS m) = cong {f=NegS} $ cong {f=S} $ plusCommutative n m + diff --git a/libs/base/Debug/Trace.idr b/libs/base/Debug/Trace.idr new file mode 100644 --- /dev/null +++ b/libs/base/Debug/Trace.idr @@ -0,0 +1,6 @@ +module Debug.Trace + +trace : String -> a -> a +trace x val = unsafePerformIO (do putStrLn x; return val) + + diff --git a/libs/base/Decidable/Decidable.idr b/libs/base/Decidable/Decidable.idr new file mode 100644 --- /dev/null +++ b/libs/base/Decidable/Decidable.idr @@ -0,0 +1,24 @@ +module Decidable.Decidable + +%access public + +-------------------------------------------------------------------------------- +-- Typeclass for decidable n-ary Relations +-------------------------------------------------------------------------------- + +{- +This can't work yet! The class parameters must appear in the method type +signatures otherwise when defining the instances class resolution doesn't +have any clues... + +using (t : Type) + class Rel (p : t) where + total liftRel : (Type -> Type) -> Type + + class (Rel p) => Decidable (p : t) where + total decide : liftRel Dec + +using (P : Type, p : P) + data Given : Dec P -> Type where + always : Given (Yes p) +-} diff --git a/libs/base/Decidable/Order.idr b/libs/base/Decidable/Order.idr new file mode 100644 --- /dev/null +++ b/libs/base/Decidable/Order.idr @@ -0,0 +1,87 @@ +module Decidable.Order + +%access public + +{- +Doesn't work yet, see note in Decidable.idr + +import Decidable.Decidable +import Decidable.Equality + +-------------------------------------------------------------------------------- +-- Utility Lemmas +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- Preorders and Posets +-------------------------------------------------------------------------------- + +class Preorder t (po : t -> t -> Type) where + total transitive : (a : t) -> (b : t) -> (c : t) -> po a b -> po b c -> po a c + total reflexive : (a : t) -> po a a + +class (Preorder t po) => Poset t (po : t -> t -> Type) where + total antisymmetric : (a : t) -> (b : t) -> po a b -> po b a -> a = b + +-------------------------------------------------------------------------------- +-- Natural numbers +-------------------------------------------------------------------------------- + +data NatLTE : Nat -> Nat -> Type where + nEqn : NatLTE n n + nLTESm : NatLTE n m -> NatLTE n (S m) + +total NatLTEIsTransitive : (m : Nat) -> (n : Nat) -> (o : Nat) -> + NatLTE m n -> NatLTE n o -> + NatLTE m o +NatLTEIsTransitive m n n mLTEn (nEqn) = mLTEn +NatLTEIsTransitive m n (S o) mLTEn (nLTESm nLTEo) + = nLTESm (NatLTEIsTransitive m n o mLTEn nLTEo) + +total NatLTEIsReflexive : (n : Nat) -> NatLTE n n +NatLTEIsReflexive _ = nEqn + +instance Preorder Nat NatLTE where + transitive = NatLTEIsTransitive + reflexive = NatLTEIsReflexive + +total NatLTEIsAntisymmetric : (m : Nat) -> (n : Nat) -> + NatLTE m n -> NatLTE n m -> m = n +NatLTEIsAntisymmetric n n nEqn nEqn = refl +NatLTEIsAntisymmetric n m nEqn (nLTESm _) impossible +NatLTEIsAntisymmetric n m (nLTESm _) nEqn impossible +NatLTEIsAntisymmetric n m (nLTESm _) (nLTESm _) impossible + +instance Poset Nat NatLTE where + antisymmetric = NatLTEIsAntisymmetric + +total zeroNeverGreater : {n : Nat} -> NatLTE (S n) Z -> _|_ +zeroNeverGreater {n} (nLTESm _) impossible +zeroNeverGreater {n} nEqn impossible + +total +nGTSm : {n : Nat} -> {m : Nat} -> (NatLTE n m -> _|_) -> NatLTE n (S m) -> _|_ +nGTSm disprf (nLTESm nLTEm) = FalseElim (disprf nLTEm) +nGTSm {n} {m} disprf (nEqn) impossible + +total +decideNatLTE : (n : Nat) -> (m : Nat) -> Dec (NatLTE n m) +decideNatLTE Z Z = Yes nEqn +decideNatLTE (S x) Z = No zeroNeverGreater +decideNatLTE x (S y) with (decEq x (S y)) + | Yes eq = rewrite eq in Yes nEqn + | No _ with (decideNatLTE x y) + | Yes nLTEm = Yes (nLTESm nLTEm) + | No nGTm = No (nGTSm nGTm) + +instance Rel NatLTE where + liftRel P = (n : Nat) -> (m : Nat) -> P (NatLTE n m) + +instance Decidable NatLTE where + decide = decideNatLTE + +lte : (m : Nat) -> (n : Nat) -> Dec (NatLTE m n) +lte m n = decide {p = NatLTE} m n + +-} + diff --git a/libs/base/Language/Reflection.idr b/libs/base/Language/Reflection.idr new file mode 100644 --- /dev/null +++ b/libs/base/Language/Reflection.idr @@ -0,0 +1,186 @@ +module Language.Reflection + +%access public + +data TTName = UN String + -- ^ User-provided name + | NS TTName (List String) + -- ^ Root, namespaces + | MN Int String + -- ^ Machine chosen names + | NErased + -- ^ Name of somethng which is never used in scope + +implicit +userSuppliedName : String -> TTName +userSuppliedName = UN + +data TTUExp = UVar Int + -- ^ universe variable + | UVal Int + -- ^ explicit universe variable + +-- | Primitive constants +data Const = I Int | BI Nat | Fl Float | Ch Char | Str String + | IType | BIType | FlType | ChType | StrType + | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64 + | B8Type | B16Type | B32Type | B64Type + | PtrType | VoidType | Forgot + +abstract class ReflConst (a : Type) where + toConst : a -> Const + +instance ReflConst Int where + toConst x = I x + +instance ReflConst Nat where + toConst = BI + +instance ReflConst Float where + toConst = Fl + +instance ReflConst Char where + toConst = Ch + +instance ReflConst String where + toConst = Str + +instance ReflConst Bits8 where + toConst = B8 + +instance ReflConst Bits16 where + toConst = B16 + +instance ReflConst Bits32 where + toConst = B32 + +instance ReflConst Bits64 where + toConst = B64 + +implicit +reflectConstant: (ReflConst a) => a -> Const +reflectConstant = toConst + + +-- | Types of named references +data NameType = Bound + -- ^ reference which is just bound, e.g. by intro + | Ref + -- ^ reference to a variable + | DCon Int Int + -- ^ constructor with tag and number + | TCon Int Int + -- ^ type constructor with tag and number + +-- | Types annotations for bound variables in different +-- binding contexts +data Binder a = Lam a + | Pi a + | Let a a + | NLet a a + | Hole a + | GHole a + | Guess a a + | PVar a + | PVTy a + + +instance Functor Binder where + map f (Lam x) = Lam (f x) + map f (Pi x) = Pi (f x) + map f (Let x y) = Let (f x) (f y) + map f (NLet x y) = NLet (f x) (f y) + map f (Hole x) = Hole (f x) + map f (GHole x) = GHole (f x) + map f (Guess x y) = Guess (f x) (f y) + map f (PVar x) = PVar (f x) + map f (PVTy x) = PVTy (f x) + +instance Foldable Binder where + foldr f z (Lam x) = f x z + foldr f z (Pi x) = f x z + foldr f z (Let x y) = f x (f y z) + foldr f z (NLet x y) = f x (f y z) + foldr f z (Hole x) = f x z + foldr f z (GHole x) = f x z + foldr f z (Guess x y) = f x (f y z) + foldr f z (PVar x) = f x z + foldr f z (PVTy x) = f x z + +instance Traversable Binder where + traverse f (Lam x) = [| Lam (f x) |] + traverse f (Pi x) = [| Pi (f x) |] + traverse f (Let x y) = [| Let (f x) (f y) |] + traverse f (NLet x y) = [| NLet (f x) (f y) |] + traverse f (Hole x) = [| Hole (f x) |] + traverse f (GHole x) = [| GHole (f x) |] + traverse f (Guess x y) = [| Guess (f x) (f y) |] + traverse f (PVar x) = [| PVar (f x) |] + traverse f (PVTy x) = [| PVTy (f x) |] + + +-- | Reflection of the well typed core language +data TT = P NameType TTName TT + -- ^ named binders + | V Int + -- ^ variables + | Bind TTName (Binder TT) TT + -- ^ type annotated named bindings + | App TT TT + -- ^ (named) application of a function to a value + | TConst Const + -- ^ constants + | Proj TT Int + -- ^ argument projection; runtime only + | Erased + -- ^ erased terms + | Impossible + -- ^ impossible terms + | TType TTUExp + -- ^ types + +-- | Raw terms without types +data Raw = Var TTName + | RBind TTName (Binder Raw) Raw + | RApp Raw Raw + | RType + | RForce Raw + | RConstant Const + +data Tactic = Try Tactic Tactic + -- ^ try the first tactic and resort to the second one on failure + | GoalType String Tactic + -- ^ only run if the goal has the right type + | Refine TTName + -- ^ resolve function name, find matching arguments in the + -- context and compute the proof target + | Seq Tactic Tactic + -- ^ apply both tactics in sequence + | Trivial + -- ^ intelligently construct the proof target from the context + | Solve + -- ^ infer the proof target from the context + | Intros + -- ^ introduce all variables into the context + | Intro TTName + -- ^ introduce a named variable into the context, use the + -- first one if the given name is not found + | ApplyTactic TT + -- ^ invoke the reflected rep. of another tactic + | Reflect TT + -- ^ turn a value into its reflected representation + | Fill Raw + -- ^ turn a raw value back into a term + | Exact TT + -- ^ use the given value to conclude the proof + | Focus TTName + -- ^ focus a named hole + | Rewrite TT + -- ^ rewrite using the reflected rep. of a equality proof + | LetTac TTName TT + -- ^ name a reflected term + | LetTacTy TTName TT TT + -- ^ name a reflected term and type it + | Compute + -- ^ normalise the context + diff --git a/libs/base/Language/Reflection/Errors.idr b/libs/base/Language/Reflection/Errors.idr new file mode 100644 --- /dev/null +++ b/libs/base/Language/Reflection/Errors.idr @@ -0,0 +1,42 @@ +module Language.Reflection.Errors + +import Language.Reflection + +data SourceLocation = FileLoc String Int + +data Err = Msg String + | InternalMsg String + | CantUnify Bool TT TT Err (List (TTName, TT)) Int + -- Int is 'score' - how much we did unify + -- Bool indicates recoverability, True indicates more info may make + -- unification succeed + | InfiniteUnify TTName TT (List (TTName, TT)) + | CantConvert TT TT (List (TTName, TT)) + | UnifyScope TTName TTName TT (List (TTName, TT)) + | CantInferType String + | NonFunctionType TT TT + | CantIntroduce TT + | NoSuchVariable TTName + | NoTypeDecl TTName + | NotInjective TT TT TT + | CantResolve TT + | CantResolveAlts (List String) + | IncompleteTT TT + | UniverseError + | ProgramLineComment + | Inaccessible TTName + | NonCollapsiblePostulate TTName + | AlreadyDefined TTName + | ProofSearchFail Err + | NoRewriting TT + | At SourceLocation Err + | Elaborating String TTName Err + | ProviderError String + +-- | Error reports are a list of report parts +data ErrorReport = Message String + | Name TTName + | Term TT + + +-- Error reports become functions in List (String, TT) -> Err -> ErrorReport diff --git a/libs/base/Language/Reflection/Utils.idr b/libs/base/Language/Reflection/Utils.idr new file mode 100644 --- /dev/null +++ b/libs/base/Language/Reflection/Utils.idr @@ -0,0 +1,187 @@ +module Language.Reflection.Utils + +import Language.Reflection + +-------------------------------------------------------- +-- Tactic construction conveniences +-------------------------------------------------------- + +seq : List Tactic -> Tactic +seq [] = GoalType "This is an impossible case" Trivial +seq [t] = t +seq (t::ts) = t `Seq` seq ts + +try : List Tactic -> Tactic +try [] = GoalType "This is an impossible case" Trivial +try [t] = t +try (t::ts) = t `Try` seq ts + + +-------------------------------------------------------- +-- For use in tactic scripts +-------------------------------------------------------- +mkPair : a -> b -> (a, b) +mkPair a b = (a, b) + + +-------------------------------------------------------- +-- Tools for constructing proof terms directly +-------------------------------------------------------- + +getUName : TTName -> Maybe String +getUName (UN n) = Just n +getUName (NS n ns) = getUName n +getUName _ = Nothing + +unApply : TT -> (TT, List TT) +unApply t = unA t [] + where unA : TT -> List TT -> (TT, List TT) + unA (App fn arg) args = unA fn (arg::args) + unA tm args = (tm, args) + +mkApp : TT -> List TT -> TT +mkApp tm [] = tm +mkApp tm (a::as) = mkApp (App tm a) as + +binderTy : (Eq t) => Binder t -> t +binderTy (Lam t) = t +binderTy (Pi t) = t +binderTy (Let t1 t2) = t1 +binderTy (NLet t1 t2) = t1 +binderTy (Hole t) = t +binderTy (GHole t) = t +binderTy (Guess t1 t2) = t1 +binderTy (PVar t) = t +binderTy (PVTy t) = t + +instance Show TTName where + show (UN str) = "(UN " ++ str ++ ")" + show (NS n ns) = "(NS " ++ show n ++ " " ++ show ns ++ ")" + show (MN i str) = "(MN " ++ show i ++ " " ++ show str ++ ")" + show NErased = "NErased" + +instance Eq TTName where + (UN str1) == (UN str2) = str1 == str2 + (NS n ns) == (NS n' ns') = n == n' && ns == ns' + (MN i str) == (MN i' str') = i == i' && str == str' + NErased == NErased = True + x == y = False + +instance Show TTUExp where + show (UVar i) = "(UVar " ++ show i ++ ")" + show (UVal i) = "(UVal " ++ show i ++ ")" + +instance Eq TTUExp where + (UVar i) == (UVar j) = i == j + (UVal i) == (UVal j) = i == j + x == y = False + +instance Show Const where + show (I i) = "(I " ++ show i ++ ")" + show (BI n) = "(BI " ++ show n ++ ")" + show (Fl f) = "(Fl " ++ show f ++ ")" + show (Ch c) = "(Ch " ++ show c ++ ")" + show (Str str) = "(Str " ++ show str ++ ")" + show IType = "IType" + show BIType = "BIType" + show FlType = "FlType" + show ChType = "ChType" + show StrType = "StrType" + show (B8 b) = "(B8 ...)" + show (B16 b) = "(B16 ...)" + show (B32 b) = "(B32 ...)" + show (B64 b) = "(B64 ...)" + show B8Type = "B8Type" + show B16Type = "B16Type" + show B32Type = "B32Type" + show B64Type = "B64Type" + show PtrType = "PtrType" + show VoidType = "VoidType" + show Forgot = "Forgot" + +instance Eq Const where + (I i) == (I i') = i == i' + (BI n) == (BI n') = n == n' + (Fl f) == (Fl f') = f == f' + (Ch c) == (Ch c') = c == c' + (Str str) == (Str str') = str == str' + IType == IType = True + BIType == BIType = True + FlType == FlType = True + ChType == ChType = True + StrType == StrType = True + (B8 b) == (B8 b') = False -- FIXME: b == b' + (B16 b) == (B16 b') = False -- FIXME: b == b' + (B32 b) == (B32 b') = False -- FIXME: b == b' + (B64 b) == (B64 b') = False -- FIXME: b == b' + B8Type == B8Type = True + B16Type == B16Type = True + B32Type == B32Type = True + B64Type == B64Type = True + PtrType == PtrType = True + VoidType == VoidType = True + Forgot == Forgot = True + x == y = False + +instance Show NameType where + show Bound = "Bound" + show Ref = "Ref" + show (DCon t ar) = "(DCon " ++ show t ++ " " ++ show ar ++ ")" + show (TCon t ar) = "(TCon " ++ show t ++ " " ++ show ar ++ ")" + +instance Eq NameType where + Bound == Bound = True + Ref == Ref = True + (DCon t ar) == (DCon t' ar') = t == t' && ar == ar' + (TCon t ar) == (TCon t' ar') = t == t' && ar == ar' + x == y = False + +instance (Show a) => Show (Binder a) where + show (Lam t) = "(Lam " ++ show t ++ ")" + show (Pi t) = "(Pi " ++ show t ++ ")" + show (Let t1 t2) = "(Let " ++ show t1 ++ " " ++ show t2 ++ ")" + show (NLet t1 t2) = "(NLet " ++ show t1 ++ " " ++ show t2 ++ ")" + show (Hole t) = "(Hole " ++ show t ++ ")" + show (GHole t) = "(GHole " ++ show t ++ ")" + show (Guess t1 t2) = "(Guess " ++ show t1 ++ " " ++ show t2 ++ ")" + show (PVar t) = "(PVar " ++ show t ++ ")" + show (PVTy t) = "(PVTy " ++ show t ++ ")" + +instance (Eq a) => Eq (Binder a) where + (Lam t) == (Lam t') = t == t' + (Pi t) == (Pi t') = t == t' + (Let t1 t2) == (Let t1' t2') = t1 == t1' && t2 == t2' + (NLet t1 t2) == (NLet t1' t2') = t1 == t1' && t2 == t2' + (Hole t) == (Hole t') = t == t' + (GHole t) == (GHole t') = t == t' + (Guess t1 t2) == (Guess t1' t2') = t1 == t1' && t2 == t2' + (PVar t) == (PVar t') = t == t' + (PVTy t) == (PVTy t') = t == t' + x == y = False + +instance Show TT where + show = my_show + where %assert_total my_show : TT -> String + my_show (P nt n t) = "(P " ++ show nt ++ " " ++ show n ++ " " ++ show t ++ ")" + my_show (V i) = "(V " ++ show i ++ ")" + my_show (Bind n b t) = "(Bind " ++ show n ++ " " ++ show b ++ " " ++ show t ++ ")" + my_show (App t1 t2) = "(App " ++ show t1 ++ " " ++ show t2 ++ ")" + my_show (TConst c) = "(TConst " ++ show c ++ ")" + my_show (Proj tm i) = "(Proj " ++ show tm ++ " " ++ show i ++ ")" + my_show Erased = "Erased" + my_show Impossible = "Impossible" + my_show (TType u) = "(TType " ++ show u ++ ")" + +instance Eq TT where + a == b = equalp a b + where %assert_total equalp : TT -> TT -> Bool + equalp (P nt n t) (P nt' n' t') = nt == nt' && n == n' && t == t' + equalp (V i) (V i') = i == i' + equalp (Bind n b t) (Bind n' b' t') = n == n' && b == b' && t == t' + equalp (App t1 t2) (App t1' t2') = t1 == t1' && t2 == t2' + equalp (TConst c) (TConst c') = c == c' + equalp (Proj tm i) (Proj tm' i') = tm == tm' && i == i' + equalp Erased Erased = True + equalp Impossible Impossible = True + equalp (TType u) (TType u') = u == u' + equalp x y = False diff --git a/libs/base/Makefile b/libs/base/Makefile new file mode 100644 --- /dev/null +++ b/libs/base/Makefile @@ -0,0 +1,17 @@ +IDRIS := idris + +build: .PHONY + $(IDRIS) --build base.ipkg + +install: + $(IDRIS) --install base.ipkg + +clean: .PHONY + $(IDRIS) --clean base.ipkg + +rebuild: clean build + +linecount: .PHONY + find . -name '*.idr' | xargs wc -l + +.PHONY: diff --git a/libs/base/Network/Cgi.idr b/libs/base/Network/Cgi.idr new file mode 100644 --- /dev/null +++ b/libs/base/Network/Cgi.idr @@ -0,0 +1,143 @@ +module Network.Cgi + +import System + +%default total + +public +Vars : Type +Vars = List (String, String) + +record CGIInfo : Type 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 : Type -> Type where + MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a + +getAction : CGI a -> CGIInfo -> IO (a, CGIInfo) +getAction (MkCGI act) = act + +instance Functor CGI where + map f (MkCGI c) = MkCGI (\s => do (a, i) <- c s + return (f a, i)) + +instance Applicative CGI where + pure v = MkCGI (\s => return (v, s)) + + (MkCGI a) <$> (MkCGI b) = MkCGI (\s => do (f, i) <- a s + (c, j) <- b i + return (f c, j)) + +instance Monad CGI where { + (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s + getAction (k (fst v)) (snd v)) +} + +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 (toNat x) "" where + getC : Nat -> String -> IO String + getC Z acc = return $ reverse acc + getC (S k) acc = do x <- getChar + getC k (strCons x acc) + +getCgiEnv : String -> IO String +getCgiEnv key = do + val <- getEnv key + return $ maybe "" id val + +abstract +runCGI : CGI a -> IO a +runCGI prog = do + clen_in <- getCgiEnv "CONTENT_LENGTH" + let clen = prim__fromStrInt clen_in + content <- getContent clen + query <- getCgiEnv "QUERY_STRING" + cookie <- getCgiEnv "HTTP_COOKIE" + agent <- getCgiEnv "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/libs/base/Providers.idr b/libs/base/Providers.idr new file mode 100644 --- /dev/null +++ b/libs/base/Providers.idr @@ -0,0 +1,5 @@ +module Providers + +public +data Provider a = Provide a | Error String + diff --git a/libs/base/System.idr b/libs/base/System.idr new file mode 100644 --- /dev/null +++ b/libs/base/System.idr @@ -0,0 +1,76 @@ +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" [] FInt) + + getArg : Int -> IO String + getArg x = mkForeign (FFun "idris_getArg" [FInt] FString) 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 + +-- Retrieves an value from the environment, if the given key is present, +-- otherwise it returns Nothing. +getEnv : String -> IO (Maybe String) +getEnv key = do + str_ptr <- getEnv' + is_nil <- nullStr str_ptr + if is_nil + then pure Nothing + else pure (Just str_ptr) + where + getEnv' : IO String + getEnv' = mkForeign (FFun "getenv" [FString] FString) key + +-- Sets an environment variable with a given value. +-- Returns true if the operation was successful. +setEnv : String -> String -> IO Bool +setEnv key value = do + ok <- mkForeign (FFun "setenv" [FString, FString, FInt] FInt) key value 1 + return (ok == 0) + +-- Unsets an environment variable. +-- Returns true if the variable was able to be unset. +unsetEnv : String -> IO Bool +unsetEnv key = do + ok <- mkForeign (FFun "unsetenv" [FString] FInt) key + return (ok == 0) + +getEnvironment : IO (List (String, String)) +getEnvironment = getAllPairs 0 [] + where + getEnvPair : Int -> IO String + getEnvPair i = mkForeign (FFun "getEnvPair" [FInt] FString) i + + splitEq : String -> (String, String) + splitEq str = + -- FIXME: There has to be a better way to split this up + let (k, v) = break (== '=') str in + let (_, v') = break (/= '=') v in + (k, v') + + getAllPairs : Int -> List String -> IO (List (String, String)) + getAllPairs n acc = do + envPair <- getEnvPair n + is_nil <- nullStr envPair + if is_nil + then return $ reverse $ map splitEq acc + else getAllPairs (n + 1) (envPair :: acc) + +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/libs/base/System/Concurrency/Process.idr b/libs/base/System/Concurrency/Process.idr new file mode 100644 --- /dev/null +++ b/libs/base/System/Concurrency/Process.idr @@ -0,0 +1,68 @@ +-- WARNING: No guarantees that this works properly yet! + +module System.Concurrency.Process + +import System.Concurrency.Raw + +%access public + +abstract +data ProcID msg = MkPID Ptr + +-- Type safe message passing programs. Parameterised over the type of +-- message which can be send, and the return type. + +data Process : (msgType : Type) -> Type -> Type where + lift : IO a -> Process msg a + +instance Functor (Process msg) where + map f (lift a) = lift (map f a) + +instance Applicative (Process msg) where + pure = lift . return + (lift f) <$> (lift a) = lift (f <$> a) + +instance Monad (Process msg) where + (lift io) >>= k = lift (do x <- io + case k x of + lift v => v) + +run : Process msg x -> IO x +run (lift prog) = prog + +-- Get current process ID + +myID : Process msg (ProcID msg) +myID = lift (return (MkPID prim__vm)) + +-- Send a message to another process + +send : ProcID msg -> msg -> Process msg () +send (MkPID p) m = lift (sendToThread p (prim__vm, m)) + +-- Return whether a message is waiting in the queue + +msgWaiting : Process msg Bool +msgWaiting = lift checkMsgs + +-- Receive a message - blocks if there is no message waiting + +recv : Process msg msg +recv {msg} = do (senderid, m) <- lift get + return m + where get : IO (Ptr, msg) + get = getMsg + +-- receive a message, and return with the sender's process ID. + +recvWithSender : Process msg (ProcID msg, msg) +recvWithSender {msg} + = do (senderid, m) <- lift get + return (MkPID senderid, m) + where get : IO (Ptr, msg) + get = getMsg + +create : |(thread : Process msg ()) -> Process msg (ProcID msg) +create (lift p) = do ptr <- lift (fork p) + return (MkPID ptr) + diff --git a/libs/base/System/Concurrency/Raw.idr b/libs/base/System/Concurrency/Raw.idr new file mode 100644 --- /dev/null +++ b/libs/base/System/Concurrency/Raw.idr @@ -0,0 +1,27 @@ +-- WARNING: No guarantees that this works properly yet! + +module System.Concurrency.Raw + +-- Raw (i.e. not type safe) message passing + +import System + +-- Send a message of any type to the thread with the given thread id + +sendToThread : (thread_id : Ptr) -> a -> IO () +sendToThread {a} dest val + = mkForeign (FFun "idris_sendMessage" + [FPtr, FPtr, FAny a] FUnit) prim__vm dest val + +checkMsgs : IO Bool +checkMsgs = do msgs <- mkForeign (FFun "idris_checkMessage" + [FPtr] FInt) prim__vm + return (intToBool msgs) + +-- Check inbox for messages. If there are none, blocks until a message +-- arrives. + +getMsg : IO a +getMsg {a} = mkForeign (FFun "idris_recvMessage" + [FPtr] (FAny a)) prim__vm + diff --git a/libs/base/Uninhabited.idr b/libs/base/Uninhabited.idr new file mode 100644 --- /dev/null +++ b/libs/base/Uninhabited.idr @@ -0,0 +1,12 @@ +module Uninhabited + +class Uninhabited t where + total uninhabited : t -> _|_ + +instance Uninhabited (Fin Z) where + uninhabited fZ impossible + uninhabited (fS f) impossible + +instance Uninhabited (Z = S n) where + uninhabited refl impossible + diff --git a/libs/base/base.ipkg b/libs/base/base.ipkg new file mode 100644 --- /dev/null +++ b/libs/base/base.ipkg @@ -0,0 +1,30 @@ +package base + +opts = "--nobasepkgs --total -i ../prelude" +modules = System, + + Network.Cgi, + Debug.Trace, + + System.Concurrency.Raw, System.Concurrency.Process, + + Decidable.Decidable, Decidable.Order, + + Uninhabited, + + Providers, + + Language.Reflection, Language.Reflection.Utils, Language.Reflection.Errors, + + Data.Morphisms, + Data.Bits, Data.Mod2, + Data.ZZ, Data.Sign, + Data.SortedMap, Data.SortedSet, Data.BoundedList, + Data.Vect, Data.HVect, Data.Vect.Quantifiers, + Data.Floats, Data.Complex, Data.Heap, + + Control.Monad.Identity, + Control.Monad.RWS, + Control.Monad.State, Control.Monad.Writer, Control.Monad.Reader, + Control.Category, Control.Arrow, + Control.Catchable, Control.IOExcept diff --git a/libs/effects/Effect/Exception.idr b/libs/effects/Effect/Exception.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effect/Exception.idr @@ -0,0 +1,40 @@ +module Effect.Exception + +import Effects +import System +import Control.IOExcept + +data Exception : Type -> Type -> Type -> Type -> Type where + Raise : a -> Exception a () () b + +instance Handler (Exception a) Maybe where + handle _ (Raise e) k = Nothing + +instance Show a => Handler (Exception a) IO where + handle _ (Raise e) k = do print e + believe_me (exit 1) + +instance Handler (Exception a) (IOExcept a) where + handle _ (Raise e) k = ioM (return (Left e)) + +instance Handler (Exception a) (Either a) where + handle _ (Raise e) k = Left e + +EXCEPTION : Type -> EFFECT +EXCEPTION t = MkEff () (Exception t) + +raise : a -> Eff m [EXCEPTION a] b +raise err = Raise err + + + + + + + +-- TODO: Catching exceptions mid program? +-- probably need to invoke a new interpreter + +-- possibly add a 'handle' to the Eff language so that an alternative +-- handler can be introduced mid interpretation? + diff --git a/libs/effects/Effect/File.idr b/libs/effects/Effect/File.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effect/File.idr @@ -0,0 +1,69 @@ +module Effect.File + +import Effects +import Control.IOExcept + +data OpenFile : Mode -> Type where + FH : File -> OpenFile m + +data FileIO : Effect where + Open : String -> (m : Mode) -> FileIO () (Either () (OpenFile m)) Bool + Close : FileIO (OpenFile m) () () + + ReadLine : FileIO (OpenFile Read) (OpenFile Read) String + WriteLine : String -> FileIO (OpenFile Write) (OpenFile Write) () + EOF : FileIO (OpenFile Read) (OpenFile Read) Bool + + +instance Handler FileIO IO where + handle () (Open fname m) k = do h <- openFile fname m + valid <- validFile h + if valid then k (Right (FH h)) True + else k (Left ()) False + handle (FH h) Close k = do closeFile h + k () () + handle (FH h) ReadLine k = do str <- fread h + k (FH h) str + handle (FH h) (WriteLine str) k = do fwrite h str + k (FH h) () + handle (FH h) EOF k = do e <- feof h + k (FH h) e + +instance Handler FileIO (IOExcept String) where + handle () (Open fname m) k + = do h <- ioe_lift (openFile fname m) + valid <- ioe_lift (validFile h) + if valid then k (Right (FH h)) True + else k (Left ()) False + handle (FH h) Close k = do ioe_lift (closeFile h); k () () + handle (FH h) ReadLine k = do str <- ioe_lift (fread h) + k (FH h) str + handle (FH h) (WriteLine str) k = do ioe_lift (fwrite h str) + k (FH h) () + handle (FH h) EOF k = do e <- ioe_lift (feof h) + k (FH h) e + +FILE_IO : Type -> EFFECT +FILE_IO t = MkEff t FileIO + +open : Handler FileIO e => + String -> (m : Mode) -> EffM e [FILE_IO ()] + [FILE_IO (Either () (OpenFile m))] Bool +open f m = Open f m + +close : Handler FileIO e => + EffM e [FILE_IO (OpenFile m)] [FILE_IO ()] () +close = Close + +readLine : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] String +readLine = ReadLine + +writeLine : Handler FileIO e => String -> Eff e [FILE_IO (OpenFile Write)] () +writeLine str = WriteLine str + +eof : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] Bool +eof = EOF + + + + diff --git a/libs/effects/Effect/Memory.idr b/libs/effects/Effect/Memory.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effect/Memory.idr @@ -0,0 +1,168 @@ +module Effect.Memory + +import Effects +import Control.IOExcept + +%access public + +abstract +data MemoryChunk : Nat -> Nat -> Type where + CH : Ptr -> MemoryChunk size initialized + +abstract +data RawMemory : Effect where + Allocate : (n : Nat) -> + RawMemory () (MemoryChunk n 0) () + Free : RawMemory (MemoryChunk n i) () () + Initialize : Bits8 -> + (size : Nat) -> + so (i + size <= n) -> + RawMemory (MemoryChunk n i) (MemoryChunk n (i + size)) () + Peek : (offset : Nat) -> + (size : Nat) -> + so (offset + size <= i) -> + RawMemory (MemoryChunk n i) (MemoryChunk n i) (Vect size Bits8) + Poke : (offset : Nat) -> + (Vect size Bits8) -> + so (offset <= i && offset + size <= n) -> + RawMemory (MemoryChunk n i) (MemoryChunk n (max i (offset + size))) () + Move : (src : MemoryChunk src_size src_init) -> + (dst_offset : Nat) -> + (src_offset : Nat) -> + (size : Nat) -> + so (dst_offset <= dst_init && dst_offset + size <= dst_size) -> + so (src_offset + size <= src_init) -> + RawMemory (MemoryChunk dst_size dst_init) + (MemoryChunk dst_size (max dst_init (dst_offset + size))) () + GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (MemoryChunk n i) + +private +do_malloc : Nat -> IOExcept String Ptr +do_malloc size with (fromInteger (cast size) == size) + | True = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (fromInteger $ cast size) + fail <- ioe_lift $ nullPtr ptr + if fail then ioe_fail "Cannot allocate memory" + else return ptr + | False = ioe_fail "The target architecture does not support adressing enough memory" + +private +do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO () +do_memset ptr offset c size + = mkForeign (FFun "idris_memset" [FPtr, FInt, FByte, FInt] FUnit) + ptr (fromInteger $ cast offset) c (fromInteger $ cast size) + +private +do_free : Ptr -> IO () +do_free ptr = mkForeign (FFun "free" [FPtr] FUnit) ptr + +private +do_memmove : Ptr -> Ptr -> Nat -> Nat -> Nat -> IO () +do_memmove dest src dest_offset src_offset size + = mkForeign (FFun "idris_memmove" [FPtr, FPtr, FInt, FInt, FInt] FUnit) + dest src (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size) + +private +do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8) +do_peek _ _ Z = return (Prelude.Vect.Nil) +do_peek ptr offset (S n) + = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FByte) ptr (fromInteger $ cast offset) + bs <- do_peek ptr (S offset) n + Prelude.Monad.return (Prelude.Vect.(::) b bs) + +private +do_poke : Ptr -> Nat -> Vect size Bits8 -> IO () +do_poke _ _ [] = return () +do_poke ptr offset (b::bs) + = do mkForeign (FFun "idris_poke" [FPtr, FInt, FByte] FUnit) ptr (fromInteger $ cast offset) b + do_poke ptr (S offset) bs + +instance Handler RawMemory (IOExcept String) where + handle () (Allocate n) k + = do ptr <- do_malloc n + k (CH ptr) () + handle {res = MemoryChunk _ offset} (CH ptr) (Initialize c size _) k + = ioe_lift (do_memset ptr offset c size) $> k (CH ptr) () + handle (CH ptr) (Free) k + = ioe_lift (do_free ptr) $> k () () + handle (CH ptr) (Peek offset size _) k + = do res <- ioe_lift (do_peek ptr offset size) + k (CH ptr) res + handle (CH ptr) (Poke offset content _) k + = do ioe_lift (do_poke ptr offset content) + k (CH ptr) () + handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k + = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size) + k (CH dest_ptr) () + handle chunk (GetRawPtr) k + = k chunk chunk + +RAW_MEMORY : Type -> EFFECT +RAW_MEMORY t = MkEff t RawMemory + +allocate : (n : Nat) -> EffM m [RAW_MEMORY ()] [RAW_MEMORY (MemoryChunk n 0)] () +allocate size = Allocate size + +initialize : {i : Nat} -> + {n : Nat} -> + Bits8 -> + (size : Nat) -> + so (i + size <= n) -> + EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (i + size))] () +initialize c size prf = Initialize c size prf + +free : EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY ()] () +free = Free + +peek : {i : Nat} -> + (offset : Nat) -> + (size : Nat) -> + so (offset + size <= i) -> + Eff m [RAW_MEMORY (MemoryChunk n i)] (Vect size Bits8) +peek offset size prf = Peek offset size prf + +poke : {n : Nat} -> + {i : Nat} -> + (offset : Nat) -> + Vect size Bits8 -> + so (offset <= i && offset + size <= n) -> + EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (max i (offset + size)))] () +poke offset content prf = Poke offset content prf + +private +getRawPtr : Eff m [RAW_MEMORY (MemoryChunk n i)] (MemoryChunk n i) +getRawPtr = GetRawPtr + +private +move' : {dst_size : Nat} -> + {dst_init : Nat} -> + {src_init : Nat} -> + (src_ptr : MemoryChunk src_size src_init) -> + (dst_offset : Nat) -> + (src_offset : Nat) -> + (size : Nat) -> + so (dst_offset <= dst_init && dst_offset + size <= dst_size) -> + so (src_offset + size <= src_init) -> + EffM m [RAW_MEMORY (MemoryChunk dst_size dst_init)] + [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))] () +move' src_ptr dst_offset src_offset size dst_bounds src_bounds + = Move src_ptr dst_offset src_offset size dst_bounds src_bounds + +data MoveDescriptor = Dst | Src + +move : {dst_size : Nat} -> + {dst_init : Nat} -> + {src_size : Nat} -> + {src_init : Nat} -> + (dst_offset : Nat) -> + (src_offset : Nat) -> + (size : Nat) -> + so (dst_offset <= dst_init && dst_offset + size <= dst_size) -> + so (src_offset + size <= src_init) -> + EffM m [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init) + , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] + [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size))) + , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] () +move dst_offset src_offset size dst_bounds src_bounds + = do src_ptr <- Src :- getRawPtr + Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds + return () diff --git a/libs/effects/Effect/Random.idr b/libs/effects/Effect/Random.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effect/Random.idr @@ -0,0 +1,25 @@ +module Effect.Random + +import Effects + +data Random : Type -> Type -> Type -> Type where + getRandom : Random Integer Integer Integer + setSeed : Integer -> Random Integer Integer () + +using (m : Type -> Type) + instance Handler Random m where + handle seed getRandom k + = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in + k seed' seed' + handle seed (setSeed n) k = k n () + +RND : EFFECT +RND = MkEff Integer Random + +rndInt : Integer -> Integer -> Eff m [RND] Integer +rndInt lower upper = do v <- getRandom + return (v `prim__sremBigInt` (upper - lower) + lower) + +srand : Integer -> Eff m [RND] () +srand n = setSeed n + diff --git a/libs/effects/Effect/Select.idr b/libs/effects/Effect/Select.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effect/Select.idr @@ -0,0 +1,23 @@ +module Effect.Select + +import Effects + +data Selection : Effect where + Select : List a -> Selection () () a + +instance Handler Selection Maybe where + handle _ (Select xs) k = tryAll xs where + tryAll [] = Nothing + tryAll (x :: xs) = case k () x of + Nothing => tryAll xs + Just v => Just v + +instance Handler Selection List where + handle r (Select xs) k = concatMap (k r) xs + +SELECT : EFFECT +SELECT = MkEff () Selection + +select : List a -> Eff m [SELECT] a +select xs = Select xs + diff --git a/libs/effects/Effect/State.idr b/libs/effects/Effect/State.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effect/State.idr @@ -0,0 +1,40 @@ +module Effect.State + +import Effects + +%access public + +data State : Effect where + Get : State a a a + Put : b -> State a b () + +using (m : Type -> Type) + instance Handler State m where + handle st Get k = k st st + handle st (Put n) k = k n () + +STATE : Type -> EFFECT +STATE t = MkEff t State + +get : Eff m [STATE x] x +get = Get + +put : x -> Eff m [STATE x] () +put val = Put val + +putM : y -> EffM m [STATE x] [STATE y] () +putM val = Put val + +update : (x -> x) -> Eff m [STATE x] () +update f = put (f !get) + +updateM : (x -> y) -> EffM m [STATE x] [STATE y] () +updateM f = putM (f !get) + +locally : x -> Eff m [STATE x] t -> Eff m [STATE y] t +locally newst prog = do st <- get + putM newst + val <- prog + putM st + return val + diff --git a/libs/effects/Effect/StdIO.idr b/libs/effects/Effect/StdIO.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effect/StdIO.idr @@ -0,0 +1,60 @@ +module Effect.StdIO + +import Effects +import Control.IOExcept + +data StdIO : Effect where + PutStr : String -> StdIO () () () + GetStr : StdIO () () String + +instance Handler StdIO IO where + handle () (PutStr s) k = do putStr s; k () () + handle () GetStr k = do x <- getLine; k () x + +instance Handler StdIO (IOExcept a) where + handle () (PutStr s) k = do ioe_lift (putStr s); k () () + handle () GetStr k = do x <- ioe_lift getLine; k () x + +-- Handle effects in a pure way, for simulating IO for unit testing/proof + +data IOStream a = MkStream (List String -> (a, List String)) + +instance Handler StdIO IOStream where + handle () (PutStr s) k + = MkStream (\x => case k () () of + MkStream f => let (res, str) = f x in + (res, s :: str)) + handle {a} () GetStr k + = MkStream (\x => case x of + [] => cont "" [] + (t :: ts) => cont t ts) + where + cont : String -> List String -> (a, List String) + cont t ts = case k () t of + MkStream f => f ts + +--- The Effect and associated functions + +STDIO : EFFECT +STDIO = MkEff () StdIO + +putStr : Handler StdIO e => String -> Eff e [STDIO] () +putStr s = PutStr s + +putStrLn : Handler StdIO e => String -> Eff e [STDIO] () +putStrLn s = putStr (s ++ "\n") + +getStr : Handler StdIO e => Eff e [STDIO] String +getStr = GetStr + +mkStrFn : Env IOStream xs -> + Eff IOStream xs a -> + List String -> (a, List String) +mkStrFn {a} env p input = case mkStrFn' of + MkStream f => f input + where injStream : a -> IOStream a + injStream v = MkStream (\x => (v, [])) + mkStrFn' : IOStream a + mkStrFn' = runWith injStream env p + + diff --git a/libs/effects/Effects.idr b/libs/effects/Effects.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effects.idr @@ -0,0 +1,289 @@ +module Effects + +import Language.Reflection +import Control.Catchable + +%access public + +---- Effects + +Effect : Type +Effect = Type -> Type -> Type -> Type + +data EFFECT : Type where + MkEff : Type -> Effect -> EFFECT + +class Handler (e : Effect) (m : Type -> Type) where + handle : res -> (eff : e res res' t) -> (res' -> t -> m a) -> m a + +---- Properties and proof construction + +using (xs : List a, ys : List a) + data SubList : List a -> List a -> Type where + SubNil : SubList {a} [] [] + Keep : SubList xs ys -> SubList (x :: xs) (x :: ys) + Drop : SubList xs ys -> SubList xs (x :: ys) + + subListId : SubList xs xs + subListId {xs = Nil} = SubNil + subListId {xs = x :: xs} = Keep subListId + +data Env : (m : Type -> Type) -> List EFFECT -> Type where + Nil : Env m Nil + (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs) + +data EffElem : (Type -> Type -> Type -> Type) -> Type -> + List EFFECT -> Type where + Here : EffElem x a (MkEff a x :: xs) + There : EffElem x a xs -> EffElem x a (y :: xs) + +-- make an environment corresponding to a sub-list +dropEnv : Env m ys -> SubList xs ys -> Env m xs +dropEnv [] SubNil = [] +dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest +dropEnv (v :: vs) (Drop rest) = dropEnv vs rest + +updateWith : (ys' : List a) -> (xs : List a) -> + SubList ys xs -> List a +updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest +updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest +updateWith [] [] SubNil = [] +updateWith (y :: ys) [] SubNil = y :: ys +updateWith [] (x :: xs) (Keep rest) = [] + +-- put things back, replacing old with new in the sub-environment +rebuildEnv : Env m ys' -> (prf : SubList ys xs) -> + Env m xs -> Env m (updateWith ys' xs prf) +rebuildEnv [] SubNil env = env +rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env +rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env +rebuildEnv (x :: xs) SubNil [] = x :: xs + +---- The Effect EDSL itself ---- + +-- some proof automation +findEffElem : Nat -> List (TTName, Binder TT) -> TT -> Tactic -- Nat is maximum search depth +findEffElem Z ctxt goal = Refine "Here" `Seq` Solve +findEffElem (S n) ctxt goal = GoalType "EffElem" + (Try (Refine "Here" `Seq` Solve) + (Refine "There" `Seq` (Solve `Seq` findEffElem n ctxt goal))) + +findSubList : Nat -> List (TTName, Binder TT) -> TT -> Tactic +findSubList Z ctxt goal = Refine "SubNil" `Seq` Solve +findSubList (S n) ctxt goal + = GoalType "SubList" + (Try (Refine "subListId" `Seq` Solve) + ((Try (Refine "Keep" `Seq` Solve) + (Refine "Drop" `Seq` Solve)) `Seq` findSubList n ctxt goal)) + +updateResTy : (xs : List EFFECT) -> EffElem e a xs -> e a b t -> + List EFFECT +updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs +updateResTy (x :: xs) (There p) n = x :: updateResTy xs p n + +updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type -> + List EFFECT +updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs +updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b + +infix 5 :::, :-, := + +data LRes : lbl -> Type -> Type where + (:=) : (x : lbl) -> res -> LRes x res + +(:::) : lbl -> EFFECT -> EFFECT +(:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff + +private +unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x] +unlabel {m} {x = MkEff a eff} [l := v] = [v] + +private +relabel : (l : ty) -> Env m [x] -> Env m [l ::: x] +relabel {x = MkEff a eff} l [v] = [l := v] + +-- the language of Effects + +data EffM : (m : Type -> Type) -> + List EFFECT -> List EFFECT -> Type -> Type where + value : a -> EffM m xs xs a + ebind : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b + effect : (prf : EffElem e a xs) -> + (eff : e a b t) -> + EffM m xs (updateResTy xs prf eff) t + lift : (prf : SubList ys xs) -> + EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t + new : Handler e m => + res -> EffM m (MkEff res e :: xs) (MkEff res' e :: xs') a -> + EffM m xs xs' a + test : (prf : EffElem e (Either l r) xs) -> + EffM m (updateResTyImm xs prf l) xs' t -> + EffM m (updateResTyImm xs prf r) xs' t -> + EffM m xs xs' t + test_lbl : {x : lbl} -> + (prf : EffElem e (LRes x (Either l r)) xs) -> + EffM m (updateResTyImm xs prf (LRes x l)) xs' t -> + EffM m (updateResTyImm xs prf (LRes x r)) xs' t -> + EffM m xs xs' t + catch : Catchable m err => + EffM m xs xs' a -> (err -> EffM m xs xs' a) -> + EffM m xs xs' a + (:-) : (l : ty) -> EffM m [x] [y] t -> EffM m [l ::: x] [l ::: y] t + +syntax [tag] ":!" [val] = !(tag :- val) + +-- Eff : List (EFFECT m) -> Type -> Type + +implicit +lift' : {default tactics { applyTactic findSubList 20; solve; } + prf : SubList ys xs} -> + EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t +lift' {prf} e = lift prf e + +implicit +effect' : {a, b: _} -> {e : Effect} -> + {default tactics { applyTactic findEffElem 20; solve; } + prf : EffElem e a xs} -> + (eff : e a b t) -> + EffM m xs (updateResTy xs prf eff) t +effect' {prf} e = effect prf e + +-- For making proofs implicitly for 'test' and 'test_lbl' + +syntax if_valid then [e] else [t] = + test (tactics { applyTactic findEffElem 20; solve; }) t e + +syntax if_valid [lbl] then [e] else [t] = + test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e + +syntax if_error then [t] else [e] = + test (tactics { applyTactic findEffElem 20; solve; }) t e + +syntax if_error [lbl] then [t] else [e] = + test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e + +-- These may read better in some contexts + +syntax if_right then [e] else [t] = + test (tactics { applyTactic findEffElem 20; solve; }) t e + +syntax if_right [lbl] then [e] else [t] = + test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e + +syntax if_left then [t] else [e] = + test (tactics { applyTactic findEffElem 20; solve; }) t e + +syntax if_left [lbl] then [t] else [e] = + test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e + + +-- for 'do' notation + +return : a -> EffM m xs xs a +return x = value x + +(>>=) : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b +(>>=) = ebind + +-- for idiom brackets + +infixl 2 <$> + +pure : a -> EffM m xs xs a +pure = value + +(<$>) : EffM m xs xs (a -> b) -> EffM m xs xs a -> EffM m xs xs b +(<$>) prog v = do fn <- prog + arg <- v + return (fn arg) + +-- an interpreter + +private +execEff : Env m xs -> (p : EffElem e res xs) -> + (eff : e res b a) -> + (Env m (updateResTy xs p eff) -> a -> m t) -> m t +execEff (val :: env) Here eff' k + = handle val eff' (\res, v => k (res :: env) v) +execEff (val :: env) (There p) eff k + = execEff env p eff (\env', v => k (val :: env') v) + +private +testEff : Env m xs -> (p : EffElem e (Either l r) xs) -> + (Env m (updateResTyImm xs p l) -> m b) -> + (Env m (updateResTyImm xs p r) -> m b) -> + m b +testEff (Left err :: env) Here lk rk = lk (err :: env) +testEff (Right ok :: env) Here lk rk = rk (ok :: env) +testEff (val :: env) (There p) lk rk + = testEff env p (\envk => lk (val :: envk)) + (\envk => rk (val :: envk)) + +private +testEffLbl : {x : lbl} -> + Env m xs -> (p : EffElem e (LRes x (Either l r)) xs) -> + (Env m (updateResTyImm xs p (LRes x l)) -> m b) -> + (Env m (updateResTyImm xs p (LRes x r)) -> m b) -> + m b +testEffLbl ((lbl := Left err) :: env) Here lk rk = lk ((lbl := err) :: env) +testEffLbl ((lbl := Right ok) :: env) Here lk rk = rk ((lbl := ok) :: env) +testEffLbl (val :: env) (There p) lk rk + = testEffLbl env p (\envk => lk (val :: envk)) + (\envk => rk (val :: envk)) + +-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state +-- updates can be propagated even through failing computations? + +eff : Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b +eff env (value x) k = k env x +eff env (prog `ebind` c) k + = eff env prog (\env', p' => eff env' (c p') k) +eff env (effect prf effP) k = execEff env prf effP k +eff env (lift prf effP) k + = let env' = dropEnv env prf in + eff env' effP (\envk, p' => k (rebuildEnv envk prf env) p') +eff env (new r prog) k + = let env' = r :: env in + eff env' prog (\(v :: envk), p' => k envk p') +eff env (test prf l r) k + = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k) +eff env (test_lbl prf l r) k + = testEffLbl env prf (\envk => eff envk l k) (\envk => eff envk r k) +eff env (catch prog handler) k + = catch (eff env prog k) + (\e => eff env (handler e) k) +-- FIXME: +-- xs is needed explicitly because otherwise the pattern binding for +-- 'l' appears too late. Solution seems to be to reorder patterns at the +-- end so that everything is in scope when it needs to be. +eff {xs = [l ::: x]} env (l :- prog) k + = let env' = unlabel env in + eff env' prog (\envk, p' => k (relabel l envk) p') + +run : Applicative m => Env m xs -> EffM m xs xs' a -> m a +run env prog = eff env prog (\env, r => pure r) + +runEnv : Applicative m => Env m xs -> EffM m xs xs' a -> m (Env m xs', a) +runEnv env prog = eff env prog (\env, r => pure (env, r)) + +runPure : Env id xs -> EffM id xs xs' a -> a +runPure env prog = eff env prog (\env, r => r) + +runPureEnv : Env id xs -> EffM id xs xs' a -> (Env id xs', a) +runPureEnv env prog = eff env prog (\env, r => (env, r)) + +runWith : (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a +runWith inj env prog = eff env prog (\env, r => inj r) + +Eff : (Type -> Type) -> List EFFECT -> Type -> Type +Eff m xs t = EffM m xs xs t + +-- some higher order things + +mapE : Applicative m => (a -> Eff m xs b) -> List a -> Eff m xs (List b) +mapE f [] = pure [] +mapE f (x :: xs) = [| f x :: mapE f xs |] + +when : Applicative m => Bool -> Eff m xs () -> Eff m xs () +when True e = e +when False e = pure () diff --git a/libs/effects/Makefile b/libs/effects/Makefile new file mode 100644 --- /dev/null +++ b/libs/effects/Makefile @@ -0,0 +1,14 @@ +IDRIS := idris + +build: .PHONY + $(IDRIS) --build effects.ipkg + +clean: .PHONY + $(IDRIS) --clean effects.ipkg + +install: + $(IDRIS) --install effects.ipkg + +rebuild: clean build + +.PHONY: diff --git a/libs/effects/effects.ipkg b/libs/effects/effects.ipkg new file mode 100644 --- /dev/null +++ b/libs/effects/effects.ipkg @@ -0,0 +1,8 @@ +package effects + +opts = "--nobasepkgs -i ../prelude -i ../base" +modules = Effects, + Effect.Exception, Effect.File, Effect.State, + Effect.Random, Effect.StdIO, Effect.Select, + Effect.Memory + diff --git a/libs/javascript/JavaScript.idr b/libs/javascript/JavaScript.idr new file mode 100644 --- /dev/null +++ b/libs/javascript/JavaScript.idr @@ -0,0 +1,104 @@ +module JavaScript + +%access public + +private +isUndefined : Ptr -> IO Bool +isUndefined p = do + res <- mkForeign ( + FFun "%0 === undefined" [FPtr] FString) p + if res == "false" + then (return False) + else (return True) + +-------------------------------------------------------------------------------- +-- Events +-------------------------------------------------------------------------------- +abstract +data Event : Type where + MkEvent : Ptr -> Event + +-------------------------------------------------------------------------------- +-- Elements +-------------------------------------------------------------------------------- +abstract +data Element : Type where + MkElem : Ptr -> Element + +setText : Element -> String -> IO () +setText (MkElem p) s = + mkForeign (FFun "%0.textContent=%1" [FPtr, FString] FUnit) p s + + +setOnClick : Element -> (Event -> IO Bool) -> IO () +setOnClick (MkElem e) f = + mkForeign ( + FFun "%0['onclick']=%1" [ FPtr + , FFunction (FAny Event) (FAny (IO Bool)) + ] FUnit) e f +-------------------------------------------------------------------------------- +-- Nodelists +-------------------------------------------------------------------------------- +abstract +data NodeList : Type where + MkNodeList : Ptr -> NodeList + +elemAt : NodeList -> Nat -> IO (Maybe Element) +elemAt (MkNodeList p) i = do + e <- mkForeign (FFun "%0.item(%1)" [FPtr, FInt] FPtr) p ( + prim__truncBigInt_Int (cast i) + ) + d <- isUndefined e + if d + then return $ Just (MkElem e) + else return Nothing + +-------------------------------------------------------------------------------- +-- Intervals +-------------------------------------------------------------------------------- +abstract +data Interval : Type where + MkInterval : Ptr -> Interval + +setInterval : (() -> IO ()) -> Float -> IO Interval +setInterval f t = do + e <- mkForeign ( + FFun "setInterval(%0,%1)" [FFunction FUnit (FAny (IO ())), FFloat] FPtr + ) f t + return (MkInterval e) + +clearInterval : Interval -> IO () +clearInterval (MkInterval p) = + mkForeign (FFun "clearInterval(%0)" [FPtr] FUnit) p + +-------------------------------------------------------------------------------- +-- Timeouts +-------------------------------------------------------------------------------- +data Timeout : Type where + MkTimeout : Ptr -> Timeout + +setTimeout : (() -> IO ()) -> Float -> IO Timeout +setTimeout f t = do + e <- mkForeign ( + FFun "setTimeout(%0,%1)" [FFunction FUnit (FAny (IO ())), FFloat] FPtr + ) f t + return (MkTimeout e) + +clearTimeout : Timeout -> IO () +clearTimeout (MkTimeout p) = + mkForeign (FFun "clearTimeout(%0)" [FPtr] FUnit) p + +-------------------------------------------------------------------------------- +-- Basic IO +-------------------------------------------------------------------------------- +alert : String -> IO () +alert msg = + mkForeign (FFun "alert(%0)" [FString] FUnit) msg + +-------------------------------------------------------------------------------- +-- DOM +-------------------------------------------------------------------------------- +query : String -> IO NodeList +query q = do + e <- mkForeign (FFun "document.querySelectorAll(%0)" [FString] FPtr) q + return (MkNodeList e) diff --git a/libs/javascript/JavaScript/JSON.idr b/libs/javascript/JavaScript/JSON.idr new file mode 100644 --- /dev/null +++ b/libs/javascript/JavaScript/JSON.idr @@ -0,0 +1,46 @@ +module JSON + +import Data.SortedMap + +data JSONType : Type where + JSONArray : (n : Nat) -> Vect n JSONType -> JSONType + JSONString : JSONType + JSONNumber : JSONType + JSONBool : JSONType + JSONObject : SortedMap String JSONType -> JSONType + JSONNull : JSONType + +mutual + using (ts : Vect n JSONType, fs : SortedMap String JSONType) + namespace JArray + data JArray : (n : Nat) -> Vect n JSONType -> Type where + Nil : JArray 0 [] + (::) : JSON t -> JArray n ts -> JArray (S n) (t :: ts) + + namespace JObject + data JObject : SortedMap String JSONType -> Type where + Nil : JObject empty + (::) : (f : (String, JSON t)) -> + JObject fs -> + JObject (insert (fst f) t fs) + + data JSON : JSONType -> Type where + JSString : String -> JSON JSONString + JSNumber : Float -> JSON JSONNumber + JSBool : Bool -> JSON JSONBool + JSNull : JSON JSONNull + JSArray : JArray n ts -> JSON (JSONArray n ts) + JSObject : JObject fs -> JSON (JSONObject fs) + +index : (i : Fin n) -> JSON (JSONArray n ts) -> JSON (index i ts) +index fZ (JSArray (x :: xs)) = x +index (fS i) (JSArray (x :: xs)) = index i (JSArray xs) + +infixl 8 ++ + +(++) : JSON (JSONArray m ts1) -> + JSON (JSONArray n ts2) -> + JSON (JSONArray (m + n) (ts1 ++ ts2)) +(++) (JSArray []) ys = ys +(++) (JSArray (x :: xs)) ys with ((JSArray xs) ++ ys) + | (JSArray as) = JSArray (x :: as) diff --git a/libs/javascript/Makefile b/libs/javascript/Makefile new file mode 100644 --- /dev/null +++ b/libs/javascript/Makefile @@ -0,0 +1,14 @@ +IDRIS := idris + +build: .PHONY + $(IDRIS) --build javascript.ipkg + +install: + $(IDRIS) --install javascript.ipkg + +clean: .PHONY + $(IDRIS) --clean javascript.ipkg + +rebuild: clean build + +.PHONY: diff --git a/libs/javascript/javascript.ipkg b/libs/javascript/javascript.ipkg new file mode 100644 --- /dev/null +++ b/libs/javascript/javascript.ipkg @@ -0,0 +1,5 @@ +package javascript + +opts = "--nobasepkgs -i ../prelude -i ../base" +modules = JavaScript, JavaScript.JSON + diff --git a/libs/prelude/Builtins.idr b/libs/prelude/Builtins.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Builtins.idr @@ -0,0 +1,44 @@ +%access public +%default total + +data Exists : (a : Type) -> (P : a -> Type) -> Type where + Ex_intro : {P : a -> Type} -> (x : a) -> P x -> Exists a P + +getWitness : {P : a -> Type} -> Exists a P -> a +getWitness (a ** v) = a + +getProof : {P : a -> Type} -> (s : Exists a P) -> P (getWitness s) +getProof (a ** v) = v + +FalseElim : _|_ -> a + +-- ------------------------------------------------------ [ For rewrite tactic ] +replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y +replace refl prf = prf + +sym : {l:a} -> {r:a} -> l = r -> r = l +sym refl = refl + +trans : {a:x} -> {b:x} -> {c:x} -> a = b -> b = c -> a = c +trans refl refl = refl + +lazy : a -> a +lazy x = x -- compiled specially + +par : |(thunk:a) -> a +par x = x -- compiled specially + +malloc : Int -> a -> a +malloc size x = x -- compiled specially + +trace_malloc : a -> a +trace_malloc x = x -- compiled specially + +abstract %assert_total -- need to pretend +believe_me : a -> b -- compiled specially as id, use with care! +believe_me x = prim__believe_me _ _ x + +public %assert_total -- reduces at compile time, use with extreme care! +really_believe_me : a -> b +really_believe_me x = prim__believe_me _ _ x + diff --git a/libs/prelude/Decidable/Equality.idr b/libs/prelude/Decidable/Equality.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Decidable/Equality.idr @@ -0,0 +1,179 @@ +module Decidable.Equality + +import Builtins +import Prelude.Either +import Prelude.List +import Prelude.Vect +import Prelude.Fin +import Prelude.Maybe + +-------------------------------------------------------------------------------- +-- Utility lemmas +-------------------------------------------------------------------------------- + +total negEqSym : {a : t} -> {b : t} -> (a = b -> _|_) -> (b = a -> _|_) +negEqSym p h = p (sym h) + + +-------------------------------------------------------------------------------- +-- Decidable equality +-------------------------------------------------------------------------------- + +class DecEq t where + total decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2) + +-------------------------------------------------------------------------------- +--- Unit +-------------------------------------------------------------------------------- + +instance DecEq () where + decEq () () = Yes refl + +-------------------------------------------------------------------------------- +-- Booleans +-------------------------------------------------------------------------------- + +total trueNotFalse : True = False -> _|_ +trueNotFalse refl impossible + +instance DecEq Bool where + decEq True True = Yes refl + decEq False False = Yes refl + decEq True False = No trueNotFalse + decEq False True = No (negEqSym trueNotFalse) + +-------------------------------------------------------------------------------- +-- Nat +-------------------------------------------------------------------------------- + +total OnotS : Z = S n -> _|_ +OnotS refl impossible + +instance DecEq Nat where + decEq Z Z = Yes refl + decEq Z (S _) = No OnotS + decEq (S _) Z = No (negEqSym OnotS) + decEq (S n) (S m) with (decEq n m) + | Yes p = Yes $ cong p + | No p = No $ \h : (S n = S m) => p $ succInjective n m h + +-------------------------------------------------------------------------------- +-- Maybe +-------------------------------------------------------------------------------- + +total nothingNotJust : {x : t} -> (Nothing {a = t} = Just x) -> _|_ +nothingNotJust refl impossible + +instance (DecEq t) => DecEq (Maybe t) where + decEq Nothing Nothing = Yes refl + decEq (Just x') (Just y') with (decEq x' y') + | Yes p = Yes $ cong p + | No p = No $ \h : Just x' = Just y' => p $ justInjective h + decEq Nothing (Just _) = No nothingNotJust + decEq (Just _) Nothing = No (negEqSym nothingNotJust) + +-------------------------------------------------------------------------------- +-- Either +-------------------------------------------------------------------------------- + +total leftNotRight : {x : a} -> {y : b} -> Left {b = b} x = Right {a = a} y -> _|_ +leftNotRight refl impossible + +instance (DecEq a, DecEq b) => DecEq (Either a b) where + decEq (Left x') (Left y') with (decEq x' y') + | Yes p = Yes $ cong p + | No p = No $ \h : Left x' = Left y' => p $ leftInjective {b = b} h + decEq (Right x') (Right y') with (decEq x' y') + | Yes p = Yes $ cong p + | No p = No $ \h : Right x' = Right y' => p $ rightInjective {a = a} h + decEq (Left x') (Right y') = No leftNotRight + decEq (Right x') (Left y') = No $ negEqSym leftNotRight + +-------------------------------------------------------------------------------- +-- Fin +-------------------------------------------------------------------------------- + +total fZNotfS : {f : Fin n} -> fZ {k = n} = fS f -> _|_ +fZNotfS refl impossible + +instance DecEq (Fin n) where + decEq fZ fZ = Yes refl + decEq fZ (fS f) = No fZNotfS + decEq (fS f) fZ = No $ negEqSym fZNotfS + decEq (fS f) (fS f') with (decEq f f') + | Yes p = Yes $ cong p + | No p = No $ \h => p $ fSinjective {f = f} {f' = f'} h + +-------------------------------------------------------------------------------- +-- Tuple +-------------------------------------------------------------------------------- + +lemma_both_neq : {x : a, y : b, x' : c, y' : d} -> (x = x' -> _|_) -> (y = y' -> _|_) -> ((x, y) = (x', y') -> _|_) +lemma_both_neq p_x_not_x' p_y_not_y' refl = p_x_not_x' refl + +lemma_snd_neq : {x : a, y : b, y' : d} -> (x = x) -> (y = y' -> _|_) -> ((x, y) = (x, y') -> _|_) +lemma_snd_neq refl p refl = p refl + +lemma_fst_neq_snd_eq : {x : a, x' : b, y : c, y' : d} -> + (x = x' -> _|_) -> + (y = y') -> + ((x, y) = (x', y) -> _|_) +lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl + +instance (DecEq a, DecEq b) => DecEq (a, b) where + decEq (a, b) (a', b') with (decEq a a') + decEq (a, b) (a, b') | (Yes refl) with (decEq b b') + decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl + decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq) + decEq (a, b) (a', b') | (No p) with (decEq b b') + decEq (a, b) (a', b) | (No p) | (Yes refl) = No (\eq => lemma_fst_neq_snd_eq p refl eq) + decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq) + + +-------------------------------------------------------------------------------- +-- List +-------------------------------------------------------------------------------- + +lemma_val_not_nil : {x : t, xs : List t} -> ((x :: xs) = Prelude.List.Nil {a = t} -> _|_) +lemma_val_not_nil refl impossible + +lemma_x_eq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y) -> (xs = ys -> _|_) -> ((x :: xs) = (y :: ys) -> _|_) +lemma_x_eq_xs_neq refl p refl = p refl + +lemma_x_neq_xs_eq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> _|_) -> (xs = ys) -> ((x :: xs) = (y :: ys) -> _|_) +lemma_x_neq_xs_eq p refl refl = p refl + +lemma_x_neq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> _|_) -> (xs = ys -> _|_) -> ((x :: xs) = (y :: ys) -> _|_) +lemma_x_neq_xs_neq p p' refl = p refl + +instance DecEq a => DecEq (List a) where + decEq [] [] = Yes refl + decEq (x :: xs) [] = No lemma_val_not_nil + decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil) + decEq (x :: xs) (y :: ys) with (decEq x y) + decEq (x :: xs) (x :: ys) | Yes refl with (decEq xs ys) + decEq (x :: xs) (x :: xs) | (Yes refl) | (Yes refl) = Yes refl -- maybe another yes refl + decEq (x :: xs) (x :: ys) | (Yes refl) | (No p) = No (\eq => lemma_x_eq_xs_neq refl p eq) + decEq (x :: xs) (y :: ys) | No p with (decEq xs ys) + decEq (x :: xs) (y :: xs) | (No p) | (Yes refl) = No (\eq => lemma_x_neq_xs_eq p refl eq) + decEq (x :: xs) (y :: ys) | (No p) | (No p') = No (\eq => lemma_x_neq_xs_neq p p' eq) + + +-------------------------------------------------------------------------------- +-- Vect +-------------------------------------------------------------------------------- + +total +vectInjective1 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> x = y +vectInjective1 {x=x} {y=x} {xs=xs} {ys=xs} refl = refl + +total +vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys +vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} refl = refl + +instance DecEq a => DecEq (Vect n a) where + decEq [] [] = Yes refl + decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys) + decEq (x :: xs) (x :: xs) | (Yes refl, Yes refl) = Yes refl + decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p)) + decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p)) diff --git a/libs/prelude/IO.idr b/libs/prelude/IO.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/IO.idr @@ -0,0 +1,149 @@ +import Prelude.List + +%access public + +abstract data PrimIO a = prim__IO a + +abstract data World = TheWorld + +abstract WorldRes : Type -> Type +WorldRes x = x + +-- abstract data WorldRes a = MkWR a World + +abstract data IO a = MkIO (World -> PrimIO (WorldRes a)) + +abstract +prim_io_bind : PrimIO a -> (a -> PrimIO b) -> PrimIO b +prim_io_bind (prim__IO v) k = k v + +unsafePerformPrimIO : PrimIO a -> a +-- compiled as primitive + +abstract +prim_io_return : a -> PrimIO a +prim_io_return x = prim__IO x + +data IntTy = ITChar | ITNative | IT8 | IT16 | IT32 | IT64 | IT8x16 | IT16x8 | IT32x4 | IT64x2 +data FTy = FIntT IntTy + | FFunction FTy FTy + | FFloat + | FString + | FPtr + | FAny Type + | FUnit + +FInt : FTy +FInt = FIntT ITNative + +FChar : FTy +FChar = FIntT ITChar + +FByte : FTy +FByte = FIntT IT8 + +FShort : FTy +FShort = FIntT IT16 + +FLong : FTy +FLong = FIntT IT64 + +FBits8 : FTy +FBits8 = FIntT IT8 + +FBits16 : FTy +FBits16 = FIntT IT16 + +FBits32 : FTy +FBits32 = FIntT IT32 + +FBits64 : FTy +FBits64 = FIntT IT64 + +FBits8x16 : FTy +FBits8x16 = FIntT IT8x16 + +FBits16x8 : FTy +FBits16x8 = FIntT IT16x8 + +FBits32x4 : FTy +FBits32x4 = FIntT IT32x4 + +FBits64x2 : FTy +FBits64x2 = FIntT IT64x2 + +interpFTy : FTy -> Type +interpFTy (FIntT ITNative) = Int +interpFTy (FIntT ITChar) = Char +interpFTy (FIntT IT8) = Bits8 +interpFTy (FIntT IT16) = Bits16 +interpFTy (FIntT IT32) = Bits32 +interpFTy (FIntT IT64) = Bits64 +interpFTy (FAny t) = t +interpFTy FFloat = Float +interpFTy FString = String +interpFTy FPtr = Ptr +interpFTy (FIntT IT8x16) = Bits8x16 +interpFTy (FIntT IT16x8) = Bits16x8 +interpFTy (FIntT IT32x4) = Bits32x4 +interpFTy (FIntT IT64x2) = Bits64x2 +interpFTy FUnit = () + +interpFTy (FFunction a b) = interpFTy a -> interpFTy b + +ForeignTy : (xs:List FTy) -> (t:FTy) -> Type +ForeignTy Nil rt = World -> PrimIO (interpFTy rt) +ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt + + +data Foreign : Type -> Type where + FFun : String -> (xs:List FTy) -> (t:FTy) -> + Foreign (ForeignTy xs t) + +mkForeignPrim : Foreign x -> x +mkLazyForeignPrim : Foreign x -> x +-- mkForeign and mkLazyForeign compiled as primitives + +abstract +io_bind : IO a -> (a -> IO b) -> IO b +io_bind (MkIO fn) k + = MkIO (\w => prim_io_bind (fn w) + (\ b => case k b of + MkIO fkb => fkb w)) + +abstract +io_return : a -> IO a +io_return x = MkIO (\w => prim_io_return x) + +liftPrimIO : (World -> PrimIO a) -> IO a +liftPrimIO f = MkIO (\w => prim_io_bind (f w) + (\x => prim_io_return x)) + +run__IO : IO () -> PrimIO () +run__IO (MkIO f) = prim_io_bind (f TheWorld) + (\ b => prim_io_return b) + +run__provider : IO a -> PrimIO a +run__provider (MkIO f) = prim_io_bind (f TheWorld) + (\ b => prim_io_return b) + +-- io_bind v (\v' => io_return v') + +prim_fork : |(thread:PrimIO ()) -> PrimIO Ptr +prim_fork x = prim_io_return prim__vm -- compiled specially + +fork : |(thread:IO ()) -> IO Ptr +fork (MkIO f) = MkIO (\w => prim_io_bind + (prim_fork (prim_io_bind (f w) + (\ x => prim_io_return x))) + (\x => prim_io_return x)) + +partial +prim_fread : Ptr -> IO String +prim_fread h = MkIO (\w => prim_io_return (prim__readString h)) + +unsafePerformIO : IO a -> a +unsafePerformIO (MkIO f) = unsafePerformPrimIO + (prim_io_bind (f TheWorld) (\ b => prim_io_return b)) + + diff --git a/libs/prelude/Makefile b/libs/prelude/Makefile new file mode 100644 --- /dev/null +++ b/libs/prelude/Makefile @@ -0,0 +1,17 @@ +IDRIS := idris + +build: .PHONY + $(IDRIS) --build prelude.ipkg + +install: + $(IDRIS) --install prelude.ipkg + +clean: .PHONY + $(IDRIS) --clean prelude.ipkg + +rebuild: clean build + +linecount: .PHONY + find . -name '*.idr' | xargs wc -l + +.PHONY: diff --git a/libs/prelude/Prelude.idr b/libs/prelude/Prelude.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude.idr @@ -0,0 +1,568 @@ +module Prelude + +import Builtins +import IO + +import Prelude.Bool +import Prelude.Classes +import Prelude.Cast +import Prelude.Nat +import Prelude.Fin +import Prelude.List +import Prelude.Maybe +import Prelude.Monad +import Prelude.Applicative +import Prelude.Functor +import Prelude.Either +import Prelude.Vect +import Prelude.Strings +import Prelude.Chars +import Prelude.Traversable +import Prelude.Bits +import Prelude.Stream + +import Decidable.Equality + +%access public +%default total + +-- Show and instances + +class Show a where + partial show : a -> String + +instance Show Int where + show = prim__toStrInt + +instance Show Integer where + show = prim__toStrBigInt + +instance Show Float where + show = prim__floatToStr + +asciiTab : Vect 32 String +asciiTab = ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", + "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", + "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", + "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US"] + +firstCharIs : (Char -> Bool) -> String -> Bool +firstCharIs p s with (strM s) + firstCharIs p "" | StrNil = False + firstCharIs p (strCons c cs) | StrCons c cs = p c + +protectEsc : (Char -> Bool) -> String -> String -> String +protectEsc p f s = f ++ (if firstCharIs p s then "\\&" else "") ++ s + +showLitChar : Char -> String -> String +showLitChar '\a' = ("\\a" ++) +showLitChar '\b' = ("\\b" ++) +showLitChar '\f' = ("\\f" ++) +showLitChar '\n' = ("\\n" ++) +showLitChar '\r' = ("\\r" ++) +showLitChar '\t' = ("\\t" ++) +showLitChar '\v' = ("\\v" ++) +showLitChar '\SO' = protectEsc (== 'H') "\\SO" +showLitChar '\DEL' = ("\\DEL" ++) +showLitChar '\\' = ("\\\\" ++) +showLitChar c = case (integerToFin (cast (cast {to=Int} c)) 32) of + Just k => strCons '\\' . ((index k asciiTab) ++) + Nothing => if (c > '\DEL') + then strCons '\\' . protectEsc isDigit (show (cast {to=Int} c)) + else strCons c + +showLitString : List Char -> String -> String +showLitString [] = id +showLitString ('"'::cs) = ("\\\"" ++) . showLitString cs +showLitString (c ::cs) = showLitChar c . showLitString cs + +instance Show Char where + show '\'' = "'\\''" + show c = strCons '\'' (showLitChar c "'") + +instance Show String where + show cs = strCons '"' (showLitString (cast cs) "\"") + +instance Show Nat where + show n = show (the Integer (cast n)) + +instance Show Bool where + show True = "True" + show False = "False" + +instance Show () where + show () = "()" + +instance Show Bits8 where + show b = b8ToString b + +instance Show Bits16 where + show b = b16ToString b + +instance Show Bits32 where + show b = b32ToString b + +instance Show Bits64 where + show b = b64ToString b + +%assert_total +viewB8x16 : Bits8x16 -> (Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8, Bits8) +viewB8x16 x = ( prim__indexB8x16 x (prim__truncBigInt_B32 0) + , prim__indexB8x16 x (prim__truncBigInt_B32 1) + , prim__indexB8x16 x (prim__truncBigInt_B32 2) + , prim__indexB8x16 x (prim__truncBigInt_B32 3) + , prim__indexB8x16 x (prim__truncBigInt_B32 4) + , prim__indexB8x16 x (prim__truncBigInt_B32 5) + , prim__indexB8x16 x (prim__truncBigInt_B32 6) + , prim__indexB8x16 x (prim__truncBigInt_B32 7) + , prim__indexB8x16 x (prim__truncBigInt_B32 8) + , prim__indexB8x16 x (prim__truncBigInt_B32 9) + , prim__indexB8x16 x (prim__truncBigInt_B32 10) + , prim__indexB8x16 x (prim__truncBigInt_B32 11) + , prim__indexB8x16 x (prim__truncBigInt_B32 12) + , prim__indexB8x16 x (prim__truncBigInt_B32 13) + , prim__indexB8x16 x (prim__truncBigInt_B32 14) + , prim__indexB8x16 x (prim__truncBigInt_B32 15) + ) + +instance Show Bits8x16 where + show x = + case viewB8x16 x of + (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) => + "<" ++ prim__toStrB8 a + ++ ", " ++ prim__toStrB8 b + ++ ", " ++ prim__toStrB8 c + ++ ", " ++ prim__toStrB8 d + ++ ", " ++ prim__toStrB8 e + ++ ", " ++ prim__toStrB8 f + ++ ", " ++ prim__toStrB8 g + ++ ", " ++ prim__toStrB8 h + ++ ", " ++ prim__toStrB8 i + ++ ", " ++ prim__toStrB8 j + ++ ", " ++ prim__toStrB8 k + ++ ", " ++ prim__toStrB8 l + ++ ", " ++ prim__toStrB8 m + ++ ", " ++ prim__toStrB8 n + ++ ", " ++ prim__toStrB8 o + ++ ", " ++ prim__toStrB8 p + ++ ">" + +%assert_total +viewB16x8 : Bits16x8 -> (Bits16, Bits16, Bits16, Bits16, Bits16, Bits16, Bits16, Bits16) +viewB16x8 x = ( prim__indexB16x8 x (prim__truncBigInt_B32 0) + , prim__indexB16x8 x (prim__truncBigInt_B32 1) + , prim__indexB16x8 x (prim__truncBigInt_B32 2) + , prim__indexB16x8 x (prim__truncBigInt_B32 3) + , prim__indexB16x8 x (prim__truncBigInt_B32 4) + , prim__indexB16x8 x (prim__truncBigInt_B32 5) + , prim__indexB16x8 x (prim__truncBigInt_B32 6) + , prim__indexB16x8 x (prim__truncBigInt_B32 7) + ) + +instance Show Bits16x8 where + show x = + case viewB16x8 x of + (a, b, c, d, e, f, g, h) => + "<" ++ prim__toStrB16 a + ++ ", " ++ prim__toStrB16 b + ++ ", " ++ prim__toStrB16 c + ++ ", " ++ prim__toStrB16 d + ++ ", " ++ prim__toStrB16 e + ++ ", " ++ prim__toStrB16 f + ++ ", " ++ prim__toStrB16 g + ++ ", " ++ prim__toStrB16 h + ++ ">" + +%assert_total +viewB32x4 : Bits32x4 -> (Bits32, Bits32, Bits32, Bits32) +viewB32x4 x = ( prim__indexB32x4 x (prim__truncBigInt_B32 0) + , prim__indexB32x4 x (prim__truncBigInt_B32 1) + , prim__indexB32x4 x (prim__truncBigInt_B32 2) + , prim__indexB32x4 x (prim__truncBigInt_B32 3) + ) + +instance Show Bits32x4 where + show x = + case viewB32x4 x of + (a, b, c, d) => + "<" ++ prim__toStrB32 a + ++ ", " ++ prim__toStrB32 b + ++ ", " ++ prim__toStrB32 c + ++ ", " ++ prim__toStrB32 d + ++ ">" + +%assert_total +viewB64x2 : Bits64x2 -> (Bits64, Bits64) +viewB64x2 x = ( prim__indexB64x2 x (prim__truncBigInt_B32 0) + , prim__indexB64x2 x (prim__truncBigInt_B32 1) + ) + +instance Show Bits64x2 where + show x = + case viewB64x2 x of + (a, b) => + "<" ++ prim__toStrB64 a + ++ ", " ++ prim__toStrB64 b + ++ ">" + +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' acc [] = acc + show' acc [x] = acc ++ show x + show' acc (x :: xs) = show' (acc ++ show x ++ ", ") xs + +instance Show a => Show (Vect n a) where + show xs = "[" ++ show' xs ++ "]" where + show' : Vect n a -> 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 + +---- Functor instances + +instance Functor PrimIO where + map f io = prim_io_bind io (prim_io_return . f) + +instance Functor IO where + map f io = io_bind io (\b => io_return (f b)) + +instance Functor Maybe where + map f (Just x) = Just (f x) + map f Nothing = Nothing + +instance Functor (Either e) where + map f (Left l) = Left l + map f (Right r) = Right (f r) + +---- Applicative instances + +instance Applicative PrimIO where + pure = prim_io_return + + am <$> bm = prim_io_bind am (\f => prim_io_bind bm (prim_io_return . f)) + +instance Applicative IO where + pure x = io_return x + f <$> a = io_bind f (\f' => + io_bind a (\a' => + io_return (f' a'))) + +instance Applicative Maybe where + pure = Just + + (Just f) <$> (Just a) = Just (f a) + _ <$> _ = Nothing + +instance Applicative (Either e) where + pure = Right + + (Left a) <$> _ = Left a + (Right f) <$> (Right r) = Right (f r) + (Right _) <$> (Left l) = Left l + +instance Applicative List where + pure x = [x] + + fs <$> vs = concatMap (\f => map f vs) fs + +instance Applicative (Vect k) where + pure = replicate _ + + fs <$> vs = zipWith ($) fs vs + +instance Applicative Stream where + pure = repeat + (<$>) = zipWith ($) + +---- Alternative instances + +instance Alternative Maybe where + empty = Nothing + + (Just x) <|> _ = Just x + Nothing <|> v = v + +instance Alternative List where + empty = [] + + (<|>) = (++) + +---- Monad instances + +instance Monad PrimIO where + b >>= k = prim_io_bind b k + +instance Monad IO where + b >>= k = io_bind b k + +instance Monad Maybe where + Nothing >>= k = Nothing + (Just x) >>= k = k x + +instance Monad (Either e) where + (Left n) >>= _ = Left n + (Right r) >>= f = f r + +instance Monad List where + m >>= f = concatMap f m + +instance Monad (Vect n) where + m >>= f = diag (map f m) + +instance Monad Stream where + s >>= f = diag (map f s) + +---- Traversable instances + +instance Traversable Maybe where + traverse f Nothing = pure Nothing + traverse f (Just x) = [| Just (f x) |] + +instance Traversable List where + traverse f [] = pure List.Nil + traverse f (x::xs) = [| List.(::) (f x) (traverse f xs) |] + +instance Traversable (Vect n) where + traverse f [] = pure Vect.Nil + traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |] + +---- some mathematical operations +---- XXX this should probably go some place else, +pow : (Num a) => a -> Nat -> a +pow x Z = 1 +pow x (S n) = x * (pow x n) + +---- Ranges + +natRange : Nat -> List Nat +natRange n = List.reverse (go n) + where go Z = [] + go (S n) = n :: go n + +class Enum a where + total pred : a -> a + total succ : a -> a + total toNat : a -> Nat + total fromNat : Nat -> a + total enumFrom : a -> Stream a + enumFrom n = n :: enumFrom (succ n) + total enumFromThen : a -> a -> Stream a + total enumFromTo : a -> a -> List a + total enumFromThenTo : a -> a -> a -> List a + + +instance Enum Nat where + pred = Nat.pred + succ = S + toNat = id + fromNat = id + enumFromThen n inc = n :: enumFromThen (fromNat (plus (toNat inc) (toNat n))) inc + enumFromThenTo _ Z _ = [] + enumFromThenTo n inc m = map (plus n . (* inc)) (natRange (S ((m - n) `div` inc))) + enumFromTo n m = map (plus n) (natRange ((S m) - n)) + +instance Enum Integer where + pred n = n - 1 + succ n = n + 1 + toNat n = cast n + fromNat n = cast n + enumFromThen n inc = n :: enumFromThen (inc + n) inc + enumFromTo n m = if n <= m + then go (natRange (S (cast {to = Nat} (m - n)))) + else [] + where go : List Nat -> List Integer + go [] = [] + go (x :: xs) = n + cast x :: go xs + enumFromThenTo _ 0 _ = [] + enumFromThenTo n inc m = go (natRange (S (fromInteger (abs (m - n)) `div` fromInteger (abs inc)))) + where go : List Nat -> List Integer + go [] = [] + go (x :: xs) = n + (cast x * inc) :: go xs + +instance Enum Int where + pred n = n - 1 + succ n = n + 1 + toNat n = cast n + fromNat n = cast n + enumFromThen n inc = n :: enumFromThen (inc + n) inc + enumFromTo n m = if n <= m + then go (natRange (S (cast {to = Nat} (m - n)))) + else [] + where go : List Nat -> List Int + go [] = [] + go (x :: xs) = n + cast x :: go xs + enumFromThenTo _ 0 _ = [] + enumFromThenTo n inc m = go (natRange (S (cast {to=Nat} (abs (m - n)) `div` cast {to=Nat} (abs inc)))) + where go : List Nat -> List Int + go [] = [] + go (x :: xs) = n + (cast x * inc) :: go xs + +syntax "[" [start] ".." [end] "]" + = enumFromTo start end +syntax "[" [start] "," [next] ".." [end] "]" + = enumFromThenTo start (next - start) end + +syntax "[" [start] "..]" + = enumFrom start 1 +syntax "[" [start] "," [next] "..]" + = enumFromThen start (next - start) + +---- More utilities + +curry : ((a, b) -> c) -> a -> b -> c +curry f a b = f (a, b) + +uncurry : (a -> b -> c) -> (a, b) -> c +uncurry f (a, b) = f a b + +uniformB8x16 : Bits8 -> Bits8x16 +uniformB8x16 x = prim__mkB8x16 x x x x x x x x x x x x x x x x + +uniformB16x8 : Bits16 -> Bits16x8 +uniformB16x8 x = prim__mkB16x8 x x x x x x x x + +uniformB32x4 : Bits32 -> Bits32x4 +uniformB32x4 x = prim__mkB32x4 x x x x + +uniformB64x2 : Bits64 -> Bits64x2 +uniformB64x2 x = prim__mkB64x2 x x + +---- 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 = prim_fread prim__stdin + +partial +putChar : Char -> IO () +putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c) + +partial +getChar : IO Char +getChar = map cast $ mkForeign (FFun "getchar" [] FInt) + +---- some basic file handling + +abstract +data File = FHandle Ptr + +partial stdin : File +stdin = FHandle prim__stdin + +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 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 = prim_fread h + +-- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String)) +-- prim__vm 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 "fileEOF" [FPtr] FInt) h + +feof : File -> IO Bool +feof (FHandle h) = do eof <- do_feof h + return (not (eof == 0)) + +partial +do_ferror : Ptr -> IO Int +do_ferror h = mkForeign (FFun "fileError" [FPtr] FInt) h + +ferror : File -> IO Bool +ferror (FHandle h) = do err <- do_ferror h + return (not (err == 0)) + +partial +nullPtr : Ptr -> IO Bool +nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p + return (ok /= 0); + +partial +nullStr : String -> IO Bool +nullStr p = do ok <- mkForeign (FFun "isNull" [FString] 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/libs/prelude/Prelude/Algebra.idr b/libs/prelude/Prelude/Algebra.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/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/libs/prelude/Prelude/Applicative.idr b/libs/prelude/Prelude/Applicative.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Applicative.idr @@ -0,0 +1,40 @@ +module Prelude.Applicative + +import Builtins +import Prelude.Functor + +---- Applicative functors/Idioms + +infixl 2 <$> + +class Functor f => Applicative (f : Type -> Type) where + pure : a -> f a + (<$>) : f (a -> b) -> f a -> f b + +infixl 2 <$ +(<$) : Applicative f => f a -> f b -> f a +a <$ b = map const a <$> b + +infixl 2 $> +($>) : Applicative f => f a -> f b -> f b +a $> b = map (const id) a <$> b + +liftA : Applicative f => (a -> b) -> f a -> f b +liftA f a = pure f <$> a + +liftA2 : Applicative f => (a -> b -> c) -> f a -> f b -> f c +liftA2 f a b = (map f a) <$> b + +liftA3 : Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d +liftA3 f a b c = (map f a) <$> b <$> c + +infixl 3 <|> +class Applicative f => Alternative (f : Type -> Type) where + empty : f a + (<|>) : f a -> f a -> f a + +guard : Alternative f => Bool -> f () +guard a = if a then pure () else empty + +when : Applicative f => Bool -> f () -> f () +when a f = if a then f else pure () diff --git a/libs/prelude/Prelude/Basics.idr b/libs/prelude/Prelude/Basics.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Basics.idr @@ -0,0 +1,48 @@ +module Prelude.Basics + +Not : Type -> Type +Not a = a -> _|_ + +-- | Identity function. +id : a -> a +id x = x + +-- | Manually assign a type to an expression. +the : (a : Type) -> a -> a +the _ = id + +-- | Constant function. +const : a -> b -> a +const x _ = x + +-- | Return the first element of a pair. +fst : (s, t) -> s +fst (x, y) = x + +-- | Return the second element of a pair. +snd : (a, b) -> b +snd (x, y) = y + +infixl 9 . + +-- | Function composition +(.) : (b -> c) -> (a -> b) -> a -> c +(.) f g x = f (g x) + +-- | Takes in the first two arguments in reverse order. +flip : (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +infixr 1 $ + +-- | Function application. +($) : (a -> b) -> a -> b +f $ a = f a + +cong : {f : t -> u} -> (a = b) -> f a = f b +cong refl = refl + +data Dec : Type -> Type where + Yes : {A : Type} -> A -> Dec A + No : {A : Type} -> (A -> _|_) -> Dec A + diff --git a/libs/prelude/Prelude/Bits.idr b/libs/prelude/Prelude/Bits.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Bits.idr @@ -0,0 +1,56 @@ +module Prelude.Bits + +import Prelude.Strings +import Prelude.Vect + +%access public +%default total + + +private +toHexDigit : Fin 16 -> Char +toHexDigit n = index n hexVect where + hexVect : Vect 16 Char + hexVect = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', + 'A', 'B', 'C', 'D', 'E', 'F'] + +b8ToString : Bits8 -> String +b8ToString c = pack [c1, c2] where + %assert_total -- We will only supply numbers that can fit in 4 bits + toFin16 : Bits8 -> Fin 16 + toFin16 n = if n == 0 + then fZ + else believe_me (fS (toFin16 (n-1))) + c1 = toHexDigit upper where + upper : Fin 16 + upper = toFin16 (prim__lshrB8 c 4) + c2 = toHexDigit lower where + lower : Fin 16 + lower = toFin16 (prim__andB8 c 0xf) + +b16ToString : Bits16 -> String +b16ToString c = c1 ++ c2 where + c1 = b8ToString upper where + upper : Bits8 + upper = prim__truncB16_B8 (prim__lshrB16 c 8) + c2 = b8ToString lower where + lower : Bits8 + lower = prim__truncB16_B8 c + +b32ToString : Bits32 -> String +b32ToString c = c1 ++ c2 where + c1 = b16ToString upper where + upper : Bits16 + upper = prim__truncB32_B16 (prim__lshrB32 c 16) + c2 = b16ToString lower where + lower : Bits16 + lower = prim__truncB32_B16 c + +b64ToString : Bits64 -> String +b64ToString c = c1 ++ c2 where + c1 = b32ToString upper where + upper : Bits32 + upper = prim__truncB64_B32 (prim__lshrB64 c 32) + c2 = b32ToString lower where + lower : Bits32 + lower = prim__truncB64_B32 c diff --git a/libs/prelude/Prelude/Bool.idr b/libs/prelude/Prelude/Bool.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Bool.idr @@ -0,0 +1,35 @@ +module Prelude.Bool + +-- | Boolean Data Type +data Bool = False | True + +-- | Boolean elimination +boolElim : Bool -> |(t : a) -> |(f : a) -> a +boolElim True t e = t +boolElim False t e = e + +-- | Defines a predicate on Bool which guarantees that the value is true. +data so : Bool -> Type where oh : so True + +-- Syntaxtic sugar for boolean elimination. +syntax if [test] then [t] else [e] = boolElim test t e +syntax [test] "?" [t] ":" [e] = if test then t else e + +-- Boolean Operator Precedence +infixl 4 &&, || + +-- | Boolean OR +(||) : Bool -> Bool -> Bool +(||) False x = x +(||) True _ = True + +-- | Boolean AND +(&&) : Bool -> Bool -> Bool +(&&) True x = x +(&&) False _ = False + +-- | Boolean NOT +not : Bool -> Bool +not True = False +not False = True + diff --git a/libs/prelude/Prelude/Cast.idr b/libs/prelude/Prelude/Cast.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/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__fromStrInt + +instance Cast String Float where + cast = prim__strToFloat + +instance Cast String Integer where + cast = prim__fromStrBigInt + +-- Int casts + +instance Cast Int String where + cast = prim__toStrInt + +instance Cast Int Float where + cast = prim__toFloatInt + +instance Cast Int Integer where + cast = prim__sextInt_BigInt + +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__fromFloatInt + +-- Integer casts + +instance Cast Integer String where + cast = prim__toStrBigInt + +-- Char casts + +instance Cast Char Int where + cast = prim__charToInt + + diff --git a/libs/prelude/Prelude/Chars.idr b/libs/prelude/Prelude/Chars.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Chars.idr @@ -0,0 +1,69 @@ +-- | Functions operating over Char's +module Prelude.Char + +import Builtins + +-- | Return the ASCII representation of the character. +chr : Int -> Char +chr x = prim__intToChar x + +-- | Convert the number to its ASCII equivalent. +ord : Char -> Int +ord x = prim__charToInt x + +-- | Returns true if the character is in the range [A-Z]. +isUpper : Char -> Bool +isUpper x = x >= 'A' && x <= 'Z' + +-- | Returns true if the character is in the range [a-z] +isLower : Char -> Bool +isLower x = x >= 'a' && x <= 'z' + +-- | Returns true if the character is in the ranges [A-Z][a-z]. +isAlpha : Char -> Bool +isAlpha x = isUpper x || isLower x + +-- | Returns true if the character is in the range [0-9] +isDigit : Char -> Bool +isDigit x = (x >= '0' && x <= '9') + +-- | Returns true if the character is in the ranges [A-Z][a-z][0-9] +isAlphaNum : Char -> Bool +isAlphaNum x = isDigit x || isAlpha x + +-- | Returns true if the character is a whitespace character. +isSpace : Char -> Bool +isSpace x = x == ' ' || x == '\t' || x == '\r' || + x == '\n' || x == '\f' || x == '\v' || + x == '\xa0' + +-- | Returns true if the character represents a new line. +isNL : Char -> Bool +isNL x = x == '\r' || x == '\n' + +-- | Convert a letter to the corresponding upper-case letter, if any. +-- Non-letters are ignored. +toUpper : Char -> Char +toUpper x = if (isLower x) + then (prim__intToChar (prim__charToInt x - 32)) + else x + +-- | Convert a letter to the corresponding lower-case letter, if any. +-- Non-letters are ignored. +toLower : Char -> Char +toLower x = if (isUpper x) + then (prim__intToChar (prim__charToInt x + 32)) + else x + +-- | Returns true if the character is a hexadecimal digit i.e. in the range [0-9][a-f][A-F] +isHexDigit : Char -> Bool +isHexDigit x = elem (toUpper x) hexChars where + hexChars : List Char + hexChars = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', + 'A', 'B', 'C', 'D', 'E', 'F'] + +-- | Returns true if the character is an octal digit. +isOctDigit : Char -> Bool +isOctDigit x = (x >= '0' && x <= '7') + +-- --------------------------------------------------------------------- [ EOF ] diff --git a/libs/prelude/Prelude/Classes.idr b/libs/prelude/Prelude/Classes.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Classes.idr @@ -0,0 +1,322 @@ +module Prelude.Classes + +import Builtins +import Prelude.Basics +import Prelude.Bool + +-- Numerical Operator Precedence +infixl 5 ==, /= +infixl 6 <, <=, >, >= +infixl 7 <<, >> +infixl 8 +,- +infixl 9 *,/ + +-- ------------------------------------------------------------- [ Boolean Ops ] +intToBool : Int -> Bool +intToBool 0 = False +intToBool x = True + +boolOp : (a -> a -> Int) -> a -> a -> Bool +boolOp op x y = intToBool (op x y) + +-- ---------------------------------------------------------- [ Equality Class ] +-- | The Eq class defines inequality and equality. +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 Bool where + True == True = True + True == False = False + False == True = False + False == False = True + +instance (Eq a, Eq b) => Eq (a, b) where + (==) (a, c) (b, d) = (a == b) && (c == d) + + +-- ---------------------------------------------------------- [ Ordering Class ] +data Ordering = LT | EQ | GT + +instance Eq Ordering where + LT == LT = True + EQ == EQ = True + GT == GT = True + _ == _ = False + +-- | The Ord class defines comparison operations on ordered data types. +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__sltInt x y) then LT else + GT + + +instance Ord Integer where + compare x y = if (x == y) then EQ else + if (boolOp prim__sltBigInt x y) then LT else + GT + + +instance Ord Float where + compare x y = if (x == y) then EQ else + if (boolOp prim__sltFloat x y) then LT else + GT + + +instance Ord Char where + compare x y = if (x == y) then EQ else + if (boolOp prim__sltChar x y) then LT else + GT + + +instance Ord String where + 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 + +-- --------------------------------------------------------- [ Numerical Class ] +-- | The Num class defines basic numerical arithmetic. +class Num a where + (+) : a -> a -> a + (-) : a -> a -> a + (*) : a -> a -> a + -- | Absolute value + abs : a -> a + -- | Conversion from Integer. + fromInteger : Integer -> a + +instance Num Integer where + (+) = prim__addBigInt + (-) = prim__subBigInt + (*) = prim__mulBigInt + + abs x = if x < 0 then -x else x + fromInteger = id + +instance Num Int where + (+) = prim__addInt + (-) = prim__subInt + (*) = prim__mulInt + + fromInteger = prim__truncBigInt_Int + abs x = if x < (prim__truncBigInt_Int 0) then -x else x + + +instance Num Float where + (+) = prim__addFloat + (-) = prim__subFloat + (*) = prim__mulFloat + + abs x = if x < (prim__toFloatBigInt 0) then -x else x + fromInteger = prim__toFloatBigInt + +instance Num Bits8 where + (+) = prim__addB8 + (-) = prim__subB8 + (*) = prim__mulB8 + abs = id + fromInteger = prim__truncBigInt_B8 + +instance Num Bits16 where + (+) = prim__addB16 + (-) = prim__subB16 + (*) = prim__mulB16 + abs = id + fromInteger = prim__truncBigInt_B16 + +instance Num Bits32 where + (+) = prim__addB32 + (-) = prim__subB32 + (*) = prim__mulB32 + abs = id + fromInteger = prim__truncBigInt_B32 + +instance Num Bits64 where + (+) = prim__addB64 + (-) = prim__subB64 + (*) = prim__mulB64 + abs = id + fromInteger = prim__truncBigInt_B64 + +instance Eq Bits8 where + x == y = intToBool (prim__eqB8 x y) + +instance Eq Bits16 where + x == y = intToBool (prim__eqB16 x y) + +instance Eq Bits32 where + x == y = intToBool (prim__eqB32 x y) + +instance Eq Bits64 where + x == y = intToBool (prim__eqB64 x y) + +instance Ord Bits8 where + (<) = boolOp prim__ltB8 + (>) = boolOp prim__gtB8 + (<=) = boolOp prim__lteB8 + (>=) = boolOp prim__gteB8 + compare l r = if l < r then LT + else if l > r then GT + else EQ + +instance Ord Bits16 where + (<) = boolOp prim__ltB16 + (>) = boolOp prim__gtB16 + (<=) = boolOp prim__lteB16 + (>=) = boolOp prim__gteB16 + compare l r = if l < r then LT + else if l > r then GT + else EQ + +instance Ord Bits32 where + (<) = boolOp prim__ltB32 + (>) = boolOp prim__gtB32 + (<=) = boolOp prim__lteB32 + (>=) = boolOp prim__gteB32 + compare l r = if l < r then LT + else if l > r then GT + else EQ + +instance Ord Bits64 where + (<) = boolOp prim__ltB64 + (>) = boolOp prim__gtB64 + (<=) = boolOp prim__lteB64 + (>=) = boolOp prim__gteB64 + compare l r = if l < r then LT + else if l > r then GT + else EQ + + +-- ------------------------------------------------------------- [ Fractionals ] + +-- | Fractional division of two Floats. +(/) : Float -> Float -> Float +(/) = prim__divFloat + + +-- --------------------------------------------------------------- [ Integrals ] +%default partial + +class Integral a where + div : a -> a -> a + mod : a -> a -> a + +-- ---------------------------------------------------------------- [ Integers ] +divBigInt : Integer -> Integer -> Integer +divBigInt = prim__sdivBigInt + +modBigInt : Integer -> Integer -> Integer +modBigInt = prim__sremBigInt + +instance Integral Integer where + div = divBigInt + mod = modBigInt + +-- --------------------------------------------------------------------- [ Int ] + +divInt : Int -> Int -> Int +divInt = prim__sdivInt + +modInt : Int -> Int -> Int +modInt = prim__sremInt + +instance Integral Int where + div = divInt + mod = modInt + +-- ------------------------------------------------------------------- [ Bits8 ] +divB8 : Bits8 -> Bits8 -> Bits8 +divB8 = prim__sdivB8 + +modB8 : Bits8 -> Bits8 -> Bits8 +modB8 = prim__sremB8 + +instance Integral Bits8 where + div = divB8 + mod = modB8 + +-- ------------------------------------------------------------------ [ Bits16 ] +divB16 : Bits16 -> Bits16 -> Bits16 +divB16 = prim__sdivB16 + +modB16 : Bits16 -> Bits16 -> Bits16 +modB16 = prim__sremB16 + +instance Integral Bits16 where + div = divB16 + mod = modB16 + +-- ------------------------------------------------------------------ [ Bits32 ] +divB32 : Bits32 -> Bits32 -> Bits32 +divB32 = prim__sdivB32 + +modB32 : Bits32 -> Bits32 -> Bits32 +modB32 = prim__sremB32 + +instance Integral Bits32 where + div = divB32 + mod = modB32 + +-- ------------------------------------------------------------------ [ Bits64 ] +divB64 : Bits64 -> Bits64 -> Bits64 +divB64 = prim__sdivB64 + +modB64 : Bits64 -> Bits64 -> Bits64 +modB64 = prim__sremB64 + +instance Integral Bits64 where + div = divB64 + mod = modB64 + + diff --git a/libs/prelude/Prelude/Either.idr b/libs/prelude/Prelude/Either.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Either.idr @@ -0,0 +1,76 @@ +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 + + +-------------------------------------------------------------------------------- +-- Injectivity of constructors +-------------------------------------------------------------------------------- + +total leftInjective : {b : Type} -> {x : a} -> {y : a} + -> (Left {b = b} x = Left {b = b} y) -> (x = y) +leftInjective refl = refl + +total rightInjective : {a : Type} -> {x : b} -> {y : b} + -> (Right {a = a} x = Right {a = a} y) -> (x = y) +rightInjective refl = refl diff --git a/libs/prelude/Prelude/Fin.idr b/libs/prelude/Prelude/Fin.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Fin.idr @@ -0,0 +1,68 @@ +module Prelude.Fin + +import Prelude.Nat +import Prelude.Either + +data Fin : Nat -> Type where + fZ : Fin (S k) + fS : Fin k -> Fin (S k) + +instance Eq (Fin n) where + (==) fZ fZ = True + (==) (fS k) (fS k') = k == k' + (==) _ _ = False + +finToNat : Fin n -> Nat -> Nat +finToNat fZ a = a +finToNat (fS x) a = finToNat x (S a) + +instance Cast (Fin n) Nat where + cast x = finToNat x Z + +finToInt : Fin n -> Integer -> Integer +finToInt fZ a = a +finToInt (fS x) a = finToInt x (a + 1) + +instance Cast (Fin n) Integer where + cast x = finToInt x 0 + +weaken : Fin n -> Fin (S n) +weaken fZ = fZ +weaken (fS k) = fS (weaken k) + +strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n) +strengthen {n = S k} fZ = Right fZ +strengthen {n = S k} (fS i) with (strengthen i) + strengthen (fS k) | Left x = Left (fS x) + strengthen (fS k) | Right x = Right (fS x) +strengthen f = Left f + +last : Fin (S n) +last {n=Z} = fZ +last {n=S _} = fS last + +total fSinjective : {f : Fin n} -> {f' : Fin n} -> (fS f = fS f') -> f = f' +fSinjective refl = refl + + +-- Construct a Fin from an integer literal which must fit in the given Fin + +natToFin : Nat -> (n : Nat) -> Maybe (Fin n) +natToFin Z (S j) = Just fZ +natToFin (S k) (S j) with (natToFin k j) + | Just k' = Just (fS k') + | Nothing = Nothing +natToFin _ _ = Nothing + +integerToFin : Integer -> (n : Nat) -> Maybe (Fin n) +integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing + +data IsJust : Maybe a -> Type where + ItIsJust : IsJust {a} (Just x) + +fromInteger : (x : Integer) -> + {default (ItIsJust _ _) + prf : (IsJust (integerToFin x n))} -> Fin n +fromInteger {n} x {prf} with (integerToFin x n) + fromInteger {n} x {prf = ItIsJust} | Just y = y + diff --git a/libs/prelude/Prelude/Foldable.idr b/libs/prelude/Prelude/Foldable.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Foldable.idr @@ -0,0 +1,40 @@ +module Prelude.Foldable + +import Builtins +import Prelude.Bool +import Prelude.Classes +import Prelude.Algebra + +%access public +%default total + +class Foldable (t : Type -> Type) where + foldr : (elt -> acc -> acc) -> acc -> t elt -> acc + +foldl : Foldable t => (acc -> elt -> acc) -> acc -> t elt -> acc +foldl f z t = foldr (flip (.) . flip f) id t z + +concat : (Foldable t, Monoid a) => t a -> a +concat = foldr (<+>) neutral + +concatMap : (Foldable t, Monoid m) => (a -> m) -> t a -> m +concatMap f = foldr ((<+>) . f) neutral + +and : Foldable t => t Bool -> Bool +and = foldr (&&) True + +or : Foldable t => t Bool -> Bool +or = foldr (||) False + +any : Foldable t => (a -> Bool) -> t a -> Bool +any p = foldr ((||) . p) False + +all : Foldable t => (a -> Bool) -> t a -> Bool +all p = foldr ((&&) . p) True + +sum : (Foldable t, Num a) => t a -> a +sum = foldr (+) 0 + +product : (Foldable t, Num a) => t a -> a +product = foldr (*) 1 + diff --git a/libs/prelude/Prelude/Functor.idr b/libs/prelude/Prelude/Functor.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Functor.idr @@ -0,0 +1,4 @@ +module Prelude.Functor + +class Functor (f : Type -> Type) where + map : (a -> b) -> f a -> f b diff --git a/libs/prelude/Prelude/List.idr b/libs/prelude/Prelude/List.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/List.idr @@ -0,0 +1,612 @@ +module Prelude.List + +import Builtins + +import Prelude.Algebra +import Prelude.Basics +import Prelude.Foldable +import Prelude.Functor +import Prelude.Maybe +import Prelude.Nat + +%access public +%default total + +infixr 7 :: +infixl 8 ++ + +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 [] refl impossible +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 [] refl impossible +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 [] refl impossible +last [x] p = x +last (x::y::ys) p = last (y::ys) refl + +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 [] refl impossible +init [x] p = [] +init (x::y::ys) p = x :: init (y::ys) refl + +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 Z xs = [] +take (S n) [] = [] +take (S n) (x::xs) = x :: take n xs + +drop : Nat -> List a -> List a +drop Z 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 :: lazy (repeat x) + +replicate : Nat -> a -> List a +replicate Z x = [] +replicate (S n) x = x :: replicate n 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 + +instance Functor List where + map f [] = [] + map f (x::xs) = f x :: map f xs + +-------------------------------------------------------------------------------- +-- Zips and unzips +-------------------------------------------------------------------------------- + +zipWith : (f : a -> b -> c) -> (l : List a) -> (r : List b) -> + (length l = length r) -> List c +zipWith f [] (y::ys) refl impossible +zipWith f (x::xs) [] refl impossible +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 _ [] (z::zs) p refl impossible +zipWith3 f _ (y::ys) [] p refl impossible +zipWith3 f [] (y::ys) _ refl q impossible +zipWith3 f (x::xs) [] _ refl q impossible +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 +-------------------------------------------------------------------------------- + +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 +-------------------------------------------------------------------------------- + +instance Foldable List where + foldr f e [] = e + foldr f e (x::xs) = f x (foldr f e xs) + +-------------------------------------------------------------------------------- +-- Special folds +-------------------------------------------------------------------------------- + +toList : Foldable t => t a -> List a +toList = foldr (::) [] + +-------------------------------------------------------------------------------- +-- 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' Z + 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' Z + 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) + +%assert_total +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) + +%assert_total -- can't work this out, because in the case which is lifted out + -- y::ys and x::xs are bigger than the inputs... +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; +} + +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/libs/prelude/Prelude/Maybe.idr b/libs/prelude/Prelude/Maybe.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Maybe.idr @@ -0,0 +1,88 @@ +module Prelude.Maybe + +import Builtins +import Prelude.Algebra +import Prelude.Cast +import Prelude.Foldable + +%access public +%default total + +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 + +justInjective : {x : t} -> {y : t} -> (Just x = Just y) -> x = y +justInjective refl = refl + +lowerMaybe : Monoid a => Maybe a -> a +lowerMaybe Nothing = neutral +lowerMaybe (Just x) = x + +raiseToMaybe : (Monoid a, Eq a) => a -> Maybe a +raiseToMaybe x = if x == neutral then Nothing else Just x + +-------------------------------------------------------------------------------- +-- Class instances +-------------------------------------------------------------------------------- + +maybe_bind : Maybe a -> (a -> Maybe b) -> Maybe b +maybe_bind Nothing k = Nothing +maybe_bind (Just x) k = k x + +instance (Eq a) => Eq (Maybe a) where + Nothing == Nothing = True + Nothing == (Just _) = False + (Just _) == Nothing = False + (Just a) == (Just b) = a == b + +-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to +-- : "Any semigroup S may be +-- turned into a monoid simply by adjoining an element i not in S +-- and defining i+i = i and i+s = s = s+i for all s in S." + +instance (Semigroup a) => Semigroup (Maybe a) where + Nothing <+> m = m + m <+> Nothing = m + (Just m1) <+> (Just m2) = Just (m1 <+> m2) + +instance (Semigroup a) => Monoid (Maybe a) where + neutral = Nothing + +instance (Monoid a, Eq a) => Cast a (Maybe a) where + cast = raiseToMaybe + +instance (Monoid a) => Cast (Maybe a) a where + cast = lowerMaybe + +instance Foldable Maybe where + foldr _ z Nothing = z + foldr f z (Just x) = f x z diff --git a/libs/prelude/Prelude/Monad.idr b/libs/prelude/Prelude/Monad.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Monad.idr @@ -0,0 +1,20 @@ +module Prelude.Monad + +-- Monads and Functors + +import Builtins +import Prelude.List +import Prelude.Applicative + +%access public + +infixl 5 >>= + +class Applicative m => Monad (m : Type -> Type) where + (>>=) : m a -> (a -> m b) -> m b + +flatten : Monad m => m (m a) -> m a +flatten a = a >>= id + +return : Monad m => a -> m a +return = pure diff --git a/libs/prelude/Prelude/Nat.idr b/libs/prelude/Prelude/Nat.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Nat.idr @@ -0,0 +1,886 @@ +module Prelude.Nat + +import Builtins + +import Prelude.Algebra +import Prelude.Bool +import Prelude.Cast +import Prelude.Classes + +%access public +%default total + +data Nat + = Z + | S Nat + +-------------------------------------------------------------------------------- +-- Syntactic tests +-------------------------------------------------------------------------------- + +total isZero : Nat -> Bool +isZero Z = True +isZero (S n) = False + +total isSucc : Nat -> Bool +isSucc Z = False +isSucc (S n) = True + +-------------------------------------------------------------------------------- +-- Basic arithmetic functions +-------------------------------------------------------------------------------- + +total plus : Nat -> Nat -> Nat +plus Z right = right +plus (S left) right = S (plus left right) + +total mult : Nat -> Nat -> Nat +mult Z right = Z +mult (S left) right = plus right $ mult left right + +%assert_total +fromIntegerNat : Integer -> Nat +fromIntegerNat 0 = Z +fromIntegerNat n = + if (n > 0) then + S (fromIntegerNat (n - 1)) + else + Z + +toIntegerNat : Nat -> Integer +toIntegerNat Z = 0 +toIntegerNat (S k) = 1 + toIntegerNat k + +total minus : Nat -> Nat -> Nat +minus Z right = Z +minus left Z = left +minus (S left) (S right) = minus left right + +total power : Nat -> Nat -> Nat +power base Z = S Z +power base (S exp) = mult base $ power base exp + +hyper : Nat -> Nat -> Nat -> Nat +hyper Z a b = S b +hyper (S Z) a Z = a +hyper (S(S Z)) a Z = Z +hyper n a Z = S Z +hyper (S pn) a (S pb) = hyper pn a (hyper (S pn) a pb) + + +-------------------------------------------------------------------------------- +-- Comparisons +-------------------------------------------------------------------------------- + +data LTE : Nat -> Nat -> Type where + lteZero : LTE Z right + lteSucc : LTE left right -> LTE (S left) (S right) + +total GTE : Nat -> Nat -> Type +GTE left right = LTE right left + +total LT : Nat -> Nat -> Type +LT left right = LTE (S left) right + +total GT : Nat -> Nat -> Type +GT left right = LT right left + +total lte : Nat -> Nat -> Bool +lte Z right = True +lte left Z = 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 + Z == Z = True + (S l) == (S r) = l == r + _ == _ = False + +instance Cast Nat Integer where + cast = toIntegerNat + +instance Ord Nat where + compare Z Z = EQ + compare Z (S k) = LT + compare (S k) Z = GT + compare (S x) (S y) = compare x y + +instance Num Nat where + (+) = plus + (-) = minus + (*) = mult + + abs x = x + + fromInteger = fromIntegerNat + +instance Cast Integer Nat where + cast = fromInteger + +record Multiplicative : Type where + getMultiplicative : Nat -> Multiplicative + +record Additive : Type 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 Z + +instance Monoid Additive where + neutral = getAdditive Z + +instance MeetSemilattice Nat where + meet = minimum + +instance JoinSemilattice Nat where + join = maximum + +instance Lattice Nat where { } + +instance BoundedJoinSemilattice Nat where + bottom = Z + + +instance Cast Int Nat where + cast i = fromInteger (cast i) + +instance Cast Nat Int where + cast Z = 0 + cast (S n) = 1 + cast {to=Int} n + + +-------------------------------------------------------------------------------- +-- Auxilliary notions +-------------------------------------------------------------------------------- + +total pred : Nat -> Nat +pred Z = Z +pred (S n) = n + +-------------------------------------------------------------------------------- +-- Fibonacci and factorial +-------------------------------------------------------------------------------- + +total fib : Nat -> Nat +fib Z = Z +fib (S Z) = S Z +fib (S (S n)) = fib (S n) + fib n + +total fact : Nat -> Nat +fact Z = S Z +fact (S Z) = S Z +fact (S n) = (S n) * fact n + +-------------------------------------------------------------------------------- +-- Division and modulus +-------------------------------------------------------------------------------- + +total +modNat : Nat -> Nat -> Nat +modNat left Z = left +modNat left (S right) = mod' left left right + where + total mod' : Nat -> Nat -> Nat -> Nat + mod' Z centre right = centre + mod' (S left) centre right = + if lte centre right then + centre + else + mod' left (centre - (S right)) right + +total +divNat : Nat -> Nat -> Nat +divNat left Z = S left -- div by zero +divNat left (S right) = div' left left right + where + total div' : Nat -> Nat -> Nat -> Nat + div' Z centre right = Z + div' (S left) centre right = + if lte centre right then + Z + else + S (div' left (centre - (S right)) right) + +instance Integral Nat where + div = divNat + mod = modNat + +%assert_total +log2 : Nat -> Nat +log2 Z = Z +log2 (S Z) = Z +log2 n = S (log2 (n `divNat` 2)) + +-------------------------------------------------------------------------------- +-- GCD and LCM +-------------------------------------------------------------------------------- +%assert_total +gcd : Nat -> Nat -> Nat +gcd a Z = a +gcd a b = gcd b (a `modNat` b) + +total lcm : Nat -> Nat -> Nat +lcm _ Z = Z +lcm Z _ = Z +lcm x y = divNat (x * y) (gcd x y) + +-------------------------------------------------------------------------------- +-- 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 Z = refl +plusZeroRightNeutral (S n) = + let inductiveHypothesis = plusZeroRightNeutral n in + ?plusZeroRightNeutralStepCase + +total plusSuccRightSucc : (left : Nat) -> (right : Nat) -> + S (left + right) = left + (S right) +plusSuccRightSucc Z right = refl +plusSuccRightSucc (S left) right = + let inductiveHypothesis = plusSuccRightSucc left right in + ?plusSuccRightSuccStepCase + +total plusCommutative : (left : Nat) -> (right : Nat) -> + left + right = right + left +plusCommutative Z 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 Z 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 Z 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' Z 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 = Z +plusLeftLeftRightZero Z right p = ?plusLeftLeftRightZeroBaseCase +plusLeftLeftRightZero (S left) right p = + let inductiveHypothesis = plusLeftLeftRightZero left right in + ?plusLeftLeftRightZeroStepCase + +-- Mult +total multZeroLeftZero : (right : Nat) -> Z * right = Z +multZeroLeftZero right = refl + +total multZeroRightZero : (left : Nat) -> left * Z = Z +multZeroRightZero Z = refl +multZeroRightZero (S left) = + let inductiveHypothesis = multZeroRightZero left in + ?multZeroRightZeroStepCase + +total multRightSuccPlus : (left : Nat) -> (right : Nat) -> + left * (S right) = left + (left * right) +multRightSuccPlus Z 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 Z 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 Z 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 Z 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 Z centre right = refl +multAssociative (S left) centre right = + let inductiveHypothesis = multAssociative left centre right in + ?multAssociativeStepCase + +total multOneLeftNeutral : (right : Nat) -> 1 * right = right +multOneLeftNeutral Z = refl +multOneLeftNeutral (S right) = + let inductiveHypothesis = multOneLeftNeutral right in + ?multOneLeftNeutralStepCase + +total multOneRightNeutral : (left : Nat) -> left * 1 = left +multOneRightNeutral Z = 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 = Z +minusZeroLeft right = refl + +total minusZeroRight : (left : Nat) -> left - 0 = left +minusZeroRight Z = refl +minusZeroRight (S left) = refl + +total minusZeroN : (n : Nat) -> Z = n - n +minusZeroN Z = refl +minusZeroN (S n) = minusZeroN n + +total minusOneSuccN : (n : Nat) -> S Z = (S n) - n +minusOneSuccN Z = refl +minusOneSuccN (S n) = minusOneSuccN n + +total minusSuccOne : (n : Nat) -> S n - 1 = n +minusSuccOne Z = refl +minusSuccOne (S n) = refl + +total minusPlusZero : (n : Nat) -> (m : Nat) -> n - (n + m) = Z +minusPlusZero Z m = refl +minusPlusZero (S n) m = minusPlusZero n m + +total minusMinusMinusPlus : (left : Nat) -> (centre : Nat) -> (right : Nat) -> + left - centre - right = left - (centre + right) +minusMinusMinusPlus Z Z right = refl +minusMinusMinusPlus (S left) Z right = refl +minusMinusMinusPlus Z (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 Z 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 Z Z right = refl +multDistributesOverMinusLeft (S left) Z right = + ?multDistributesOverMinusLeftBaseCase +multDistributesOverMinusLeft Z (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 Z exp' = ?multPowerPowerPlusBaseCase +multPowerPowerPlus base (S exp) exp' = + let inductiveHypothesis = multPowerPowerPlus base exp exp' in + ?multPowerPowerPlusStepCase + +total powerZeroOne : (base : Nat) -> power base 0 = S Z +powerZeroOne base = refl + +total powerOneNeutral : (base : Nat) -> power base 1 = base +powerOneNeutral Z = refl +powerOneNeutral (S base) = + let inductiveHypothesis = powerOneNeutral base in + ?powerOneNeutralStepCase + +total powerOneSuccOne : (exp : Nat) -> power 1 exp = S Z +powerOneSuccOne Z = refl +powerOneSuccOne (S exp) = + let inductiveHypothesis = powerOneSuccOne exp in + ?powerOneSuccOneStepCase + +total powerSuccSuccMult : (base : Nat) -> power base 2 = mult base base +powerSuccSuccMult Z = 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 Z = ?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 Z right = refl +minusSuccPred (S left) Z = + let inductiveHypothesis = minusSuccPred left Z 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 Z = refl +lteNTrue (S n) = lteNTrue n + +total lteSuccZeroFalse : (n : Nat) -> lte (S n) Z = False +lteSuccZeroFalse Z = refl +lteSuccZeroFalse (S n) = refl + +-- Minimum and maximum +total minimumZeroZeroRight : (right : Nat) -> minimum 0 right = Z +minimumZeroZeroRight Z = refl +minimumZeroZeroRight (S right) = minimumZeroZeroRight right + +total minimumZeroZeroLeft : (left : Nat) -> minimum left 0 = Z +minimumZeroZeroLeft Z = refl +minimumZeroZeroLeft (S left) = refl + +total minimumSuccSucc : (left : Nat) -> (right : Nat) -> + minimum (S left) (S right) = S (minimum left right) +minimumSuccSucc Z Z = refl +minimumSuccSucc (S left) Z = refl +minimumSuccSucc Z (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 Z Z = refl +minimumCommutative Z (S right) = refl +minimumCommutative (S left) Z = refl +minimumCommutative (S left) (S right) = + let inductiveHypothesis = minimumCommutative left right in + ?minimumCommutativeStepCase + +total maximumZeroNRight : (right : Nat) -> maximum Z right = right +maximumZeroNRight Z = refl +maximumZeroNRight (S right) = refl + +total maximumZeroNLeft : (left : Nat) -> maximum left Z = left +maximumZeroNLeft Z = refl +maximumZeroNLeft (S left) = refl + +total maximumSuccSucc : (left : Nat) -> (right : Nat) -> + S (maximum left right) = maximum (S left) (S right) +maximumSuccSucc Z Z = refl +maximumSuccSucc (S left) Z = refl +maximumSuccSucc Z (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 Z Z = refl +maximumCommutative (S left) Z = refl +maximumCommutative Z (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 = Z +modZeroZero Z = 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 Z) 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/libs/prelude/Prelude/Stream.idr b/libs/prelude/Prelude/Stream.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Stream.idr @@ -0,0 +1,52 @@ +module Prelude.Stream + +import Prelude.Functor +import Prelude.Vect + +%access public +%default total + +codata Stream : Type -> Type where + (::) : a -> Stream a -> Stream a + +instance Functor Stream where + map f (x::xs) = f x :: map f xs + +head : Stream a -> a +head (x::xs) = x + +tail : Stream a -> Stream a +tail (x::xs) = xs + +take : (n : Nat) -> Stream a -> Vect n a +take Z _ = [] +take (S n) (x :: xs) = x :: (take n xs) + +%assert_total +drop : Nat -> Stream a -> Stream a +drop Z xs = xs +drop (S k) (x::xs) = drop k xs + +repeat : a -> Stream a +repeat x = x :: repeat x + +iterate : (a -> a) -> a -> Stream a +iterate f x = x :: iterate f (f x) + +index : Nat -> Stream a -> a +index Z (x::xs) = x +index (S k) (x::xs) = index k xs + +zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c +zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys + +zip : Stream a -> Stream b -> Stream (a, b) +zip = zipWith (\x,y => (x,y)) + +unzip : Stream (a, b) -> (Stream a, Stream b) +unzip xs = (map fst xs, map snd xs) + +diag : Stream (Stream a) -> Stream a +diag ((x::xs)::xss) = x :: diag (map tail xss) + + diff --git a/libs/prelude/Prelude/Strings.idr b/libs/prelude/Prelude/Strings.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Strings.idr @@ -0,0 +1,155 @@ +module Prelude.Strings + +import Builtins +import Prelude.List +import Prelude.Chars +import Prelude.Cast +import Prelude.Either +import Prelude.Foldable + +-- | Appends two strings together. +(++) : String -> String -> String +(++) = prim__concat + +-- | Returns the first character in the specified string. +partial +strHead : String -> Char +strHead = prim__strHead + +-- | Returns the characters specified after the head of the string. +partial +strTail : String -> String +strTail = prim__strTail + +-- | Adds a character to the from of the specified string. +strCons : Char -> String -> String +strCons = prim__strCons + +-- | Returns the nth character (starting from 0) of the specified string. +partial +strIndex : String -> Int -> Char +strIndex = prim__strIndex + +-- | Reverses the elements within a String. +reverse : String -> String +reverse = prim__strRev + +null : Ptr +null = prim__null + +-- Some more complex string operations + +data StrM : String -> Type 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) = really_believe_me $ StrCons (strHead' x p) (strTail' x p) + strM x | (Right p) = really_believe_me StrNil + +-- annoyingly, we need these assert_totals because StrCons doesn't have +-- a recursive argument, therefore the termination checker doesn't believe +-- the string is guaranteed smaller. It makes a good point. + +%assert_total +unpack : String -> List Char +unpack s with (strM s) + unpack "" | StrNil = [] + unpack (strCons x xs) | (StrCons x xs) = x :: unpack xs + +pack : (Foldable t) => t Char -> String +pack = foldr strCons "" + +singleton : Char -> String +singleton c = strCons c "" + +instance Cast String (List Char) where + cast = unpack + +instance Cast (List Char) String where + cast = pack + +instance Cast Char String where + cast = singleton + +instance Semigroup String where + (<+>) = (++) + +instance Monoid String where + neutral = "" + +%assert_total +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)) + +%assert_total +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))) + +%assert_total +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 + +%assert_total +lines' : List Char -> List (List Char) +lines' s = case dropWhile isNL s of + [] => [] + s' => let (w, s'') = break isNL s' + in w :: lines' s'' + +lines : String -> List String +lines s = map pack $ lines' $ 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 + +length : String -> Nat +length = fromInteger . prim__zextInt_BigInt . prim_lenString diff --git a/libs/prelude/Prelude/Traversable.idr b/libs/prelude/Prelude/Traversable.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Traversable.idr @@ -0,0 +1,16 @@ +module Prelude.Traversable + +import Prelude.Applicative +import Prelude.Foldable + +traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f () +traverse_ f = foldr (($>) . f) (pure ()) + +sequence_ : (Foldable t, Applicative f) => t (f a) -> f () +sequence_ = foldr ($>) (pure ()) + +class (Functor t, Foldable t) => Traversable (t : Type -> Type) where + traverse : Applicative f => (a -> f b) -> t a -> f (t b) + +sequence : (Traversable t, Applicative f) => t (f a) -> f (t a) +sequence = traverse id diff --git a/libs/prelude/Prelude/Vect.idr b/libs/prelude/Prelude/Vect.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Vect.idr @@ -0,0 +1,325 @@ +module Prelude.Vect + +import Prelude.Fin +import Prelude.Foldable +import Prelude.Functor +import Prelude.List +import Prelude.Nat + +%access public +%default total + +infixr 7 :: + +data Vect : Nat -> Type -> Type where + Nil : Vect Z a + (::) : a -> Vect n a -> Vect (S n) a + +-------------------------------------------------------------------------------- +-- Indexing into vectors +-------------------------------------------------------------------------------- + +tail : Vect (S n) a -> Vect n a +tail (x::xs) = xs + +head : Vect (S n) a -> a +head (x::xs) = x + +last : Vect (S n) a -> a +last (x::[]) = x +last (x::y::ys) = last $ y::ys + +init : Vect (S n) a -> Vect n a +init (x::[]) = [] +init (x::y::ys) = x :: init (y::ys) + +index : Fin n -> Vect n a -> a +index fZ (x::xs) = x +index (fS k) (x::xs) = index k xs +index fZ [] impossible + +deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a +deleteAt fZ (x::xs) = xs +deleteAt {n = S m} (fS k) (x::xs) = x :: deleteAt k xs +deleteAt _ [] impossible + +replaceAt : Fin n -> t -> Vect n t -> Vect n t +replaceAt fZ y (x::xs) = y::xs +replaceAt (fS k) y (x::xs) = x :: replaceAt k y xs + +-------------------------------------------------------------------------------- +-- Subvectors +-------------------------------------------------------------------------------- + +take : Fin n -> Vect n a -> (p ** Vect p a) +take fZ xs = (_ ** []) +take (fS k) [] impossible +take (fS k) (x::xs) with (take k xs) + | (_ ** tail) = (_ ** x::tail) + +drop : Fin n -> Vect n a -> (p ** Vect p a) +drop fZ xs = (_ ** xs) +drop (fS k) [] impossible +drop (fS k) (x::xs) = drop k xs + +-------------------------------------------------------------------------------- +-- Conversion from list (toList is provided by Foldable) +-------------------------------------------------------------------------------- + +fromList : (l : List a) -> Vect (length l) a +fromList [] = [] +fromList (x::xs) = x :: fromList xs + +-------------------------------------------------------------------------------- +-- Building (bigger) vectors +-------------------------------------------------------------------------------- + +(++) : Vect m a -> Vect n a -> Vect (m + n) a +(++) [] ys = ys +(++) (x::xs) ys = x :: xs ++ ys + +replicate : (n : Nat) -> a -> Vect n a +replicate Z x = [] +replicate (S k) x = x :: replicate k x + +-------------------------------------------------------------------------------- +-- Zips and unzips +-------------------------------------------------------------------------------- + +zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c +zipWith f [] [] = [] +zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys + +zip : Vect n a -> Vect n b -> Vect n (a, b) +zip = zipWith (\x => \y => (x,y)) + +unzip : Vect n (a, b) -> (Vect n a, Vect n b) +unzip [] = ([], []) +unzip ((l, r)::xs) with (unzip xs) + | (lefts, rights) = (l::lefts, r::rights) + +-------------------------------------------------------------------------------- +-- Maps +-------------------------------------------------------------------------------- + +instance Functor (Vect n) where + 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 n a -> (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 +-------------------------------------------------------------------------------- + +instance Foldable (Vect n) where + foldr f e [] = e + foldr f e (x::xs) = f x (foldr f e xs) + +-------------------------------------------------------------------------------- +-- Special folds +-------------------------------------------------------------------------------- + +concat : Vect m (Vect n a) -> Vect (m * n) a +concat [] = [] +concat (v::vs) = v ++ concat vs + +-------------------------------------------------------------------------------- +-- Transformations +-------------------------------------------------------------------------------- + +total reverse : Vect n a -> Vect n a +reverse = reverse' [] + where + total reverse' : Vect m a -> Vect n a -> Vect (m + n) a + reverse' acc [] ?= acc + reverse' acc (x::xs) ?= reverse' (x::acc) xs + +total intersperse' : a -> Vect m a -> (p ** Vect p a) +intersperse' sep [] = (_ ** []) +intersperse' sep (y::ys) with (intersperse' sep ys) + | (_ ** tail) = (_ ** sep::y::tail) + +total intersperse : a -> Vect m a -> (p ** Vect p a) +intersperse sep [] = (_ ** []) +intersperse sep (x::xs) with (intersperse' sep xs) + | (_ ** tail) = (_ ** x::tail) + +-------------------------------------------------------------------------------- +-- Membership tests +-------------------------------------------------------------------------------- + +elemBy : (a -> a -> Bool) -> a -> Vect n a -> 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 n a -> Bool +elem = elemBy (==) + +lookupBy : (a -> a -> Bool) -> a -> Vect n (a, b) -> 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 n (a, b) -> Maybe b +lookup = lookupBy (==) + +hasAnyBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> 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 m a -> Vect n a -> Bool +hasAny = hasAnyBy (==) + +-------------------------------------------------------------------------------- +-- Searching with a predicate +-------------------------------------------------------------------------------- + +find : (a -> Bool) -> Vect n a -> Maybe a +find p [] = Nothing +find p (x::xs) with (p x) + | True = Just x + | False = find p xs + +findIndex : (a -> Bool) -> Vect n a -> Maybe Nat +findIndex = findIndex' 0 + where + findIndex' : Nat -> (a -> Bool) -> Vect n a -> 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 m a -> (p ** Vect p Nat) +findIndices = findIndices' 0 + where + total findIndices' : Nat -> (a -> Bool) -> Vect m a -> (p ** Vect p Nat) + 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 m a -> Maybe Nat +elemIndexBy p e = findIndex $ p e + +elemIndex : Eq a => a -> Vect m a -> Maybe Nat +elemIndex = elemIndexBy (==) + +total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat) +elemIndicesBy p e = findIndices $ p e + +total elemIndices : Eq a => a -> Vect m a -> (p ** Vect p Nat) +elemIndices = elemIndicesBy (==) + +-------------------------------------------------------------------------------- +-- Filters +-------------------------------------------------------------------------------- + +total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a) +filter p [] = ( _ ** [] ) +filter p (x::xs) with (filter p xs) + | (_ ** tail) = + if p x then + (_ ** x::tail) + else + (_ ** tail) + +nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) +nubBy = nubBy' [] + where + nubBy' : Vect m a -> (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) + 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 n a -> (p ** Vect p a) +nub = nubBy (==) + +-------------------------------------------------------------------------------- +-- Splitting and breaking lists +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- Predicates +-------------------------------------------------------------------------------- + +isPrefixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> 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 m a -> Vect n a -> Bool +isPrefixOf = isPrefixOfBy (==) + +isSuffixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool +isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right) + +isSuffixOf : Eq a => Vect m a -> Vect n a -> Bool +isSuffixOf = isSuffixOfBy (==) + +-------------------------------------------------------------------------------- +-- Conversions +-------------------------------------------------------------------------------- + +total maybeToVect : Maybe a -> (p ** Vect p a) +maybeToVect Nothing = (_ ** []) +maybeToVect (Just j) = (_ ** [j]) + +total vectToMaybe : Vect n a -> Maybe a +vectToMaybe [] = Nothing +vectToMaybe (x::xs) = Just x + +-------------------------------------------------------------------------------- +-- Misc +-------------------------------------------------------------------------------- + +catMaybes : Vect n (Maybe a) -> (p ** Vect p a) +catMaybes [] = (_ ** []) +catMaybes (Nothing::xs) = catMaybes xs +catMaybes ((Just j)::xs) with (catMaybes xs) + | (_ ** tail) = (_ ** j::tail) + +diag : Vect n (Vect n a) -> Vect n a +diag [] = [] +diag ((x::xs)::xss) = x :: diag (map tail xss) + +range : Vect n (Fin n) +range {n=Z} = [] +range {n=S _} = fZ :: map fS range + +-------------------------------------------------------------------------------- +-- 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/libs/prelude/prelude.ipkg b/libs/prelude/prelude.ipkg new file mode 100644 --- /dev/null +++ b/libs/prelude/prelude.ipkg @@ -0,0 +1,13 @@ +package prelude + +opts = "--nobuiltins --total" +modules = Builtins, Prelude, IO, + + Prelude.Algebra, Prelude.Basics, Prelude.Bool, Prelude.Cast, + Prelude.Classes, Prelude.Nat, Prelude.Fin, Prelude.List, + Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either, + Prelude.Vect, Prelude.Strings, Prelude.Chars, Prelude.Functor, + Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream, + + Decidable.Equality + diff --git a/llvm/defs.c b/llvm/defs.c --- a/llvm/defs.c +++ b/llvm/defs.c @@ -169,3 +169,14 @@ } return t; } + +int __idris_argc; +char **__idris_argv; + +int idris_numArgs() { + return __idris_argc; +} + +const char* idris_getArg(int i) { + return __idris_argv[i]; +} diff --git a/rts/Makefile b/rts/Makefile --- a/rts/Makefile +++ b/rts/Makefile @@ -1,11 +1,11 @@ include ../config.mk -OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_stdfgn.o idris_bitstring.o idris_opts.o idris_stats.o -HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_stdfgn.h idris_bitstring.h idris_opts.h idris_stats.h +OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_stdfgn.o \ + idris_bitstring.o idris_opts.o idris_stats.o mini-gmp.o +HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_stdfgn.h \ + idris_bitstring.h idris_opts.h idris_stats.h mini-gmp.h CFLAGS:=-fPIC $(CFLAGS) -ifneq ($(GMP_INCLUDE_DIR),) - CFLAGS += -isystem $(GMP_INCLUDE_DIR) -endif +CFLAGS += $(GMP_INCLUDE_DIR) $(GMP) LIBTARGET = libidris_rts.a diff --git a/rts/idris_gc.c b/rts/idris_gc.c --- a/rts/idris_gc.c +++ b/rts/idris_gc.c @@ -24,6 +24,9 @@ case STRING: cl = MKSTRc(vm, x->info.str); break; + case STROFFSET: + cl = MKSTROFFc(vm, x->info.str_offset); + break; case BIGINT: cl = MKBIGMc(vm, x->info.ptr); break; @@ -60,7 +63,7 @@ while(scan < vm->heap.next) { size_t inc = *((size_t*)scan); VAL heap_item = (VAL)(scan+sizeof(size_t)); - // If it's a CON, copy its arguments + // If it's a CON or STROFFSET, copy its arguments switch(GETTY(heap_item)) { case CON: ar = ARITY(heap_item); @@ -70,6 +73,10 @@ // printf("Got %p\t\t%p %p\n", newptr, scan, vm->heap_next); heap_item->info.c.args[i] = newptr; } + break; + case STROFFSET: + heap_item->info.str_offset->str + = copy(vm, heap_item->info.str_offset->str); break; default: // Nothing to copy break; diff --git a/rts/idris_gmp.c b/rts/idris_gmp.c --- a/rts/idris_gmp.c +++ b/rts/idris_gmp.c @@ -1,5 +1,9 @@ #include "idris_rts.h" +#ifdef IDRIS_GMP #include +#else +#include "mini-gmp.h" +#endif #include #include @@ -92,7 +96,12 @@ return cl; } else { - return x; + switch(GETTY(x)) { + case FWD: + return GETBIG(vm, x->info.ptr); + default: + return x; + } } } @@ -100,7 +109,7 @@ mpz_t* bigint; VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); - mpz_add(*bigint, GETMPZ(x), GETMPZ(y)); + mpz_add(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT); cl -> info.ptr = (void*)bigint; return cl; @@ -110,7 +119,7 @@ mpz_t* bigint; VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); - mpz_sub(*bigint, GETMPZ(x), GETMPZ(y)); + mpz_sub(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT); cl -> info.ptr = (void*)bigint; return cl; @@ -120,7 +129,7 @@ mpz_t* bigint; VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); - mpz_mul(*bigint, GETMPZ(x), GETMPZ(y)); + mpz_mul(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT); cl -> info.ptr = (void*)bigint; return cl; @@ -130,7 +139,7 @@ mpz_t* bigint; VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); - mpz_div(*bigint, GETMPZ(x), GETMPZ(y)); + mpz_tdiv_q(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT); cl -> info.ptr = (void*)bigint; return cl; @@ -140,7 +149,7 @@ mpz_t* bigint; VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); - mpz_mod(*bigint, GETMPZ(x), GETMPZ(y)); + mpz_mod(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT); cl -> info.ptr = (void*)bigint; return cl; diff --git a/rts/idris_gmp.h b/rts/idris_gmp.h --- a/rts/idris_gmp.h +++ b/rts/idris_gmp.h @@ -1,6 +1,12 @@ #ifndef _IDRISGMP_H #define _IDRISGMP_H +#ifdef IDRIS_GMP +#include +#else +#include "mini-gmp.h" +#endif + VAL MKBIGI(int val); VAL MKBIGC(VM* vm, char* bigint); VAL MKBIGM(VM* vm, void* bigint); diff --git a/rts/idris_main.c b/rts/idris_main.c --- a/rts/idris_main.c +++ b/rts/idris_main.c @@ -10,8 +10,11 @@ int main(int argc, char* argv[]) { parse_shift_args(&opts, &argc, &argv); - - VM* vm = init_vm(opts.max_stack_size, opts.init_heap_size, 1, argc, argv); + + __idris_argc = argc; + __idris_argv = argv; + + VM* vm = init_vm(opts.max_stack_size, opts.init_heap_size, 1); _idris__123_runMain0_125_(vm, NULL); #ifdef IDRIS_DEBUG diff --git a/rts/idris_opts.c b/rts/idris_opts.c --- a/rts/idris_opts.c +++ b/rts/idris_opts.c @@ -6,18 +6,17 @@ #include -char usage[] = - "\n" \ +#define USAGE "\n" \ "Usage: [+RTS -RTS] \n\n" \ "Options:\n\n" \ " -? Print this message and exits.\n" \ " -s Summary GC statistics.\n" \ " -H Initial heap size. Egs: -H4M, -H500K, -H1G\n" \ " -K Sets the maximum stack size. Egs: -K8M\n" \ - "\n"; + "\n" void print_usage(FILE * s) { - fprintf(s, usage); + fprintf(s, USAGE); } int read_size(char * str) { @@ -26,7 +25,7 @@ int r = sscanf(str, "%u%c", &size, &mult); - if (r == 1) + if (r == 1) return size; if (r == 2) { @@ -34,8 +33,8 @@ case 'K': size = size << 10; break; case 'M': size = size << 20; break; case 'G': size = size << 30; break; - default: - fprintf(stderr, + default: + fprintf(stderr, "RTS Opts: Unable to recognize size suffix `%c'.\n" \ " Possible suffixes are K or M or G.\n", mult); @@ -58,7 +57,7 @@ if (strcmp(argv[0], "+RTS") != 0) return 0; - + int i; for (i = 1; i < argc; i++) { if (strcmp(argv[i], "-RTS") == 0) { diff --git a/rts/idris_rts.c b/rts/idris_rts.c --- a/rts/idris_rts.c +++ b/rts/idris_rts.c @@ -12,8 +12,8 @@ VM* init_vm(int stack_size, size_t heap_size, - int max_threads, // not implemented yet - int argc, char* argv[]) { + int max_threads // not implemented yet + ) { VM* vm = malloc(sizeof(VM)); STATS_INIT_STATS(vm->stats) @@ -45,9 +45,6 @@ vm->max_threads = max_threads; vm->processes = 0; - vm->argv = argv; - vm->argc = argc; - STATS_LEAVE_INIT(vm->stats) return vm; } @@ -87,6 +84,10 @@ } } +int space(VM* vm, size_t size) { + return (vm->heap.next + size + sizeof(size_t) < vm->heap.end); +} + void* allocate(VM* vm, size_t size, int outerlock) { // return malloc(size); int lock = vm->processes > 0 && !outerlock; @@ -145,7 +146,7 @@ return cl; } -VAL MKSTR(VM* vm, char* str) { +VAL MKSTR(VM* vm, const char* str) { int len; if (str == NULL) { len = 0; @@ -164,6 +165,12 @@ return cl; } +char* GETSTROFF(VAL stroff) { + // Assume STROFF + StrOffset* root = stroff->info.str_offset; + return (root->str->info.str + root->offset); +} + VAL MKPTR(VM* vm, void* ptr) { Closure* cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, PTR); @@ -400,8 +407,41 @@ return MKINT((i_int)(GETSTR(str)[0])); } +VAL MKSTROFFc(VM* vm, StrOffset* off) { + Closure* cl = allocate(vm, sizeof(Closure) + sizeof(StrOffset), 1); + SETTY(cl, STROFFSET); + cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure)); + + cl->info.str_offset->str = off->str; + cl->info.str_offset->offset = off->offset; + + return cl; +} + VAL idris_strTail(VM* vm, VAL str) { - return MKSTR(vm, GETSTR(str)+1); + // If there's no room, just copy the string, or we'll have a problem after + // gc moves str + if (space(vm, sizeof(Closure) + sizeof(StrOffset))) { + Closure* cl = allocate(vm, sizeof(Closure) + sizeof(StrOffset), 0); + SETTY(cl, STROFFSET); + cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure)); + + int offset = 0; + VAL root = str; + + while(root!=NULL && !ISSTR(root)) { // find the root, carry on. + // In theory, at most one step here! + offset += root->info.str_offset->offset; + root = root->info.str_offset->str; + } + + cl->info.str_offset->str = root; + cl->info.str_offset->offset = offset+1; + + return cl; + } else { + return MKSTR(vm, GETSTR(str)+1); + } } VAL idris_strCons(VM* vm, VAL x, VAL xs) { @@ -455,15 +495,15 @@ free(td); - Stats stats = terminate(vm); + // Stats stats = + terminate(vm); // aggregate_stats(&(td->vm->stats), &stats); return NULL; } void* vmThread(VM* callvm, func f, VAL arg) { VM* vm = init_vm(callvm->stack_max - callvm->valstack, callvm->heap.size, - callvm->max_threads, - 0, NULL); + callvm->max_threads); vm->processes=1; // since it can send and receive messages pthread_t t; pthread_attr_t attr; @@ -626,12 +666,15 @@ return msg; } -int idris_numArgs(VM* vm) { - return vm->argc; +int __idris_argc; +char **__idris_argv; + +int idris_numArgs() { + return __idris_argc; } -VAL idris_getArg(VM* vm, int i) { - return MKSTR(vm, vm->argv[i]); +const char* idris_getArg(int i) { + return __idris_argv[i]; } void stackOverflow() { diff --git a/rts/idris_rts.h b/rts/idris_rts.h --- a/rts/idris_rts.h +++ b/rts/idris_rts.h @@ -15,7 +15,8 @@ // Closures typedef enum { - CON, INT, BIGINT, FLOAT, STRING, BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD + CON, INT, BIGINT, FLOAT, STRING, STROFFSET, + BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD } ClosureType; typedef struct Closure *VAL; @@ -25,6 +26,11 @@ VAL args[]; } con; +typedef struct { + VAL str; + int offset; +} StrOffset; + typedef struct Closure { // Use top 16 bits of ty for saying which heap value is in // Bottom 16 bits for closure type @@ -34,6 +40,7 @@ int i; double f; char* str; + StrOffset* str_offset; void* ptr; uint8_t bits8; uint16_t bits16; @@ -66,17 +73,13 @@ Stats stats; - int argc; - char** argv; // command line arguments - VAL ret; VAL reg1; } VM; // Create a new VM VM* init_vm(int stack_size, size_t heap_size, - int max_threads, - int argc, char* argv[]); + int max_threads); // Clean up a VM once it's no longer needed Stats terminate(VM* vm); @@ -96,7 +99,7 @@ // Retrieving values -#define GETSTR(x) (((VAL)(x))->info.str) +#define GETSTR(x) (ISSTR(x) ? (((VAL)(x))->info.str) : GETSTROFF(x)) #define GETPTR(x) (((VAL)(x))->info.ptr) #define GETFLOAT(x) (((VAL)(x))->info.f) @@ -123,6 +126,7 @@ #define MKINT(x) ((void*)((x)<<1)+1) #define GETINT(x) ((i_int)(x)>>1) #define ISINT(x) ((((i_int)x)&1) == 1) +#define ISSTR(x) (((VAL)(x))->ty == STRING) #define INTOP(op,x,y) MKINT((i_int)((((i_int)x)>>1) op (((i_int)y)>>1))) #define UINTOP(op,x,y) MKINT((i_int)((((uintptr_t)x)>>1) op (((uintptr_t)y)>>1))) @@ -146,7 +150,7 @@ // Creating new values (each value placed at the top of the stack) VAL MKFLOAT(VM* vm, double val); -VAL MKSTR(VM* vm, char* str); +VAL MKSTR(VM* vm, const char* str); VAL MKPTR(VM* vm, void* ptr); VAL MKB8(VM* vm, uint8_t b); VAL MKB16(VM* vm, uint16_t b); @@ -155,9 +159,12 @@ // following versions don't take a lock when allocating VAL MKFLOATc(VM* vm, double val); +VAL MKSTROFFc(VM* vm, StrOffset* off); VAL MKSTRc(VM* vm, char* str); VAL MKPTRc(VM* vm, void* ptr); +char* GETSTROFF(VAL stroff); + // #define SETTAG(x, a) (x)->info.c.tag = (a) #define SETARG(x, i, a) ((x)->info.c.args)[i] = ((VAL)(a)) #define GETARG(x, i) ((x)->info.c.args)[i] @@ -229,8 +236,11 @@ // Command line args -int idris_numArgs(VM* vm); -VAL idris_getArg(VM* vm, int i); +extern int __idris_argc; +extern char **__idris_argv; + +int idris_numArgs(); +const char *idris_getArg(int i); // Handle stack overflow. // Just reports an error and exits. diff --git a/rts/mini-gmp.c b/rts/mini-gmp.c new file mode 100644 --- /dev/null +++ b/rts/mini-gmp.c @@ -0,0 +1,4120 @@ +/* mini-gmp, a minimalistic implementation of a GNU GMP subset. + + Contributed to the GNU project by Niels Möller + +Copyright 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1999, 2000, 2001, +2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 +Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as published by +the Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public +License for more details. + +You should have received a copy of the GNU Lesser General Public License +along with the GNU MP Library. If not, see http://www.gnu.org/licenses/. */ + +/* NOTE: All functions in this file which are not declared in + mini-gmp.h are internal, and are not intended to be compatible + neither with GMP nor with future versions of mini-gmp. */ + +/* Much of the material copied from GMP files, including: gmp-impl.h, + longlong.h, mpn/generic/add_n.c, mpn/generic/addmul_1.c, + mpn/generic/lshift.c, mpn/generic/mul_1.c, + mpn/generic/mul_basecase.c, mpn/generic/rshift.c, + mpn/generic/sbpi1_div_qr.c, mpn/generic/sub_n.c, + mpn/generic/submul_1.c. */ + +#include +#include +#include +#include +#include +#include + +#include "mini-gmp.h" + + +/* Macros */ +#define GMP_LIMB_BITS (sizeof(mp_limb_t) * CHAR_BIT) + +#define GMP_LIMB_MAX (~ (mp_limb_t) 0) +#define GMP_LIMB_HIGHBIT ((mp_limb_t) 1 << (GMP_LIMB_BITS - 1)) + +#define GMP_HLIMB_BIT ((mp_limb_t) 1 << (GMP_LIMB_BITS / 2)) +#define GMP_LLIMB_MASK (GMP_HLIMB_BIT - 1) + +#define GMP_ULONG_BITS (sizeof(unsigned long) * CHAR_BIT) +#define GMP_ULONG_HIGHBIT ((unsigned long) 1 << (GMP_ULONG_BITS - 1)) + +#define GMP_ABS(x) ((x) >= 0 ? (x) : -(x)) +#define GMP_NEG_CAST(T,x) (-((T)((x) + 1) - 1)) + +#define GMP_MIN(a, b) ((a) < (b) ? (a) : (b)) +#define GMP_MAX(a, b) ((a) > (b) ? (a) : (b)) + +#define gmp_assert_nocarry(x) do { \ + mp_limb_t __cy = x; \ + assert (__cy == 0); \ + } while (0) + +#define gmp_clz(count, x) do { \ + mp_limb_t __clz_x = (x); \ + unsigned __clz_c; \ + for (__clz_c = 0; \ + (__clz_x & ((mp_limb_t) 0xff << (GMP_LIMB_BITS - 8))) == 0; \ + __clz_c += 8) \ + __clz_x <<= 8; \ + for (; (__clz_x & GMP_LIMB_HIGHBIT) == 0; __clz_c++) \ + __clz_x <<= 1; \ + (count) = __clz_c; \ + } while (0) + +#define gmp_ctz(count, x) do { \ + mp_limb_t __ctz_x = (x); \ + unsigned __ctz_c = 0; \ + gmp_clz (__ctz_c, __ctz_x & - __ctz_x); \ + (count) = GMP_LIMB_BITS - 1 - __ctz_c; \ + } while (0) + +#define gmp_add_ssaaaa(sh, sl, ah, al, bh, bl) \ + do { \ + mp_limb_t __x; \ + __x = (al) + (bl); \ + (sh) = (ah) + (bh) + (__x < (al)); \ + (sl) = __x; \ + } while (0) + +#define gmp_sub_ddmmss(sh, sl, ah, al, bh, bl) \ + do { \ + mp_limb_t __x; \ + __x = (al) - (bl); \ + (sh) = (ah) - (bh) - ((al) < (bl)); \ + (sl) = __x; \ + } while (0) + +#define gmp_umul_ppmm(w1, w0, u, v) \ + do { \ + mp_limb_t __x0, __x1, __x2, __x3; \ + unsigned __ul, __vl, __uh, __vh; \ + mp_limb_t __u = (u), __v = (v); \ + \ + __ul = __u & GMP_LLIMB_MASK; \ + __uh = __u >> (GMP_LIMB_BITS / 2); \ + __vl = __v & GMP_LLIMB_MASK; \ + __vh = __v >> (GMP_LIMB_BITS / 2); \ + \ + __x0 = (mp_limb_t) __ul * __vl; \ + __x1 = (mp_limb_t) __ul * __vh; \ + __x2 = (mp_limb_t) __uh * __vl; \ + __x3 = (mp_limb_t) __uh * __vh; \ + \ + __x1 += __x0 >> (GMP_LIMB_BITS / 2);/* this can't give carry */ \ + __x1 += __x2; /* but this indeed can */ \ + if (__x1 < __x2) /* did we get it? */ \ + __x3 += GMP_HLIMB_BIT; /* yes, add it in the proper pos. */ \ + \ + (w1) = __x3 + (__x1 >> (GMP_LIMB_BITS / 2)); \ + (w0) = (__x1 << (GMP_LIMB_BITS / 2)) + (__x0 & GMP_LLIMB_MASK); \ + } while (0) + +#define gmp_udiv_qrnnd_preinv(q, r, nh, nl, d, di) \ + do { \ + mp_limb_t _qh, _ql, _r, _mask; \ + gmp_umul_ppmm (_qh, _ql, (nh), (di)); \ + gmp_add_ssaaaa (_qh, _ql, _qh, _ql, (nh) + 1, (nl)); \ + _r = (nl) - _qh * (d); \ + _mask = -(mp_limb_t) (_r > _ql); /* both > and >= are OK */ \ + _qh += _mask; \ + _r += _mask & (d); \ + if (_r >= (d)) \ + { \ + _r -= (d); \ + _qh++; \ + } \ + \ + (r) = _r; \ + (q) = _qh; \ + } while (0) + +#define gmp_udiv_qr_3by2(q, r1, r0, n2, n1, n0, d1, d0, dinv) \ + do { \ + mp_limb_t _q0, _t1, _t0, _mask; \ + gmp_umul_ppmm ((q), _q0, (n2), (dinv)); \ + gmp_add_ssaaaa ((q), _q0, (q), _q0, (n2), (n1)); \ + \ + /* Compute the two most significant limbs of n - q'd */ \ + (r1) = (n1) - (d1) * (q); \ + gmp_sub_ddmmss ((r1), (r0), (r1), (n0), (d1), (d0)); \ + gmp_umul_ppmm (_t1, _t0, (d0), (q)); \ + gmp_sub_ddmmss ((r1), (r0), (r1), (r0), _t1, _t0); \ + (q)++; \ + \ + /* Conditionally adjust q and the remainders */ \ + _mask = - (mp_limb_t) ((r1) >= _q0); \ + (q) += _mask; \ + gmp_add_ssaaaa ((r1), (r0), (r1), (r0), _mask & (d1), _mask & (d0)); \ + if ((r1) >= (d1)) \ + { \ + if ((r1) > (d1) || (r0) >= (d0)) \ + { \ + (q)++; \ + gmp_sub_ddmmss ((r1), (r0), (r1), (r0), (d1), (d0)); \ + } \ + } \ + } while (0) + +/* Swap macros. */ +#define MP_LIMB_T_SWAP(x, y) \ + do { \ + mp_limb_t __mp_limb_t_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_limb_t_swap__tmp; \ + } while (0) +#define MP_SIZE_T_SWAP(x, y) \ + do { \ + mp_size_t __mp_size_t_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_size_t_swap__tmp; \ + } while (0) +#define MP_BITCNT_T_SWAP(x,y) \ + do { \ + mp_bitcnt_t __mp_bitcnt_t_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_bitcnt_t_swap__tmp; \ + } while (0) +#define MP_PTR_SWAP(x, y) \ + do { \ + mp_ptr __mp_ptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_ptr_swap__tmp; \ + } while (0) +#define MP_SRCPTR_SWAP(x, y) \ + do { \ + mp_srcptr __mp_srcptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_srcptr_swap__tmp; \ + } while (0) + +#define MPN_PTR_SWAP(xp,xs, yp,ys) \ + do { \ + MP_PTR_SWAP (xp, yp); \ + MP_SIZE_T_SWAP (xs, ys); \ + } while(0) +#define MPN_SRCPTR_SWAP(xp,xs, yp,ys) \ + do { \ + MP_SRCPTR_SWAP (xp, yp); \ + MP_SIZE_T_SWAP (xs, ys); \ + } while(0) + +#define MPZ_PTR_SWAP(x, y) \ + do { \ + mpz_ptr __mpz_ptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mpz_ptr_swap__tmp; \ + } while (0) +#define MPZ_SRCPTR_SWAP(x, y) \ + do { \ + mpz_srcptr __mpz_srcptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mpz_srcptr_swap__tmp; \ + } while (0) + + +/* Memory allocation and other helper functions. */ +static void +gmp_die (const char *msg) +{ + fprintf (stderr, "%s\n", msg); + abort(); +} + +static void * +gmp_default_alloc (size_t size) +{ + void *p; + + assert (size > 0); + + p = malloc (size); + if (!p) + gmp_die("gmp_default_alloc: Virtual memory exhausted."); + + return p; +} + +static void * +gmp_default_realloc (void *old, size_t old_size, size_t new_size) +{ + mp_ptr p; + + p = realloc (old, new_size); + + if (!p) + gmp_die("gmp_default_realoc: Virtual memory exhausted."); + + return p; +} + +static void +gmp_default_free (void *p, size_t size) +{ + free (p); +} + +static void * (*gmp_allocate_func) (size_t) = gmp_default_alloc; +static void * (*gmp_reallocate_func) (void *, size_t, size_t) = gmp_default_realloc; +static void (*gmp_free_func) (void *, size_t) = gmp_default_free; + +void +mp_get_memory_functions (void *(**alloc_func) (size_t), + void *(**realloc_func) (void *, size_t, size_t), + void (**free_func) (void *, size_t)) +{ + if (alloc_func) + *alloc_func = gmp_allocate_func; + + if (realloc_func) + *realloc_func = gmp_reallocate_func; + + if (free_func) + *free_func = gmp_free_func; +} + +void +mp_set_memory_functions (void *(*alloc_func) (size_t), + void *(*realloc_func) (void *, size_t, size_t), + void (*free_func) (void *, size_t)) +{ + if (!alloc_func) + alloc_func = gmp_default_alloc; + if (!realloc_func) + realloc_func = gmp_default_realloc; + if (!free_func) + free_func = gmp_default_free; + + gmp_allocate_func = alloc_func; + gmp_reallocate_func = realloc_func; + gmp_free_func = free_func; +} + +#define gmp_xalloc(size) ((*gmp_allocate_func)((size))) +#define gmp_free(p) ((*gmp_free_func) ((p), 0)) + +static mp_ptr +gmp_xalloc_limbs (mp_size_t size) +{ + return gmp_xalloc (size * sizeof (mp_limb_t)); +} + +static mp_ptr +gmp_xrealloc_limbs (mp_ptr old, mp_size_t size) +{ + assert (size > 0); + return (*gmp_reallocate_func) (old, 0, size * sizeof (mp_limb_t)); +} + + +/* MPN interface */ + +void +mpn_copyi (mp_ptr d, mp_srcptr s, mp_size_t n) +{ + mp_size_t i; + for (i = 0; i < n; i++) + d[i] = s[i]; +} + +void +mpn_copyd (mp_ptr d, mp_srcptr s, mp_size_t n) +{ + while (n-- > 0) + d[n] = s[n]; +} + +int +mpn_cmp (mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + while (--n >= 0) + { + if (ap[n] != bp[n]) + return ap[n] > bp[n] ? 1 : -1; + } + return 0; +} + +static int +mpn_cmp4 (mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) +{ + if (an != bn) + return an < bn ? -1 : 1; + else + return mpn_cmp (ap, bp, an); +} + +static mp_size_t +mpn_normalized_size (mp_srcptr xp, mp_size_t n) +{ + for (; n > 0 && xp[n-1] == 0; n--) + ; + return n; +} + +#define mpn_zero_p(xp, n) (mpn_normalized_size ((xp), (n)) == 0) + +mp_limb_t +mpn_add_1 (mp_ptr rp, mp_srcptr ap, mp_size_t n, mp_limb_t b) +{ + mp_size_t i; + + assert (n > 0); + i = 0; + do + { + mp_limb_t r = ap[i] + b; + /* Carry out */ + b = (r < b); + rp[i] = r; + } + while (++i < n); + + return b; +} + +mp_limb_t +mpn_add_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + mp_size_t i; + mp_limb_t cy; + + for (i = 0, cy = 0; i < n; i++) + { + mp_limb_t a, b, r; + a = ap[i]; b = bp[i]; + r = a + cy; + cy = (r < cy); + r += b; + cy += (r < b); + rp[i] = r; + } + return cy; +} + +mp_limb_t +mpn_add (mp_ptr rp, mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) +{ + mp_limb_t cy; + + assert (an >= bn); + + cy = mpn_add_n (rp, ap, bp, bn); + if (an > bn) + cy = mpn_add_1 (rp + bn, ap + bn, an - bn, cy); + return cy; +} + +mp_limb_t +mpn_sub_1 (mp_ptr rp, mp_srcptr ap, mp_size_t n, mp_limb_t b) +{ + mp_size_t i; + + assert (n > 0); + + i = 0; + do + { + mp_limb_t a = ap[i]; + /* Carry out */ + mp_limb_t cy = a < b;; + rp[i] = a - b; + b = cy; + } + while (++i < n); + + return b; +} + +mp_limb_t +mpn_sub_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + mp_size_t i; + mp_limb_t cy; + + for (i = 0, cy = 0; i < n; i++) + { + mp_limb_t a, b; + a = ap[i]; b = bp[i]; + b += cy; + cy = (b < cy); + cy += (a < b); + rp[i] = a - b; + } + return cy; +} + +mp_limb_t +mpn_sub (mp_ptr rp, mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) +{ + mp_limb_t cy; + + assert (an >= bn); + + cy = mpn_sub_n (rp, ap, bp, bn); + if (an > bn) + cy = mpn_sub_1 (rp + bn, ap + bn, an - bn, cy); + return cy; +} + +mp_limb_t +mpn_mul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) +{ + mp_limb_t ul, cl, hpl, lpl; + + assert (n >= 1); + + cl = 0; + do + { + ul = *up++; + gmp_umul_ppmm (hpl, lpl, ul, vl); + + lpl += cl; + cl = (lpl < cl) + hpl; + + *rp++ = lpl; + } + while (--n != 0); + + return cl; +} + +mp_limb_t +mpn_addmul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) +{ + mp_limb_t ul, cl, hpl, lpl, rl; + + assert (n >= 1); + + cl = 0; + do + { + ul = *up++; + gmp_umul_ppmm (hpl, lpl, ul, vl); + + lpl += cl; + cl = (lpl < cl) + hpl; + + rl = *rp; + lpl = rl + lpl; + cl += lpl < rl; + *rp++ = lpl; + } + while (--n != 0); + + return cl; +} + +mp_limb_t +mpn_submul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) +{ + mp_limb_t ul, cl, hpl, lpl, rl; + + assert (n >= 1); + + cl = 0; + do + { + ul = *up++; + gmp_umul_ppmm (hpl, lpl, ul, vl); + + lpl += cl; + cl = (lpl < cl) + hpl; + + rl = *rp; + lpl = rl - lpl; + cl += lpl > rl; + *rp++ = lpl; + } + while (--n != 0); + + return cl; +} + +mp_limb_t +mpn_mul (mp_ptr rp, mp_srcptr up, mp_size_t un, mp_srcptr vp, mp_size_t vn) +{ + assert (un >= vn); + assert (vn >= 1); + + /* We first multiply by the low order limb. This result can be + stored, not added, to rp. We also avoid a loop for zeroing this + way. */ + + rp[un] = mpn_mul_1 (rp, up, un, vp[0]); + rp += 1, vp += 1, vn -= 1; + + /* Now accumulate the product of up[] and the next higher limb from + vp[]. */ + + while (vn >= 1) + { + rp[un] = mpn_addmul_1 (rp, up, un, vp[0]); + rp += 1, vp += 1, vn -= 1; + } + return rp[un - 1]; +} + +void +mpn_mul_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + mpn_mul (rp, ap, n, bp, n); +} + +void +mpn_sqr (mp_ptr rp, mp_srcptr ap, mp_size_t n) +{ + mpn_mul (rp, ap, n, ap, n); +} + +mp_limb_t +mpn_lshift (mp_ptr rp, mp_srcptr up, mp_size_t n, unsigned int cnt) +{ + mp_limb_t high_limb, low_limb; + unsigned int tnc; + mp_size_t i; + mp_limb_t retval; + + assert (n >= 1); + assert (cnt >= 1); + assert (cnt < GMP_LIMB_BITS); + + up += n; + rp += n; + + tnc = GMP_LIMB_BITS - cnt; + low_limb = *--up; + retval = low_limb >> tnc; + high_limb = (low_limb << cnt); + + for (i = n; --i != 0;) + { + low_limb = *--up; + *--rp = high_limb | (low_limb >> tnc); + high_limb = (low_limb << cnt); + } + *--rp = high_limb; + + return retval; +} + +mp_limb_t +mpn_rshift (mp_ptr rp, mp_srcptr up, mp_size_t n, unsigned int cnt) +{ + mp_limb_t high_limb, low_limb; + unsigned int tnc; + mp_size_t i; + mp_limb_t retval; + + assert (n >= 1); + assert (cnt >= 1); + assert (cnt < GMP_LIMB_BITS); + + tnc = GMP_LIMB_BITS - cnt; + high_limb = *up++; + retval = (high_limb << tnc); + low_limb = high_limb >> cnt; + + for (i = n; --i != 0;) + { + high_limb = *up++; + *rp++ = low_limb | (high_limb << tnc); + low_limb = high_limb >> cnt; + } + *rp = low_limb; + + return retval; +} + +static mp_bitcnt_t +mpn_common_scan (mp_limb_t limb, mp_size_t i, mp_srcptr up, mp_size_t un, + mp_limb_t ux) +{ + unsigned cnt; + + assert (ux == 0 || ux == GMP_LIMB_MAX); + assert (0 <= i && i <= un ); + + while (limb == 0) + { + i++; + if (i == un) + return (ux == 0 ? ~(mp_bitcnt_t) 0 : un * GMP_LIMB_BITS); + limb = ux ^ up[i]; + } + gmp_ctz (cnt, limb); + return (mp_bitcnt_t) i * GMP_LIMB_BITS + cnt; +} + +mp_bitcnt_t +mpn_scan1 (mp_srcptr ptr, mp_bitcnt_t bit) +{ + mp_size_t i; + i = bit / GMP_LIMB_BITS; + + return mpn_common_scan ( ptr[i] & (GMP_LIMB_MAX << (bit % GMP_LIMB_BITS)), + i, ptr, i, 0); +} + +mp_bitcnt_t +mpn_scan0 (mp_srcptr ptr, mp_bitcnt_t bit) +{ + mp_size_t i; + i = bit / GMP_LIMB_BITS; + + return mpn_common_scan (~ptr[i] & (GMP_LIMB_MAX << (bit % GMP_LIMB_BITS)), + i, ptr, i, GMP_LIMB_MAX); +} + + +/* MPN division interface. */ +mp_limb_t +mpn_invert_3by2 (mp_limb_t u1, mp_limb_t u0) +{ + mp_limb_t r, p, m; + unsigned ul, uh; + unsigned ql, qh; + + /* First, do a 2/1 inverse. */ + /* The inverse m is defined as floor( (B^2 - 1 - u1)/u1 ), so that 0 < + * B^2 - (B + m) u1 <= u1 */ + assert (u1 >= GMP_LIMB_HIGHBIT); + + ul = u1 & GMP_LLIMB_MASK; + uh = u1 >> (GMP_LIMB_BITS / 2); + + qh = ~u1 / uh; + r = ((~u1 - (mp_limb_t) qh * uh) << (GMP_LIMB_BITS / 2)) | GMP_LLIMB_MASK; + + p = (mp_limb_t) qh * ul; + /* Adjustment steps taken from udiv_qrnnd_c */ + if (r < p) + { + qh--; + r += u1; + if (r >= u1) /* i.e. we didn't get carry when adding to r */ + if (r < p) + { + qh--; + r += u1; + } + } + r -= p; + + /* Do a 3/2 division (with half limb size) */ + p = (r >> (GMP_LIMB_BITS / 2)) * qh + r; + ql = (p >> (GMP_LIMB_BITS / 2)) + 1; + + /* By the 3/2 method, we don't need the high half limb. */ + r = (r << (GMP_LIMB_BITS / 2)) + GMP_LLIMB_MASK - ql * u1; + + if (r >= (p << (GMP_LIMB_BITS / 2))) + { + ql--; + r += u1; + } + m = ((mp_limb_t) qh << (GMP_LIMB_BITS / 2)) + ql; + if (r >= u1) + { + m++; + r -= u1; + } + + if (u0 > 0) + { + mp_limb_t th, tl; + r = ~r; + r += u0; + if (r < u0) + { + m--; + if (r >= u1) + { + m--; + r -= u1; + } + r -= u1; + } + gmp_umul_ppmm (th, tl, u0, m); + r += th; + if (r < th) + { + m--; + m -= ((r > u1) | ((r == u1) & (tl > u0))); + } + } + + return m; +} + +struct gmp_div_inverse +{ + /* Normalization shift count. */ + unsigned shift; + /* Normalized divisor (d0 unused for mpn_div_qr_1) */ + mp_limb_t d1, d0; + /* Inverse, for 2/1 or 3/2. */ + mp_limb_t di; +}; + +static void +mpn_div_qr_1_invert (struct gmp_div_inverse *inv, mp_limb_t d) +{ + unsigned shift; + + assert (d > 0); + gmp_clz (shift, d); + inv->shift = shift; + inv->d1 = d << shift; + inv->di = mpn_invert_limb (inv->d1); +} + +static void +mpn_div_qr_2_invert (struct gmp_div_inverse *inv, + mp_limb_t d1, mp_limb_t d0) +{ + unsigned shift; + + assert (d1 > 0); + gmp_clz (shift, d1); + inv->shift = shift; + if (shift > 0) + { + d1 = (d1 << shift) | (d0 >> (GMP_LIMB_BITS - shift)); + d0 <<= shift; + } + inv->d1 = d1; + inv->d0 = d0; + inv->di = mpn_invert_3by2 (d1, d0); +} + +static void +mpn_div_qr_invert (struct gmp_div_inverse *inv, + mp_srcptr dp, mp_size_t dn) +{ + assert (dn > 0); + + if (dn == 1) + mpn_div_qr_1_invert (inv, dp[0]); + else if (dn == 2) + mpn_div_qr_2_invert (inv, dp[1], dp[0]); + else + { + unsigned shift; + mp_limb_t d1, d0; + + d1 = dp[dn-1]; + d0 = dp[dn-2]; + assert (d1 > 0); + gmp_clz (shift, d1); + inv->shift = shift; + if (shift > 0) + { + d1 = (d1 << shift) | (d0 >> (GMP_LIMB_BITS - shift)); + d0 = (d0 << shift) | (dp[dn-3] >> (GMP_LIMB_BITS - shift)); + } + inv->d1 = d1; + inv->d0 = d0; + inv->di = mpn_invert_3by2 (d1, d0); + } +} + +/* Not matching current public gmp interface, rather corresponding to + the sbpi1_div_* functions. */ +static mp_limb_t +mpn_div_qr_1_preinv (mp_ptr qp, mp_srcptr np, mp_size_t nn, + const struct gmp_div_inverse *inv) +{ + mp_limb_t d, di; + mp_limb_t r; + mp_ptr tp = NULL; + + if (inv->shift > 0) + { + tp = gmp_xalloc_limbs (nn); + r = mpn_lshift (tp, np, nn, inv->shift); + np = tp; + } + else + r = 0; + + d = inv->d1; + di = inv->di; + while (nn-- > 0) + { + mp_limb_t q; + + gmp_udiv_qrnnd_preinv (q, r, r, np[nn], d, di); + if (qp) + qp[nn] = q; + } + if (inv->shift > 0) + gmp_free (tp); + + return r >> inv->shift; +} + +static mp_limb_t +mpn_div_qr_1 (mp_ptr qp, mp_srcptr np, mp_size_t nn, mp_limb_t d) +{ + assert (d > 0); + + /* Special case for powers of two. */ + if ((d & (d-1)) == 0) + { + mp_limb_t r = np[0] & (d-1); + if (qp) + { + if (d <= 1) + mpn_copyi (qp, np, nn); + else + { + unsigned shift; + gmp_ctz (shift, d); + mpn_rshift (qp, np, nn, shift); + } + } + return r; + } + else + { + struct gmp_div_inverse inv; + mpn_div_qr_1_invert (&inv, d); + return mpn_div_qr_1_preinv (qp, np, nn, &inv); + } +} + +static void +mpn_div_qr_2_preinv (mp_ptr qp, mp_ptr rp, mp_srcptr np, mp_size_t nn, + const struct gmp_div_inverse *inv) +{ + unsigned shift; + mp_size_t i; + mp_limb_t d1, d0, di, r1, r0; + mp_ptr tp; + + assert (nn >= 2); + shift = inv->shift; + d1 = inv->d1; + d0 = inv->d0; + di = inv->di; + + if (shift > 0) + { + tp = gmp_xalloc_limbs (nn); + r1 = mpn_lshift (tp, np, nn, shift); + np = tp; + } + else + r1 = 0; + + r0 = np[nn - 1]; + + i = nn - 2; + do + { + mp_limb_t n0, q; + n0 = np[i]; + gmp_udiv_qr_3by2 (q, r1, r0, r1, r0, n0, d1, d0, di); + + if (qp) + qp[i] = q; + } + while (--i >= 0); + + if (shift > 0) + { + assert ((r0 << (GMP_LIMB_BITS - shift)) == 0); + r0 = (r0 >> shift) | (r1 << (GMP_LIMB_BITS - shift)); + r1 >>= shift; + + gmp_free (tp); + } + + rp[1] = r1; + rp[0] = r0; +} + +#if 0 +static void +mpn_div_qr_2 (mp_ptr qp, mp_ptr rp, mp_srcptr np, mp_size_t nn, + mp_limb_t d1, mp_limb_t d0) +{ + struct gmp_div_inverse inv; + assert (nn >= 2); + + mpn_div_qr_2_invert (&inv, d1, d0); + mpn_div_qr_2_preinv (qp, rp, np, nn, &inv); +} +#endif + +static void +mpn_div_qr_pi1 (mp_ptr qp, + mp_ptr np, mp_size_t nn, mp_limb_t n1, + mp_srcptr dp, mp_size_t dn, + mp_limb_t dinv) +{ + mp_size_t i; + + mp_limb_t d1, d0; + mp_limb_t cy, cy1; + mp_limb_t q; + + assert (dn > 2); + assert (nn >= dn); + + d1 = dp[dn - 1]; + d0 = dp[dn - 2]; + + assert ((d1 & GMP_LIMB_HIGHBIT) != 0); + /* Iteration variable is the index of the q limb. + * + * We divide + * by + */ + + i = nn - dn; + do + { + mp_limb_t n0 = np[dn-1+i]; + + if (n1 == d1 && n0 == d0) + { + q = GMP_LIMB_MAX; + mpn_submul_1 (np+i, dp, dn, q); + n1 = np[dn-1+i]; /* update n1, last loop's value will now be invalid */ + } + else + { + gmp_udiv_qr_3by2 (q, n1, n0, n1, n0, np[dn-2+i], d1, d0, dinv); + + cy = mpn_submul_1 (np + i, dp, dn-2, q); + + cy1 = n0 < cy; + n0 = n0 - cy; + cy = n1 < cy1; + n1 = n1 - cy1; + np[dn-2+i] = n0; + + if (cy != 0) + { + n1 += d1 + mpn_add_n (np + i, np + i, dp, dn - 1); + q--; + } + } + + if (qp) + qp[i] = q; + } + while (--i >= 0); + + np[dn - 1] = n1; +} + +static void +mpn_div_qr_preinv (mp_ptr qp, mp_ptr np, mp_size_t nn, + mp_srcptr dp, mp_size_t dn, + const struct gmp_div_inverse *inv) +{ + assert (dn > 0); + assert (nn >= dn); + + if (dn == 1) + np[0] = mpn_div_qr_1_preinv (qp, np, nn, inv); + else if (dn == 2) + mpn_div_qr_2_preinv (qp, np, np, nn, inv); + else + { + mp_limb_t nh; + unsigned shift; + + assert (inv->d1 == dp[dn-1]); + assert (inv->d0 == dp[dn-2]); + assert ((inv->d1 & GMP_LIMB_HIGHBIT) != 0); + + shift = inv->shift; + if (shift > 0) + nh = mpn_lshift (np, np, nn, shift); + else + nh = 0; + + mpn_div_qr_pi1 (qp, np, nn, nh, dp, dn, inv->di); + + if (shift > 0) + gmp_assert_nocarry (mpn_rshift (np, np, dn, shift)); + } +} + +static void +mpn_div_qr (mp_ptr qp, mp_ptr np, mp_size_t nn, mp_srcptr dp, mp_size_t dn) +{ + struct gmp_div_inverse inv; + mp_ptr tp = NULL; + + assert (dn > 0); + assert (nn >= dn); + + mpn_div_qr_invert (&inv, dp, dn); + if (dn > 2 && inv.shift > 0) + { + tp = gmp_xalloc_limbs (dn); + gmp_assert_nocarry (mpn_lshift (tp, dp, dn, inv.shift)); + dp = tp; + } + mpn_div_qr_preinv (qp, np, nn, dp, dn, &inv); + if (tp) + gmp_free (tp); +} + + +/* MPN base conversion. */ +static unsigned +mpn_base_power_of_two_p (unsigned b) +{ + switch (b) + { + case 2: return 1; + case 4: return 2; + case 8: return 3; + case 16: return 4; + case 32: return 5; + case 64: return 6; + case 128: return 7; + case 256: return 8; + default: return 0; + } +} + +struct mpn_base_info +{ + /* bb is the largest power of the base which fits in one limb, and + exp is the corresponding exponent. */ + unsigned exp; + mp_limb_t bb; +}; + +static void +mpn_get_base_info (struct mpn_base_info *info, mp_limb_t b) +{ + mp_limb_t m; + mp_limb_t p; + unsigned exp; + + m = GMP_LIMB_MAX / b; + for (exp = 1, p = b; p <= m; exp++) + p *= b; + + info->exp = exp; + info->bb = p; +} + +static mp_bitcnt_t +mpn_limb_size_in_base_2 (mp_limb_t u) +{ + unsigned shift; + + assert (u > 0); + gmp_clz (shift, u); + return GMP_LIMB_BITS - shift; +} + +static size_t +mpn_get_str_bits (unsigned char *sp, unsigned bits, mp_srcptr up, mp_size_t un) +{ + unsigned char mask; + size_t sn, j; + mp_size_t i; + int shift; + + sn = ((un - 1) * GMP_LIMB_BITS + mpn_limb_size_in_base_2 (up[un-1]) + + bits - 1) / bits; + + mask = (1U << bits) - 1; + + for (i = 0, j = sn, shift = 0; j-- > 0;) + { + unsigned char digit = up[i] >> shift; + + shift += bits; + + if (shift >= GMP_LIMB_BITS && ++i < un) + { + shift -= GMP_LIMB_BITS; + digit |= up[i] << (bits - shift); + } + sp[j] = digit & mask; + } + return sn; +} + +/* We generate digits from the least significant end, and reverse at + the end. */ +static size_t +mpn_limb_get_str (unsigned char *sp, mp_limb_t w, + const struct gmp_div_inverse *binv) +{ + mp_size_t i; + for (i = 0; w > 0; i++) + { + mp_limb_t h, l, r; + + h = w >> (GMP_LIMB_BITS - binv->shift); + l = w << binv->shift; + + gmp_udiv_qrnnd_preinv (w, r, h, l, binv->d1, binv->di); + assert ( (r << (GMP_LIMB_BITS - binv->shift)) == 0); + r >>= binv->shift; + + sp[i] = r; + } + return i; +} + +static size_t +mpn_get_str_other (unsigned char *sp, + int base, const struct mpn_base_info *info, + mp_ptr up, mp_size_t un) +{ + struct gmp_div_inverse binv; + size_t sn; + size_t i; + + mpn_div_qr_1_invert (&binv, base); + + sn = 0; + + if (un > 1) + { + struct gmp_div_inverse bbinv; + mpn_div_qr_1_invert (&bbinv, info->bb); + + do + { + mp_limb_t w; + size_t done; + w = mpn_div_qr_1_preinv (up, up, un, &bbinv); + un -= (up[un-1] == 0); + done = mpn_limb_get_str (sp + sn, w, &binv); + + for (sn += done; done < info->exp; done++) + sp[sn++] = 0; + } + while (un > 1); + } + sn += mpn_limb_get_str (sp + sn, up[0], &binv); + + /* Reverse order */ + for (i = 0; 2*i + 1 < sn; i++) + { + unsigned char t = sp[i]; + sp[i] = sp[sn - i - 1]; + sp[sn - i - 1] = t; + } + + return sn; +} + +size_t +mpn_get_str (unsigned char *sp, int base, mp_ptr up, mp_size_t un) +{ + unsigned bits; + + assert (un > 0); + assert (up[un-1] > 0); + + bits = mpn_base_power_of_two_p (base); + if (bits) + return mpn_get_str_bits (sp, bits, up, un); + else + { + struct mpn_base_info info; + + mpn_get_base_info (&info, base); + return mpn_get_str_other (sp, base, &info, up, un); + } +} + +static mp_size_t +mpn_set_str_bits (mp_ptr rp, const unsigned char *sp, size_t sn, + unsigned bits) +{ + mp_size_t rn; + size_t j; + unsigned shift; + + for (j = sn, rn = 0, shift = 0; j-- > 0; ) + { + if (shift == 0) + { + rp[rn++] = sp[j]; + shift += bits; + } + else + { + rp[rn-1] |= (mp_limb_t) sp[j] << shift; + shift += bits; + if (shift >= GMP_LIMB_BITS) + { + shift -= GMP_LIMB_BITS; + if (shift > 0) + rp[rn++] = (mp_limb_t) sp[j] >> (bits - shift); + } + } + } + rn = mpn_normalized_size (rp, rn); + return rn; +} + +static mp_size_t +mpn_set_str_other (mp_ptr rp, const unsigned char *sp, size_t sn, + mp_limb_t b, const struct mpn_base_info *info) +{ + mp_size_t rn; + mp_limb_t w; + unsigned k; + size_t j; + + k = 1 + (sn - 1) % info->exp; + + j = 0; + w = sp[j++]; + for (; --k > 0; ) + w = w * b + sp[j++]; + + rp[0] = w; + + for (rn = (w > 0); j < sn;) + { + mp_limb_t cy; + + w = sp[j++]; + for (k = 1; k < info->exp; k++) + w = w * b + sp[j++]; + + cy = mpn_mul_1 (rp, rp, rn, info->bb); + cy += mpn_add_1 (rp, rp, rn, w); + if (cy > 0) + rp[rn++] = cy; + } + assert (j == sn); + + return rn; +} + +mp_size_t +mpn_set_str (mp_ptr rp, const unsigned char *sp, size_t sn, int base) +{ + unsigned bits; + + if (sn == 0) + return 0; + + bits = mpn_base_power_of_two_p (base); + if (bits) + return mpn_set_str_bits (rp, sp, sn, bits); + else + { + struct mpn_base_info info; + + mpn_get_base_info (&info, base); + return mpn_set_str_other (rp, sp, sn, base, &info); + } +} + + +/* MPZ interface */ +void +mpz_init (mpz_t r) +{ + r->_mp_alloc = 1; + r->_mp_size = 0; + r->_mp_d = gmp_xalloc_limbs (1); +} + +/* The utility of this function is a bit limited, since many functions + assigns the result variable using mpz_swap. */ +void +mpz_init2 (mpz_t r, mp_bitcnt_t bits) +{ + mp_size_t rn; + + bits -= (bits != 0); /* Round down, except if 0 */ + rn = 1 + bits / GMP_LIMB_BITS; + + r->_mp_alloc = rn; + r->_mp_size = 0; + r->_mp_d = gmp_xalloc_limbs (rn); +} + +void +mpz_clear (mpz_t r) +{ + gmp_free (r->_mp_d); +} + +static void * +mpz_realloc (mpz_t r, mp_size_t size) +{ + size = GMP_MAX (size, 1); + + r->_mp_d = gmp_xrealloc_limbs (r->_mp_d, size); + r->_mp_alloc = size; + + if (GMP_ABS (r->_mp_size) > size) + r->_mp_size = 0; + + return r->_mp_d; +} + +/* Realloc for an mpz_t WHAT if it has less than NEEDED limbs. */ +#define MPZ_REALLOC(z,n) ((n) > (z)->_mp_alloc \ + ? mpz_realloc(z,n) \ + : (z)->_mp_d) + +/* MPZ assignment and basic conversions. */ +void +mpz_set_si (mpz_t r, signed long int x) +{ + if (x >= 0) + mpz_set_ui (r, x); + else /* (x < 0) */ + { + r->_mp_size = -1; + r->_mp_d[0] = GMP_NEG_CAST (unsigned long int, x); + } +} + +void +mpz_set_ui (mpz_t r, unsigned long int x) +{ + if (x > 0) + { + r->_mp_size = 1; + r->_mp_d[0] = x; + } + else + r->_mp_size = 0; +} + +void +mpz_set (mpz_t r, const mpz_t x) +{ + /* Allow the NOP r == x */ + if (r != x) + { + mp_size_t n; + mp_ptr rp; + + n = GMP_ABS (x->_mp_size); + rp = MPZ_REALLOC (r, n); + + mpn_copyi (rp, x->_mp_d, n); + r->_mp_size = x->_mp_size; + } +} + +void +mpz_init_set_si (mpz_t r, signed long int x) +{ + mpz_init (r); + mpz_set_si (r, x); +} + +void +mpz_init_set_ui (mpz_t r, unsigned long int x) +{ + mpz_init (r); + mpz_set_ui (r, x); +} + +void +mpz_init_set (mpz_t r, const mpz_t x) +{ + mpz_init (r); + mpz_set (r, x); +} + +int +mpz_fits_slong_p (const mpz_t u) +{ + mp_size_t us = u->_mp_size; + + if (us == 0) + return 1; + else if (us == 1) + return u->_mp_d[0] < GMP_LIMB_HIGHBIT; + else if (us == -1) + return u->_mp_d[0] <= GMP_LIMB_HIGHBIT; + else + return 0; +} + +int +mpz_fits_ulong_p (const mpz_t u) +{ + mp_size_t us = u->_mp_size; + + return (us == (us > 0)); +} + +long int +mpz_get_si (const mpz_t u) +{ + mp_size_t us = u->_mp_size; + + if (us > 0) + return (long) (u->_mp_d[0] & ~GMP_LIMB_HIGHBIT); + else if (us < 0) + return (long) (- u->_mp_d[0] | GMP_LIMB_HIGHBIT); + else + return 0; +} + +unsigned long int +mpz_get_ui (const mpz_t u) +{ + return u->_mp_size == 0 ? 0 : u->_mp_d[0]; +} + +size_t +mpz_size (const mpz_t u) +{ + return GMP_ABS (u->_mp_size); +} + +mp_limb_t +mpz_getlimbn (const mpz_t u, mp_size_t n) +{ + if (n >= 0 && n < GMP_ABS (u->_mp_size)) + return u->_mp_d[n]; + else + return 0; +} + + +/* Conversions and comparison to double. */ +void +mpz_set_d (mpz_t r, double x) +{ + int sign; + mp_ptr rp; + mp_size_t rn, i; + double B; + double Bi; + mp_limb_t f; + + /* x != x is true when x is a NaN, and x == x * 0.5 is true when x is + zero or infinity. */ + if (x != x || x == x * 0.5) + { + r->_mp_size = 0; + return; + } + + sign = x < 0.0 ; + if (sign) + x = - x; + + if (x < 1.0) + { + r->_mp_size = 0; + return; + } + B = 2.0 * (double) GMP_LIMB_HIGHBIT; + Bi = 1.0 / B; + for (rn = 1; x >= B; rn++) + x *= Bi; + + rp = MPZ_REALLOC (r, rn); + + f = (mp_limb_t) x; + x -= f; + assert (x < 1.0); + i = rn-1; + rp[i] = f; + while (--i >= 0) + { + x = B * x; + f = (mp_limb_t) x; + x -= f; + assert (x < 1.0); + rp[i] = f; + } + + r->_mp_size = sign ? - rn : rn; +} + +void +mpz_init_set_d (mpz_t r, double x) +{ + mpz_init (r); + mpz_set_d (r, x); +} + +double +mpz_get_d (const mpz_t u) +{ + mp_size_t un; + double x; + double B = 2.0 * (double) GMP_LIMB_HIGHBIT; + + un = GMP_ABS (u->_mp_size); + + if (un == 0) + return 0.0; + + x = u->_mp_d[--un]; + while (un > 0) + x = B*x + u->_mp_d[--un]; + + if (u->_mp_size < 0) + x = -x; + + return x; +} + +int +mpz_cmpabs_d (const mpz_t x, double d) +{ + mp_size_t xn; + double B, Bi; + mp_size_t i; + + xn = x->_mp_size; + d = GMP_ABS (d); + + if (xn != 0) + { + xn = GMP_ABS (xn); + + B = 2.0 * (double) GMP_LIMB_HIGHBIT; + Bi = 1.0 / B; + + /* Scale d so it can be compared with the top limb. */ + for (i = 1; i < xn; i++) + d *= Bi; + + if (d >= B) + return -1; + + /* Compare floor(d) to top limb, subtract and cancel when equal. */ + for (i = xn; i-- > 0;) + { + mp_limb_t f, xl; + + f = (mp_limb_t) d; + xl = x->_mp_d[i]; + if (xl > f) + return 1; + else if (xl < f) + return -1; + d = B * (d - f); + } + } + return - (d > 0.0); +} + +int +mpz_cmp_d (const mpz_t x, double d) +{ + if (x->_mp_size < 0) + { + if (d >= 0.0) + return -1; + else + return -mpz_cmpabs_d (x, d); + } + else + { + if (d < 0.0) + return 1; + else + return mpz_cmpabs_d (x, d); + } +} + + +/* MPZ comparisons and the like. */ +int +mpz_sgn (const mpz_t u) +{ + mp_size_t usize = u->_mp_size; + + return (usize > 0) - (usize < 0); +} + +int +mpz_cmp_si (const mpz_t u, long v) +{ + mp_size_t usize = u->_mp_size; + + if (usize < -1) + return -1; + else if (v >= 0) + return mpz_cmp_ui (u, v); + else if (usize >= 0) + return 1; + else /* usize == -1 */ + { + mp_limb_t ul = u->_mp_d[0]; + if ((mp_limb_t)GMP_NEG_CAST (unsigned long int, v) < ul) + return -1; + else + return (mp_limb_t)GMP_NEG_CAST (unsigned long int, v) > ul; + } +} + +int +mpz_cmp_ui (const mpz_t u, unsigned long v) +{ + mp_size_t usize = u->_mp_size; + + if (usize > 1) + return 1; + else if (usize < 0) + return -1; + else + { + mp_limb_t ul = (usize > 0) ? u->_mp_d[0] : 0; + return (ul > v) - (ul < v); + } +} + +int +mpz_cmp (const mpz_t a, const mpz_t b) +{ + mp_size_t asize = a->_mp_size; + mp_size_t bsize = b->_mp_size; + + if (asize != bsize) + return (asize < bsize) ? -1 : 1; + else if (asize >= 0) + return mpn_cmp (a->_mp_d, b->_mp_d, asize); + else + return mpn_cmp (b->_mp_d, a->_mp_d, -asize); +} + +int +mpz_cmpabs_ui (const mpz_t u, unsigned long v) +{ + mp_size_t un = GMP_ABS (u->_mp_size); + mp_limb_t ul; + + if (un > 1) + return 1; + + ul = (un == 1) ? u->_mp_d[0] : 0; + + return (ul > v) - (ul < v); +} + +int +mpz_cmpabs (const mpz_t u, const mpz_t v) +{ + return mpn_cmp4 (u->_mp_d, GMP_ABS (u->_mp_size), + v->_mp_d, GMP_ABS (v->_mp_size)); +} + +void +mpz_abs (mpz_t r, const mpz_t u) +{ + if (r != u) + mpz_set (r, u); + + r->_mp_size = GMP_ABS (r->_mp_size); +} + +void +mpz_neg (mpz_t r, const mpz_t u) +{ + if (r != u) + mpz_set (r, u); + + r->_mp_size = -r->_mp_size; +} + +void +mpz_swap (mpz_t u, mpz_t v) +{ + MP_SIZE_T_SWAP (u->_mp_size, v->_mp_size); + MP_SIZE_T_SWAP (u->_mp_alloc, v->_mp_alloc); + MP_PTR_SWAP (u->_mp_d, v->_mp_d); +} + + +/* MPZ addition and subtraction */ + +/* Adds to the absolute value. Returns new size, but doesn't store it. */ +static mp_size_t +mpz_abs_add_ui (mpz_t r, const mpz_t a, unsigned long b) +{ + mp_size_t an; + mp_ptr rp; + mp_limb_t cy; + + an = GMP_ABS (a->_mp_size); + if (an == 0) + { + r->_mp_d[0] = b; + return b > 0; + } + + rp = MPZ_REALLOC (r, an + 1); + + cy = mpn_add_1 (rp, a->_mp_d, an, b); + rp[an] = cy; + an += cy; + + return an; +} + +/* Subtract from the absolute value. Returns new size, (or -1 on underflow), + but doesn't store it. */ +static mp_size_t +mpz_abs_sub_ui (mpz_t r, const mpz_t a, unsigned long b) +{ + mp_size_t an = GMP_ABS (a->_mp_size); + mp_ptr rp = MPZ_REALLOC (r, an); + + if (an == 0) + { + rp[0] = b; + return -(b > 0); + } + else if (an == 1 && a->_mp_d[0] < b) + { + rp[0] = b - a->_mp_d[0]; + return -1; + } + else + { + gmp_assert_nocarry (mpn_sub_1 (rp, a->_mp_d, an, b)); + return mpn_normalized_size (rp, an); + } +} + +void +mpz_add_ui (mpz_t r, const mpz_t a, unsigned long b) +{ + if (a->_mp_size >= 0) + r->_mp_size = mpz_abs_add_ui (r, a, b); + else + r->_mp_size = -mpz_abs_sub_ui (r, a, b); +} + +void +mpz_sub_ui (mpz_t r, const mpz_t a, unsigned long b) +{ + if (a->_mp_size < 0) + r->_mp_size = -mpz_abs_add_ui (r, a, b); + else + r->_mp_size = mpz_abs_sub_ui (r, a, b); +} + +void +mpz_ui_sub (mpz_t r, unsigned long a, const mpz_t b) +{ + if (b->_mp_size < 0) + r->_mp_size = mpz_abs_add_ui (r, b, a); + else + r->_mp_size = -mpz_abs_sub_ui (r, b, a); +} + +static mp_size_t +mpz_abs_add (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t an = GMP_ABS (a->_mp_size); + mp_size_t bn = GMP_ABS (b->_mp_size); + mp_ptr rp; + mp_limb_t cy; + + if (an < bn) + { + MPZ_SRCPTR_SWAP (a, b); + MP_SIZE_T_SWAP (an, bn); + } + + rp = MPZ_REALLOC (r, an + 1); + cy = mpn_add (rp, a->_mp_d, an, b->_mp_d, bn); + + rp[an] = cy; + + return an + cy; +} + +static mp_size_t +mpz_abs_sub (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t an = GMP_ABS (a->_mp_size); + mp_size_t bn = GMP_ABS (b->_mp_size); + int cmp; + mp_ptr rp; + + cmp = mpn_cmp4 (a->_mp_d, an, b->_mp_d, bn); + if (cmp > 0) + { + rp = MPZ_REALLOC (r, an); + gmp_assert_nocarry (mpn_sub (rp, a->_mp_d, an, b->_mp_d, bn)); + return mpn_normalized_size (rp, an); + } + else if (cmp < 0) + { + rp = MPZ_REALLOC (r, bn); + gmp_assert_nocarry (mpn_sub (rp, b->_mp_d, bn, a->_mp_d, an)); + return -mpn_normalized_size (rp, bn); + } + else + return 0; +} + +void +mpz_add (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t rn; + + if ( (a->_mp_size ^ b->_mp_size) >= 0) + rn = mpz_abs_add (r, a, b); + else + rn = mpz_abs_sub (r, a, b); + + r->_mp_size = a->_mp_size >= 0 ? rn : - rn; +} + +void +mpz_sub (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t rn; + + if ( (a->_mp_size ^ b->_mp_size) >= 0) + rn = mpz_abs_sub (r, a, b); + else + rn = mpz_abs_add (r, a, b); + + r->_mp_size = a->_mp_size >= 0 ? rn : - rn; +} + + +/* MPZ multiplication */ +void +mpz_mul_si (mpz_t r, const mpz_t u, long int v) +{ + if (v < 0) + { + mpz_mul_ui (r, u, GMP_NEG_CAST (unsigned long int, v)); + mpz_neg (r, r); + } + else + mpz_mul_ui (r, u, (unsigned long int) v); +} + +void +mpz_mul_ui (mpz_t r, const mpz_t u, unsigned long int v) +{ + mp_size_t un, us; + mp_ptr tp; + mp_limb_t cy; + + us = u->_mp_size; + + if (us == 0 || v == 0) + { + r->_mp_size = 0; + return; + } + + un = GMP_ABS (us); + + tp = MPZ_REALLOC (r, un + 1); + cy = mpn_mul_1 (tp, u->_mp_d, un, v); + tp[un] = cy; + + un += (cy > 0); + r->_mp_size = (us < 0) ? - un : un; +} + +void +mpz_mul (mpz_t r, const mpz_t u, const mpz_t v) +{ + int sign; + mp_size_t un, vn, rn; + mpz_t t; + mp_ptr tp; + + un = u->_mp_size; + vn = v->_mp_size; + + if (un == 0 || vn == 0) + { + r->_mp_size = 0; + return; + } + + sign = (un ^ vn) < 0; + + un = GMP_ABS (un); + vn = GMP_ABS (vn); + + mpz_init2 (t, (un + vn) * GMP_LIMB_BITS); + + tp = t->_mp_d; + if (un >= vn) + mpn_mul (tp, u->_mp_d, un, v->_mp_d, vn); + else + mpn_mul (tp, v->_mp_d, vn, u->_mp_d, un); + + rn = un + vn; + rn -= tp[rn-1] == 0; + + t->_mp_size = sign ? - rn : rn; + mpz_swap (r, t); + mpz_clear (t); +} + +void +mpz_mul_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t bits) +{ + mp_size_t un, rn; + mp_size_t limbs; + unsigned shift; + mp_ptr rp; + + un = GMP_ABS (u->_mp_size); + if (un == 0) + { + r->_mp_size = 0; + return; + } + + limbs = bits / GMP_LIMB_BITS; + shift = bits % GMP_LIMB_BITS; + + rn = un + limbs + (shift > 0); + rp = MPZ_REALLOC (r, rn); + if (shift > 0) + { + mp_limb_t cy = mpn_lshift (rp + limbs, u->_mp_d, un, shift); + rp[rn-1] = cy; + rn -= (cy == 0); + } + else + mpn_copyd (rp + limbs, u->_mp_d, un); + + while (limbs > 0) + rp[--limbs] = 0; + + r->_mp_size = (u->_mp_size < 0) ? - rn : rn; +} + + +/* MPZ division */ +enum mpz_div_round_mode { GMP_DIV_FLOOR, GMP_DIV_CEIL, GMP_DIV_TRUNC }; + +/* Allows q or r to be zero. Returns 1 iff remainder is non-zero. */ +static int +mpz_div_qr (mpz_t q, mpz_t r, + const mpz_t n, const mpz_t d, enum mpz_div_round_mode mode) +{ + mp_size_t ns, ds, nn, dn, qs; + ns = n->_mp_size; + ds = d->_mp_size; + + if (ds == 0) + gmp_die("mpz_div_qr: Divide by zero."); + + if (ns == 0) + { + if (q) + q->_mp_size = 0; + if (r) + r->_mp_size = 0; + return 0; + } + + nn = GMP_ABS (ns); + dn = GMP_ABS (ds); + + qs = ds ^ ns; + + if (nn < dn) + { + if (mode == GMP_DIV_CEIL && qs >= 0) + { + /* q = 1, r = n - d */ + if (r) + mpz_sub (r, n, d); + if (q) + mpz_set_ui (q, 1); + } + else if (mode == GMP_DIV_FLOOR && qs < 0) + { + /* q = -1, r = n + d */ + if (r) + mpz_add (r, n, d); + if (q) + mpz_set_si (q, -1); + } + else + { + /* q = 0, r = d */ + if (r) + mpz_set (r, n); + if (q) + q->_mp_size = 0; + } + return 1; + } + else + { + mp_ptr np, qp; + mp_size_t qn, rn; + mpz_t tq, tr; + + mpz_init (tr); + mpz_set (tr, n); + np = tr->_mp_d; + + qn = nn - dn + 1; + + if (q) + { + mpz_init2 (tq, qn * GMP_LIMB_BITS); + qp = tq->_mp_d; + } + else + qp = NULL; + + mpn_div_qr (qp, np, nn, d->_mp_d, dn); + + if (qp) + { + qn -= (qp[qn-1] == 0); + + tq->_mp_size = qs < 0 ? -qn : qn; + } + rn = mpn_normalized_size (np, dn); + tr->_mp_size = ns < 0 ? - rn : rn; + + if (mode == GMP_DIV_FLOOR && qs < 0 && rn != 0) + { + if (q) + mpz_sub_ui (tq, tq, 1); + if (r) + mpz_add (tr, tr, d); + } + else if (mode == GMP_DIV_CEIL && qs >= 0 && rn != 0) + { + if (q) + mpz_add_ui (tq, tq, 1); + if (r) + mpz_sub (tr, tr, d); + } + + if (q) + { + mpz_swap (tq, q); + mpz_clear (tq); + } + if (r) + mpz_swap (tr, r); + + mpz_clear (tr); + + return rn != 0; + } +} + +void +mpz_cdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, r, n, d, GMP_DIV_CEIL); +} + +void +mpz_fdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, r, n, d, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, r, n, d, GMP_DIV_TRUNC); +} + +void +mpz_cdiv_q (mpz_t q, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, NULL, n, d, GMP_DIV_CEIL); +} + +void +mpz_fdiv_q (mpz_t q, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, NULL, n, d, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_q (mpz_t q, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, NULL, n, d, GMP_DIV_TRUNC); +} + +void +mpz_cdiv_r (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, GMP_DIV_CEIL); +} + +void +mpz_fdiv_r (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_r (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, GMP_DIV_TRUNC); +} + +void +mpz_mod (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, d->_mp_size >= 0 ? GMP_DIV_FLOOR : GMP_DIV_CEIL); +} + +static void +mpz_div_q_2exp (mpz_t q, const mpz_t u, mp_bitcnt_t bit_index, + enum mpz_div_round_mode mode) +{ + mp_size_t un, qn; + mp_size_t limb_cnt; + mp_ptr qp; + int adjust; + + un = u->_mp_size; + if (un == 0) + { + q->_mp_size = 0; + return; + } + limb_cnt = bit_index / GMP_LIMB_BITS; + qn = GMP_ABS (un) - limb_cnt; + bit_index %= GMP_LIMB_BITS; + + if (mode == ((un > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* un != 0 here. */ + /* Note: Below, the final indexing at limb_cnt is valid because at + that point we have qn > 0. */ + adjust = (qn <= 0 + || !mpn_zero_p (u->_mp_d, limb_cnt) + || (u->_mp_d[limb_cnt] + & (((mp_limb_t) 1 << bit_index) - 1))); + else + adjust = 0; + + if (qn <= 0) + qn = 0; + + else + { + qp = MPZ_REALLOC (q, qn); + + if (bit_index != 0) + { + mpn_rshift (qp, u->_mp_d + limb_cnt, qn, bit_index); + qn -= qp[qn - 1] == 0; + } + else + { + mpn_copyi (qp, u->_mp_d + limb_cnt, qn); + } + } + + q->_mp_size = qn; + + if (adjust) + mpz_add_ui (q, q, 1); + if (un < 0) + mpz_neg (q, q); +} + +static void +mpz_div_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t bit_index, + enum mpz_div_round_mode mode) +{ + mp_size_t us, un, rn; + mp_ptr rp; + mp_limb_t mask; + + us = u->_mp_size; + if (us == 0 || bit_index == 0) + { + r->_mp_size = 0; + return; + } + rn = (bit_index + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS; + assert (rn > 0); + + rp = MPZ_REALLOC (r, rn); + un = GMP_ABS (us); + + mask = GMP_LIMB_MAX >> (rn * GMP_LIMB_BITS - bit_index); + + if (rn > un) + { + /* Quotient (with truncation) is zero, and remainder is + non-zero */ + if (mode == ((us > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* us != 0 here. */ + { + /* Have to negate and sign extend. */ + mp_size_t i; + mp_limb_t cy; + + for (cy = 1, i = 0; i < un; i++) + { + mp_limb_t s = ~u->_mp_d[i] + cy; + cy = s < cy; + rp[i] = s; + } + assert (cy == 0); + for (; i < rn - 1; i++) + rp[i] = GMP_LIMB_MAX; + + rp[rn-1] = mask; + us = -us; + } + else + { + /* Just copy */ + if (r != u) + mpn_copyi (rp, u->_mp_d, un); + + rn = un; + } + } + else + { + if (r != u) + mpn_copyi (rp, u->_mp_d, rn - 1); + + rp[rn-1] = u->_mp_d[rn-1] & mask; + + if (mode == ((us > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* us != 0 here. */ + { + /* If r != 0, compute 2^{bit_count} - r. */ + mp_size_t i; + + for (i = 0; i < rn && rp[i] == 0; i++) + ; + if (i < rn) + { + /* r > 0, need to flip sign. */ + rp[i] = ~rp[i] + 1; + while (++i < rn) + rp[i] = ~rp[i]; + + rp[rn-1] &= mask; + + /* us is not used for anything else, so we can modify it + here to indicate flipped sign. */ + us = -us; + } + } + } + rn = mpn_normalized_size (rp, rn); + r->_mp_size = us < 0 ? -rn : rn; +} + +void +mpz_cdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_q_2exp (r, u, cnt, GMP_DIV_CEIL); +} + +void +mpz_fdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_q_2exp (r, u, cnt, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_q_2exp (r, u, cnt, GMP_DIV_TRUNC); +} + +void +mpz_cdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_r_2exp (r, u, cnt, GMP_DIV_CEIL); +} + +void +mpz_fdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_r_2exp (r, u, cnt, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_r_2exp (r, u, cnt, GMP_DIV_TRUNC); +} + +void +mpz_divexact (mpz_t q, const mpz_t n, const mpz_t d) +{ + gmp_assert_nocarry (mpz_div_qr (q, NULL, n, d, GMP_DIV_TRUNC)); +} + +int +mpz_divisible_p (const mpz_t n, const mpz_t d) +{ + return mpz_div_qr (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0; +} + +static unsigned long +mpz_div_qr_ui (mpz_t q, mpz_t r, + const mpz_t n, unsigned long d, enum mpz_div_round_mode mode) +{ + mp_size_t ns, qn; + mp_ptr qp; + mp_limb_t rl; + mp_size_t rs; + + ns = n->_mp_size; + if (ns == 0) + { + if (q) + q->_mp_size = 0; + if (r) + r->_mp_size = 0; + return 0; + } + + qn = GMP_ABS (ns); + if (q) + qp = MPZ_REALLOC (q, qn); + else + qp = NULL; + + rl = mpn_div_qr_1 (qp, n->_mp_d, qn, d); + assert (rl < d); + + rs = rl > 0; + rs = (ns < 0) ? -rs : rs; + + if (rl > 0 && ( (mode == GMP_DIV_FLOOR && ns < 0) + || (mode == GMP_DIV_CEIL && ns >= 0))) + { + if (q) + gmp_assert_nocarry (mpn_add_1 (qp, qp, qn, 1)); + rl = d - rl; + rs = -rs; + } + + if (r) + { + r->_mp_d[0] = rl; + r->_mp_size = rs; + } + if (q) + { + qn -= (qp[qn-1] == 0); + assert (qn == 0 || qp[qn-1] > 0); + + q->_mp_size = (ns < 0) ? - qn : qn; + } + + return rl; +} + +unsigned long +mpz_cdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, r, n, d, GMP_DIV_CEIL); +} + +unsigned long +mpz_fdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, r, n, d, GMP_DIV_FLOOR); +} + +unsigned long +mpz_tdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, r, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_cdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_CEIL); +} + +unsigned long +mpz_fdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_FLOOR); +} + +unsigned long +mpz_tdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_cdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_CEIL); +} +unsigned long +mpz_fdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR); +} +unsigned long +mpz_tdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_cdiv_ui (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_CEIL); +} + +unsigned long +mpz_fdiv_ui (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_FLOOR); +} + +unsigned long +mpz_tdiv_ui (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_mod_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR); +} + +void +mpz_divexact_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + gmp_assert_nocarry (mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC)); +} + +int +mpz_divisible_ui_p (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0; +} + + +/* GCD */ +static mp_limb_t +mpn_gcd_11 (mp_limb_t u, mp_limb_t v) +{ + unsigned shift; + + assert ( (u | v) > 0); + + if (u == 0) + return v; + else if (v == 0) + return u; + + gmp_ctz (shift, u | v); + + u >>= shift; + v >>= shift; + + if ( (u & 1) == 0) + MP_LIMB_T_SWAP (u, v); + + while ( (v & 1) == 0) + v >>= 1; + + while (u != v) + { + if (u > v) + { + u -= v; + do + u >>= 1; + while ( (u & 1) == 0); + } + else + { + v -= u; + do + v >>= 1; + while ( (v & 1) == 0); + } + } + return u << shift; +} + +unsigned long +mpz_gcd_ui (mpz_t g, const mpz_t u, unsigned long v) +{ + mp_size_t un; + + if (v == 0) + { + if (g) + mpz_abs (g, u); + } + else + { + un = GMP_ABS (u->_mp_size); + if (un != 0) + v = mpn_gcd_11 (mpn_div_qr_1 (NULL, u->_mp_d, un, v), v); + + if (g) + mpz_set_ui (g, v); + } + + return v; +} + +static mp_bitcnt_t +mpz_make_odd (mpz_t r) +{ + mp_bitcnt_t shift; + + assert (r->_mp_size > 0); + /* Count trailing zeros, equivalent to mpn_scan1, because we know that there is a 1 */ + shift = mpn_common_scan (r->_mp_d[0], 0, r->_mp_d, 0, 0); + mpz_tdiv_q_2exp (r, r, shift); + + return shift; +} + +void +mpz_gcd (mpz_t g, const mpz_t u, const mpz_t v) +{ + mpz_t tu, tv; + mp_bitcnt_t uz, vz, gz; + + if (u->_mp_size == 0) + { + mpz_abs (g, v); + return; + } + if (v->_mp_size == 0) + { + mpz_abs (g, u); + return; + } + + mpz_init (tu); + mpz_init (tv); + + mpz_abs (tu, u); + uz = mpz_make_odd (tu); + mpz_abs (tv, v); + vz = mpz_make_odd (tv); + gz = GMP_MIN (uz, vz); + + if (tu->_mp_size < tv->_mp_size) + mpz_swap (tu, tv); + + mpz_tdiv_r (tu, tu, tv); + if (tu->_mp_size == 0) + { + mpz_swap (g, tv); + } + else + for (;;) + { + int c; + + mpz_make_odd (tu); + c = mpz_cmp (tu, tv); + if (c == 0) + { + mpz_swap (g, tu); + break; + } + if (c < 0) + mpz_swap (tu, tv); + + if (tv->_mp_size == 1) + { + mp_limb_t vl = tv->_mp_d[0]; + mp_limb_t ul = mpz_tdiv_ui (tu, vl); + mpz_set_ui (g, mpn_gcd_11 (ul, vl)); + break; + } + mpz_sub (tu, tu, tv); + } + mpz_clear (tu); + mpz_clear (tv); + mpz_mul_2exp (g, g, gz); +} + +void +mpz_gcdext (mpz_t g, mpz_t s, mpz_t t, const mpz_t u, const mpz_t v) +{ + mpz_t tu, tv, s0, s1, t0, t1; + mp_bitcnt_t uz, vz, gz; + mp_bitcnt_t power; + + if (u->_mp_size == 0) + { + /* g = 0 u + sgn(v) v */ + signed long sign = mpz_sgn (v); + mpz_abs (g, v); + if (s) + mpz_set_ui (s, 0); + if (t) + mpz_set_si (t, sign); + return; + } + + if (v->_mp_size == 0) + { + /* g = sgn(u) u + 0 v */ + signed long sign = mpz_sgn (u); + mpz_abs (g, u); + if (s) + mpz_set_si (s, sign); + if (t) + mpz_set_ui (t, 0); + return; + } + + mpz_init (tu); + mpz_init (tv); + mpz_init (s0); + mpz_init (s1); + mpz_init (t0); + mpz_init (t1); + + mpz_abs (tu, u); + uz = mpz_make_odd (tu); + mpz_abs (tv, v); + vz = mpz_make_odd (tv); + gz = GMP_MIN (uz, vz); + + uz -= gz; + vz -= gz; + + /* Cofactors corresponding to odd gcd. gz handled later. */ + if (tu->_mp_size < tv->_mp_size) + { + mpz_swap (tu, tv); + MPZ_SRCPTR_SWAP (u, v); + MPZ_PTR_SWAP (s, t); + MP_BITCNT_T_SWAP (uz, vz); + } + + /* Maintain + * + * u = t0 tu + t1 tv + * v = s0 tu + s1 tv + * + * where u and v denote the inputs with common factors of two + * eliminated, and det (s0, t0; s1, t1) = 2^p. Then + * + * 2^p tu = s1 u - t1 v + * 2^p tv = -s0 u + t0 v + */ + + /* After initial division, tu = q tv + tu', we have + * + * u = 2^uz (tu' + q tv) + * v = 2^vz tv + * + * or + * + * t0 = 2^uz, t1 = 2^uz q + * s0 = 0, s1 = 2^vz + */ + + mpz_setbit (t0, uz); + mpz_tdiv_qr (t1, tu, tu, tv); + mpz_mul_2exp (t1, t1, uz); + + mpz_setbit (s1, vz); + power = uz + vz; + + if (tu->_mp_size > 0) + { + mp_bitcnt_t shift; + shift = mpz_make_odd (tu); + mpz_mul_2exp (t0, t0, shift); + mpz_mul_2exp (s0, s0, shift); + power += shift; + + for (;;) + { + int c; + c = mpz_cmp (tu, tv); + if (c == 0) + break; + + if (c < 0) + { + /* tv = tv' + tu + * + * u = t0 tu + t1 (tv' + tu) = (t0 + t1) tu + t1 tv' + * v = s0 tu + s1 (tv' + tu) = (s0 + s1) tu + s1 tv' */ + + mpz_sub (tv, tv, tu); + mpz_add (t0, t0, t1); + mpz_add (s0, s0, s1); + + shift = mpz_make_odd (tv); + mpz_mul_2exp (t1, t1, shift); + mpz_mul_2exp (s1, s1, shift); + } + else + { + mpz_sub (tu, tu, tv); + mpz_add (t1, t0, t1); + mpz_add (s1, s0, s1); + + shift = mpz_make_odd (tu); + mpz_mul_2exp (t0, t0, shift); + mpz_mul_2exp (s0, s0, shift); + } + power += shift; + } + } + + /* Now tv = odd part of gcd, and -s0 and t0 are corresponding + cofactors. */ + + mpz_mul_2exp (tv, tv, gz); + mpz_neg (s0, s0); + + /* 2^p g = s0 u + t0 v. Eliminate one factor of two at a time. To + adjust cofactors, we need u / g and v / g */ + + mpz_divexact (s1, v, tv); + mpz_abs (s1, s1); + mpz_divexact (t1, u, tv); + mpz_abs (t1, t1); + + while (power-- > 0) + { + /* s0 u + t0 v = (s0 - v/g) u - (t0 + u/g) v */ + if (mpz_odd_p (s0) || mpz_odd_p (t0)) + { + mpz_sub (s0, s0, s1); + mpz_add (t0, t0, t1); + } + mpz_divexact_ui (s0, s0, 2); + mpz_divexact_ui (t0, t0, 2); + } + + /* Arrange so that |s| < |u| / 2g */ + mpz_add (s1, s0, s1); + if (mpz_cmpabs (s0, s1) > 0) + { + mpz_swap (s0, s1); + mpz_sub (t0, t0, t1); + } + if (u->_mp_size < 0) + mpz_neg (s0, s0); + if (v->_mp_size < 0) + mpz_neg (t0, t0); + + mpz_swap (g, tv); + if (s) + mpz_swap (s, s0); + if (t) + mpz_swap (t, t0); + + mpz_clear (tu); + mpz_clear (tv); + mpz_clear (s0); + mpz_clear (s1); + mpz_clear (t0); + mpz_clear (t1); +} + +void +mpz_lcm (mpz_t r, const mpz_t u, const mpz_t v) +{ + mpz_t g; + + if (u->_mp_size == 0 || v->_mp_size == 0) + { + r->_mp_size = 0; + return; + } + + mpz_init (g); + + mpz_gcd (g, u, v); + mpz_divexact (g, u, g); + mpz_mul (r, g, v); + + mpz_clear (g); + mpz_abs (r, r); +} + +void +mpz_lcm_ui (mpz_t r, const mpz_t u, unsigned long v) +{ + if (v == 0 || u->_mp_size == 0) + { + r->_mp_size = 0; + return; + } + + v /= mpz_gcd_ui (NULL, u, v); + mpz_mul_ui (r, u, v); + + mpz_abs (r, r); +} + +int +mpz_invert (mpz_t r, const mpz_t u, const mpz_t m) +{ + mpz_t g, tr; + int invertible; + + if (u->_mp_size == 0 || mpz_cmpabs_ui (m, 1) <= 0) + return 0; + + mpz_init (g); + mpz_init (tr); + + mpz_gcdext (g, tr, NULL, u, m); + invertible = (mpz_cmp_ui (g, 1) == 0); + + if (invertible) + { + if (tr->_mp_size < 0) + { + if (m->_mp_size >= 0) + mpz_add (tr, tr, m); + else + mpz_sub (tr, tr, m); + } + mpz_swap (r, tr); + } + + mpz_clear (g); + mpz_clear (tr); + return invertible; +} + + +/* Higher level operations (sqrt, pow and root) */ + +void +mpz_pow_ui (mpz_t r, const mpz_t b, unsigned long e) +{ + unsigned long bit; + mpz_t tr; + mpz_init_set_ui (tr, 1); + + bit = GMP_ULONG_HIGHBIT; + do + { + mpz_mul (tr, tr, tr); + if (e & bit) + mpz_mul (tr, tr, b); + bit >>= 1; + } + while (bit > 0); + + mpz_swap (r, tr); + mpz_clear (tr); +} + +void +mpz_ui_pow_ui (mpz_t r, unsigned long blimb, unsigned long e) +{ + mpz_t b; + mpz_init_set_ui (b, blimb); + mpz_pow_ui (r, b, e); + mpz_clear (b); +} + +void +mpz_powm (mpz_t r, const mpz_t b, const mpz_t e, const mpz_t m) +{ + mpz_t tr; + mpz_t base; + mp_size_t en, mn; + mp_srcptr mp; + struct gmp_div_inverse minv; + unsigned shift; + mp_ptr tp = NULL; + + en = GMP_ABS (e->_mp_size); + mn = GMP_ABS (m->_mp_size); + if (mn == 0) + gmp_die ("mpz_powm: Zero modulo."); + + if (en == 0) + { + mpz_set_ui (r, 1); + return; + } + + mp = m->_mp_d; + mpn_div_qr_invert (&minv, mp, mn); + shift = minv.shift; + + if (shift > 0) + { + /* To avoid shifts, we do all our reductions, except the final + one, using a *normalized* m. */ + minv.shift = 0; + + tp = gmp_xalloc_limbs (mn); + gmp_assert_nocarry (mpn_lshift (tp, mp, mn, shift)); + mp = tp; + } + + mpz_init (base); + + if (e->_mp_size < 0) + { + if (!mpz_invert (base, b, m)) + gmp_die ("mpz_powm: Negative exponent and non-invertible base."); + } + else + { + mp_size_t bn; + mpz_abs (base, b); + + bn = base->_mp_size; + if (bn >= mn) + { + mpn_div_qr_preinv (NULL, base->_mp_d, base->_mp_size, mp, mn, &minv); + bn = mn; + } + + /* We have reduced the absolute value. Now take care of the + sign. Note that we get zero represented non-canonically as + m. */ + if (b->_mp_size < 0) + { + mp_ptr bp = MPZ_REALLOC (base, mn); + gmp_assert_nocarry (mpn_sub (bp, mp, mn, bp, bn)); + bn = mn; + } + base->_mp_size = mpn_normalized_size (base->_mp_d, bn); + } + mpz_init_set_ui (tr, 1); + + while (en-- > 0) + { + mp_limb_t w = e->_mp_d[en]; + mp_limb_t bit; + + bit = GMP_LIMB_HIGHBIT; + do + { + mpz_mul (tr, tr, tr); + if (w & bit) + mpz_mul (tr, tr, base); + if (tr->_mp_size > mn) + { + mpn_div_qr_preinv (NULL, tr->_mp_d, tr->_mp_size, mp, mn, &minv); + tr->_mp_size = mpn_normalized_size (tr->_mp_d, mn); + } + bit >>= 1; + } + while (bit > 0); + } + + /* Final reduction */ + if (tr->_mp_size >= mn) + { + minv.shift = shift; + mpn_div_qr_preinv (NULL, tr->_mp_d, tr->_mp_size, mp, mn, &minv); + tr->_mp_size = mpn_normalized_size (tr->_mp_d, mn); + } + if (tp) + gmp_free (tp); + + mpz_swap (r, tr); + mpz_clear (tr); + mpz_clear (base); +} + +void +mpz_powm_ui (mpz_t r, const mpz_t b, unsigned long elimb, const mpz_t m) +{ + mpz_t e; + mpz_init_set_ui (e, elimb); + mpz_powm (r, b, e, m); + mpz_clear (e); +} + +/* x=trunc(y^(1/z)), r=y-x^z */ +void +mpz_rootrem (mpz_t x, mpz_t r, const mpz_t y, unsigned long z) +{ + int sgn; + mpz_t t, u; + + sgn = y->_mp_size < 0; + if ((~z & sgn) != 0) + gmp_die ("mpz_rootrem: Negative argument, with even root."); + if (z == 0) + gmp_die ("mpz_rootrem: Zeroth root."); + + if (mpz_cmpabs_ui (y, 1) <= 0) { + mpz_set (x, y); + if (r) + r->_mp_size = 0; + return; + } + + mpz_init (u); + { + mp_bitcnt_t tb; + tb = mpz_sizeinbase (y, 2) / z + 1; + mpz_init2 (t, tb); + mpz_setbit (t, tb); + } + + if (z == 2) /* simplify sqrt loop: z-1 == 1 */ + do { + mpz_swap (u, t); /* u = x */ + mpz_tdiv_q (t, y, u); /* t = y/x */ + mpz_add (t, t, u); /* t = y/x + x */ + mpz_tdiv_q_2exp (t, t, 1); /* x'= (y/x + x)/2 */ + } while (mpz_cmpabs (t, u) < 0); /* |x'| < |x| */ + else /* z != 2 */ { + mpz_t v; + + mpz_init (v); + if (sgn) + mpz_neg (t, t); + + do { + mpz_swap (u, t); /* u = x */ + mpz_pow_ui (t, u, z - 1); /* t = x^(z-1) */ + mpz_tdiv_q (t, y, t); /* t = y/x^(z-1) */ + mpz_mul_ui (v, u, z - 1); /* v = x*(z-1) */ + mpz_add (t, t, v); /* t = y/x^(z-1) + x*(z-1) */ + mpz_tdiv_q_ui (t, t, z); /* x'=(y/x^(z-1) + x*(z-1))/z */ + } while (mpz_cmpabs (t, u) < 0); /* |x'| < |x| */ + + mpz_clear (v); + } + + if (r) { + mpz_pow_ui (t, u, z); + mpz_sub (r, y, t); + } + mpz_swap (x, u); + mpz_clear (u); + mpz_clear (t); +} + +int +mpz_root (mpz_t x, const mpz_t y, unsigned long z) +{ + int res; + mpz_t r; + + mpz_init (r); + mpz_rootrem (x, r, y, z); + res = r->_mp_size == 0; + mpz_clear (r); + + return res; +} + +/* Compute s = floor(sqrt(u)) and r = u - s^2. Allows r == NULL */ +void +mpz_sqrtrem (mpz_t s, mpz_t r, const mpz_t u) +{ + mpz_rootrem (s, r, u, 2); +} + +void +mpz_sqrt (mpz_t s, const mpz_t u) +{ + mpz_rootrem (s, NULL, u, 2); +} + + +/* Combinatorics */ + +void +mpz_fac_ui (mpz_t x, unsigned long n) +{ + mpz_set_ui (x, n + (n == 0)); + for (;n > 2;) + mpz_mul_ui (x, x, --n); +} + +void +mpz_bin_uiui (mpz_t r, unsigned long n, unsigned long k) +{ + mpz_t t; + + mpz_set_ui (r, k <= n); + + if (k > (n >> 1)) + k = (k <= n) ? n - k : 0; + + mpz_init (t); + mpz_fac_ui (t, k); + + for (; k > 0; k--) + mpz_mul_ui (r, r, n--); + + mpz_divexact (r, r, t); + mpz_clear (t); +} + + +/* Logical operations and bit manipulation. */ + +/* Numbers are treated as if represented in two's complement (and + infinitely sign extended). For a negative values we get the two's + complement from -x = ~x + 1, where ~ is bitwise complement. + Negation transforms + + xxxx10...0 + + into + + yyyy10...0 + + where yyyy is the bitwise complement of xxxx. So least significant + bits, up to and including the first one bit, are unchanged, and + the more significant bits are all complemented. + + To change a bit from zero to one in a negative number, subtract the + corresponding power of two from the absolute value. This can never + underflow. To change a bit from one to zero, add the corresponding + power of two, and this might overflow. E.g., if x = -001111, the + two's complement is 110001. Clearing the least significant bit, we + get two's complement 110000, and -010000. */ + +int +mpz_tstbit (const mpz_t d, mp_bitcnt_t bit_index) +{ + mp_size_t limb_index; + unsigned shift; + mp_size_t ds; + mp_size_t dn; + mp_limb_t w; + int bit; + + ds = d->_mp_size; + dn = GMP_ABS (ds); + limb_index = bit_index / GMP_LIMB_BITS; + if (limb_index >= dn) + return ds < 0; + + shift = bit_index % GMP_LIMB_BITS; + w = d->_mp_d[limb_index]; + bit = (w >> shift) & 1; + + if (ds < 0) + { + /* d < 0. Check if any of the bits below is set: If so, our bit + must be complemented. */ + if (shift > 0 && (w << (GMP_LIMB_BITS - shift)) > 0) + return bit ^ 1; + while (limb_index-- > 0) + if (d->_mp_d[limb_index] > 0) + return bit ^ 1; + } + return bit; +} + +static void +mpz_abs_add_bit (mpz_t d, mp_bitcnt_t bit_index) +{ + mp_size_t dn, limb_index; + mp_limb_t bit; + mp_ptr dp; + + dn = GMP_ABS (d->_mp_size); + + limb_index = bit_index / GMP_LIMB_BITS; + bit = (mp_limb_t) 1 << (bit_index % GMP_LIMB_BITS); + + if (limb_index >= dn) + { + mp_size_t i; + /* The bit should be set outside of the end of the number. + We have to increase the size of the number. */ + dp = MPZ_REALLOC (d, limb_index + 1); + + dp[limb_index] = bit; + for (i = dn; i < limb_index; i++) + dp[i] = 0; + dn = limb_index + 1; + } + else + { + mp_limb_t cy; + + dp = d->_mp_d; + + cy = mpn_add_1 (dp + limb_index, dp + limb_index, dn - limb_index, bit); + if (cy > 0) + { + dp = MPZ_REALLOC (d, dn + 1); + dp[dn++] = cy; + } + } + + d->_mp_size = (d->_mp_size < 0) ? - dn : dn; +} + +static void +mpz_abs_sub_bit (mpz_t d, mp_bitcnt_t bit_index) +{ + mp_size_t dn, limb_index; + mp_ptr dp; + mp_limb_t bit; + + dn = GMP_ABS (d->_mp_size); + dp = d->_mp_d; + + limb_index = bit_index / GMP_LIMB_BITS; + bit = (mp_limb_t) 1 << (bit_index % GMP_LIMB_BITS); + + assert (limb_index < dn); + + gmp_assert_nocarry (mpn_sub_1 (dp + limb_index, dp + limb_index, + dn - limb_index, bit)); + dn -= (dp[dn-1] == 0); + d->_mp_size = (d->_mp_size < 0) ? - dn : dn; +} + +void +mpz_setbit (mpz_t d, mp_bitcnt_t bit_index) +{ + if (!mpz_tstbit (d, bit_index)) + { + if (d->_mp_size >= 0) + mpz_abs_add_bit (d, bit_index); + else + mpz_abs_sub_bit (d, bit_index); + } +} + +void +mpz_clrbit (mpz_t d, mp_bitcnt_t bit_index) +{ + if (mpz_tstbit (d, bit_index)) + { + if (d->_mp_size >= 0) + mpz_abs_sub_bit (d, bit_index); + else + mpz_abs_add_bit (d, bit_index); + } +} + +void +mpz_combit (mpz_t d, mp_bitcnt_t bit_index) +{ + if (mpz_tstbit (d, bit_index) ^ (d->_mp_size < 0)) + mpz_abs_sub_bit (d, bit_index); + else + mpz_abs_add_bit (d, bit_index); +} + +void +mpz_com (mpz_t r, const mpz_t u) +{ + mpz_neg (r, u); + mpz_sub_ui (r, r, 1); +} + +void +mpz_and (mpz_t r, const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, rn, i; + mp_ptr up, vp, rp; + + mp_limb_t ux, vx, rx; + mp_limb_t uc, vc, rc; + mp_limb_t ul, vl, rl; + + un = GMP_ABS (u->_mp_size); + vn = GMP_ABS (v->_mp_size); + if (un < vn) + { + MPZ_SRCPTR_SWAP (u, v); + MP_SIZE_T_SWAP (un, vn); + } + if (vn == 0) + { + r->_mp_size = 0; + return; + } + + uc = u->_mp_size < 0; + vc = v->_mp_size < 0; + rc = uc & vc; + + ux = -uc; + vx = -vc; + rx = -rc; + + /* If the smaller input is positive, higher limbs don't matter. */ + rn = vx ? un : vn; + + rp = MPZ_REALLOC (r, rn + rc); + + up = u->_mp_d; + vp = v->_mp_d; + + i = 0; + do + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + vl = (vp[i] ^ vx) + vc; + vc = vl < vc; + + rl = ( (ul & vl) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + while (++i < vn); + assert (vc == 0); + + for (; i < rn; i++) + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + rl = ( (ul & vx) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + if (rc) + rp[rn++] = rc; + else + rn = mpn_normalized_size (rp, rn); + + r->_mp_size = rx ? -rn : rn; +} + +void +mpz_ior (mpz_t r, const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, rn, i; + mp_ptr up, vp, rp; + + mp_limb_t ux, vx, rx; + mp_limb_t uc, vc, rc; + mp_limb_t ul, vl, rl; + + un = GMP_ABS (u->_mp_size); + vn = GMP_ABS (v->_mp_size); + if (un < vn) + { + MPZ_SRCPTR_SWAP (u, v); + MP_SIZE_T_SWAP (un, vn); + } + if (vn == 0) + { + mpz_set (r, u); + return; + } + + uc = u->_mp_size < 0; + vc = v->_mp_size < 0; + rc = uc | vc; + + ux = -uc; + vx = -vc; + rx = -rc; + + /* If the smaller input is negative, by sign extension higher limbs + don't matter. */ + rn = vx ? vn : un; + + rp = MPZ_REALLOC (r, rn + rc); + + up = u->_mp_d; + vp = v->_mp_d; + + i = 0; + do + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + vl = (vp[i] ^ vx) + vc; + vc = vl < vc; + + rl = ( (ul | vl) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + while (++i < vn); + assert (vc == 0); + + for (; i < rn; i++) + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + rl = ( (ul | vx) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + if (rc) + rp[rn++] = rc; + else + rn = mpn_normalized_size (rp, rn); + + r->_mp_size = rx ? -rn : rn; +} + +void +mpz_xor (mpz_t r, const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, i; + mp_ptr up, vp, rp; + + mp_limb_t ux, vx, rx; + mp_limb_t uc, vc, rc; + mp_limb_t ul, vl, rl; + + un = GMP_ABS (u->_mp_size); + vn = GMP_ABS (v->_mp_size); + if (un < vn) + { + MPZ_SRCPTR_SWAP (u, v); + MP_SIZE_T_SWAP (un, vn); + } + if (vn == 0) + { + mpz_set (r, u); + return; + } + + uc = u->_mp_size < 0; + vc = v->_mp_size < 0; + rc = uc ^ vc; + + ux = -uc; + vx = -vc; + rx = -rc; + + rp = MPZ_REALLOC (r, un + rc); + + up = u->_mp_d; + vp = v->_mp_d; + + i = 0; + do + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + vl = (vp[i] ^ vx) + vc; + vc = vl < vc; + + rl = (ul ^ vl ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + while (++i < vn); + assert (vc == 0); + + for (; i < un; i++) + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + rl = (ul ^ ux) + rc; + rc = rl < rc; + rp[i] = rl; + } + if (rc) + rp[un++] = rc; + else + un = mpn_normalized_size (rp, un); + + r->_mp_size = rx ? -un : un; +} + +static unsigned +gmp_popcount_limb (mp_limb_t x) +{ + unsigned c; + + /* Do 16 bits at a time, to avoid limb-sized constants. */ + for (c = 0; x > 0; x >>= 16) + { + unsigned w = ((x >> 1) & 0x5555) + (x & 0x5555); + w = ((w >> 2) & 0x3333) + (w & 0x3333); + w = ((w >> 4) & 0x0f0f) + (w & 0x0f0f); + w = (w >> 8) + (w & 0x00ff); + c += w; + } + return c; +} + +mp_bitcnt_t +mpz_popcount (const mpz_t u) +{ + mp_size_t un, i; + mp_bitcnt_t c; + + un = u->_mp_size; + + if (un < 0) + return ~(mp_bitcnt_t) 0; + + for (c = 0, i = 0; i < un; i++) + c += gmp_popcount_limb (u->_mp_d[i]); + + return c; +} + +mp_bitcnt_t +mpz_hamdist (const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, i; + mp_limb_t uc, vc, ul, vl, comp; + mp_srcptr up, vp; + mp_bitcnt_t c; + + un = u->_mp_size; + vn = v->_mp_size; + + if ( (un ^ vn) < 0) + return ~(mp_bitcnt_t) 0; + + comp = - (uc = vc = (un < 0)); + if (uc) + { + assert (vn < 0); + un = -un; + vn = -vn; + } + + up = u->_mp_d; + vp = v->_mp_d; + + if (un < vn) + MPN_SRCPTR_SWAP (up, un, vp, vn); + + for (i = 0, c = 0; i < vn; i++) + { + ul = (up[i] ^ comp) + uc; + uc = ul < uc; + + vl = (vp[i] ^ comp) + vc; + vc = vl < vc; + + c += gmp_popcount_limb (ul ^ vl); + } + assert (vc == 0); + + for (; i < un; i++) + { + ul = (up[i] ^ comp) + uc; + uc = ul < uc; + + c += gmp_popcount_limb (ul ^ comp); + } + + return c; +} + +mp_bitcnt_t +mpz_scan1 (const mpz_t u, mp_bitcnt_t starting_bit) +{ + mp_ptr up; + mp_size_t us, un, i; + mp_limb_t limb, ux; + + us = u->_mp_size; + un = GMP_ABS (us); + i = starting_bit / GMP_LIMB_BITS; + + /* Past the end there's no 1 bits for u>=0, or an immediate 1 bit + for u<0. Notice this test picks up any u==0 too. */ + if (i >= un) + return (us >= 0 ? ~(mp_bitcnt_t) 0 : starting_bit); + + up = u->_mp_d; + ux = 0; + limb = up[i]; + + if (starting_bit != 0) + { + if (us < 0) + { + ux = mpn_zero_p (up, i); + limb = ~ limb + ux; + ux = - (mp_limb_t) (limb >= ux); + } + + /* Mask to 0 all bits before starting_bit, thus ignoring them. */ + limb &= (GMP_LIMB_MAX << (starting_bit % GMP_LIMB_BITS)); + } + + return mpn_common_scan (limb, i, up, un, ux); +} + +mp_bitcnt_t +mpz_scan0 (const mpz_t u, mp_bitcnt_t starting_bit) +{ + mp_ptr up; + mp_size_t us, un, i; + mp_limb_t limb, ux; + + us = u->_mp_size; + ux = - (mp_limb_t) (us >= 0); + un = GMP_ABS (us); + i = starting_bit / GMP_LIMB_BITS; + + /* When past end, there's an immediate 0 bit for u>=0, or no 0 bits for + u<0. Notice this test picks up all cases of u==0 too. */ + if (i >= un) + return (ux ? starting_bit : ~(mp_bitcnt_t) 0); + + up = u->_mp_d; + limb = up[i] ^ ux; + + if (ux == 0) + limb -= mpn_zero_p (up, i); /* limb = ~(~limb + zero_p) */ + + /* Mask all bits before starting_bit, thus ignoring them. */ + limb &= (GMP_LIMB_MAX << (starting_bit % GMP_LIMB_BITS)); + + return mpn_common_scan (limb, i, up, un, ux); +} + + +/* MPZ base conversion. */ + +size_t +mpz_sizeinbase (const mpz_t u, int base) +{ + mp_size_t un; + mp_srcptr up; + mp_ptr tp; + mp_bitcnt_t bits; + struct gmp_div_inverse bi; + size_t ndigits; + + assert (base >= 2); + assert (base <= 36); + + un = GMP_ABS (u->_mp_size); + if (un == 0) + return 1; + + up = u->_mp_d; + + bits = (un - 1) * GMP_LIMB_BITS + mpn_limb_size_in_base_2 (up[un-1]); + switch (base) + { + case 2: + return bits; + case 4: + return (bits + 1) / 2; + case 8: + return (bits + 2) / 3; + case 16: + return (bits + 3) / 4; + case 32: + return (bits + 4) / 5; + /* FIXME: Do something more clever for the common case of base + 10. */ + } + + tp = gmp_xalloc_limbs (un); + mpn_copyi (tp, up, un); + mpn_div_qr_1_invert (&bi, base); + + ndigits = 0; + do + { + ndigits++; + mpn_div_qr_1_preinv (tp, tp, un, &bi); + un -= (tp[un-1] == 0); + } + while (un > 0); + + gmp_free (tp); + return ndigits; +} + +char * +mpz_get_str (char *sp, int base, const mpz_t u) +{ + unsigned bits; + const char *digits; + mp_size_t un; + size_t i, sn; + + if (base >= 0) + { + digits = "0123456789abcdefghijklmnopqrstuvwxyz"; + } + else + { + base = -base; + digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; + } + if (base <= 1) + base = 10; + if (base > 36) + return NULL; + + sn = 1 + mpz_sizeinbase (u, base); + if (!sp) + sp = gmp_xalloc (1 + sn); + + un = GMP_ABS (u->_mp_size); + + if (un == 0) + { + sp[0] = '0'; + sp[1] = '\0'; + return sp; + } + + i = 0; + + if (u->_mp_size < 0) + sp[i++] = '-'; + + bits = mpn_base_power_of_two_p (base); + + if (bits) + /* Not modified in this case. */ + sn = i + mpn_get_str_bits ((unsigned char *) sp + i, bits, u->_mp_d, un); + else + { + struct mpn_base_info info; + mp_ptr tp; + + mpn_get_base_info (&info, base); + tp = gmp_xalloc_limbs (un); + mpn_copyi (tp, u->_mp_d, un); + + sn = i + mpn_get_str_other ((unsigned char *) sp + i, base, &info, tp, un); + gmp_free (tp); + } + + for (; i < sn; i++) + sp[i] = digits[(unsigned char) sp[i]]; + + sp[sn] = '\0'; + return sp; +} + +int +mpz_set_str (mpz_t r, const char *sp, int base) +{ + unsigned bits; + mp_size_t rn, alloc; + mp_ptr rp; + size_t sn; + int sign; + unsigned char *dp; + + assert (base == 0 || (base >= 2 && base <= 36)); + + while (isspace( (unsigned char) *sp)) + sp++; + + sign = (*sp == '-'); + sp += sign; + + if (base == 0) + { + if (*sp == '0') + { + sp++; + if (*sp == 'x' || *sp == 'X') + { + base = 16; + sp++; + } + else if (*sp == 'b' || *sp == 'B') + { + base = 2; + sp++; + } + else + base = 8; + } + else + base = 10; + } + + sn = strlen (sp); + dp = gmp_xalloc (sn + (sn == 0)); + + for (sn = 0; *sp; sp++) + { + unsigned digit; + + if (isspace ((unsigned char) *sp)) + continue; + if (*sp >= '0' && *sp <= '9') + digit = *sp - '0'; + else if (*sp >= 'a' && *sp <= 'z') + digit = *sp - 'a' + 10; + else if (*sp >= 'A' && *sp <= 'Z') + digit = *sp - 'A' + 10; + else + digit = base; /* fail */ + + if (digit >= base) + { + gmp_free (dp); + r->_mp_size = 0; + return -1; + } + + dp[sn++] = digit; + } + + bits = mpn_base_power_of_two_p (base); + + if (bits > 0) + { + alloc = (sn * bits + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS; + rp = MPZ_REALLOC (r, alloc); + rn = mpn_set_str_bits (rp, dp, sn, bits); + } + else + { + struct mpn_base_info info; + mpn_get_base_info (&info, base); + alloc = (sn + info.exp - 1) / info.exp; + rp = MPZ_REALLOC (r, alloc); + rn = mpn_set_str_other (rp, dp, sn, base, &info); + } + assert (rn <= alloc); + gmp_free (dp); + + r->_mp_size = sign ? - rn : rn; + + return 0; +} + +int +mpz_init_set_str (mpz_t r, const char *sp, int base) +{ + mpz_init (r); + return mpz_set_str (r, sp, base); +} + +size_t +mpz_out_str (FILE *stream, int base, const mpz_t x) +{ + char *str; + size_t len; + + str = mpz_get_str (NULL, base, x); + len = strlen (str); + len = fwrite (str, 1, len, stream); + gmp_free (str); + return len; +} + + +static int +gmp_detect_endian (void) +{ + static const int i = 2; + const unsigned char *p = (const unsigned char *) &i; + return 1 - *p; +} + +/* Import and export. Does not support nails. */ +void +mpz_import (mpz_t r, size_t count, int order, size_t size, int endian, + size_t nails, const void *src) +{ + const unsigned char *p; + ptrdiff_t word_step; + mp_ptr rp; + mp_size_t rn; + + /* The current (partial) limb. */ + mp_limb_t limb; + /* The number of bytes already copied to this limb (starting from + the low end). */ + size_t bytes; + /* The index where the limb should be stored, when completed. */ + mp_size_t i; + + if (nails != 0) + gmp_die ("mpz_import: Nails not supported."); + + assert (order == 1 || order == -1); + assert (endian >= -1 && endian <= 1); + + if (endian == 0) + endian = gmp_detect_endian (); + + p = (unsigned char *) src; + + word_step = (order != endian) ? 2 * size : 0; + + /* Process bytes from the least significant end, so point p at the + least significant word. */ + if (order == 1) + { + p += size * (count - 1); + word_step = - word_step; + } + + /* And at least significant byte of that word. */ + if (endian == 1) + p += (size - 1); + + rn = (size * count + sizeof(mp_limb_t) - 1) / sizeof(mp_limb_t); + rp = MPZ_REALLOC (r, rn); + + for (limb = 0, bytes = 0, i = 0; count > 0; count--, p += word_step) + { + size_t j; + for (j = 0; j < size; j++, p -= (ptrdiff_t) endian) + { + limb |= (mp_limb_t) *p << (bytes++ * CHAR_BIT); + if (bytes == sizeof(mp_limb_t)) + { + rp[i++] = limb; + bytes = 0; + limb = 0; + } + } + } + assert (i + (bytes > 0) == rn); + if (limb != 0) + rp[i++] = limb; + else + i = mpn_normalized_size (rp, i); + + r->_mp_size = i; +} + +void * +mpz_export (void *r, size_t *countp, int order, size_t size, int endian, + size_t nails, const mpz_t u) +{ + size_t count; + mp_size_t un; + + if (nails != 0) + gmp_die ("mpz_import: Nails not supported."); + + assert (order == 1 || order == -1); + assert (endian >= -1 && endian <= 1); + assert (size > 0 || u->_mp_size == 0); + + un = u->_mp_size; + count = 0; + if (un != 0) + { + size_t k; + unsigned char *p; + ptrdiff_t word_step; + /* The current (partial) limb. */ + mp_limb_t limb; + /* The number of bytes left to to in this limb. */ + size_t bytes; + /* The index where the limb was read. */ + mp_size_t i; + + un = GMP_ABS (un); + + /* Count bytes in top limb. */ + limb = u->_mp_d[un-1]; + assert (limb != 0); + + k = 0; + do { + k++; limb >>= CHAR_BIT; + } while (limb != 0); + + count = (k + (un-1) * sizeof (mp_limb_t) + size - 1) / size; + + if (!r) + r = gmp_xalloc (count * size); + + if (endian == 0) + endian = gmp_detect_endian (); + + p = (unsigned char *) r; + + word_step = (order != endian) ? 2 * size : 0; + + /* Process bytes from the least significant end, so point p at the + least significant word. */ + if (order == 1) + { + p += size * (count - 1); + word_step = - word_step; + } + + /* And at least significant byte of that word. */ + if (endian == 1) + p += (size - 1); + + for (bytes = 0, i = 0, k = 0; k < count; k++, p += word_step) + { + size_t j; + for (j = 0; j < size; j++, p -= (ptrdiff_t) endian) + { + if (bytes == 0) + { + if (i < un) + limb = u->_mp_d[i++]; + bytes = sizeof (mp_limb_t); + } + *p = limb; + limb >>= CHAR_BIT; + bytes--; + } + } + assert (i == un); + assert (k == count); + } + + if (countp) + *countp = count; + + return r; +} diff --git a/rts/mini-gmp.h b/rts/mini-gmp.h new file mode 100644 --- /dev/null +++ b/rts/mini-gmp.h @@ -0,0 +1,259 @@ +/* mini-gmp, a minimalistic implementation of a GNU GMP subset. + +Copyright 2011, 2012, 2013 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as published by +the Free Software Foundation; either version 3 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public +License for more details. + +You should have received a copy of the GNU Lesser General Public License +along with the GNU MP Library. If not, see http://www.gnu.org/licenses/. */ + +/* About mini-gmp: This is a minimal implementation of a subset of the + GMP interface. It is intended for inclusion into applications which + have modest bignums needs, as a fallback when the real GMP library + is not installed. + + This file defines the public interface. */ + +#ifndef __MINI_GMP_H__ +#define __MINI_GMP_H__ + +/* For size_t */ +#include + +#if defined (__cplusplus) +extern "C" { +#endif + +void mp_set_memory_functions (void *(*) (size_t), + void *(*) (void *, size_t, size_t), + void (*) (void *, size_t)); + +void mp_get_memory_functions (void *(**) (size_t), + void *(**) (void *, size_t, size_t), + void (**) (void *, size_t)); + +typedef unsigned long mp_limb_t; +typedef long mp_size_t; +typedef unsigned long mp_bitcnt_t; + +typedef mp_limb_t *mp_ptr; +typedef const mp_limb_t *mp_srcptr; + +typedef struct +{ + int _mp_alloc; /* Number of *limbs* allocated and pointed + to by the _mp_d field. */ + int _mp_size; /* abs(_mp_size) is the number of limbs the + last field points to. If _mp_size is + negative this is a negative number. */ + mp_limb_t *_mp_d; /* Pointer to the limbs. */ +} __mpz_struct; + +typedef __mpz_struct mpz_t[1]; + +typedef __mpz_struct *mpz_ptr; +typedef const __mpz_struct *mpz_srcptr; + +void mpn_copyi (mp_ptr, mp_srcptr, mp_size_t); +void mpn_copyd (mp_ptr, mp_srcptr, mp_size_t); + +int mpn_cmp (mp_srcptr, mp_srcptr, mp_size_t); + +mp_limb_t mpn_add_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_add_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); +mp_limb_t mpn_add (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); + +mp_limb_t mpn_sub_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_sub_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); +mp_limb_t mpn_sub (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); + +mp_limb_t mpn_mul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_addmul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_submul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); + +mp_limb_t mpn_mul (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); +void mpn_mul_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); +void mpn_sqr (mp_ptr, mp_srcptr, mp_size_t); + +mp_limb_t mpn_lshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int); +mp_limb_t mpn_rshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int); + +mp_bitcnt_t mpn_scan0 (mp_srcptr, mp_bitcnt_t); +mp_bitcnt_t mpn_scan1 (mp_srcptr, mp_bitcnt_t); + +mp_limb_t mpn_invert_3by2 (mp_limb_t, mp_limb_t); +#define mpn_invert_limb(x) mpn_invert_3by2 ((x), 0) + +size_t mpn_get_str (unsigned char *, int, mp_ptr, mp_size_t); +mp_size_t mpn_set_str (mp_ptr, const unsigned char *, size_t, int); + +void mpz_init (mpz_t); +void mpz_init2 (mpz_t, mp_bitcnt_t); +void mpz_clear (mpz_t); + +#define mpz_odd_p(z) (((z)->_mp_size != 0) & (int) (z)->_mp_d[0]) +#define mpz_even_p(z) (! mpz_odd_p (z)) + +int mpz_sgn (const mpz_t); +int mpz_cmp_si (const mpz_t, long); +int mpz_cmp_ui (const mpz_t, unsigned long); +int mpz_cmp (const mpz_t, const mpz_t); +int mpz_cmpabs_ui (const mpz_t, unsigned long); +int mpz_cmpabs (const mpz_t, const mpz_t); +int mpz_cmp_d (const mpz_t, double); +int mpz_cmpabs_d (const mpz_t, double); + +void mpz_abs (mpz_t, const mpz_t); +void mpz_neg (mpz_t, const mpz_t); +void mpz_swap (mpz_t, mpz_t); + +void mpz_add_ui (mpz_t, const mpz_t, unsigned long); +void mpz_add (mpz_t, const mpz_t, const mpz_t); +void mpz_sub_ui (mpz_t, const mpz_t, unsigned long); +void mpz_ui_sub (mpz_t, unsigned long, const mpz_t); +void mpz_sub (mpz_t, const mpz_t, const mpz_t); + +void mpz_mul_si (mpz_t, const mpz_t, long int); +void mpz_mul_ui (mpz_t, const mpz_t, unsigned long int); +void mpz_mul (mpz_t, const mpz_t, const mpz_t); +void mpz_mul_2exp (mpz_t, const mpz_t, mp_bitcnt_t); + +void mpz_cdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_fdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_tdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_cdiv_q (mpz_t, const mpz_t, const mpz_t); +void mpz_fdiv_q (mpz_t, const mpz_t, const mpz_t); +void mpz_tdiv_q (mpz_t, const mpz_t, const mpz_t); +void mpz_cdiv_r (mpz_t, const mpz_t, const mpz_t); +void mpz_fdiv_r (mpz_t, const mpz_t, const mpz_t); +void mpz_tdiv_r (mpz_t, const mpz_t, const mpz_t); + +void mpz_cdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_fdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_tdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_cdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_fdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_tdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); + +void mpz_mod (mpz_t, const mpz_t, const mpz_t); + +void mpz_divexact (mpz_t, const mpz_t, const mpz_t); + +int mpz_divisible_p (const mpz_t, const mpz_t); + +unsigned long mpz_cdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); +unsigned long mpz_fdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); +unsigned long mpz_tdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); +unsigned long mpz_cdiv_q_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_fdiv_q_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_tdiv_q_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_cdiv_r_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_fdiv_r_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_tdiv_r_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_cdiv_ui (const mpz_t, unsigned long); +unsigned long mpz_fdiv_ui (const mpz_t, unsigned long); +unsigned long mpz_tdiv_ui (const mpz_t, unsigned long); + +unsigned long mpz_mod_ui (mpz_t, const mpz_t, unsigned long); + +void mpz_divexact_ui (mpz_t, const mpz_t, unsigned long); + +int mpz_divisible_ui_p (const mpz_t, unsigned long); + +unsigned long mpz_gcd_ui (mpz_t, const mpz_t, unsigned long); +void mpz_gcd (mpz_t, const mpz_t, const mpz_t); +void mpz_gcdext (mpz_t, mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_lcm_ui (mpz_t, const mpz_t, unsigned long); +void mpz_lcm (mpz_t, const mpz_t, const mpz_t); +int mpz_invert (mpz_t, const mpz_t, const mpz_t); + +void mpz_sqrtrem (mpz_t, mpz_t, const mpz_t); +void mpz_sqrt (mpz_t, const mpz_t); + +void mpz_pow_ui (mpz_t, const mpz_t, unsigned long); +void mpz_ui_pow_ui (mpz_t, unsigned long, unsigned long); +void mpz_powm (mpz_t, const mpz_t, const mpz_t, const mpz_t); +void mpz_powm_ui (mpz_t, const mpz_t, unsigned long, const mpz_t); + +void mpz_rootrem (mpz_t, mpz_t, const mpz_t, unsigned long); +int mpz_root (mpz_t, const mpz_t, unsigned long); + +void mpz_fac_ui (mpz_t, unsigned long); +void mpz_bin_uiui (mpz_t, unsigned long, unsigned long); + +int mpz_tstbit (const mpz_t, mp_bitcnt_t); +void mpz_setbit (mpz_t, mp_bitcnt_t); +void mpz_clrbit (mpz_t, mp_bitcnt_t); +void mpz_combit (mpz_t, mp_bitcnt_t); + +void mpz_com (mpz_t, const mpz_t); +void mpz_and (mpz_t, const mpz_t, const mpz_t); +void mpz_ior (mpz_t, const mpz_t, const mpz_t); +void mpz_xor (mpz_t, const mpz_t, const mpz_t); + +mp_bitcnt_t mpz_popcount (const mpz_t); +mp_bitcnt_t mpz_hamdist (const mpz_t, const mpz_t); +mp_bitcnt_t mpz_scan0 (const mpz_t, mp_bitcnt_t); +mp_bitcnt_t mpz_scan1 (const mpz_t, mp_bitcnt_t); + +int mpz_fits_slong_p (const mpz_t); +int mpz_fits_ulong_p (const mpz_t); +long int mpz_get_si (const mpz_t); +unsigned long int mpz_get_ui (const mpz_t); +double mpz_get_d (const mpz_t); +size_t mpz_size (const mpz_t); +mp_limb_t mpz_getlimbn (const mpz_t, mp_size_t); + +void mpz_set_si (mpz_t, signed long int); +void mpz_set_ui (mpz_t, unsigned long int); +void mpz_set (mpz_t, const mpz_t); +void mpz_set_d (mpz_t, double); + +void mpz_init_set_si (mpz_t, signed long int); +void mpz_init_set_ui (mpz_t, unsigned long int); +void mpz_init_set (mpz_t, const mpz_t); +void mpz_init_set_d (mpz_t, double); + +size_t mpz_sizeinbase (const mpz_t, int); +char *mpz_get_str (char *, int, const mpz_t); +int mpz_set_str (mpz_t, const char *, int); +int mpz_init_set_str (mpz_t, const char *, int); + +/* This long list taken from gmp.h. */ +/* For reference, "defined(EOF)" cannot be used here. In g++ 2.95.4, + defines EOF but not FILE. */ +#if defined (FILE) \ + || defined (H_STDIO) \ + || defined (_H_STDIO) /* AIX */ \ + || defined (_STDIO_H) /* glibc, Sun, SCO */ \ + || defined (_STDIO_H_) /* BSD, OSF */ \ + || defined (__STDIO_H) /* Borland */ \ + || defined (__STDIO_H__) /* IRIX */ \ + || defined (_STDIO_INCLUDED) /* HPUX */ \ + || defined (__dj_include_stdio_h_) /* DJGPP */ \ + || defined (_FILE_DEFINED) /* Microsoft */ \ + || defined (__STDIO__) /* Apple MPW MrC */ \ + || defined (_MSL_STDIO_H) /* Metrowerks */ \ + || defined (_STDIO_H_INCLUDED) /* QNX4 */ \ + || defined (_ISO_STDIO_ISO_H) /* Sun C++ */ \ + || defined (__STDIO_LOADED) /* VMS */ +size_t mpz_out_str (FILE *, int, const mpz_t); +#endif + +void mpz_import (mpz_t, size_t, int, size_t, int, size_t, const void *); +void *mpz_export (void *, size_t *, int, size_t, int, size_t, const mpz_t); + +#if defined (__cplusplus) +} +#endif +#endif /* __MINI_GMP_H__ */ 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,6 @@ {-# LANGUAGE PatternGuards, DeriveFunctor, TypeSynonymInstances #-} -module Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..), +module Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..), Phase(..), CaseTree, simpleCase, small, namesUsed, findCalls, findUsedArgs) where @@ -11,29 +11,29 @@ import Data.List hiding (partition) import Debug.Trace -data CaseDef = CaseDef [Name] SC [Term] +data CaseDef = CaseDef [Name] !SC [Term] deriving Show data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first | ProjCase t [CaseAlt' t] -- ^ special case for projections - | STerm t + | STerm !t | UnmatchedCase String -- ^ error message | ImpossibleCase -- ^ already checked to be impossible deriving (Eq, Ord, Functor) -{-! -deriving instance Binary SC +{-! +deriving instance Binary SC !-} type SC = SC' Term -data CaseAlt' t = ConCase Name Int [Name] (SC' t) - | FnCase Name [Name] (SC' t) -- ^ reflection function - | ConstCase Const (SC' t) - | SucCase Name (SC' t) - | DefaultCase (SC' t) +data CaseAlt' t = ConCase Name Int [Name] !(SC' t) + | FnCase Name [Name] !(SC' t) -- ^ reflection function + | ConstCase Const !(SC' t) + | SucCase Name !(SC' t) + | DefaultCase !(SC' t) deriving (Show, Eq, Ord, Functor) -{-! -deriving instance Binary CaseAlt +{-! +deriving instance Binary CaseAlt !-} type CaseAlt = CaseAlt' Term @@ -41,7 +41,7 @@ instance Show t => Show (SC' t) where show sc = show' 1 sc where - show' i (Case n alts) = "case " ++ show n ++ " of\n" ++ indent i ++ + 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) @@ -51,20 +51,20 @@ indent i = concat $ take i (repeat " ") - showA i (ConCase n t args sc) + showA i (ConCase n t args sc) = show n ++ "(" ++ showSep (", ") (map show args) ++ ") => " ++ show' (i+1) sc - showA i (FnCase n args sc) + showA i (FnCase n args sc) = "FN " ++ show n ++ "(" ++ showSep (", ") (map show args) ++ ") => " ++ show' (i+1) sc - showA i (ConstCase t sc) + showA i (ConstCase t sc) = show t ++ " => " ++ show' (i+1) sc - showA i (SucCase n sc) + showA i (SucCase n sc) = show n ++ "+1 => " ++ show' (i+1) sc - showA i (DefaultCase sc) + showA i (DefaultCase sc) = "_ => " ++ show' (i+1) sc - + type CaseTree = SC type Clause = ([Pat], (Term, Term)) type CS = ([Term], Int) @@ -88,13 +88,13 @@ small :: Name -> [Name] -> SC -> Bool small n args t = let as = findAllUsedArgs t args in - length as == length (nub as) && + length as == length (nub as) && termsize n t < 10 namesUsed :: SC -> [Name] namesUsed sc = nub $ nu' [] sc where nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n] - nu' ps (ProjCase t alts) = nub $ (nut ps t ++ + nu' ps (ProjCase t alts) = nub $ (nut ps t ++ (concatMap (nua ps) alts)) nu' ps (STerm t) = nub $ nut ps t nu' ps _ = [] @@ -124,18 +124,19 @@ nu' ps (STerm t) = nub $ nut ps t nu' ps _ = [] - nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc) - nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc) + nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc) + nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc) nua ps (ConstCase _ sc) = nu' ps sc nua ps (SucCase _ 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) + 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 + | (P (TCon _ _) n _, _) <- unApply fn = [] | otherwise = nut ps f ++ nut ps a nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc nut ps (Proj t _) = nut ps t @@ -152,7 +153,7 @@ 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) +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 @@ -169,8 +170,8 @@ nu' (STerm t) = directUse t nu' _ = [] - nua (ConCase n i args sc) = nu' sc - nua (FnCase n args sc) = nu' sc + nua (ConCase n i args sc) = nu' sc + nua (FnCase n args sc) = nu' sc nua (ConstCase _ sc) = nu' sc nua (SucCase _ sc) = nu' sc nua (DefaultCase sc) = nu' sc @@ -182,27 +183,27 @@ -- Work Right to Left simpleCase :: Bool -> Bool -> Bool -> - Phase -> FC -> [([Name], Term, Term)] -> + Phase -> FC -> [([Name], Term, Term)] -> TC CaseDef simpleCase tc cover reflect phase fc cs - = sc' tc cover phase fc (filter (\(_, _, r) -> + = sc' tc cover phase fc (filter (\(_, _, r) -> case r of Impossible -> False - _ -> True) cs) + _ -> True) cs) where - sc' tc cover phase fc [] + sc' tc cover phase fc [] = return $ CaseDef [] (UnmatchedCase "No pattern clauses") [] - sc' tc cover phase fc cs + sc' tc cover phase fc cs = let proj = phase == RunTime - pats = map (\ (avs, l, r) -> + pats = map (\ (avs, l, r) -> (avs, toPats reflect tc l, (l, r))) cs chkPats = mapM chkAccessible pats in case chkPats of OK pats -> - let numargs = length (fst (head pats)) + let numargs = length (fst (head pats)) ns = take numargs args (ns', ps') = order ns pats - (tree, st) = runState + (tree, st) = runState (match ns' ps' (defaultCase cover)) ([], numargs) t = CaseDef ns (prune proj (depatt ns' tree)) (fst st) in if proj then return (stripLambdas t) else return t @@ -211,12 +212,12 @@ defaultCase True = STerm Erased defaultCase False = UnmatchedCase "Error" - chkAccessible (avs, l, c) + chkAccessible (avs, l, c) | phase == RunTime || reflect = return (l, c) | otherwise = do mapM_ (acc l) avs return (l, c) - acc [] n = Error (Inaccessible n) + acc [] n = Error (Inaccessible n) acc (PV x : xs) n | x == n = OK () acc (PCon _ _ ps : xs) n = acc (ps ++ xs) n acc (PSuc p : xs) n = acc (p : xs) n @@ -244,31 +245,31 @@ toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args return $ PCon n t args' -- n + 1 - toPat' (P _ (UN "prim__addBigInt") _) + toPat' (P _ (UN "prim__addBigInt") _) [p, Constant (BI 1)] = do p' <- toPat' p [] return $ PSuc p' -- Typecase - toPat' (P (TCon t a) n _) args | tc + toPat' (P (TCon t a) n _) args | tc = do args' <- mapM (\x -> toPat' x []) args return $ PCon n t args' toPat' (Constant (AType (ATInt ITNative))) [] - | tc = return $ PCon (UN "Int") 1 [] - toPat' (Constant (AType ATFloat)) [] | tc = return $ PCon (UN "Float") 2 [] - toPat' (Constant (AType (ATInt ITChar))) [] | tc = return $ PCon (UN "Char") 3 [] - toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 [] - toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 [] + | tc = return $ PCon (UN "Int") 1 [] + toPat' (Constant (AType ATFloat)) [] | tc = return $ PCon (UN "Float") 2 [] + toPat' (Constant (AType (ATInt ITChar))) [] | tc = return $ PCon (UN "Char") 3 [] + toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 [] + toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 [] toPat' (Constant (AType (ATInt ITBig))) [] | tc = return $ PCon (UN "Integer") 6 [] toPat' (Constant (AType (ATInt (ITFixed n)))) [] | tc = return $ PCon (UN (fixedN n)) (7 + fromEnum n) [] -- 7-10 inclusive toPat' (P Bound n _) [] = do ns <- get - if n `elem` ns - then return PAny + if n `elem` ns + then return PAny else do put (n : ns) return (PV n) toPat' (App f a) args = toPat' f (a : args) - toPat' (Constant x) [] = return $ PConst x + toPat' (Constant x) [] = return $ PConst x toPat' (Bind n (Pi t) sc) [] | reflect && noOccurrence n sc = do t' <- toPat' t [] sc' <- toPat' sc [] @@ -276,7 +277,7 @@ toPat' (P _ n _) args | reflect = do args' <- mapM (\x -> toPat' x []) args return $ PReflected n args' - toPat' _ _ = return PAny + toPat' t _ = return PAny fixedN IT8 = "Bits8" fixedN IT16 = "Bits16" @@ -323,10 +324,10 @@ rebuild patnames clause = (map snd patnames, snd clause) - moreDistinct xs ys = compare (numNames [] (map snd ys)) + moreDistinct xs ys = compare (numNames [] (map snd ys)) (numNames [] (map snd xs)) - numNames xs (PCon n _ _ : ps) + numNames xs (PCon n _ _ : ps) | not (Left n `elem` xs) = numNames (Left n : xs) ps numNames xs (PConst c : ps) | not (Right c `elem` xs) = numNames (Right c : xs) ps @@ -335,7 +336,7 @@ match :: [Name] -> [Clause] -> SC -- error case -> State CS SC -match [] (([], ret) : xs) err +match [] (([], ret) : xs) err = do (ts, v) <- get put (ts ++ (map (fst.snd) xs), v) case snd ret of @@ -382,7 +383,7 @@ = do g <- altSucGroup args rest <- altGroups cs return (g : rest) - altGroups (ConGroup (CConst c) args : cs) + altGroups (ConGroup (CConst c) args : cs) = do g <- altConstGroup c args rest <- altGroups cs return (g : rest) @@ -405,7 +406,7 @@ argsToAlt rs@((r, m) : rest) = do newArgs <- getNewVars r return (newArgs, addRs rs) - where + where getNewVars [] = return [] getNewVars ((PV n) : ns) = do v <- getVar "e" nsv <- getNewVars ns @@ -429,7 +430,7 @@ groupCons cs = gc [] cs where gc acc [] = return acc - gc acc ((p : ps, res) : cs) = + gc acc ((p : ps, res) : cs) = do acc' <- addGroup p ps res acc gc acc' cs addGroup p ps res acc = case p of @@ -439,7 +440,7 @@ PReflected fn args -> return $ addg (CFn fn) args (ps, res) acc pat -> fail $ show pat ++ " is not a constructor or constant (can't happen)" - addg c conargs res [] + addg c conargs res [] = [ConGroup c [(conargs, res)]] addg c conargs res (g@(ConGroup c' cs):gs) | c == c' = ConGroup c (cs ++ [(conargs, res)]) : gs @@ -456,7 +457,7 @@ do let alts' = map (repVar v) alts match vs alts' err where - repVar v (PV p : ps , (lhs, res)) + repVar v (PV p : ps , (lhs, res)) = (ps, (lhs, subst p (P Bound v Erased) res)) repVar v (PAny : ps , res) = (ps, res) @@ -487,20 +488,24 @@ | and ((length args == length args') : (n == cn) : zipWith same args args') = P Ref x Erased | otherwise = applyMap ms nt cn pty args' - same n (P _ n' _) = n == n' + same n (P _ n' _) = n == n' same _ _ = False applyMaps ms (App f a) = App (applyMaps ms f) (applyMaps ms a) applyMaps ms t = t +-- FIXME: Do this for SucCase too prune :: Bool -- ^ Convert single branches to projections (only useful at runtime) -> SC -> SC -prune proj (Case n alts) +prune proj (Case n alts) = let alts' = filter notErased (map pruneAlt alts) in case alts' of [] -> ImpossibleCase as@[ConCase cn i args sc] -> if proj then mkProj n 0 args sc else Case n as + as@[SucCase cn sc] -> if proj then mkProj n (-1) [cn] sc + else Case n as + as@[ConstCase _ sc] -> prune proj sc -- Bit of a hack here! The default case will always be 0, make sure -- it gets caught first. [s@(SucCase _ _), DefaultCase dc] @@ -516,12 +521,19 @@ notErased (DefaultCase ImpossibleCase) = False notErased _ = True - mkProj n i [] sc = sc + mkProj n i [] sc = prune proj sc mkProj n i (x : xs) sc = mkProj n (i + 1) xs (projRep x n i sc) + -- Change every 'n' in sc to 'n-1' +-- mkProjS n cn sc = prune proj (fmap projn sc) where +-- projn pn@(P _ n' _) +-- | cn == n' = App (App (P Ref (UN "prim__subBigInt") Erased) +-- (P Bound n Erased)) (Constant (BI 1)) +-- projn t = t + projRep :: Name -> Name -> Int -> SC -> SC projRep arg n i (Case x alts) - | x == arg = ProjCase (Proj (P Bound n Erased) i) + | 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) @@ -540,7 +552,7 @@ 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 + projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t prune _ t = t diff --git a/src/Core/Constraints.hs b/src/Core/Constraints.hs --- a/src/Core/Constraints.hs +++ b/src/Core/Constraints.hs @@ -25,7 +25,7 @@ mkRels :: [(UConstraint, FC)] -> Relations -> Relations mkRels [] acc = acc -mkRels ((c, f) : cs) acc +mkRels ((c, f) : cs) acc | not (ignore c) = case M.lookup (lhs c) acc of Nothing -> mkRels cs (M.insert (lhs c) [(c,f)] acc) @@ -38,7 +38,7 @@ acyclic :: Relations -> [UExp] -> TC () -acyclic r cvs = checkCycle (FC "root" 0) r [] 0 cvs +acyclic r cvs = checkCycle (fileFC "root") r [] 0 cvs where checkCycle :: FC -> Relations -> [(UExp, FC)] -> Int -> [UExp] -> TC () checkCycle fc r path inc [] = return () @@ -50,18 +50,18 @@ check fc path inc (UVar x) | x < 0 = return () check fc path inc cv - | inc > 0 && cv `elem` map fst path + | inc > 0 && cv `elem` map fst path = Error $ At fc UniverseError -- FIXME: Make informative -- e.g. (Msg ("Cycle: " ++ show cv ++ ", " ++ show path)) -- if we reach a cycle but we're at the same universe level, it's -- fine, because they must all be equal, so stop. | inc == 0 && cv `elem` map fst path - = return () + = return () | otherwise = case M.lookup cv r of Nothing -> return () Just cs -> mapM_ (next ((cv, fc):path) inc) cs - + next path inc (ULT l r, fc) = check fc path (inc + 1) r next path inc (ULE l r, fc) = check fc path inc r diff --git a/src/Core/CoreParser.hs b/src/Core/CoreParser.hs deleted file mode 100644 --- a/src/Core/CoreParser.hs +++ /dev/null @@ -1,578 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} - -module Core.CoreParser(parseTerm, parseFile, parseDef, pTerm, iName, - idrisLexer, maybeWithNS, pDocComment, opChars) where - -import Core.TT - -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Expr -import Text.ParserCombinators.Parsec.Language -import Text.ParserCombinators.Parsec.Prim -import Text.ParserCombinators.Parsec.Char -import Text.ParserCombinators.Parsec.Combinator -import qualified Text.ParserCombinators.Parsec.Token as PTok - -import Control.Monad.State -import Control.Monad.Identity -import Data.Char -import Data.List -import Debug.Trace - -type TokenParser a = PTok.TokenParser a - -idrisDef = haskellDef { - opStart = iOpStart, - opLetter = iOpLetter, - identLetter = identLetter haskellDef <|> lchar '.', - reservedOpNames - = [":", "..", "=", "\\", "|", "<-", "->", "=>", "**"], - reservedNames - = ["let", "in", "data", "codata", "record", "Type", - "do", "dsl", "import", "impossible", - "case", "of", "total", "partial", "mutual", - "infix", "infixl", "infixr", "rewrite", - "where", "with", "syntax", "proof", "postulate", - "using", "namespace", "class", "instance", - "public", "private", "abstract", "implicit", - "quoteGoal", - "Int", "Integer", "Float", "Char", "String", "Ptr", - "Bits8", "Bits16", "Bits32", "Bits64", - "Bits8x16", "Bits16x8", "Bits32x4", "Bits64x2"] - } - --- | The characters allowed in operator names -opChars = ":!#$%&*+./<=>?@\\^|-~" - -iOpStart = oneOf opChars -iOpLetter = oneOf opChars --- <|> letter - -idrisLexer :: TokenParser a -idrisLexer = idrisMakeTokenParser idrisDef - -lexer = idrisLexer - --- Taken from Parsec source code -lexWS = do i <- getInput - skipMany (simpleSpace <|> oneLineComment <|> multiLineComment "") - where - - simpleSpace = skipMany1 (satisfy isSpace) - oneLineComment = - try (void $ string "--\n") <|> - do try (do string "--" - satisfy (\x -> x /= '|' && x /= '^')) - skipMany (satisfy (/= '\n')) - multiLineComment = - try (void $ string "{--}") <|> - do try (do string "{-" - satisfy (\x -> x /= '|' && x /= '^')) - inCommentMulti - - inCommentMulti - = do{ try (string "-}") ; return () } - <|> do{ multiLineComment ; inCommentMulti } - <|> do{ skipMany1 (noneOf startEnd) ; inCommentMulti } - <|> do{ oneOf startEnd ; inCommentMulti } - "end of comment" - where - startEnd = "-}{" - -whiteSpace= PTok.whiteSpace lexer -lexeme = PTok.lexeme lexer -symbol = PTok.symbol lexer -natural = PTok.natural lexer -parens = PTok.parens lexer -semi = PTok.semi lexer -comma = PTok.comma lexer -identifier= PTok.identifier lexer -reserved = PTok.reserved lexer -operator = PTok.operator lexer -reservedOp= PTok.reservedOp lexer -strlit = PTok.stringLiteral lexer -lchar = lexeme.char - -type CParser a = GenParser Char a - -parseFile = runParser pTestFile () "(input)" -parseDef = runParser pDef () "(input)" -parseTerm = runParser pTerm () "(input)" - -pTestFile :: CParser a RProgram -pTestFile = do p <- many1 pDef ; eof - return p - -iName :: [String] -> CParser a Name -iName bad = maybeWithNS identifier False bad - --- Enhances a given parser to accept an optional namespace. All possible --- namespace prefixes are tried in ascending / descending order, and --- identifiers of a given list fail. -maybeWithNS :: CParser a String -> Bool -> [String] -> CParser a Name -maybeWithNS parser ascend bad = do - i <- option "" (lookAhead identifier) - when (i `elem` bad) $ fail "Reserved identifier" - let transf = if ascend then id else reverse - (x, xs) <- choice $ transf (parserNoNS : parsersNS i) - return $ mkName (x, xs) - where - parserNoNS = do x <- parser; return (x, "") - parserNS ns = do xs <- string ns; lchar '.'; x <- parser; return (x, xs) - parsersNS i = [try (parserNS ns) | ns <- (initsEndAt (=='.') i)] - --- List of all initial segments in ascending order of a list. Every such --- initial segment ends right before an element satisfying the given --- condition. -initsEndAt :: (a -> Bool) -> [a] -> [[a]] -initsEndAt p [] = [] -initsEndAt p (x:xs) | p x = [] : x_inits_xs - | otherwise = x_inits_xs - where x_inits_xs = [x : cs | cs <- initsEndAt p xs] - --- Create a `Name' from a pair of strings representing a base name and its --- namespace. -mkName :: (String, String) -> Name -mkName (n, "") = UN n -mkName (n, ns) = NS (UN n) (reverse (parseNS ns)) - where parseNS x = case span (/= '.') x of - (x, "") -> [x] - (x, '.':y) -> x : parseNS y - -pDocComment :: Char -> CParser a String -pDocComment c - = try (do string ("--") - char c - skipMany simpleSpace - i <- getInput - let (doc, rest) = span (/='\n') i - setInput rest - whiteSpace - return doc) - <|> try (do string ("{-") - char c - skipMany simpleSpace - i <- getInput - -- read to '-}' - let (doc, rest) = spanComment "" i - setInput rest - whiteSpace - return doc) - where spanComment acc ('-':'}':xs) = (reverse acc, xs) - spanComment acc (x:xs) = spanComment (x : acc) xs - spanComment acc [] = (acc, []) - simpleSpace = skipMany1 (satisfy isSpace) - -pDef :: CParser a (Name, RDef) -pDef = try (do x <- iName []; lchar ':'; ty <- pTerm - lchar '=' - tm <- pTerm - lchar ';' - return (x, RFunction (RawFun ty tm))) - <|> do x <- iName []; lchar ':'; ty <- pTerm; lchar ';' - return (x, RConst ty) - <|> do (x, d) <- pData; lchar ';' - return (x, RData d) - -app :: CParser a (Raw -> Raw -> Raw) -app = do whiteSpace ; return RApp - -arrow :: CParser a (Raw -> Raw -> Raw) -arrow = do symbol "->" ; return $ \s t -> RBind (MN 0 "X") (Pi s) t - -pTerm :: CParser a Raw -pTerm = try (do chainl1 pNoApp app) - <|> pNoApp - -pNoApp :: CParser a Raw -pNoApp = try (chainr1 pExp arrow) - <|> pExp -pExp :: CParser a Raw -pExp = do lchar '\\'; x <- iName []; lchar ':'; ty <- pTerm - symbol "=>"; - sc <- pTerm - return (RBind x (Lam ty) sc) - <|> try (do lchar '?'; x <- iName []; lchar ':'; ty <- pTerm - lchar '.'; - sc <- pTerm - return (RBind x (Hole ty) sc)) - <|> try (do lchar '('; - x <- iName []; lchar ':'; ty <- pTerm - lchar ')'; - symbol "->"; - sc <- pTerm - return (RBind x (Pi ty) sc)) - <|> try (do lchar '('; - t <- pTerm - lchar ')' - return t) - <|> try (do symbol "??"; - x <- iName []; lchar ':'; ty <- pTerm - lchar '='; - val <- pTerm - sc <- pTerm - return (RBind x (Guess ty val) sc)) - <|> try (do reserved "let"; - x <- iName []; lchar ':'; ty <- pTerm - lchar '='; - val <- pTerm - reserved "in"; - sc <- pTerm - return (RBind x (Let ty val) sc)) - <|> try (do lchar '_'; - x <- iName []; lchar ':'; ty <- pTerm - lchar '.'; - sc <- pTerm - return (RBind x (PVar ty) sc)) - <|> try (do reserved "Type" - return RType) - <|> try (do x <- iName [] - return (Var x)) - -pData :: CParser a (Name, RawDatatype) -pData = do reserved "data"; x <- iName []; lchar ':'; ty <- pTerm; reserved "where" - cs <- many pConstructor - return (x, RDatatype x ty cs) - -pConstructor :: CParser a (Name, Raw) -pConstructor = do lchar '|' - c <- iName []; lchar ':'; ty <- pTerm - return (c, ty) - ------- borrowed from Parsec --- (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 - -idrisMakeTokenParser languageDef - = PTok.TokenParser{ - PTok.identifier = identifier - , PTok.reserved = reserved - , PTok.operator = operator - , PTok.reservedOp = reservedOp - - , PTok.charLiteral = charLiteral - , PTok.stringLiteral = stringLiteral - , PTok.natural = natural - , PTok.integer = integer - , PTok.float = float - , PTok.naturalOrFloat = naturalOrFloat - , PTok.decimal = decimal - , PTok.hexadecimal = hexadecimal - , PTok.octal = octal - - , PTok.symbol = symbol - , PTok.lexeme = lexeme - , PTok.whiteSpace = lexWS - - , PTok.parens = parens - , PTok.braces = braces - , PTok.angles = angles - , PTok.brackets = brackets - , PTok.squares = brackets - , PTok.semi = semi - , PTok.comma = comma - , PTok.colon = colon - , PTok.dot = dot - , PTok.semiSep = semiSep - , PTok.semiSep1 = semiSep1 - , PTok.commaSep = commaSep - , PTok.commaSep1 = commaSep1 - } - where - - ----------------------------------------------------------- - -- Bracketing - ----------------------------------------------------------- - parens p = between (symbol "(") (symbol ")") p - braces p = between (symbol "{") (symbol "}") p - angles p = between (symbol "<") (symbol ">") p - brackets p = between (symbol "[") (symbol "]") p - - semi = symbol ";" - comma = symbol "," - dot = symbol "." - colon = symbol ":" - - commaSep p = sepBy p comma - semiSep p = sepBy p semi - - commaSep1 p = sepBy1 p comma - semiSep1 p = sepBy1 p semi - - - ----------------------------------------------------------- - -- Chars & Strings - ----------------------------------------------------------- - charLiteral = lexeme (between (char '\'') - (char '\'' "end of character") - characterChar ) - "character" - - characterChar = charLetter <|> charEscape - "literal character" - - charEscape = do{ char '\\'; escapeCode } - charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) - - - - stringLiteral = lexeme ( - do{ str <- between (char '"') - (char '"' "end of string") - (many stringChar) - ; return (foldr (maybe id (:)) "" str) - } - "literal string") - - stringChar = do{ c <- stringLetter; return (Just c) } - <|> stringEscape - "string character" - - stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) - - stringEscape = do{ char '\\' - ; do{ escapeGap ; return Nothing } - <|> do{ escapeEmpty; return Nothing } - <|> do{ esc <- escapeCode; return (Just esc) } - } - - escapeEmpty = char '&' - escapeGap = do{ many1 space - ; char '\\' "end of string gap" - } - - - - -- escape codes - escapeCode = charEsc <|> charNum <|> charAscii <|> charControl - "escape code" - - charControl = do{ char '^' - ; code <- upper - ; return (toEnum (fromEnum code - fromEnum 'A')) - } - - charNum = do{ code <- decimal - <|> do{ char 'o'; number 8 octDigit } - <|> do{ char 'x'; number 16 hexDigit } - ; return (toEnum (fromInteger code)) - } - - charEsc = choice (map parseEsc escMap) - where - parseEsc (c,code) = do{ char c; return code } - - charAscii = choice (map parseAscii asciiMap) - where - parseAscii (asc,code) = try (do{ string asc; return code }) - - - -- escape code tables - escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") - asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) - - ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", - "FS","GS","RS","US","SP"] - ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", - "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", - "CAN","SUB","ESC","DEL"] - - ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', - '\EM','\FS','\GS','\RS','\US','\SP'] - ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', - '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', - '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] - - - ----------------------------------------------------------- - -- Numbers - ----------------------------------------------------------- - naturalOrFloat = lexeme (natFloat) "number" - - float = lexeme floating "float" - integer = lexeme int "integer" - natural = lexeme nat "natural" - - - -- floats - floating = do{ n <- decimal - ; fractExponent n - } - - - natFloat = do{ char '0' - ; zeroNumFloat - } - <|> decimalFloat - - zeroNumFloat = do{ n <- hexadecimal <|> octal - ; return (Left n) - } - <|> decimalFloat - <|> fractFloat 0 - <|> return (Left 0) - - decimalFloat = do{ n <- decimal - ; option (Left n) - (fractFloat n) - } - - fractFloat n = do{ f <- fractExponent n - ; return (Right f) - } - - fractExponent n = do{ fract <- fraction - ; expo <- option 1.0 exponent' - ; return ((fromInteger n + fract)*expo) - } - <|> - do{ expo <- exponent' - ; return ((fromInteger n)*expo) - } - - fraction = do{ char '.' - ; digits <- many1 digit "fraction" - ; return (foldr op 0.0 digits) - } - "fraction" - where - op d f = (f + fromIntegral (digitToInt d))/10.0 - - exponent' = do{ oneOf "eE" - ; f <- sign - ; e <- decimal "exponent" - ; return (power (f e)) - } - "exponent" - where - power e | e < 0 = 1.0/power(-e) - | otherwise = fromInteger (10^e) - - - -- integers and naturals - int = do{ f <- lexeme sign - ; n <- nat - ; return (f n) - } - - sign = (char '-' >> return negate) - <|> (char '+' >> return id) - <|> return id - - nat = zeroNumber <|> decimal - - zeroNumber = do{ char '0' - ; hexadecimal <|> octal <|> decimal <|> return 0 - } - "" - - decimal = number 10 digit - hexadecimal = do{ oneOf "xX"; number 16 hexDigit } - octal = do{ oneOf "oO"; number 8 octDigit } - - number base baseDigit - = do{ digits <- many1 baseDigit - ; let n = foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 digits - ; seq n (return n) - } - - ----------------------------------------------------------- - -- Operators & reserved ops - ----------------------------------------------------------- - reservedOp name = - lexeme $ try $ - do{ string name - ; notFollowedBy (opLetter languageDef) ("end of " ++ show name) - } - - operator = - lexeme $ try $ - do{ name <- oper - ; if (isReservedOp name) - then unexpected ("reserved operator " ++ show name) - else return name - } - - oper = - do{ c <- (opStart languageDef) - ; cs <- many (opLetter languageDef) - ; return (c:cs) - } - "operator" - - isReservedOp name = - isReserved (sort (reservedOpNames languageDef)) name - - - ----------------------------------------------------------- - -- Identifiers & Reserved words - ----------------------------------------------------------- - reserved name = - lexeme $ try $ - do{ caseString name - ; notFollowedBy (identLetter languageDef) ("end of " ++ show name) - } - - caseString name - | caseSensitive languageDef = string name - | otherwise = do{ walk name; return name } - where - walk [] = return () - walk (c:cs) = do{ caseChar c msg; walk cs } - - caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c) - | otherwise = char c - - msg = show name - - - identifier = - lexeme $ try $ - do{ name <- ident - ; if (isReservedName name) - then unexpected ("reserved word " ++ show name) - else return name - } - - - ident - = do{ c <- identStart languageDef - ; cs <- many (identLetter languageDef) - ; return (c:cs) - } - "identifier" - - isReservedName name - = isReserved theReservedNames caseName - where - caseName | caseSensitive languageDef = name - | otherwise = map toLower name - - - isReserved names name - = scan names - where - scan [] = False - scan (r:rs) = case (compare r name) of - LT -> scan rs - EQ -> True - GT -> False - - theReservedNames - | caseSensitive languageDef = sortedNames - | otherwise = map (map toLower) sortedNames - where - sortedNames = sort (reservedNames languageDef) - - - - ----------------------------------------------------------- - -- White space & symbols - ----------------------------------------------------------- - symbol name - = lexeme (string name) - - lexeme p - = do{ x <- p; whiteSpace; return x } - - --whiteSpace - whiteSpace = lexWS diff --git a/src/Core/Elaborate.hs b/src/Core/Elaborate.hs --- a/src/Core/Elaborate.hs +++ b/src/Core/Elaborate.hs @@ -8,7 +8,7 @@ tactics out of the primitives. -} -module Core.Elaborate(module Core.Elaborate, +module Core.Elaborate(module Core.Elaborate, module Core.ProofState) where import Core.ProofState @@ -64,7 +64,7 @@ case runStateT elab s of OK (a, s') -> do put s' return a - Error (At f e) -> + Error (At f e) -> lift $ Error (At f (Elaborating thing n e)) Error e -> lift $ Error (Elaborating thing n e) @@ -182,8 +182,8 @@ checkInjective :: (Term, Term, Term) -> Elab' aux () checkInjective (tm, l, r) = do ctxt <- get_context if isInj ctxt tm then return () - else lift $ tfail (NotInjective tm l r) - where isInj ctxt (P _ n _) + else lift $ tfail (NotInjective tm l r) + where isInj ctxt (P _ n _) | isConName n ctxt = True isInj ctxt (App f a) = isInj ctxt f isInj ctxt (Constant _) = True @@ -200,15 +200,15 @@ unique_hole = unique_hole' False unique_hole' :: Bool -> Name -> Elab' aux Name -unique_hole' reusable n +unique_hole' reusable n = do ES p _ _ <- get - let bs = bound_in (pterm (fst p)) ++ + let bs = bound_in (pterm (fst p)) ++ bound_in (ptype (fst p)) - n' <- uniqueNameCtxt (context (fst p)) n (holes (fst p) + n' <- uniqueNameCtxt (context (fst p)) n (holes (fst p) ++ bs ++ dontunify (fst p) ++ usedns (fst p)) ES (p, a) s u <- get -- Hmm: Do we need this level of uniqueness? - let p' = p -- if reusable then p else p { usedns = n' : usedns p } + let p' = p -- if reusable then p else p { usedns = n' : usedns p } put (ES (p', a) s u) return n' where @@ -221,7 +221,7 @@ bound_in _ = [] uniqueNameCtxt :: Context -> Name -> [Name] -> Elab' aux Name -uniqueNameCtxt ctxt n hs +uniqueNameCtxt ctxt n hs | n `elem` hs = uniqueNameCtxt ctxt (nextName n) hs | [_] <- lookupTy n ctxt = uniqueNameCtxt ctxt (nextName n) hs | otherwise = return n @@ -272,7 +272,7 @@ compute :: Elab' aux () compute = processTactic' Compute -computeLet :: Name -> Elab' aux () +computeLet :: Name -> Elab' aux () computeLet n = processTactic' (ComputeLet n) simplify :: Elab' aux () @@ -326,6 +326,12 @@ movelast :: Name -> Elab' aux () movelast n = processTactic' (MoveLast n) +matchProblems :: Elab' aux () +matchProblems = processTactic' MatchProblems + +unifyProblems :: Elab' aux () +unifyProblems = processTactic' UnifyProblems + defer :: Name -> Elab' aux () defer n = do n' <- unique_hole n processTactic' (Defer n') @@ -385,7 +391,7 @@ | Var n <- fn = do ctxt <- get_context case lookupTy n ctxt of - [] -> lift $ tfail $ NoSuchVariable n + [] -> lift $ tfail $ NoSuchVariable n _ -> fail $ "Too many arguments for " ++ show fn | otherwise = fail $ "Too many arguments for " ++ show fn @@ -409,7 +415,7 @@ match_apply = apply' match_fill apply' :: (Raw -> Elab' aux ()) -> Raw -> [(Bool, Int)] -> Elab' aux [Name] -apply' fillt fn imps = +apply' fillt fn imps = do args <- prepare_apply fn (map fst imps) env <- get_env g <- goal @@ -422,20 +428,20 @@ hs <- get_holes ES (p, a) s prev <- get let dont = nub $ head hs : dontunify p ++ - if null imps then [] -- do all we can + if null imps then [] -- do all we can else map fst (filter (not.snd) (zip args (map fst imps))) - let (n, hunis) = -- trace ("AVOID UNIFY: " ++ show (fn, dont) ++ "\n" ++ show ptm) $ + let (n, hunis) = -- trace ("AVOID UNIFY: " ++ show (fn, dont) ++ "\n" ++ show ptm) $ unified p - let unify = -- trace ("Not done " ++ show hs) $ + let unify = -- trace ("Not done " ++ show hs) $ dropGiven dont hunis hs - let notunify = -- trace ("Not done " ++ show hs) $ + let notunify = -- trace ("Not done " ++ show hs) $ keepGiven dont hunis hs put (ES (p { dontunify = dont, unified = (n, unify), notunified = notunify ++ notunified p }, a) s prev) ptm <- get_term g <- goal --- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $ +-- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $ end_unify ptm <- get_term return (map (updateUnify unify) args) @@ -443,8 +449,8 @@ Just (P _ t _) -> t _ -> n -apply2 :: Raw -> [Maybe (Elab' aux ())] -> Elab' aux () -apply2 fn elabs = +apply2 :: Raw -> [Maybe (Elab' aux ())] -> Elab' aux () +apply2 fn elabs = do args <- prepare_apply fn (map isJust elabs) fill (raw_apply fn (map Var args)) elabArgs args elabs @@ -457,11 +463,11 @@ elabArgs ns es elabArgs (n:ns) (_:es) = elabArgs ns es - isJust (Just _) = False + isJust (Just _) = False isJust _ = True apply_elab :: Name -> [Maybe (Int, Elab' aux ())] -> Elab' aux () -apply_elab n args = +apply_elab n args = do ty <- get_type (Var n) ctxt <- get_context env <- get_env @@ -491,7 +497,7 @@ doClaims t [] claims = return (reverse claims) doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n - elabClaims failed r [] + elabClaims failed r [] | null failed = return () | otherwise = if r then elabClaims [] False failed else return () @@ -509,7 +515,7 @@ -- If the goal is not a Pi-type, invent some names and make it a pi type checkPiGoal :: Name -> Elab' aux () -checkPiGoal n +checkPiGoal n = do g <- goal case g of Bind _ (Pi _) _ -> return () @@ -545,8 +551,8 @@ complete_fill hs <- get_holes env <- get_env - -- We don't need a and b in the hole queue any more since they were - -- just for checking f, so discard them if they are still there. + -- We don't need a and b in the hole queue any more since they were + -- just for checking f, so discard them if they are still there. -- If they haven't been solved, regret will fail when (a `elem` hs) $ do focus a; regretWith (CantInferType appstr) when (b `elem` hs) $ do focus b; regretWith (CantInferType appstr) @@ -563,7 +569,7 @@ -- try a tactic, if it adds any unification problem, return an error no_errors :: Elab' aux () -> Elab' aux () -no_errors tac +no_errors tac = do ps <- get_probs tac ps' <- get_probs @@ -588,11 +594,11 @@ Error e1 -> if recoverableErr e1 then do case runStateT t2 s of OK (v, s') -> do put s'; return v - Error e2 -> if score e1 >= score e2 - then lift (tfail e1) + Error e2 -> if score e1 >= score e2 + then lift (tfail e1) else lift (tfail e2) else lift (tfail e1) - where recoverableErr err@(CantUnify r _ _ _ _ _) + where recoverableErr err@(CantUnify r _ _ _ _ _) = -- traceWhen r (show err) $ r || proofSearch recoverableErr (ProofSearchFail _) = False @@ -608,7 +614,7 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs) where cantResolve :: Elab' aux a - cantResolve = lift $ tfail $ CantResolveAlts (map snd xs) + cantResolve = lift $ tfail $ CantResolveAlts (map snd xs) tryAll' :: [Elab' aux a] -> -- successes Int -> -- most problems @@ -618,12 +624,12 @@ tryAll' [res] pmax _ [] = res tryAll' (_:_) pmax _ [] = cantResolve tryAll' [] pmax (f, _) [] = f - tryAll' cs pmax f (x:xs) + tryAll' cs pmax f (x:xs) = do s <- get ps <- get_probs case prunStateT pmax True ps x s of - OK ((v, newps), s') -> - do let cs' = if (newps < pmax) + OK ((v, newps), s') -> + do let cs' = if (newps < pmax) then [do put s'; return v] else (do put s'; return v) : cs tryAll' cs' newps f xs @@ -637,10 +643,10 @@ if (s >= i) then (lift (tfail err), s) else (f, i) -prunStateT pmax zok ps x s +prunStateT pmax zok ps x s = case runStateT x s of - OK (v, s'@(ES (p, _) _ _)) -> - let newps = length (problems p) - length ps + OK (v, s'@(ES (p, _) _ _)) -> + let newps = length (problems p) - length ps newpmax = if newps < 0 then 0 else newps in if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0)) then case reverse (problems p) of @@ -649,7 +655,7 @@ Error e -> Error e qshow :: Fails -> String -qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs) +qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs) dumpprobs [] = "" dumpprobs ((_,_,_,e):es) = show e ++ "\n" ++ dumpprobs es diff --git a/src/Core/Evaluate.hs b/src/Core/Evaluate.hs --- a/src/Core/Evaluate.hs +++ b/src/Core/Evaluate.hs @@ -2,15 +2,15 @@ PatternGuards #-} module Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll, - simplify, specialise, hnf, convEq, convEq', + rt_simplify, simplify, specialise, hnf, convEq, convEq', Def(..), CaseInfo(..), CaseDefs(..), Accessibility(..), Totality(..), PReason(..), Context, initContext, ctxtAlist, uconstraints, next_tvar, - addToCtxt, setAccess, setTotal, addCtxtDef, addTyDecl, + addToCtxt, setAccess, setTotal, addCtxtDef, addTyDecl, addDatatype, addCasedef, simplifyCasedef, addOperator, - lookupNames, lookupTy, lookupP, lookupDef, lookupVal, - lookupTotal, lookupTyEnv, isDConName, isTConName, isConName, isFnName, - Value(..), Quote(..), evalState, initEval) where + lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal, + lookupTotal, lookupNameTotal, lookupTyEnv, isDConName, isTConName, isConName, isFnName, + Value(..), Quote(..), initEval) where import Debug.Trace import Control.Monad.State @@ -22,13 +22,15 @@ data EvalState = ES { limited :: [(Name, Int)], nexthole :: Int } + deriving Show type Eval a = State EvalState a -data EvalOpt = Spec - | HNF - | Simplify +data EvalOpt = Spec + | HNF + | Simplify | AtREPL + | RunTT deriving (Show, Eq) initEval = ES [] 0 @@ -44,7 +46,9 @@ | VApp Value Value | VType UExp | VErased + | VImpossible | VConstant Const + | VProj Value Int -- | VLazy Env [Value] Term | VTmp Int @@ -56,19 +60,19 @@ -- THE EVALUATOR ------------------------------------------------------------ --- The environment is assumed to be "locally named" - i.e., not de Bruijn +-- The environment is assumed to be "locally named" - i.e., not de Bruijn -- indexed. -- i.e. it's an intermediate environment that we have while type checking or -- while building a proof. -- | Normalise fully type checked terms (so, assume all names/let bindings resolved) normaliseC :: Context -> Env -> TT Name -> TT Name -normaliseC ctxt env t +normaliseC ctxt env t = evalState (do val <- eval False ctxt [] env t [] quote 0 val) initEval normaliseAll :: Context -> Env -> TT Name -> TT Name -normaliseAll ctxt env t +normaliseAll ctxt env t = evalState (do val <- eval False ctxt [] env t [AtREPL] quote 0 val) initEval @@ -76,38 +80,50 @@ normalise = normaliseTrace False normaliseTrace :: Bool -> Context -> Env -> TT Name -> TT Name -normaliseTrace tr ctxt env t +normaliseTrace tr ctxt env t = evalState (do val <- eval tr ctxt [] (map finalEntry env) (finalise t) [] quote 0 val) initEval specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> TT Name -specialise ctxt env limits t - = evalState (do val <- eval False ctxt [] - (map finalEntry env) (finalise t) +specialise ctxt env limits t + = evalState (do val <- eval False ctxt [] + (map finalEntry env) (finalise t) [Spec] quote 0 val) (initEval { limited = limits }) --- | Like normalise, but we only reduce functions that are marked as okay to +-- | Like normalise, but we only reduce functions that are marked as okay to -- inline (and probably shouldn't reduce lets?) -- 20130908: now only used to reduce for totality checking. Inlining should -- be done elsewhere. simplify :: Context -> Env -> TT Name -> TT Name -simplify ctxt env t +simplify ctxt env t = evalState (do val <- eval False ctxt [(UN "lazy", 0), (UN "assert_smaller", 0), (UN "par", 0), (UN "prim__syntactic_eq", 0), - (UN "fork", 0)] - (map finalEntry env) (finalise t) + (UN "fork", 0)] + (map finalEntry env) (finalise t) [Simplify] quote 0 val) initEval +-- | Simplify for run-time (i.e. basic inlining) +rt_simplify :: Context -> Env -> TT Name -> TT Name +rt_simplify ctxt env t + = evalState (do val <- eval False ctxt [(UN "lazy", 0), + (UN "assert_smaller", 0), + (UN "par", 0), + (UN "prim__syntactic_eq", 0), + (UN "prim_fork", 0)] + (map finalEntry env) (finalise t) + [RunTT] + quote 0 val) initEval + -- | Reduce a term to head normal form hnf :: Context -> Env -> TT Name -> TT Name -hnf ctxt env t - = evalState (do val <- eval False ctxt [] - (map finalEntry env) +hnf ctxt env t + = evalState (do val <- eval False ctxt [] + (map finalEntry env) (finalise t) [HNF] quote 0 val) initEval @@ -136,7 +152,7 @@ Just 0 -> return (False, ns) Just i -> return (True, ns) _ -> return (False, ns) -usable False n ns +usable False n ns = case lookup n ns of Just 0 -> return (False, ns) Just i -> return $ (True, (n, abs (i-1)) : filter (\ (n', _) -> n/=n') ns) @@ -157,58 +173,67 @@ -- a name. The corresponding pair in the state is the maximum number of -- unfoldings overall. -eval :: Bool -> Context -> [(Name, Int)] -> Env -> TT Name -> +eval :: Bool -> Context -> [(Name, Int)] -> Env -> TT Name -> [EvalOpt] -> Eval Value eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where spec = Spec `elem` opts - simpl = Simplify `elem` opts + simpl = Simplify `elem` opts + runtime = RunTT `elem` opts atRepl = AtREPL `elem` opts hnf = HNF `elem` opts -- returns 'True' if the function should block -- normal evaluation should return false - blockSimplify (CaseInfo inl dict) n stk - | Simplify `elem` opts + blockSimplify (CaseInfo inl dict) n stk + | RunTT `elem` opts + = not (inl || dict) || elem n stk + | Simplify `elem` opts = (not (inl || dict) || elem n stk) || (n == UN "prim__syntactic_eq") | otherwise = False + getCases cd | simpl = cases_totcheck cd + | runtime = cases_runtime cd + | otherwise = cases_compiletime cd + ev ntimes stk top env (P _ n ty) - | Just (Let t v) <- lookup n genv = ev ntimes stk top env v - ev ntimes_in stk top env (P Ref n ty) + | Just (Let t v) <- lookup n genv = ev ntimes stk top env v + ev ntimes_in stk top env (P Ref n ty) | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty) - | otherwise + | otherwise = do (u, ntimes) <- usable spec n ntimes_in if u then - do let val = lookupDefAcc n atRepl ctxt + do let val = lookupDefAcc n (spec || atRepl) ctxt case val of - [(Function _ tm, Public)] -> + [(Function _ tm, Public)] -> ev ntimes (n:stk) True env tm + [(Function _ tm, Hidden)] -> + ev ntimes (n:stk) True env tm [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty return $ VP nt n vty - [(CaseOp ci _ _ _ cd, acc)] - | acc == Public && + [(CaseOp ci _ _ _ cd, acc)] + | (acc /= Frozen) && null (fst (cases_totcheck cd)) -> -- unoptimised version - let (_, tree) = if simpl then cases_totcheck cd - else cases_compiletime cd in + let (ns, tree) = getCases cd in if blockSimplify ci n stk then liftM (VP Ref n) (ev ntimes stk top env ty) - else do c <- evCase ntimes n (n:stk) top env [] [] tree + else -- traceWhen runtime (show (n, ns, tree)) $ + do c <- evCase ntimes n (n:stk) top env ns [] tree case c of (Nothing, _) -> liftM (VP Ref n) (ev ntimes stk top env ty) (Just v, _) -> return v _ -> liftM (VP Ref n) (ev ntimes stk top env ty) else liftM (VP Ref n) (ev ntimes stk top env ty) - ev ntimes stk top env (P nt n ty) + ev ntimes stk top env (P nt n ty) = liftM (VP nt n) (ev ntimes stk top env ty) - ev ntimes stk top env (V i) + ev ntimes stk top env (V i) | i < length env && i >= 0 = return $ env !! i - | otherwise = return $ VV i + | otherwise = return $ VV i ev ntimes stk top env (Bind n (Let t v) sc) = do v' <- ev ntimes stk top env v --(finalise v) sc' <- ev ntimes stk top (v' : env) sc wknV (-1) sc' --- | otherwise +-- | otherwise -- = do t' <- ev ntimes stk top env t -- v' <- ev ntimes stk top env v --(finalise v) -- -- use Tmp as a placeholder, then make it a variable reference @@ -223,49 +248,74 @@ v' <- ev ntimes stk top env (finalise v) sc' <- ev ntimes stk top (v' : env) sc return $ VBind True n (Let t' v') (\x -> return sc') - ev ntimes stk top env (Bind n b sc) + ev ntimes stk top env (Bind n b sc) = do b' <- vbind env b return $ VBind True -- (vinstances 0 sc < 2) n b' (\x -> ev ntimes stk False (x:env) sc) - where vbind env t --- | simpl --- = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes) --- stk top env (finalise tm)) t --- | otherwise + where vbind env t +-- | simpl +-- = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes) +-- stk top env (finalise tm)) t +-- | otherwise = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t - ev ntimes stk top env (App f a) + ev ntimes stk top env (App f a) = do f' <- ev ntimes stk False env f a' <- ev ntimes stk False env a evApply ntimes stk top env [a'] f' + ev ntimes stk top env (Proj t i) + = do -- evaluate dictionaries if it means the projection works + t' <- ev ntimes stk top env t +-- tfull' <- reapply ntimes stk top env t' [] + return (doProj t' (getValArgs t')) + where doProj t' (VP (DCon _ _) _ _, args) | i < length args = args!!i + doProj t' _ = VProj t' i + ev ntimes stk top env (Constant c) = return $ VConstant c ev ntimes stk top env Erased = return VErased + ev ntimes stk top env Impossible = return VImpossible ev ntimes stk top env (TType i) = return $ VType i - + evApply ntimes stk top env args (VApp f a) = evApply ntimes stk top env (a:args) f - evApply ntimes stk top env args f + evApply ntimes stk top env args f = apply ntimes stk top env f args - apply ntimes stk top env (VBind True n (Lam t) sc) (a:as) + reapply ntimes stk top env f@(VP Ref n ty) args + = let val = lookupDefAcc n (spec || atRepl) ctxt in + case val of + [(CaseOp ci _ _ _ cd, acc)] -> + let (ns, tree) = getCases cd in + do c <- evCase ntimes n (n:stk) top env ns args tree + case c of + (Nothing, _) -> return $ unload env (VP Ref n ty) args + (Just v, rest) -> evApply ntimes stk top env rest v + _ -> case args of + (a : as) -> return $ unload env f (a : as) + [] -> return f + reapply ntimes stk top env (VApp f a) args + = reapply ntimes stk top env f (a : args) + reapply ntimes stk top env v args = return v + + apply ntimes stk top env (VBind True n (Lam t) sc) (a:as) = do a' <- sc a - app <- apply ntimes stk top env a' as + app <- apply ntimes stk top env a' as wknV (-1) app apply ntimes_in stk top env f@(VP Ref n ty) args | not top && hnf = case args of [] -> return f _ -> return $ unload env f args - | otherwise + | otherwise = do (u, ntimes) <- usable spec n ntimes_in - if u then - do let val = lookupDefAcc n atRepl ctxt + if u then + do let val = lookupDefAcc n (spec || atRepl) ctxt case val of [(CaseOp ci _ _ _ cd, acc)] - | acc == Public -> -- unoptimised version - let (ns, tree) = if simpl then cases_totcheck cd - else cases_compiletime cd in + | acc /= Frozen -> -- unoptimised version + let (ns, tree) = getCases cd in if blockSimplify ci n stk then return $ unload env (VP Ref n ty) args - else do c <- evCase ntimes n (n:stk) top env ns args tree + else -- traceWhen runtime (show (n, ns, tree)) $ + do c <- evCase ntimes n (n:stk) top env ns args tree case c of (Nothing, _) -> return $ unload env (VP Ref n ty) args (Just v, rest) -> evApply ntimes stk top env rest v @@ -286,19 +336,19 @@ -- specApply stk env f@(VP Ref n ty) args -- = case lookupCtxt n statics of --- [as] -> if or as --- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $ +-- [as] -> if or as +-- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $ -- return $ unload env f args -- else return $ unload env f args -- _ -> return $ unload env f args -- specApply stk env f args = return $ unload env f args - unload :: [Value] -> Value -> [Value] -> Value + unload :: [Value] -> Value -> [Value] -> Value unload env f [] = f unload env f (a:as) = unload env (VApp f a) as evCase ntimes n stk top env ns args tree - | length ns <= length args + | length ns <= length args = do let args' = take (length ns) args let rest = drop (length ns) args when spec $ deduct n -- successful, so deduct usages @@ -307,27 +357,33 @@ return (t, rest) | otherwise = return (Nothing, args) - evTree :: [(Name, Int)] -> [Name] -> Bool -> + evTree :: [(Name, Int)] -> [Name] -> Bool -> [Value] -> [(Name, Value)] -> SC -> Eval (Maybe Value) evTree ntimes stk top env amap (UnmatchedCase str) = return Nothing - evTree ntimes stk top env amap (STerm tm) + evTree ntimes stk top env amap (STerm tm) = do let etm = pToVs (map fst amap) tm - etm' <- ev ntimes stk (not (conHeaded tm)) + etm' <- ev ntimes stk (not (conHeaded tm)) (map snd amap ++ env) etm return $ Just etm' + evTree ntimes stk top env amap (ProjCase t alts) + = do t' <- ev ntimes stk top env t + doCase ntimes stk top env amap t' alts evTree ntimes stk top env amap (Case n alts) = case lookup n amap of - Just v -> do c <- chooseAlt env v (getValArgs v) alts amap - case c of - Just (altmap, sc) -> evTree ntimes stk top env altmap sc - _ -> do c' <- chooseAlt' ntimes stk env v (getValArgs v) alts amap - case c' of - Just (altmap, sc) -> evTree ntimes stk top env altmap sc - _ -> return Nothing + Just v -> doCase ntimes stk top env amap v alts _ -> return Nothing evTree ntimes stk top env amap ImpossibleCase = return Nothing - conHeaded tm@(App _ _) + doCase ntimes stk top env amap v alts = + do c <- chooseAlt env v (getValArgs v) alts amap + case c of + Just (altmap, sc) -> evTree ntimes stk top env altmap sc + _ -> do c' <- chooseAlt' ntimes stk env v (getValArgs v) alts amap + case c' of + Just (altmap, sc) -> evTree ntimes stk top env altmap sc + _ -> return Nothing + + conHeaded tm@(App _ _) | (P (DCon _ _) _ _, args) <- unApply tm = True conHeaded t = False @@ -336,14 +392,14 @@ chooseAlt env f' (getValArgs f') alts amap - chooseAlt :: [Value] -> Value -> (Value, [Value]) -> [CaseAlt] -> + chooseAlt :: [Value] -> Value -> (Value, [Value]) -> [CaseAlt] -> [(Name, Value)] -> Eval (Maybe ([(Name, Value)], SC)) chooseAlt env _ (VP (DCon i a) _ _, args) alts amap | Just (ns, sc) <- findTag i alts = return $ Just (updateAmap (zip ns args) amap, sc) | Just v <- findDefault alts = return $ Just (amap, v) chooseAlt env _ (VP (TCon i a) _ _, args) alts amap - | Just (ns, sc) <- findTag i alts + | Just (ns, sc) <- findTag i alts = return $ Just (updateAmap (zip ns args) amap, sc) | Just v <- findDefault alts = return $ Just (amap, v) chooseAlt env _ (VConstant c, []) alts amap @@ -358,7 +414,7 @@ = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern return $ Just (updateAmap (zip ns [s, t']) amap, sc) chooseAlt _ _ _ alts amap - | Just v <- findDefault alts + | Just v <- findDefault alts = if (any fnCase alts) then return $ Just (amap, v) else return Nothing @@ -370,7 +426,7 @@ -- Replace old variable names in the map with new matches -- (This is possibly unnecessary since we make unique names and don't -- allow repeated variables...?) - updateAmap newm amap + updateAmap newm amap = newm ++ filter (\ (x, _) -> not (elem x (map fst newm))) amap findTag i [] = Nothing findTag i (ConCase n j ns sc : xs) | i == j = Just (ns, sc) @@ -382,7 +438,7 @@ findDefault [] = Nothing findDefault (DefaultCase sc : xs) = Just sc - findDefault (_ : xs) = findDefault xs + findDefault (_ : xs) = findDefault xs findSuc c [] = Nothing findSuc (BI val) (SucCase n sc : _) @@ -393,10 +449,10 @@ findConst c (ConstCase c' v : xs) | c == c' = Just v findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v findConst (AType ATFloat) (ConCase n 2 [] v : xs) = Just v - findConst (AType (ATInt ITChar)) (ConCase n 3 [] v : xs) = Just v - findConst StrType (ConCase n 4 [] v : xs) = Just v + findConst (AType (ATInt ITChar)) (ConCase n 3 [] v : xs) = Just v + findConst StrType (ConCase n 4 [] v : xs) = Just v findConst PtrType (ConCase n 5 [] v : xs) = Just v - findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v + findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v findConst (AType (ATInt (ITFixed ity))) (ConCase n tag [] v : xs) | tag == 7 + fromEnum ity = Just v findConst (AType (ATInt (ITVec ity count))) (ConCase n tag [] v : xs) @@ -430,7 +486,7 @@ b' <- quoteB b liftM (Bind n b') (quote (i+1) sc') where quoteB t = fmapMB (quote i) t - quote i (VBLet vd n t v sc) + quote i (VBLet vd n t v sc) = do sc' <- quote i sc t' <- quote i t v' <- quote i v @@ -439,6 +495,9 @@ quote i (VApp f a) = liftM2 App (quote i f) (quote i a) quote i (VType u) = return $ TType u quote i VErased = return $ Erased + quote i VImpossible = return $ Impossible + quote i (VProj v j) = do v' <- quote i v + return (Proj v' j) quote i (VConstant c) = return $ Constant c quote i (VTmp x) = return $ V (i - x - 1) @@ -455,7 +514,7 @@ convEq :: Context -> TT Name -> TT Name -> StateT UCs TC Bool convEq ctxt = ceq [] where ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs TC Bool - ceq ps (P xt x _) (P yt y _) + ceq ps (P xt x _) (P yt y _) | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True | otherwise = sameDefs ps x y ceq ps x (Bind n (Lam t) (App y (V 0))) = ceq ps x y @@ -465,9 +524,9 @@ ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y | n == n' = ceq ps x y ceq ps (V x) (V y) = return (x == y) - ceq ps (Bind _ xb xs) (Bind _ yb ys) + ceq ps (Bind _ xb xs) (Bind _ yb ys) = liftM2 (&&) (ceqB ps xb yb) (ceq ps xs ys) - where + where ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') ceqB ps b b' = ceq ps (binderTy b) (binderTy b') @@ -501,7 +560,7 @@ sameDefs ps x y = case (lookupDef x ctxt, lookupDef y ctxt) of ([Function _ xdef], [Function _ ydef]) -> ceq ((x,y):ps) xdef ydef - ([CaseOp _ _ _ _ xd], + ([CaseOp _ _ _ _ xd], [CaseOp _ _ _ _ yd]) -> let (_, xdef) = cases_compiletime xd (_, ydef) = cases_compiletime yd in @@ -509,36 +568,36 @@ _ -> return False -- SPECIALISATION ----------------------------------------------------------- --- We need too much control to be able to do this by tweaking the main +-- We need too much control to be able to do this by tweaking the main -- evaluator spec :: Context -> Ctxt [Bool] -> Env -> TT Name -> Eval (TT Name) -spec ctxt statics genv tm = error "spec undefined" +spec ctxt statics genv tm = error "spec undefined" -- CONTEXTS ----------------------------------------------------------------- {-| A definition is either a simple function (just an expression with a type), a constant, which could be a data or type constructor, an axiom or as an yet undefined function, or an Operator. - An Operator is a function which explains how to reduce. + An Operator is a function which explains how to reduce. A CaseOp is a function defined by a simple case tree -} - -data Def = Function Type Term - | TyDecl NameType Type + +data Def = Function !Type !Term + | TyDecl NameType !Type | Operator Type Int ([Value] -> Maybe Value) - | CaseOp CaseInfo - Type - [Either Term (Term, Term)] -- original definition - [([Name], Term, Term)] -- simplified for totality check definition - CaseDefs + | CaseOp CaseInfo + !Type + ![Either Term (Term, Term)] -- original definition + ![([Name], Term, Term)] -- simplified for totality check definition + !CaseDefs -- [Name] SC -- Compile time case definition -- [Name] SC -- Run time cae definitions data CaseDefs = CaseDefs { - cases_totcheck :: ([Name], SC), - cases_compiletime :: ([Name], SC), - cases_inlined :: ([Name], SC), - cases_runtime :: ([Name], SC) + cases_totcheck :: !([Name], SC), + cases_compiletime :: !([Name], SC), + cases_inlined :: !([Name], SC), + cases_runtime :: !([Name], SC) } data CaseInfo = CaseInfo { @@ -546,13 +605,13 @@ tc_dictionary :: Bool } -{-! -deriving instance Binary Def +{-! +deriving instance Binary Def !-} -{-! +{-! deriving instance Binary CaseInfo !-} -{-! +{-! deriving instance Binary CaseDefs !-} @@ -560,11 +619,11 @@ 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 (CaseInfo inlc inlr) ty ps_in ps cd) + show (CaseOp (CaseInfo inlc inlr) ty ps_in ps cd) = let (ns, sc) = cases_compiletime cd - (ns_t, sc_t) = cases_totcheck cd + (ns_t, sc_t) = cases_totcheck cd (ns', sc') = cases_runtime cd in - "Case: " ++ show ty ++ " " ++ show ps ++ "\n" ++ + "Case: " ++ show ty ++ " " ++ show ps ++ "\n" ++ "TOTALITY CHECK TIME:\n\n" ++ show ns_t ++ " " ++ show sc_t ++ "\n\n" ++ "COMPILE TIME:\n\n" ++ @@ -580,7 +639,7 @@ put x = return () get = error "Getting a function" -------- +------- -- Frozen => doesn't reduce -- Hidden => doesn't reduce and invisible to type checker @@ -610,7 +669,7 @@ show (Partial NotProductive) = "not productive" show (Partial BelieveMe) = "not total due to use of believe_me in proof" show (Partial (Other ns)) = "possibly not total due to: " ++ showSep ", " (map show ns) - show (Partial (Mutual ns)) = "possibly not total due to recursive path " ++ + show (Partial (Mutual ns)) = "possibly not total due to recursive path " ++ showSep " --> " (map show ns) {-! @@ -627,10 +686,10 @@ -- | Contexts used for global definitions and for proof state. They contain -- universe constraints and existing definitions. -data Context = MkContext { +data Context = MkContext { uconstraints :: [UConstraint], next_tvar :: Int, - definitions :: Ctxt (Def, Accessibility, Totality) + definitions :: Ctxt (Def, Accessibility, Totality) } deriving Show -- | The initial empty context @@ -643,10 +702,10 @@ veval ctxt env t = evalState (eval False ctxt [] env t []) initEval addToCtxt :: Name -> Term -> Type -> Context -> Context -addToCtxt n tm ty uctxt - = let ctxt = definitions uctxt +addToCtxt n tm ty uctxt + = let ctxt = definitions uctxt ctxt' = addDef n (Function ty tm, Public, Unchecked) ctxt in - uctxt { definitions = ctxt' } + uctxt { definitions = ctxt' } setAccess :: Name -> Accessibility -> Context -> Context setAccess n a uctxt @@ -662,58 +721,58 @@ addCtxtDef :: Name -> Def -> Context -> Context addCtxtDef n d c = let ctxt = definitions c - ctxt' = addDef n (d, Public, Unchecked) ctxt in + ctxt' = addDef n (d, Public, Unchecked) $! ctxt in c { definitions = ctxt' } addTyDecl :: Name -> NameType -> Type -> Context -> Context -addTyDecl n nt ty uctxt +addTyDecl n nt ty uctxt = let ctxt = definitions uctxt ctxt' = addDef n (TyDecl nt ty, Public, Unchecked) ctxt in uctxt { definitions = ctxt' } addDatatype :: Datatype Name -> Context -> Context addDatatype (Data n tag ty cons) uctxt - = let ctxt = definitions uctxt + = let ctxt = definitions uctxt ty' = normalise uctxt [] ty - ctxt' = addCons 0 cons (addDef n + ctxt' = addCons 0 cons (addDef n (TyDecl (TCon tag (arity ty')) ty, Public, Unchecked) ctxt) in uctxt { definitions = ctxt' } where addCons tag [] ctxt = ctxt - addCons tag ((n, ty) : cons) ctxt + addCons tag ((n, ty) : cons) ctxt = let ty' = normalise uctxt [] ty in addCons (tag+1) cons (addDef n (TyDecl (DCon tag (arity ty')) ty, Public, Unchecked) ctxt) -- FIXME: Too many arguments! Refactor all these Bools. addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool -> - [Either Term (Term, Term)] -> + [Either Term (Term, Term)] -> [([Name], Term, Term)] -> -- totality [([Name], Term, Term)] -> -- compile time - [([Name], Term, Term)] -> -- inlined + [([Name], Term, Term)] -> -- inlined [([Name], Term, Term)] -> -- run time Type -> Context -> Context addCasedef n ci@(CaseInfo alwaysInline tcdict) - tcase covering reflect asserted ps_in - ps_tot ps_inl ps_ct ps_rt ty uctxt + tcase covering reflect asserted ps_in + ps_tot ps_inl ps_ct ps_rt ty uctxt = let ctxt = definitions uctxt access = case lookupDefAcc n False uctxt of [(_, acc)] -> acc _ -> Public - ctxt' = case (simpleCase tcase covering reflect CompileTime (FC "" 0) ps_tot, - simpleCase tcase covering reflect CompileTime (FC "" 0) ps_ct, - simpleCase tcase covering reflect CompileTime (FC "" 0) ps_inl, - simpleCase tcase covering reflect RunTime (FC "" 0) ps_rt) of - (OK (CaseDef args_tot sc_tot _), + ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC ps_tot, + simpleCase tcase covering reflect CompileTime emptyFC ps_ct, + simpleCase tcase covering reflect CompileTime emptyFC ps_inl, + simpleCase tcase covering reflect RunTime emptyFC ps_rt) of + (OK (CaseDef args_tot sc_tot _), OK (CaseDef args_ct sc_ct _), OK (CaseDef args_inl sc_inl _), - OK (CaseDef args_rt sc_rt _)) -> + OK (CaseDef args_rt sc_rt _)) -> let inl = alwaysInline -- || tcdict - inlc = (inl || small n args_ct sc_ct) && (not asserted) + inlc = (inl || small n args_ct sc_ct) && (not asserted) inlr = inl || small n args_rt sc_rt - cdef = CaseDefs (args_tot, sc_tot) - (args_ct, sc_ct) - (args_inl, sc_inl) + cdef = CaseDefs (args_tot, sc_tot) + (args_ct, sc_ct) + (args_inl, sc_inl) (args_rt, sc_rt) in addDef n (CaseOp (ci { case_inlinable = inlc }) ty ps_in ps_tot cdef, @@ -730,19 +789,19 @@ [(CaseOp ci ty ps_in ps cd, acc, tot)] -> let ps_in' = map simpl ps_in pdef = map debind ps_in' in - case simpleCase False True False CompileTime (FC "" 0) pdef of + case simpleCase False True False CompileTime emptyFC pdef of OK (CaseDef args sc _) -> - addDef n (CaseOp ci + addDef n (CaseOp ci ty ps_in' ps (cd { cases_totcheck = (args, sc) }), - acc, tot) ctxt + acc, tot) ctxt Error err -> error (show err) _ -> ctxt in uctxt { definitions = ctxt' } - where - depat acc (Bind n (PVar t) sc) + 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 + 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 @@ -750,10 +809,10 @@ simpl (Right (x, y)) = Right (x, simplify uctxt [] y) simpl t = t -addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) -> +addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) -> Context -> Context addOperator n ty a op uctxt - = let ctxt = definitions uctxt + = let ctxt = definitions uctxt ctxt' = addDef n (Operator ty a op, Public, Unchecked) ctxt in uctxt { definitions = ctxt' } @@ -826,6 +885,10 @@ lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt) where mkt (d, a, t) = t +lookupNameTotal :: Name -> Context -> [(Name, Totality)] +lookupNameTotal n = map (\(n, (_, _, t)) -> (n, t)) . lookupCtxtName n . definitions + + lookupVal :: Name -> Context -> [Value] lookupVal n ctxt = do def <- lookupCtxt n (definitions ctxt) @@ -836,7 +899,7 @@ lookupTyEnv :: Name -> Env -> Maybe (Int, Type) lookupTyEnv n env = li n 0 env where li n i [] = Nothing - li n i ((x, b): xs) + li n i ((x, b): xs) | n == x = Just (i, binderTy b) | otherwise = li n (i+1) xs diff --git a/src/Core/Execute.hs b/src/Core/Execute.hs --- a/src/Core/Execute.hs +++ b/src/Core/Execute.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards, ExistentialQuantification #-} +{-# LANGUAGE PatternGuards, ExistentialQuantification, CPP #-} module Core.Execute (execute) where import Idris.AbsSyntax @@ -25,13 +25,20 @@ import Data.Bits import qualified Data.Map as M +#ifdef IDRIS_FFI import Foreign.LibFFI import Foreign.C.String import Foreign.Marshal.Alloc (free) import Foreign.Ptr +#endif import System.IO +#ifndef IDRIS_FFI +execute :: Term -> Idris Term +execute tm = fail "libffi not supported, rebuild Idris with -f FFI" +#else +-- else is rest of file readMay :: (Read a) => String -> Maybe a readMay s = case reads s of [(x, "")] -> Just x @@ -79,7 +86,7 @@ fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2 fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2 fixBinder (Hole t) = Hole <$> toTT t - fixBinder (GHole t) = GHole <$> toTT t + fixBinder (GHole i t) = GHole i <$> toTT t fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2 fixBinder (PVar t) = PVar <$> toTT t fixBinder (PVTy t) = PVTy <$> toTT t @@ -159,8 +166,8 @@ execute :: Term -> Idris Term execute tm = do est <- initState ctxt <- getContext - res <- lift $ flip runExec est $ do res <- doExec [] ctxt tm - toTT res + res <- lift . lift $ flip runExec est $ do res <- doExec [] ctxt tm + toTT res case res of Left err -> fail err Right tm' -> return tm' @@ -241,15 +248,15 @@ -- Special cases arising from not having access to the C RTS in the interpreter execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str arg):_:rest) - | Just (FFun "putStr" _ _) <- foreignFromTT fn + | Just (FFun "putStr" _ _) <- foreignFromTT fn = do execIO (putStr arg) execApp' env ctxt ioUnit rest execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:_:EHandle h:_:rest) - | Just (FFun "idris_readStr" _ _) <- foreignFromTT fn + | Just (FFun "idris_readStr" _ _) <- foreignFromTT fn = do contents <- execIO $ hGetLine h execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest) - | Just (FFun "fileOpen" _ _) <- foreignFromTT fn + | Just (FFun "fileOpen" _ _) <- foreignFromTT fn = do m <- case mode of "r" -> return ReadMode "w" -> return WriteMode @@ -262,25 +269,25 @@ execApp' env ctxt (ioWrap (EHandle h)) (tail rest) execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest) - | Just (FFun "fileEOF" _ _) <- foreignFromTT fn + | Just (FFun "fileEOF" _ _) <- foreignFromTT fn = do eofp <- execIO $ hIsEOF h let res = ioWrap (EConstant (I $ if eofp then 1 else 0)) execApp' env ctxt res (tail rest) execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest) - | Just (FFun "fileClose" _ _) <- foreignFromTT fn + | Just (FFun "fileClose" _ _) <- foreignFromTT fn = do execIO $ hClose h execApp' env ctxt ioUnit (tail rest) execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EPtr p):rest) - | Just (FFun "isNull" _ _) <- foreignFromTT fn + | Just (FFun "isNull" _ _) <- foreignFromTT fn = let res = ioWrap . EConstant . I $ if p == nullPtr then 1 else 0 in execApp' env ctxt res (tail rest) -- Throw away the 'World' argument to the foreign function -execApp' env ctxt f@(EP _ (UN "mkForeignPrim") _) args@(ty:fn:xs) +execApp' env ctxt f@(EP _ (UN "mkForeignPrim") _) args@(ty:fn:xs) | Just (FFun f argTs retT) <- foreignFromTT fn , length xs >= length argTs = do let (args', xs') = (take (length argTs) xs, -- foreign args @@ -409,10 +416,7 @@ call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal) call (FFun name argTypes retType) args = do fn <- findForeign name - case fn of - Nothing -> return Nothing - Just f -> do res <- call' f args retType - return . Just . ioWrap $ res + maybe (return Nothing) (\f -> Just . ioWrap <$> call' f args retType) fn where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal call' (Fun _ h) args (FArith (ATInt ITNative)) = do res <- execIO $ callFFI h retCInt (prepArgs args) @@ -440,10 +444,9 @@ -- lift $ free res return (EConstant (Str hStr)) - call' (Fun _ h) args FPtr = do res <- execIO $ callFFI h (retPtr retVoid) (prepArgs args) - return (EPtr res) - call' (Fun _ h) args FUnit = do res <- execIO $ callFFI h retVoid (prepArgs args) - return (EP Ref unitCon EErased) + call' (Fun _ h) args FPtr = EPtr <$> (execIO $ callFFI h (retPtr retVoid) (prepArgs args)) + call' (Fun _ h) args FUnit = do _ <- execIO $ callFFI h retVoid (prepArgs args) + return $ EP Ref unitCon EErased -- call' (Fun _ h) args other = fail ("Unsupported foreign return type " ++ show other) @@ -511,21 +514,16 @@ toConst _ = Nothing stepForeign :: [ExecVal] -> Exec (Maybe ExecVal) -stepForeign (ty:fn:args) = do let ffun = foreignFromTT fn - f' <- case (call <$> ffun) of - Just f -> f args - Nothing -> return Nothing - return f' +stepForeign (ty:fn:args) = let ffun = foreignFromTT fn + in case (call <$> ffun) of + Just f -> f args + Nothing -> return Nothing stepForeign _ = fail "Tried to call foreign function that wasn't mkForeignPrim" -mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM :: (Functor m, Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f [] = return [] mapMaybeM f (x:xs) = do rest <- mapMaybeM f xs - x' <- f x - case x' of - Just x'' -> return (x'':rest) - Nothing -> return rest - + maybe rest (:rest) <$> f x findForeign :: String -> Exec (Maybe ForeignFun) findForeign fn = do est <- getExecState let libs = exec_dynamic_libs est @@ -538,3 +536,5 @@ show (length fs) ++ " occurrences." return Nothing where getFn lib = execIO $ catchIO (tryLoadFn fn lib) (\_ -> return Nothing) + +#endif diff --git a/src/Core/ProofShell.hs b/src/Core/ProofShell.hs deleted file mode 100644 --- a/src/Core/ProofShell.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-} - -module Core.ProofShell where - -import Core.Typecheck -import Core.Evaluate -import Core.TT -import Core.ShellParser -import Core.Elaborate - -import Control.Monad.State -import System.Console.Haskeline - -import Idris.AbsSyntaxTree (Idris) - -import Util.Pretty - -data ShellState = ShellState - { ctxt :: Context, - prf :: Maybe ProofState, - deferred :: [(Name, ProofState)], - exitNow :: Bool - } - -initState c = ShellState c Nothing [] False - -processCommand :: Command -> ShellState -> (ShellState, String) -processCommand (Theorem n ty) state - = case check (ctxt state) [] ty of - OK (gl, t) -> - case isType (ctxt state) [] t of - OK _ -> (state { prf = Just (newProof n (ctxt state) gl) }, "") - _ -> (state, "Goal is not a type") - err -> (state, show err) -processCommand Quit state = (state { exitNow = True }, "Bye bye") -processCommand (Eval t) state = - case check (ctxt state) [] t of - OK (val, ty) -> - let nf = normalise (ctxt state) [] val - tnf = normalise (ctxt state) [] ty in - (state, show nf ++ " : " ++ show ty) - err -> (state, show err) -processCommand (Print n) state = - case lookupDef n (ctxt state) of - [tm] -> (state, show tm) - _ -> (state, "No such name") -processCommand (Tac e) state - | Just ps <- prf state = case execElab () e ps of - OK (ES (ps', _) resp _) -> - if (not (done ps')) - then (state { prf = Just ps' }, resp) - else (state { prf = Nothing, - ctxt = addToCtxt (thname ps') - (pterm ps') - (ptype ps') - (context ps') }, resp) - err -> (state, show err) - | otherwise = (state, "No proof in progress") - -runShell :: ShellState -> Idris ShellState -runShell st = runInputT defaultSettings $ runShell' st - where - runShell' st = do (prompt, parser) <- - maybe (return ("TT# ", parseCommand)) - (\st -> do outputStrLn . render . pretty $ st - return (show (thname st) ++ "# ", parseTactic)) - (prf st) - x <- getInputLine prompt - cmd <- case x of - Nothing -> return $ Right Quit - Just input -> return (parser input) - case cmd of - Left err -> do outputStrLn (show err) - runShell' st - Right cmd -> do let (st', r) = processCommand cmd st - outputStrLn r - if (not (exitNow st')) then runShell' st' - else return st' - 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, + Tactic(..), Goal(..), processTactic, dropGiven, keepGiven) where import Core.Typecheck @@ -31,7 +31,7 @@ notunified :: [(Name, Term)], solved :: Maybe (Name, Term), problems :: Fails, - injective :: [Name], + injective :: [Name], deferred :: [Name], -- names we'll need to define instances :: [Name], -- instance arguments (for type classes) previous :: Maybe ProofState, -- for undo @@ -40,7 +40,7 @@ unifylog :: Bool, done :: Bool } - + data Goal = GD { premises :: Env, goalType :: Binder Term } @@ -78,6 +78,8 @@ | Instance Name | SetInjective Name | MoveLast Name + | MatchProblems + | UnifyProblems | ProofState | Undo | QED @@ -86,27 +88,27 @@ -- Some utilites on proof and tactic states instance Show ProofState where - show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _) + show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals" - show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _) + show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _) = let OK g = goal (Just h) tm wkenv = premises g in "Other goals: " ++ show hs ++ "\n" ++ showPs wkenv (reverse wkenv) ++ "\n" ++ - "-------------------------------- (" ++ show nm ++ + "-------------------------------- (" ++ show nm ++ ") -------\n " ++ show h ++ " : " ++ showG wkenv (goalType g) ++ "\n" where showPs env [] = "" - showPs env ((n, Let t v):bs) - = " " ++ show n ++ " : " ++ + showPs env ((n, Let t v):bs) + = " " ++ show n ++ " : " ++ showEnv env ({- normalise ctxt env -} t) ++ " = " ++ showEnv env ({- normalise ctxt env -} v) ++ "\n" ++ showPs env bs - showPs env ((n, b):bs) - = " " ++ show n ++ " : " ++ - showEnv env ({- normalise ctxt env -} (binderTy b)) ++ + showPs env ((n, b):bs) + = " " ++ show n ++ " : " ++ + showEnv env ({- normalise ctxt env -} (binderTy b)) ++ "\n" ++ showPs env bs - showG ps (Guess t v) = showEnv ps ({- normalise ctxt ps -} t) ++ + showG ps (Guess t v) = showEnv ps ({- normalise ctxt ps -} t) ++ " =?= " ++ showEnv ps v showG ps b = showEnv ps (binderTy b) @@ -128,7 +130,7 @@ if size v > breakingSize then prettyEnv ps t <+> text "=?=" $$ nest nestingSize (prettyEnv ps v) - else + else prettyEnv ps t <+> text "=?=" <+> prettyEnv ps v prettyGoal ps b = prettyEnv ps $ binderTy b @@ -156,14 +158,14 @@ hole (Guess _ _) = True hole _ = False -holeName i = MN i "hole" +holeName i = MN i "hole" qshow :: Fails -> String -qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs) +qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs) -match_unify' :: Context -> Env -> TT Name -> TT Name -> +match_unify' :: Context -> Env -> TT Name -> TT Name -> StateT TState TC [(Name, TT Name)] -match_unify' ctxt env topx topy = +match_unify' ctxt env topx topy = do ps <- get let dont = dontunify ps u <- lift $ match_unify ctxt env topx topy dont (holes ps) @@ -171,34 +173,34 @@ put (ps { unified = (h, u ++ ns) }) return u -unify' :: Context -> Env -> TT Name -> TT Name -> +unify' :: Context -> Env -> TT Name -> TT Name -> StateT TState TC [(Name, TT Name)] -unify' ctxt env topx topy = +unify' ctxt env topx topy = do ps <- get let dont = dontunify ps - (u, fails) <- traceWhen (unifylog ps) + (u, fails) <- traceWhen (unifylog ps) ("Trying " ++ show (topx, topy) ++ - " in " ++ show env ++ - "\nHoles: " ++ show (holes ps) ++ "\n") $ + " in " ++ show env ++ + "\nHoles: " ++ show (holes ps) ++ "\n") $ lift $ unify ctxt env topx topy dont (holes ps) traceWhen (unifylog ps) ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++ - "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails + "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails ++ "\nCurrent problems:\n" ++ qshow (problems ps) --- ++ show (pterm ps) +-- ++ show (pterm ps) ++ "\n----------") $ case fails of -- [] -> return u - err -> + err -> do ps <- get let (h, ns) = unified ps - let (ns', probs') = updateProblems (context ps) (u ++ ns) + let (ns', probs') = updateProblems (context ps) (u ++ ns) (err ++ problems ps) (injective ps) (holes ps) put (ps { problems = probs', unified = (h, ns') }) - return u + return u getName :: Monad m => String -> StateT TState m Name getName tag = do ps <- get @@ -214,9 +216,9 @@ addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" }) newProof :: Name -> Context -> Type -> ProofState -newProof n ctxt ty = let h = holeName 0 +newProof n ctxt ty = let h = holeName 0 ty' = vToP ty in - PS n [h] [] 1 (Bind h (Hole ty') + PS n [h] [] 1 (Bind h (Hole ty') (P Bound h ty')) ty [] (h, []) [] Nothing [] [] [] [] @@ -227,7 +229,7 @@ type Hole = Maybe Name -- Nothing = default hole, first in list in proof state envAtFocus :: ProofState -> TC Env -envAtFocus ps +envAtFocus ps | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps) return (premises g) | otherwise = fail "No holes" @@ -236,16 +238,16 @@ goalAtFocus ps | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps) return (goalType g) - | otherwise = error $ "No goal in " ++ show (holes ps) ++ show (pterm ps) + | otherwise = Error . Msg $ "No goal in " ++ show (holes ps) ++ show (pterm ps) goal :: Hole -> Term -> TC Goal goal h tm = g [] tm where - g env (Bind n b@(Guess _ _) sc) - | same h n = return $ GD env b - | otherwise - = gb env b `mplus` g ((n, b):env) sc - g env (Bind n b sc) | hole b && same h n = return $ GD env b - | otherwise + g env (Bind n b@(Guess _ _) sc) + | same h n = return $ GD env b + | otherwise + = gb env b `mplus` g ((n, b):env) sc + g env (Bind n b sc) | hole b && same h n = return $ GD env b + | otherwise = g ((n, b):env) sc `mplus` gb env b g env (App f a) = g env f `mplus` g env a g env t = fail "Can't find hole" @@ -263,7 +265,7 @@ updated o = do o' <- o return (o', True) - ulift2 c env op a b + ulift2 c env op a b = do (b', u) <- atH c env b if u then return (op a b', True) else do (a', u) <- atH c env a @@ -272,15 +274,15 @@ -- Search the things most likely to contain the binding first! atH :: Context -> Env -> Term -> StateT TState TC (Term, Bool) - atH c env binder@(Bind n b@(Guess t v) sc) + atH c env binder@(Bind n b@(Guess t v) sc) | same h n = updated (f c env binder) - | otherwise + | otherwise = do -- binder first (b', u) <- ulift2 c env Guess t v if u then return (Bind n b' sc, True) else do (sc', u) <- atH c ((n, b) : env) sc return (Bind n b' sc', u) - atH c env binder@(Bind n b sc) + atH c env binder@(Bind n b sc) | hole b && same h n = updated (f c env binder) | otherwise -- scope first = do (sc', u) <- atH c ((n, b) : env) sc @@ -289,8 +291,8 @@ return (Bind n b' sc', u) atH c env (App f a) = ulift2 c env App f a atH c env t = return (t, False) - - atHb c env (Let t v) = ulift2 c env Let t v + + atHb c env (Let t v) = ulift2 c env Let t v atHb c env (Guess t v) = ulift2 c env Guess t v atHb c env t = do (ty', u) <- atH c env (binderTy t) return (t { binderTy = ty' }, u) @@ -305,12 +307,12 @@ cl env t = t attack :: RunTactic -attack ctxt env (Bind x (Hole t) sc) +attack ctxt env (Bind x (Hole t) sc) = do h <- getName "hole" action (\ps -> ps { holes = h : holes ps }) return $ Bind x (Guess t (newtm h)) sc where - newtm h = Bind h (Hole t) (P Bound h t) + newtm h = Bind h (Hole t) (P Bound h t) attack ctxt env _ = fail "Not an attackable hole" claim :: Name -> Raw -> RunTactic @@ -323,7 +325,7 @@ reorder_claims :: RunTactic reorder_claims ctxt env t - = -- trace (showSep "\n" (map show (scvs t))) $ + = -- trace (showSep "\n" (map show (scvs t))) $ let (bs, sc) = scvs t [] newbs = reverse (sortB (reverse bs)) in traceWhen (bs /= newbs) (show bs ++ "\n ==> \n" ++ show newbs) $ @@ -350,14 +352,14 @@ then ps { holes = n : (hs \\ [n]) } else ps) ps <- get - return t + return t movelast :: Name -> RunTactic movelast n ctxt env t = do action (\ps -> let hs = holes ps in if n `elem` hs then ps { holes = (hs \\ [n]) ++ [n] } else ps) - return t + return t instanceArg :: Name -> RunTactic instanceArg n ctxt env (Bind x (Hole t) sc) @@ -374,10 +376,10 @@ return (Bind x (Hole t) sc) defer :: Name -> RunTactic -defer n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' = +defer n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' = do action (\ps -> let hs = holes ps in ps { holes = hs \\ [x] }) - return (Bind n (GHole (mkTy (reverse env) t)) + return (Bind n (GHole (length env) (mkTy (reverse env) t)) (mkApp (P Ref n ty) (map getP (reverse env)))) where mkTy [] t = t @@ -387,13 +389,13 @@ -- as defer, but build the type and application explicitly deferType :: Name -> Raw -> [Name] -> RunTactic -deferType n fty_in args ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' = +deferType n fty_in args ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' = do (fty, _) <- lift $ check ctxt env fty_in - action (\ps -> let hs = holes ps + action (\ps -> let hs = holes ps ds = deferred ps in ps { holes = hs \\ [x], deferred = n : ds }) - return (Bind n (GHole fty) + return (Bind n (GHole 0 fty) (mkApp (P Ref n ty) (map getP args))) where getP n = case lookup n env of @@ -405,12 +407,12 @@ do action (\ps -> let hs = holes ps in ps { holes = hs \\ [x] }) return sc -regret ctxt env (Bind x (Hole t) _) +regret ctxt env (Bind x (Hole t) _) = fail $ show x ++ " : " ++ show t ++ " is not solved..." exact :: Raw -> RunTactic -exact guess ctxt env (Bind x (Hole ty) sc) = - do (val, valty) <- lift $ check ctxt env guess +exact guess ctxt env (Bind x (Hole ty) sc) = + do (val, valty) <- lift $ check ctxt env guess lift $ converts ctxt env valty ty return $ Bind x (Guess ty val) sc exact _ _ _ _ = fail "Can't fill here." @@ -418,7 +420,7 @@ -- As exact, but attempts to solve other goals by unification fill :: Raw -> RunTactic -fill guess ctxt env (Bind x (Hole ty) sc) = +fill guess ctxt env (Bind x (Hole ty) sc) = do (val, valty) <- lift $ check ctxt env guess -- let valtyn = normalise ctxt env valty -- let tyn = normalise ctxt env ty @@ -433,7 +435,7 @@ -- As fill, but attempts to solve other goals by matching match_fill :: Raw -> RunTactic -match_fill guess ctxt env (Bind x (Hole ty) sc) = +match_fill guess ctxt env (Bind x (Hole ty) sc) = do (val, valty) <- lift $ check ctxt env guess -- let valtyn = normalise ctxt env valty -- let tyn = normalise ctxt env ty @@ -454,7 +456,7 @@ complete_fill :: RunTactic complete_fill ctxt env (Bind x (Guess ty val) sc) = do let guess = forget val - (val', valty) <- lift $ check ctxt env guess + (val', valty) <- lift $ check ctxt env guess ns <- unify' ctxt env valty ty ps <- get let (uh, uns) = unified ps @@ -471,13 +473,13 @@ | True = do ps <- get let (uh, uns) = unified ps case lookup x (notunified ps) of - Just tm -> do -- trace ("AVOIDED " ++ show (x, tm, val)) $ + Just tm -> do -- trace ("AVOIDED " ++ show (x, tm, val)) $ -- return [] unify' ctxt env tm val _ -> return [] action (\ps -> ps { holes = holes ps \\ [x], solved = Just (x, val), --- problems = solveInProblems +-- problems = solveInProblems -- x val (problems ps), -- dontunify = dontunify ps \\ [x], -- unified = (uh, uns ++ [(x, val)]), @@ -485,13 +487,13 @@ let tm' = instantiate val (pToV x sc) in return tm' | otherwise = lift $ tfail $ IncompleteTerm val -solve _ _ h@(Bind x t sc) +solve _ _ h@(Bind x t sc) = 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' = - do let n = case mn of + do let n = case mn of Just name -> name Nothing -> x let t' = case t of @@ -511,7 +513,7 @@ intro :: Maybe Name -> RunTactic intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = - do let n = case mn of + do let n = case mn of Just name -> name Nothing -> x let t' = case t of @@ -519,7 +521,7 @@ _ -> hnf ctxt env t case t' of Bind y (Pi s) t -> -- trace ("in type " ++ show t') $ - let t' = instantiate (P Bound n s) (pToV y t) in + let t' = instantiate (P Bound n s) (pToV y t) in return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t')) _ -> lift $ tfail $ CantIntroduce t' intro n ctxt env _ = fail "Can't introduce here." @@ -527,7 +529,8 @@ forall :: Name -> Raw -> RunTactic forall n ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do (tyv, tyt) <- lift $ check ctxt env ty - unify' ctxt env tyt (TType (UVar 0)) + unify' ctxt env tyt (TType (UVar 0)) + unify' ctxt env t (TType (UVar 0)) return $ Bind n (Pi tyv) (Bind x (Hole t) (P Bound x t)) forall n ty ctxt env _ = fail "Can't pi bind here" @@ -546,7 +549,7 @@ letbind n ty val ctxt env _ = fail "Can't let bind here" expandLet :: Name -> Term -> RunTactic -expandLet n v ctxt env tm = +expandLet n v ctxt env tm = return $ subst n v tm rewrite :: Raw -> RunTactic @@ -556,8 +559,8 @@ case unApply tmt' of (P _ (UN "=") _, [lt,rt,l,r]) -> do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t) - let newt = mkP l r l t - let sc = forget $ (Bind x (Hole newt) + let newt = mkP l r l t + let sc = forget $ (Bind x (Hole newt) (mkApp (P Ref (UN "replace") (TType (UVal 0))) [lt, l, r, p, tmv, xp])) (scv, sct) <- lift $ check ctxt env sc @@ -570,14 +573,14 @@ mkP lt l r (App f a) = let f' = if (r /= f) then mkP lt l r f else f a' = if (r /= a) then mkP lt l r a else a in App f' a' - mkP lt l r (Bind n b sc) - = let b' = mkPB b + mkP lt l r (Bind n b sc) + = let b' = mkPB b sc' = if (r /= sc) then mkP lt l r sc else sc in Bind n b' sc' where mkPB (Let t v) = let t' = if (r /= t) then mkP lt l r t else t v' = if (r /= v) then mkP lt l r v else v in Let t' v' - mkPB b = let ty = binderTy b + mkPB b = let ty = binderTy b ty' = if (r /= ty) then mkP lt l r ty else ty in b { binderTy = ty' } mkP lt l r x = x @@ -607,11 +610,11 @@ compute ctxt env (Bind x (Hole ty) sc) = do return $ Bind x (Hole (normalise ctxt env ty)) sc compute ctxt env t = return t - + hnf_compute :: RunTactic -hnf_compute ctxt env (Bind x (Hole ty) sc) = +hnf_compute ctxt env (Bind x (Hole ty) sc) = do let ty' = hnf ctxt env ty in --- trace ("HNF " ++ show (ty, ty')) $ +-- trace ("HNF " ++ show (ty, ty')) $ return $ Bind x (Hole ty') sc hnf_compute ctxt env t = return t @@ -620,23 +623,23 @@ simplify ctxt env (Bind x (Hole ty) sc) = do return $ Bind x (Hole (specialise ctxt env [] ty)) sc simplify ctxt env t = return t - + check_in :: Raw -> RunTactic -check_in t ctxt env tm = +check_in t ctxt env tm = do (val, valty) <- lift $ check ctxt env t addLog (showEnv env val ++ " : " ++ showEnv env valty) return tm eval_in :: Raw -> RunTactic -eval_in t ctxt env tm = +eval_in t ctxt env tm = do (val, valty) <- lift $ check ctxt env t let val' = normalise ctxt env val let valty' = normalise ctxt env valty - addLog (showEnv env val ++ " : " ++ - showEnv env valty ++ --- " in " ++ show env ++ + addLog (showEnv env val ++ " : " ++ + showEnv env valty ++ +-- " in " ++ show env ++ " ==>\n " ++ - showEnv env val' ++ " : " ++ + showEnv env val' ++ " : " ++ showEnv env valty') return tm @@ -647,7 +650,7 @@ tmap f (a, b, c) = (f a, b, c) solve_unified :: RunTactic -solve_unified ctxt env tm = +solve_unified ctxt env tm = do ps <- get let (_, ns) = unified ps let unify = dropGiven (dontunify ps) ns (holes ps) @@ -661,7 +664,7 @@ | n `elem` du && not (t `elem` du) && n `elem` hs && t `elem` hs = (t, P Bound n ty) : dropGiven du us hs -dropGiven du (u@(n, _) : us) hs +dropGiven du (u@(n, _) : us) hs | n `elem` du = dropGiven du us hs -- dropGiven du (u@(_, P a n ty) : us) | n `elem` du = dropGiven du us dropGiven du (u : us) hs = u : dropGiven du us hs @@ -671,15 +674,15 @@ | n `elem` du && not (t `elem` du) && n `elem` hs && t `elem` hs = keepGiven du us hs -keepGiven du (u@(n, _) : us) hs +keepGiven du (u@(n, _) : us) hs | n `elem` du = u : keepGiven du us hs keepGiven du (u : us) hs = keepGiven du us hs -updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $ +updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $ updateSolved' xs x 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) +updateSolved' xs (Bind n b t) | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t) updateSolved' xs (App f a) = App (updateSolved' xs f) (updateSolved' xs a) updateSolved' xs (P _ n _) @@ -702,55 +705,87 @@ up ns [] = (ns, []) up ns ((x, y, env, err) : ps) = let x' = updateSolved ns x - y' = updateSolved ns y + y' = updateSolved ns y err' = updateError ns err env' = updateEnv ns env in case unify ctxt env' x' y' inj holes of - OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $ + OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $ up (ns ++ v) ps _ -> let (ns', ps') = up ns ps in (ns', (x',y',env',err') : ps') +-- attempt to solve remaining problems with match_unify +matchProblems ctxt ps inj holes = up [] ps where + up ns [] = (ns, []) + up ns ((x, y, env, err) : ps) = + let x' = updateSolved ns x + y' = updateSolved ns y + err' = updateError ns err + env' = updateEnv ns env in + case match_unify ctxt env' x' y' inj holes of + OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $ + up (ns ++ v) ps + _ -> let (ns', ps') = up ns ps in + (ns', (x',y',env',err') : ps') + processTactic :: Tactic -> ProofState -> TC (ProofState, String) processTactic QED ps = case holes ps of [] -> do let tm = {- normalise (context ps) [] -} (pterm ps) (tm', ty', _) <- recheck (context ps) [] (forget tm) tm - return (ps { done = True, pterm = tm' }, + return (ps { done = True, pterm = tm' }, "Proof complete: " ++ showEnv [] tm') _ -> fail "Still holes to fill." processTactic ProofState ps = return (ps, showEnv [] (pterm ps)) processTactic Undo ps = case previous ps of Nothing -> fail "Nothing to undo." Just pold -> return (pold, "") -processTactic EndUnify ps +processTactic EndUnify ps = let (h, ns_in) = unified ps ns = dropGiven (dontunify ps) ns_in (holes ps) - ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns + ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns (ns'', probs') = updateProblems (context ps) ns' (problems ps) (injective ps) (holes ps) tm' = -- trace ("Updating " ++ show ns_in ++ "\n" ++ show ns'') $ -- ++ " in " ++ show (pterm ps)) $ updateSolved ns'' (pterm ps) in - return (ps { pterm = tm', + return (ps { pterm = tm', unified = (h, []), problems = probs', holes = holes ps \\ map fst ns'' }, "") -processTactic (Reorder n) ps +processTactic (Reorder n) ps = do ps' <- execStateT (tactic (Just n) reorder_claims) ps return (ps' { previous = Just ps, plog = "" }, plog ps') processTactic (ComputeLet n) ps = return (ps { pterm = computeLet (context ps) n (pterm ps) }, "") -processTactic t ps +processTactic UnifyProblems ps + = let (ns', probs') = updateProblems (context ps) [] + (problems ps) + (injective ps) + (holes ps) + pterm' = updateSolved ns' (pterm ps) in + return (ps { pterm = pterm', solved = Nothing, problems = probs', + previous = Just ps, plog = "", + holes = holes ps \\ (map fst ns') }, plog ps) +processTactic MatchProblems ps + = let (ns', probs') = matchProblems (context ps) + (problems ps) + (injective ps) + (holes ps) + pterm' = updateSolved ns' (pterm ps) in + return (ps { pterm = pterm', solved = Nothing, problems = probs', + previous = Just ps, plog = "", + holes = holes ps \\ (map fst ns') }, plog ps) +processTactic t ps = case holes ps of [] -> fail "Nothing to fill in." (h:_) -> do ps' <- execStateT (process t h) ps - let (ns', probs') + let (ns', probs') = case solved ps' of Just s -> updateProblems (context ps') - [s] (problems ps') + [s] (problems ps') (injective ps') (holes ps') _ -> ([], problems ps') - -- rechecking problems may find more solutions, so + -- rechecking problems may find more solutions, so -- apply them here let pterm'' = updateSolved ns' (pterm ps') return (ps' { pterm = pterm'', @@ -760,7 +795,7 @@ holes = holes ps' \\ (map fst ns')}, plog ps') process :: Tactic -> Name -> StateT TState TC () -process EndUnify _ +process EndUnify _ = do ps <- get let (h, _) = unified ps tactic (Just h) solve_unified @@ -795,4 +830,3 @@ mktac (Instance n) = instanceArg n mktac (SetInjective n) = setinj n mktac (MoveLast n) = movelast n - diff --git a/src/Core/ShellParser.hs b/src/Core/ShellParser.hs deleted file mode 100644 --- a/src/Core/ShellParser.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} - -module Core.ShellParser(parseCommand, parseTactic) where - -import Core.TT -import Core.Elaborate -import Core.CoreParser - -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Expr -import Text.ParserCombinators.Parsec.Language -import qualified Text.ParserCombinators.Parsec.Token as PTok - -import Debug.Trace - -type TokenParser a = PTok.TokenParser a - -lexer :: TokenParser () -lexer = PTok.makeTokenParser haskellDef - -whiteSpace= PTok.whiteSpace lexer -lexeme = PTok.lexeme lexer -symbol = PTok.symbol lexer -natural = PTok.natural lexer -parens = PTok.parens lexer -semi = PTok.semi lexer -comma = PTok.comma lexer -identifier= PTok.identifier lexer -reserved = PTok.reserved lexer -operator = PTok.operator lexer -reservedOp= PTok.reservedOp lexer -lchar = lexeme.char - -parseCommand = parse pCommand "(input)" -parseTactic = parse (pTactic >>= return . Tac) "(input)" - -pCommand :: Parser Command -pCommand = do reserved "theorem"; n <- iName []; lchar ':'; ty <- pTerm - return (Theorem n ty) - <|> do reserved "eval"; tm <- pTerm - return (Eval tm) - <|> do reserved "print"; n <- iName []; return (Print n) - <|> do reserved "quit"; - return Quit - -pTactic :: Parser (Elab ()) -pTactic = do reserved "attack"; return attack - <|> do reserved "claim"; n <- iName []; lchar ':'; ty <- pTerm - return (claim n ty) - <|> do reserved "regret"; return regret - <|> do reserved "exact"; tm <- pTerm; return (exact tm) - <|> do reserved "fill"; tm <- pTerm; return (fill tm) - <|> do reserved "apply"; tm <- pTerm; args <- many pArgType; - return (discard (apply tm (map (\x -> (x,0)) args))) - <|> do reserved "solve"; return solve - <|> do reserved "compute"; return compute - <|> do reserved "intro"; n <- iName []; return (intro (Just n)) - <|> do reserved "forall"; n <- iName []; lchar ':'; ty <- pTerm - return (forall n ty) - <|> do reserved "arg"; n <- iName []; t <- iName []; return (arg n t) - <|> do reserved "patvar"; n <- iName []; return (patvar n) --- <|> do reserved "patarg"; n <- iName []; t <- iName []; return (patarg n t) - <|> do reserved "eval"; t <- pTerm; return (eval_in t) - <|> do reserved "check"; t <- pTerm; return (check_in t) - <|> do reserved "focus"; n <- iName []; return (focus n) - <|> do reserved "state"; return proofstate - <|> do reserved "undo"; return undo - <|> do reserved "qed"; return (discard qed) - -pArgType :: Parser Bool -pArgType = do lchar '_'; return True -- implicit (machine fills in) - <|> do lchar '?'; return False -- user fills in - diff --git a/src/Core/TT.hs b/src/Core/TT.hs --- a/src/Core/TT.hs +++ b/src/Core/TT.hs @@ -21,6 +21,7 @@ module Core.TT where import Control.Monad.State +import Control.Monad.Trans.Error (Error(..)) import Debug.Trace import qualified Data.Map as Map import Data.Char @@ -37,24 +38,45 @@ | CheckConv deriving Eq --- | Source location. These are typically produced by the parser 'Idris.Parser.pfc' +-- | Source location. These are typically produced by the parser 'Idris.Parser.getFC' data FC = FC { fc_fname :: String, -- ^ Filename - fc_line :: Int -- ^ Line number + fc_line :: Int, -- ^ Line number + fc_column :: Int -- ^ Column number } - deriving Eq -{-! -deriving instance Binary FC + +-- | Ignore source location equality (so deriving classes do not compare FCs) +instance Eq FC where + _ == _ = True + +-- | FC with equality +newtype FC' = FC' { unwrapFC :: FC } + +instance Eq FC' where + FC' fc == FC' fc' = fcEq fc fc' + where fcEq (FC n l c) (FC n' l' c') = n == n' && l == l' && c == c' + +-- | Empty source location +emptyFC :: FC +emptyFC = fileFC "" + +-- | Source location with file only +fileFC :: String -> FC +fileFC s = FC s 0 0 + +{-! +deriving instance Binary FC +deriving instance NFData FC !-} instance Sized FC where - size (FC f l) = 1 + length f + size (FC f l c) = 1 + length f instance Show FC where - show (FC f l) = f ++ ":" ++ show l + show (FC f l c) = f ++ ":" ++ show l ++ ":" ++ show c data Err = Msg String | InternalMsg String - | CantUnify Bool Term Term Err [(Name, Type)] Int + | CantUnify Bool Term Term Err [(Name, Type)] Int -- Int is 'score' - how much we did unify -- Bool indicates recoverability, True indicates more info may make -- unification succeed @@ -80,7 +102,11 @@ | At FC Err | Elaborating String Name Err | ProviderError String + | LoadingFailed String Err deriving Eq +{-! +deriving instance NFData Err +!-} instance Sized Err where size (Msg msg) = length msg @@ -101,6 +127,7 @@ size (At fc err) = size fc + size err size (Elaborating _ n err) = size err size (ProviderError msg) = length msg + size (LoadingFailed fn e) = 1 + length fn + size e size _ = 1 score :: Err -> Int @@ -118,6 +145,7 @@ ++ show e ++ " in " ++ show sc ++ " " ++ show i show (Inaccessible n) = show n ++ " is not an accessible pattern variable" show (ProviderError msg) = "Type provider error: " ++ msg + show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: " ++ show e show _ = "Error" instance Pretty Err where @@ -131,8 +159,12 @@ text "Cannot unify" <+> colon <+> pretty l <+> text "and" <+> pretty r $$ nest nestingSize (text "where" <+> pretty e <+> text "with" <+> (text . show $ i)) pretty (ProviderError msg) = text msg + pretty err@(LoadingFailed _ _) = text (show err) pretty _ = text "Error" +instance Error Err where + strMsg = Msg + data TC a = OK a | Error Err deriving (Eq, Functor) @@ -153,8 +185,8 @@ -- (e.g. Type:Type) instance Monad TC where - return = OK - x >>= k = case x of + return = OK + x >>= k = case x of OK v -> k v Error e -> Error e fail e = Error (InternalMsg e) @@ -164,7 +196,7 @@ trun :: FC -> TC a -> TC a trun fc (OK a) = OK a -trun fc (Error e) = Error (At fc e) +trun fc (Error e) = Error (At fc e) instance MonadPlus TC where mzero = fail "Unknown error" @@ -190,23 +222,25 @@ -- | Names are hierarchies of strings, describing scope (so no danger of -- duplicate names, but need to be careful on lookup). data Name = UN String -- ^ User-provided name - | NS Name [String] -- ^ Root, namespaces + | NS Name [String] -- ^ Root, namespaces | MN Int String -- ^ Machine chosen names | NErased -- ^ Name of somethng which is never used in scope | SN SpecialName -- ^ Decorated function names deriving (Eq, Ord) -{-! -deriving instance Binary Name +{-! +deriving instance Binary Name +deriving instance NFData Name !-} data SpecialName = WhereN Int Name Name | InstanceN Name [String] | ParentN Name String - | MethodN Name + | MethodN Name | CaseN Name deriving (Eq, Ord) -{-! -deriving instance Binary SpecialName +{-! +deriving instance Binary SpecialName +deriving instance NFData SpecialName !-} instance Sized Name where @@ -265,6 +299,7 @@ implicitable (NS n _) = implicitable n implicitable (UN (x:xs)) = isLower x +implicitable (MN _ _) = True implicitable _ = False nsroot (NS n _) = n @@ -272,9 +307,9 @@ addDef :: Name -> a -> Ctxt a -> Ctxt a addDef n v ctxt = case Map.lookup (nsroot n) ctxt of - Nothing -> Map.insert (nsroot n) + Nothing -> Map.insert (nsroot n) (Map.insert n v Map.empty) ctxt - Just xs -> Map.insert (nsroot n) + Just xs -> Map.insert (nsroot n) (Map.insert n v xs) ctxt {-| Look up a name in the context, given an optional namespace. @@ -298,7 +333,7 @@ Nothing -> [] where filterNS [] = [] - filterNS ((found, v) : xs) + filterNS ((found, v) : xs) | nsmatch n found = (found, v) : filterNS xs | otherwise = filterNS xs @@ -313,9 +348,9 @@ lookupCtxtExact n ctxt = [ v | (nm, v) <- lookupCtxtName n ctxt, nm == n] updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a -updateDef n f ctxt +updateDef n f ctxt = let ds = lookupCtxtName n ctxt in - foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds + foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds toAlist :: Ctxt a -> [(Name, a)] toAlist ctxt = let allns = map snd (Map.toList ctxt) in @@ -340,6 +375,11 @@ data ArithTy = ATInt IntTy | ATFloat -- TODO: Float vectors deriving (Show, Eq, Ord) +{-! +deriving instance NFData IntTy +deriving instance NFData NativeTy +deriving instance NFData ArithTy +!-} instance Pretty ArithTy where pretty (ATInt ITNative) = text "Int" @@ -362,15 +402,16 @@ intTyWidth ITChar = error "IRTS.Lang.intTyWidth: Characters have platform and backend dependent width" intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width" -data Const = I Int | BI Integer | Fl Double | Ch Char | Str String +data Const = I Int | BI Integer | Fl Double | Ch Char | Str String | B8 Word8 | B16 Word16 | B32 Word32 | B64 Word64 | B8V (Vector Word8) | B16V (Vector Word16) | B32V (Vector Word32) | B64V (Vector Word64) | AType ArithTy | StrType | PtrType | VoidType | Forgot deriving (Eq, Ord) -{-! -deriving instance Binary Const +{-! +deriving instance Binary Const +deriving instance NFData Const !-} instance Sized Const where @@ -411,8 +452,9 @@ instance Pretty Raw where pretty = text . show -{-! -deriving instance Binary Raw +{-! +deriving instance Binary Raw +deriving instance NFData Raw !-} -- | All binding forms are represented in a unform fashion. @@ -423,14 +465,16 @@ | NLet { binderTy :: b, binderVal :: b } | Hole { binderTy :: b} - | GHole { binderTy :: b} + | GHole { envlen :: Int, + binderTy :: b} | Guess { binderTy :: b, binderVal :: b } | PVar { binderTy :: b } | PVTy { binderTy :: b } deriving (Show, Eq, Ord, Functor) -{-! -deriving instance Binary Binder +{-! +deriving instance Binary Binder +deriving instance NFData Binder !-} instance Sized a => Sized (Binder a) where @@ -439,7 +483,7 @@ size (Let ty val) = 1 + size ty + size val size (NLet ty val) = 1 + size ty + size val size (Hole ty) = 1 + size ty - size (GHole ty) = 1 + size ty + size (GHole _ ty) = 1 + size ty size (Guess ty val) = 1 + size ty + size val size (PVar ty) = 1 + size ty size (PVTy ty) = 1 + size ty @@ -451,7 +495,7 @@ fmapMB f (Lam t) = liftM Lam (f t) fmapMB f (Pi t) = liftM Pi (f t) fmapMB f (Hole t) = liftM Hole (f t) -fmapMB f (GHole t) = liftM GHole (f t) +fmapMB f (GHole i t) = liftM (GHole i) (f t) fmapMB f (PVar t) = liftM PVar (f t) fmapMB f (PVTy t) = liftM PVTy (f t) @@ -485,6 +529,9 @@ data UExp = UVar Int -- ^ universe variable | UVal Int -- ^ explicit universe level deriving (Eq, Ord) +{-! +deriving instance NFData UExp +!-} instance Sized UExp where size _ = 1 @@ -519,8 +566,9 @@ | DCon Int Int -- ^ Data constructor; Ints are tag and arity | TCon Int Int -- ^ Type constructor; Ints are tag and arity deriving (Show, Ord) -{-! -deriving instance Binary NameType +{-! +deriving instance Binary NameType +deriving instance NFData NameType !-} instance Sized NameType where @@ -543,12 +591,14 @@ | App (TT n) (TT n) -- ^ function, function type, arg | Constant Const -- ^ constant | Proj (TT n) Int -- ^ argument projection; runtime only + -- (-1) is a special case for 'subtract one from BI' | Erased -- ^ an erased term | Impossible -- ^ special case for totality checking | TType UExp -- ^ the type of types at some level deriving (Ord, Functor) -{-! -deriving instance Binary TT +{-! +deriving instance Binary TT +deriving instance NFData TT !-} class TermSize a where @@ -559,14 +609,14 @@ termsize n (x : xs) = termsize n x + termsize n xs instance TermSize (TT Name) where - termsize n (P _ x _) + termsize n (P _ x _) | x == n = 1000000 -- recursive => really big | otherwise = 1 termsize n (V _) = 1 - termsize n (Bind n' (Let t v) sc) + termsize n (Bind n' (Let t v) sc) = let rn = if n == n' then MN 0 "noname" else n in termsize rn v + termsize rn sc - termsize n (Bind n' b sc) + termsize n (Bind n' b sc) = let rn = if n == n' then MN 0 "noname" else n in termsize rn sc termsize n (App f a) = termsize n f + termsize n a @@ -623,7 +673,7 @@ vinstances :: Int -> TT n -> Int vinstances i (V x) | i == x = 1 vinstances i (App f a) = vinstances i f + vinstances i a -vinstances i (Bind x b sc) = instancesB b + vinstances (i + 1) sc +vinstances i (Bind x b sc) = instancesB b + vinstances (i + 1) sc where instancesB (Let t v) = vinstances i v instancesB _ = 0 vinstances i t = 0 @@ -633,7 +683,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 (Proj x idx) = Proj (subst i x) idx subst i t = t substV :: TT n -> TT n -> TT n @@ -648,7 +698,7 @@ explicitNames :: TT n -> TT n explicitNames (Bind x b sc) = let b' = fmap explicitNames b in Bind x b' - (explicitNames (instantiate + (explicitNames (instantiate (P Bound x (binderTy b')) sc)) explicitNames (App f a) = App (explicitNames f) (explicitNames a) explicitNames (Proj x idx) = Proj (explicitNames x) idx @@ -756,15 +806,15 @@ where fe env (P _ n _) = Var n fe env (V i) = Var (env !! i) - fe env (Bind n b sc) = RBind n (fmap (fe env) b) + fe env (Bind n b sc) = RBind n (fmap (fe env) b) (fe (n:env) sc) fe env (App f a) = RApp (fe env f) (fe env a) - fe env (Constant c) + fe env (Constant c) = RConstant c fe env (TType i) = RType - fe env Erased = RConstant Forgot - -bindAll :: [(n, Binder (TT n))] -> TT n -> TT n + fe env Erased = RConstant Forgot + +bindAll :: [(n, Binder (TT n))] -> TT n -> TT n bindAll [] t =t bindAll ((n, b) : bs) t = Bind n b (bindAll bs t) @@ -791,8 +841,8 @@ Bind n' (fmap (uniqueBinders (n':ns)) b) (uniqueBinders ns sc) uniqueBinders ns (App f a) = App (uniqueBinders ns f) (uniqueBinders ns a) uniqueBinders ns t = t - + nextName (NS x s) = NS (nextName x) s nextName (MN i n) = MN (i+1) n nextName (UN x) = let (num', nm') = span isDigit (reverse x) @@ -863,7 +913,7 @@ | otherwise = p prettySe p env (P nt n t) debug = - pretty n <+> + pretty n <+> if debug then lbrack <+> pretty nt <+> colon <+> prettySe 10 env t debug <+> rbrack else @@ -902,16 +952,16 @@ prettyBv env op sc n t v debug = text op <> pretty n <+> colon <+> prettySe 10 env t debug <+> text "=" <+> prettySe 10 env v debug <> text sc - + showEnv' env t dbg = se 10 env t where - se p env (P nt n t) = show n + se p env (P nt n t) = show n ++ if dbg then "{" ++ show nt ++ " : " ++ se 10 env t ++ "}" else "" se p env (V i) | i < length env && i >= 0 = (show $ fst $ env!!i) ++ if dbg then "{" ++ show i ++ "}" else "" | otherwise = "!!V " ++ show i ++ "!!" - se p env (Bind n b@(Pi t) sc) + se p env (Bind n b@(Pi t) sc) | 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 @@ -923,7 +973,7 @@ sb env n (Lam t) = showb env "\\ " " => " n t sb env n (Hole t) = showb env "? " ". " n t - sb env n (GHole t) = showb env "?defer " ". " n t + sb env n (GHole i t) = showb env "?defer " ". " n t sb env n (Pi t) = showb env "(" ") -> " n t sb env n (PVar t) = showb env "pat " ". " n t sb env n (PVTy t) = showb env "pty " ". " n t @@ -931,8 +981,8 @@ sb env n (Guess t v) = showbv env "?? " " in " n t v showb env op sc n t = op ++ show n ++ " : " ++ se 10 env t ++ sc - showbv env op sc n t v = op ++ show n ++ " : " ++ se 10 env t ++ " = " ++ - se 10 env v ++ sc + showbv env op sc n t v = op ++ show n ++ " : " ++ se 10 env t ++ " = " ++ + se 10 env v ++ sc bracket outer inner str | inner > outer = "(" ++ str ++ ")" | otherwise = str @@ -979,7 +1029,7 @@ where op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc - op ps sc = bindAll (map (\ (n, t) -> (n, t)) (sortP ps)) sc + op ps sc = bindAll (sortP ps) sc sortP ps = pick [] (reverse ps) @@ -996,7 +1046,7 @@ insert n t [] = [(n, t)] insert n t ((n',t') : ps) - | n `elem` (namesIn (binderTy t') ++ + | n `elem` (namesIn (binderTy t') ++ concatMap namesIn (map (binderTy . snd) ps)) = (n', t') : insert n t ps | otherwise = (n,t):(n',t'):ps diff --git a/src/Core/Typecheck.hs b/src/Core/Typecheck.hs --- a/src/Core/Typecheck.hs +++ b/src/Core/Typecheck.hs @@ -16,10 +16,10 @@ -- indexed with 'finalise' convertsC :: Context -> Env -> Term -> Term -> StateT UCs TC () -convertsC ctxt env x y +convertsC ctxt env x y = do c1 <- convEq ctxt x y if c1 then return () - else + else do c2 <- convEq ctxt (finalise (normalise ctxt env x)) (finalise (normalise ctxt env y)) if c2 then return () @@ -28,10 +28,10 @@ (finalise (normalise ctxt env y)) (errEnv env)) converts :: Context -> Env -> Term -> Term -> TC () -converts ctxt env x y - = case convEq' ctxt x y of +converts ctxt env x y + = case convEq' ctxt x y of OK True -> return () - _ -> case convEq' ctxt (finalise (normalise ctxt env x)) + _ -> case convEq' ctxt (finalise (normalise ctxt env x)) (finalise (normalise ctxt env y)) of OK True -> return () _ -> tfail (CantConvert @@ -51,7 +51,7 @@ case runStateT (check' False ctxt env tm) (v, []) of -- holes banned Error (IncompleteTerm _) -> Error $ IncompleteTerm orig Error e -> Error e - OK ((tm, ty), constraints) -> + OK ((tm, ty), constraints) -> return (tm, ty, constraints) check :: Context -> Env -> Raw -> TC (Term, Type) @@ -68,7 +68,7 @@ (av, aty) <- chk env a let fty' = case uniqueBinders (map fst env) (finalise fty) of ty@(Bind x (Pi s) t) -> ty - _ -> uniqueBinders (map fst env) + _ -> uniqueBinders (map fst env) $ case hnf ctxt env fty of ty@(Bind x (Pi s) t) -> ty _ -> normalise ctxt env fty @@ -77,21 +77,21 @@ -- trace ("Converting " ++ show aty ++ " and " ++ show s ++ -- " from " ++ show fv ++ " : " ++ show fty) $ do convertsC ctxt env aty s - -- let apty = normalise initContext env + -- let apty = normalise initContext env -- (Bind x (Let aty av) t) - let apty = simplify initContext env + let apty = simplify initContext env (Bind x (Let aty av) t) return (App fv av, apty) t -> lift $ tfail $ NonFunctionType fv fty -- "Can't apply a non-function type" - -- This rather unpleasant hack is needed because during incomplete - -- proofs, variables are locally bound with an explicit name. If we just + -- This rather unpleasant hack is needed because during incomplete + -- proofs, variables are locally bound with an explicit name. If we just -- make sure bound names in function types are locally unique, machine -- generated names, we'll be fine. -- NOTE: now replaced with 'uniqueBinders' above - where renameBinders i (Bind x (Pi s) t) = Bind (MN i "binder") (Pi s) + where renameBinders i (Bind x (Pi s) t) = Bind (MN i "binder") (Pi s) (renameBinders (i+1) t) renameBinders i sc = sc - chk env RType + chk env RType | holes = return (TType (UVal 0), TType (UVal 0)) | otherwise = do (v, cs) <- get let c = ULT (UVar v) (UVar (v+1)) @@ -123,8 +123,8 @@ let TType su = normalise ctxt env st let TType tu = normalise ctxt env tt when (not holes) $ put (v+1, ULE su (UVar v):ULE tu (UVar v):cs) - return (Bind n (Pi (uniqueBinders (map fst env) sv)) - (pToV n tv), TType (UVar v)) + return (Bind n (Pi (uniqueBinders (map fst env) sv)) + (pToV n tv), TType (UVar v)) chk env (RBind n b sc) = do b' <- checkBinder b (scv, sct) <- chk ((n, b'):env) sc @@ -165,12 +165,12 @@ let tt' = normalise ctxt env tt lift $ isType ctxt env tt' return (Hole tv) - checkBinder (GHole t) + checkBinder (GHole i t) = do (tv, tt) <- chk env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt lift $ isType ctxt env tt' - return (GHole tv) + return (GHole i tv) checkBinder (Guess t v) | not holes = lift $ tfail (IncompleteTerm undefined) | otherwise @@ -186,6 +186,8 @@ let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt lift $ isType ctxt env tt' + -- Normalised version, for erasure purposes (it's easier + -- to tell if it's a collapsible variable) return (PVar tv) checkBinder (PVTy t) = do (tv, tt) <- chk env t @@ -193,7 +195,7 @@ let tt' = normalise ctxt env tt lift $ isType ctxt env tt' return (PVTy tv) - + discharge n (Lam t) scv sct = return (Bind n (Lam t) scv, Bind n (Pi t) sct) discharge n (Pi t) scv sct @@ -204,8 +206,8 @@ = return (Bind n (NLet t v) scv, Bind n (Let t v) sct) discharge n (Hole t) scv sct = return (Bind n (Hole t) scv, sct) - discharge n (GHole t) scv sct - = return (Bind n (GHole t) scv, sct) + discharge n (GHole i t) scv sct + = return (Bind n (GHole i t) scv, sct) discharge n (Guess t v) scv sct = return (Bind n (Guess t v) scv, sct) discharge n (PVar t) scv sct @@ -216,7 +218,7 @@ checkProgram :: Context -> RProgram -> TC Context checkProgram ctxt [] = return ctxt -checkProgram ctxt ((n, RConst t) : xs) +checkProgram ctxt ((n, RConst t) : xs) = do (t', tt') <- trace (show n) $ check ctxt [] t isType ctxt [] tt' checkProgram (addTyDecl n Ref t' ctxt) xs diff --git a/src/Core/Unify.hs b/src/Core/Unify.hs --- a/src/Core/Unify.hs +++ b/src/Core/Unify.hs @@ -34,17 +34,22 @@ match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> TC [(Name, TT Name)] match_unify ctxt env topx topy dont holes = --- trace ("Matching " ++ show (topx, topy)) $ case runStateT (un [] topx topy) (UI 0 []) of OK (v, UI _ []) -> return (filter notTrivial v) - res -> + res -> let topxn = normalise ctxt env topx topyn = normalise ctxt env topy in case runStateT (un [] topxn topyn) (UI 0 []) of - OK (v, UI _ fails) -> + OK (v, UI _ fails) -> return (filter notTrivial v) - Error e -> tfail e + Error e -> + -- just normalise the term we're matching against + case runStateT (un [] topxn topy) + (UI 0 []) of + OK (v, UI _ fails) -> + return (filter notTrivial v) + _ -> tfail e where un names (P _ x _) tm | holeIn env x || x `elem` holes @@ -61,7 +66,7 @@ h2 <- un ((x, y) : bnames) sx sy combine bnames h1 h2 un names (App fx ax) (App fy ay) - = do hf <- un names fx fy + = do hf <- un names fx fy ha <- un names ax ay combine names hf ha un names x y @@ -82,7 +87,7 @@ uB bnames (Pi tx) (Pi ty) = un bnames tx ty uB bnames x y = do UI s f <- get let r = recoverable (binderTy x) (binderTy y) - let err = CantUnify r topx topy + let err = CantUnify r topx topy (CantUnify r (binderTy x) (binderTy y) (Msg "") [] s) (errEnv env) s put (UI s ((binderTy x, binderTy y, env, err) : f)) @@ -102,7 +107,7 @@ lift $ tfail err combine bnames as [] = return as combine bnames as ((n, t) : bs) - = case lookup n as of + = case lookup n as of Nothing -> combine bnames (as ++ [(n,t)]) bs Just t' -> do ns <- un bnames t t' -- make sure there's n mapping from n in ns @@ -110,15 +115,15 @@ sc 1 combine bnames as (ns' ++ bs) - checkCycle ns p@(x, P _ _ _) = return [p] - checkCycle ns (x, tm) + checkCycle ns p@(x, P _ _ _) = return [p] + checkCycle ns (x, tm) | not (x `elem` freeNames tm) = checkScope ns (x, tm) - | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) + | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) checkScope ns (x, tm) = case boundVs (envPos x 0 env) tm of [] -> return [(x, tm)] - (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i)) + (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i)) (inst ns tm) (errEnv env)) where inst [] tm = tm inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm) @@ -141,15 +146,15 @@ -- trace ("Unifying " ++ show (topx, topy)) $ -- don't bother if topx and topy are different at the head case runStateT (un False [] topx topy) (UI 0 []) of - OK (v, UI _ []) -> return (filter notTrivial v, + OK (v, UI _ []) -> return (filter notTrivial v, []) - res -> + res -> let topxn = normalise ctxt env topx topyn = normalise ctxt env topy in -- trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n" ++ show res ++ "\n\n") $ case runStateT (un False [] topxn topyn) (UI 0 []) of - OK (v, UI _ fails) -> + OK (v, UI _ fails) -> return (filter notTrivial v, reverse fails) -- Error e@(CantUnify False _ _ _ _ _) -> tfail e Error e -> tfail e @@ -160,8 +165,8 @@ injective (P (DCon _ _) _ _) = True injective (P (TCon _ _) _ _) = True --- injective (App f (P _ _ _)) = injective f --- injective (App f (Constant _)) = injective f +-- injective (App f (P _ _ _)) = injective f +-- injective (App f (Constant _)) = injective f injective (App f a) = injective f -- && injective a injective _ = False @@ -177,15 +182,15 @@ uplus u1 u2 = do UI s f <- get r <- u1 UI s f' <- get - if (length f == length f') + if (length f == length f') then return r else do put (UI s f); u2 un :: Bool -> [(Name, Name)] -> TT Name -> TT Name -> - StateT UInfo + StateT UInfo TC [(Name, TT Name)] un = un' --- un fn names x y +-- un fn names x y -- = let (xf, _) = unApply x -- (yf, _) = unApply y in -- if headDiff xf yf then unifyFail x y else @@ -193,7 +198,7 @@ -- (un' fn names (hnf ctxt env x) (hnf ctxt env y)) un' :: Bool -> [(Name, Name)] -> TT Name -> TT Name -> - StateT UInfo + StateT UInfo TC [(Name, TT Name)] un' fn names x y | x == y = return [] -- shortcut un' fn names topx@(P (DCon _ _) x _) topy@(P (DCon _ _) y _) @@ -208,7 +213,7 @@ = unifyFail topx topy un' fn names topx@(P (TCon _ _) x _) topy@(Constant _) = unifyFail topx topy - un' fn bnames tx@(P _ x _) ty@(P _ y _) + un' fn bnames tx@(P _ x _) ty@(P _ y _) | (x,y) `elem` bnames || x == y = do sc 1; return [] | injective tx && not (holeIn env y || y `elem` holes) = unifyTmpFail tx ty @@ -218,10 +223,10 @@ | holeIn env x || x `elem` holes = do UI s f <- get -- injectivity check - if (notP tm && fn) + if (notP tm && fn) -- trace (show (x, tm, normalise ctxt env tm)) $ -- put (UI s ((tm, topx, topy) : i) f) - then unifyTmpFail xtm tm + then unifyTmpFail xtm tm else do sc 1 checkCycle bnames (x, tm) | not (injective xtm) && injective tm = unifyFail xtm tm @@ -241,7 +246,7 @@ un' fn bnames (P _ x _) (V i) | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return [] - un' fn bnames appx@(App _ _) appy@(App _ _) + un' fn bnames appx@(App _ _) appy@(App _ _) = unApp fn bnames appx appy -- = uplus (unApp fn bnames appx appy) -- (unifyTmpFail appx appy) -- take the whole lot @@ -254,15 +259,24 @@ = un' False bnames x y un' fn bnames (Bind n (Lam t) (App x (V 0))) y = un' False bnames x y --- un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy) +-- 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' 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) + + -- f D unifies with t -> D. This is dubious, but it helps with type + -- class resolution for type classes over functions. + + un' fn bnames (App f x) (Bind n (Pi t) y) + | noOccurrence n y && x == y + = un' False bnames f (Bind (MN 0 "uv") (Lam (TType (UVar 0))) + (Bind n (Pi t) (V 1))) + + 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 combine bnames h1 h2 - un' fn bnames x y + un' fn bnames x y | OK True <- convEq' ctxt x y = do sc 1; return [] | otherwise = do UI s f <- get let r = recoverable x y @@ -272,7 +286,7 @@ else do put (UI s ((x, y, env, err) : f)) return [] -- lift $ tfail err - unApp fn bnames appx@(App fx ax) appy@(App fy ay) + unApp fn bnames appx@(App fx ax) appy@(App fy ay) | (injective fx && injective fy) || (injective fx && rigid appx && metavarApp appy) || (injective fy && rigid appy && metavarApp appx) @@ -283,11 +297,11 @@ -- fail quickly if the heads are disjoint checkHeads headx heady -- if True then -- (injective fx || injective fy || fx == fy) then --- if (injective fx && metavarApp appy) || +-- if (injective fx && metavarApp appy) || -- (injective fy && metavarApp appx) || -- (injective fx && injective fy) || fx == fy uplus - (do hf <- un' True bnames fx fy + (do hf <- un' True bnames fx fy let ax' = hnormalise hf ctxt env (substNames hf ax) let ay' = hnormalise hf ctxt env (substNames hf ay) ha <- un' False bnames ax' ay' @@ -304,7 +318,7 @@ let (heady, argsy) = unApply appy -- traceWhen (headx == heady) (show (appx, appy)) $ uplus ( - if (length argsx == length argsy && + if (length argsx == length argsy && ((headx == heady && inenv headx) || (argsx == argsy) || (and (zipWith sameStruct (headx:argsx) (heady:argsy))))) then @@ -313,7 +327,7 @@ failed <- errors if (not failed) then unArgs uf argsx argsy else return [] - else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $ + else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $ unifyTmpFail appx appy) (unifyTmpFail appx appy) -- whole application fails where hnormalise [] _ _ t = t @@ -329,9 +343,9 @@ checkHeads _ _ = return [] unArgs as [] [] = return as - unArgs as (x : xs) (y : ys) + unArgs as (x : xs) (y : ys) = do let x' = hnormalise as ctxt env (substNames as x) - let y' = hnormalise as ctxt env (substNames as y) + let y' = hnormalise as ctxt env (substNames as y) as' <- un' False bnames x' y' vs <- combine bnames as as' unArgs vs xs ys @@ -347,13 +361,13 @@ all (\x -> pat x || metavar x) (f : args) && nub args == args - sameArgStruct appx appy + sameArgStruct appx appy = let (_, ax) = unApply appx (_, ay) = unApply appy in length ax == length ay && and (zipWith sameStruct ax ay) - sameStruct fapp@(App f x) gapp@(App g y) + sameStruct fapp@(App f x) gapp@(App g y) = let (f',a') = unApply fapp (g',b') = unApply gapp in (f' == g' && length a' == length b' && @@ -384,13 +398,13 @@ P _ x _ -> x `elem` holes || patIn env x _ -> False inenv t = case t of - P _ x _ -> x `elem` (map fst env) + P _ x _ -> x `elem` (map fst env) _ -> False - notFn t = injective t || metavar t || inenv t + notFn t = injective t || metavar t || inenv t - unifyTmpFail x y + unifyTmpFail x y = do UI s f <- get let r = recoverable x y let err = CantUnify r @@ -429,15 +443,15 @@ put (UI s ((binderTy x, binderTy y, env, err) : f)) return [] -- lift $ tfail err - checkCycle ns p@(x, P _ _ _) = return [p] - checkCycle ns (x, tm) + checkCycle ns p@(x, P _ _ _) = return [p] + checkCycle ns (x, tm) | not (x `elem` freeNames tm) = checkScope ns (x, tm) - | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) + | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env)) checkScope ns (x, tm) = case boundVs (envPos x 0 env) tm of [] -> return [(x, tm)] - (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i)) + (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i)) (inst ns tm) (errEnv env)) where inst [] tm = tm inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm) @@ -449,7 +463,7 @@ combine bnames as [] = return as combine bnames as ((n, t) : bs) - = case lookup n as of + = case lookup n as of Nothing -> combine bnames (as ++ [(n,t)]) bs Just t' -> do ns <- un' False bnames t t' -- make sure there's n mapping from n in ns @@ -461,7 +475,7 @@ boundVs i (V j) | j <= i = [] | otherwise = [j] boundVs i (Bind n b sc) = boundVs (i + 1) sc -boundVs i (App f x) = let fs = boundVs i f +boundVs i (App f x) = let fs = boundVs i f xs = boundVs i x in nub (fs ++ xs) boundVs i _ = [] diff --git a/src/IRTS/BCImp.hs b/src/IRTS/BCImp.hs --- a/src/IRTS/BCImp.hs +++ b/src/IRTS/BCImp.hs @@ -1,6 +1,6 @@ module IRTS.BCImp where --- Bytecode for a register/variable based VM (e.g. for generating code in an +-- Bytecode for a register/variable based VM (e.g. for generating code in an -- imperative language where we let the language deal with GC) import IRTS.Lang diff --git a/src/IRTS/Bytecode.hs b/src/IRTS/Bytecode.hs --- a/src/IRTS/Bytecode.hs +++ b/src/IRTS/Bytecode.hs @@ -80,6 +80,7 @@ bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg] ++ clean r +-- bc reg (SUpdate x sc) r = bc reg sc r -- can't update, just do it bc reg (SCon 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 @@ -93,6 +94,7 @@ | otherwise = conCase True reg (L l) alts r bc reg (SChkCase (Loc l) alts) r = conCase False reg (L l) alts r +bc reg t r = error $ "Can't compile " ++ show t isConst [] = False isConst (SConstCase _ _ : xs) = True diff --git a/src/IRTS/CodegenC.hs b/src/IRTS/CodegenC.hs --- a/src/IRTS/CodegenC.hs +++ b/src/IRTS/CodegenC.hs @@ -20,9 +20,9 @@ codegenC :: [(Name, SDecl)] -> String -> -- output file name - OutputType -> -- generate executable if True, only .o if False + OutputType -> -- generate executable if True, only .o if False [FilePath] -> -- include files - String -> -- extra object files + String -> -- extra object files String -> -- extra compiler flags (libraries) String -> -- extra compiler flags (anything) DbgLevel -> @@ -34,9 +34,10 @@ let cc = concatMap (uncurry toC) bc d <- getDataDir mprog <- readFile (d "rts" "idris_main" <.> "c") - let cout = headers incs ++ debug dbg ++ h ++ cc ++ + let cout = headers incs ++ debug dbg ++ h ++ cc ++ (if (exec == Executable) then mprog else "") case exec of + MavenProject -> putStrLn ("FAILURE: output type not supported") Raw -> writeFile out cout _ -> do (tmpn, tmph) <- tempfile @@ -66,7 +67,7 @@ headers xs = concatMap (\h -> "#include <" ++ h ++ ">\n") - (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h", "gmp.h", "assert.h"]) + (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h", "assert.h"]) debug TRACE = "#define IDRIS_TRACE\n\n" debug _ = "" @@ -93,18 +94,18 @@ creg Tmp = "REG1" toDecl :: Name -> String -toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n" +toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n" toC :: Name -> [BC] -> String -toC f code - = -- "/* " ++ show code ++ "*/\n\n" ++ +toC f code + = -- "/* " ++ show code ++ "*/\n\n" ++ "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++ - indent 1 ++ "INITFRAME;\n" ++ + indent 1 ++ "INITFRAME;\n" ++ concatMap (bcc 1) code ++ "}\n\n" bcc :: Int -> BC -> String bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n" -bcc i (ASSIGNCONST l c) +bcc i (ASSIGNCONST l c) = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n" where mkConst (I i) = "MKINT(" ++ show i ++ ")" @@ -122,9 +123,9 @@ bcc i (MKCON l tag args) = indent i ++ "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ "," ++ show (length args) ++ ", 0);\n" ++ - indent i ++ setArgs 0 args ++ "\n" ++ + indent i ++ setArgs 0 args ++ "\n" ++ indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n" - + -- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++ -- show (length args) ++ concatMap showArg args ++ ");\n" where showArg r = ", " ++ creg r @@ -132,15 +133,15 @@ setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++ "); " ++ setArgs (i + 1) xs -bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++ +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 True r code def) + = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n" +bcc i (CASE True r code def) | length code < 4 = showCase i def code where showCode :: Int -> [BC] -> String - showCode i bc = "{\n" ++ indent i ++ concatMap (bcc (i + 1)) bc ++ + showCode i bc = "{\n" ++ indent i ++ concatMap (bcc (i + 1)) bc ++ indent i ++ "}\n" showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String @@ -150,7 +151,7 @@ = "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c ++ "else " ++ showCase i def cs -bcc i (CASE safe r code def) +bcc i (CASE safe r code def) = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++ concatMap (showCase i) code ++ showDef i def ++ @@ -162,9 +163,9 @@ showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n" ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n" showDef i Nothing = "" - showDef i (Just c) = indent i ++ "default:\n" + showDef i (Just c) = indent i ++ "default:\n" ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n" -bcc i (CONSTCASE r code def) +bcc i (CONSTCASE r code def) | intConsts code -- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++ -- concatMap (showCase i) code ++ @@ -200,15 +201,15 @@ indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n" ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n" iCase v (Ch b, bc) = - indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n" + indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n" ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n" showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n" - ++ concatMap (bcc (i+1)) bc ++ + ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n" showDef i Nothing = "" - showDef i (Just c) = indent i ++ "default:\n" - ++ concatMap (bcc (i+1)) c ++ + showDef i (Just c) = indent i ++ "default:\n" + ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n" showDefS i Nothing = "" showDefS i (Just c) = concatMap (bcc (i+1)) c @@ -226,8 +227,8 @@ bcc i STOREOLD = indent i ++ "STOREOLD;\n" bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n" bcc i (FOREIGNCALL l LANG_C rty fn args) - = indent i ++ - c_irts rty (creg l ++ " = ") + = indent i ++ + 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 @@ -288,27 +289,27 @@ doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")" doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")" -doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r] -doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r] +doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r] +doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r] doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r] -doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r] -doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r] -doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r] -doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r] -doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r] -doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r] -doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r] -doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r] -doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r] -doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r] -doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x] -doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r] -doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r] -doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r] +doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r] +doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r] +doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r] +doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r] +doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r] +doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r] +doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r] +doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r] +doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r] +doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r] +doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x] +doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r] +doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r] +doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r] doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r] doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r] -doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r] -doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r] +doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r] +doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r] doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r] doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r] @@ -445,6 +446,7 @@ doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)" +doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)" doOp v (LChInt ITNative) args = v ++ creg (last args) doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args doOp v (LIntCh ITNative) args = v ++ creg (last args) diff --git a/src/IRTS/CodegenCommon.hs b/src/IRTS/CodegenCommon.hs --- a/src/IRTS/CodegenCommon.hs +++ b/src/IRTS/CodegenCommon.hs @@ -7,7 +7,7 @@ import System.Environment data DbgLevel = NONE | DEBUG | TRACE deriving Eq -data OutputType = Raw | Object | Executable deriving (Eq, Show) +data OutputType = Raw | Object | Executable | MavenProject deriving (Eq, Show) environment :: String -> IO (Maybe String) environment x = Control.Exception.catch (do e <- getEnv x diff --git a/src/IRTS/CodegenJava.hs b/src/IRTS/CodegenJava.hs --- a/src/IRTS/CodegenJava.hs +++ b/src/IRTS/CodegenJava.hs @@ -2,14 +2,13 @@ module IRTS.CodegenJava (codegenJava) where import Core.TT hiding (mkApp) -import IRTS.BCImp import IRTS.CodegenCommon import IRTS.Java.ASTBuilding import IRTS.Java.JTypes import IRTS.Java.Mangling +import IRTS.Java.Pom (pomString) import IRTS.Lang import IRTS.Simplified -import Paths_idris import Util.System import Control.Applicative hiding (Const) @@ -18,10 +17,7 @@ import Control.Monad.Error import qualified Control.Monad.Trans as T import Control.Monad.Trans.State -import Data.Int -import Data.List (foldl', intercalate, isPrefixOf, - isSuffixOf) -import Data.Maybe (fromJust) +import Data.List (foldl', isSuffixOf) import qualified Data.Text as T import qualified Data.Text.IO as TIO import qualified Data.Vector.Unboxed as V @@ -37,73 +33,130 @@ ----------------------------------------------------------------------- -- Main function - codegenJava :: [(Name, SExp)] -> -- initialization of globals - [(Name, SDecl)] -> + [(Name, SDecl)] -> -- decls FilePath -> -- output file name [String] -> -- headers [String] -> -- libs OutputType -> IO () -codegenJava globalInit defs out hdrs libs exec = do - withTempdir (takeBaseName out) $ \ tmpDir -> do - let srcdir = tmpDir "src" "main" "java" - createDirectoryIfMissing True srcdir - let (Ident clsName) = either error id (mkClassName out) - let outjava = srcdir clsName <.> "java" - let jout = either error +codegenJava globalInit defs out hdrs libs exec = + withTgtDir exec out (codegenJava' exec) + where + codegenJava' :: OutputType -> FilePath -> IO () + codegenJava' Raw tgtDir = do + srcDir <- prepareSrcDir exec tgtDir + generateJavaFile globalInit defs hdrs srcDir out + codegenJava' MavenProject tgtDir = do + codegenJava' Raw tgtDir + generatePom tgtDir out libs + codegenJava' Object tgtDir = do + codegenJava' MavenProject tgtDir + invokeMvn tgtDir "compile" + copyClassFiles tgtDir out + cleanUpTmp tgtDir + codegenJava' _ tgtDir = do + codegenJava' MavenProject tgtDir + invokeMvn tgtDir "package"; + copyJar tgtDir out + makeJarExecutable out + cleanUpTmp tgtDir + +----------------------------------------------------------------------- +-- Compiler IO + +withTgtDir :: OutputType -> FilePath -> (FilePath -> IO ()) -> IO () +withTgtDir Raw out action = action (dropFileName out) +withTgtDir MavenProject out action = createDirectoryIfMissing False out >> action out +withTgtDir _ out action = withTempdir (takeBaseName out) action + +prepareSrcDir :: OutputType -> FilePath -> IO FilePath +prepareSrcDir Raw tgtDir = return tgtDir +prepareSrcDir _ tgtDir = do + let srcDir = (tgtDir "src" "main" "java") + createDirectoryIfMissing True srcDir + return srcDir + +javaFileName :: FilePath -> FilePath -> FilePath +javaFileName srcDir out = + either error (\ (Ident clsName) -> srcDir clsName <.> "java") (mkClassName out) + +generateJavaFile :: [(Name, SExp)] -> -- initialization of globals + [(Name, SDecl)] -> -- definitions + [String] -> -- headers + FilePath -> -- Source dir + FilePath -> -- output target + IO () +generateJavaFile globalInit defs hdrs srcDir out = do + let code = either error (prettyPrint)-- flatIndent . prettyPrint) (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv) - writeFile outjava jout - if (exec == Raw) - then copyFile outjava (takeDirectory out clsName <.> "java") - else do - execPom <- getExecutablePom - execPomTemplate <- TIO.readFile execPom - let execPom = T.replace (T.pack "$MAIN-CLASS$") - (T.pack clsName) - (T.replace (T.pack "$ARTIFACT-NAME$") - (T.pack $ takeBaseName out) - (T.replace (T.pack "$DEPENDENCIES$") - (mkPomDependencies libs) - execPomTemplate - ) - ) - TIO.writeFile (tmpDir "pom.xml") execPom - mvnCmd <- getMvn - let args = ["-f", (tmpDir "pom.xml")] - (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["compile"]) "" - when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout) - if (exec == Object) - then do - classFiles <- - map (\ clsFile -> tmpDir "target" "classes" clsFile) + writeFile (javaFileName srcDir out) code + +pomFileName :: FilePath -> FilePath +pomFileName tgtDir = tgtDir "pom.xml" + +generatePom :: FilePath -> -- tgt dir + FilePath -> -- output target + [String] -> -- libs + IO () +generatePom tgtDir out libs = writeFile (pomFileName tgtDir) execPom + where + (Ident clsName) = either error id (mkClassName out) + execPom = pomString clsName (takeBaseName out) libs + + +invokeMvn :: FilePath -> String -> IO () +invokeMvn tgtDir command = do + mvnCmd <- getMvn + let args = ["-f", pomFileName tgtDir] + (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ [command]) "" + when (exit /= ExitSuccess) $ + error ("FAILURE: " ++ mvnCmd ++ " " ++ command ++ "\n" ++ err ++ mvout) + +classFileDir :: FilePath -> FilePath +classFileDir tgtDir = tgtDir "target" "classes" + +copyClassFiles :: FilePath -> FilePath -> IO () +copyClassFiles tgtDir out = do + classFiles <- map (\ clsFile -> classFileDir tgtDir clsFile) . filter ((".class" ==) . takeExtension) - <$> getDirectoryContents (tmpDir "target" "classes") - mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out takeFileName clsFile)) - classFiles - else do - (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) "" - when (exit /= ExitSuccess) (error ("FAILURE: " ++ mvnCmd ++ " package\n" ++ err ++ mvout)) - copyFile (tmpDir "target" (takeBaseName out) <.> "jar") out - handle <- openBinaryFile out ReadMode - contents <- TIO.hGetContents handle - hClose handle - handle <- openBinaryFile out WriteMode - TIO.hPutStr handle (T.append (T.pack jarHeader) contents) - hFlush handle - hClose handle - perms <- getPermissions out - setPermissions out (setOwnerExecutable True perms) - readProcess mvnCmd (args ++ ["clean"]) "" - removeFile (tmpDir "pom.xml") + <$> getDirectoryContents (classFileDir tgtDir) + mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out takeFileName clsFile)) classFiles +jarFileName :: FilePath -> FilePath -> FilePath +jarFileName tgtDir out = tgtDir "target" (takeBaseName out) <.> "jar" + +copyJar :: FilePath -> FilePath -> IO () +copyJar tgtDir out = + copyFile (jarFileName tgtDir out) out + +makeJarExecutable :: FilePath -> IO () +makeJarExecutable out = do + handle <- openBinaryFile out ReadMode + contents <- TIO.hGetContents handle + hClose handle + handle <- openBinaryFile out WriteMode + TIO.hPutStr handle (T.append (T.pack jarHeader) contents) + hFlush handle + hClose handle + perms <- getPermissions out + setPermissions out (setOwnerExecutable True perms) + +removePom :: FilePath -> IO () +removePom tgtDir = removeFile (pomFileName tgtDir) + +cleanUpTmp :: FilePath -> IO () +cleanUpTmp tgtDir = do + invokeMvn tgtDir "clean" + removePom tgtDir + ----------------------------------------------------------------------- -- Jar and Pom infrastructure jarHeader :: String jarHeader = - "#!/bin/sh\n" + "#!/usr/bin/env sh\n" ++ "MYSELF=`which \"$0\" 2>/dev/null`\n" ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n" ++ "java=java\n" @@ -113,24 +166,6 @@ ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\"" ++ "exit 1\n" -mkPomDependencies :: [String] -> T.Text -mkPomDependencies deps = - T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps - where - mkDependency s = - case T.splitOn (T.pack ":") s of - [g, a, v] -> - [ T.pack $ "\n" - , T.append (T.pack " ") $ mkGroupId g - , T.append (T.pack " ") $ mkArtifactId a - , T.append (T.pack " ") $ mkVersion v - , T.pack $ "\n" - ] - _ -> [] - mkGroupId g = T.append (T.pack $ "") (T.append g $ T.pack "\n") - mkArtifactId a = T.append (T.pack $ "") (T.append a $ T.pack "\n") - mkVersion v = T.append (T.pack $ "") (T.append v $ T.pack "\n") - ----------------------------------------------------------------------- -- Code generation environment @@ -419,8 +454,10 @@ -- Bindings mkExp pp (SLet var newExp inExp) = mkLet pp var newExp inExp -mkExp pp (SUpdate var newExp) = +mkExp pp (SUpdate var@(Loc i) newExp) = -- can only update locals mkUpdate pp var newExp +mkExp pp (SUpdate var newExp) = + mkExp pp newExp -- Objects mkExp pp (SCon conId _ args) = @@ -449,6 +486,8 @@ (Nothing <>@! arg) >>= ppExp pp mkExp pp (SOp LNoOp args) = (Nothing <>@! (last args)) >>= ppExp pp +mkExp pp (SOp LNullPtr args) = + ppExp pp $ Lit Null mkExp pp (SOp op args) = (mkPrimitiveFunction op args) >>= ppExp pp diff --git a/src/IRTS/CodegenJavaScript.hs b/src/IRTS/CodegenJavaScript.hs --- a/src/IRTS/CodegenJavaScript.hs +++ b/src/IRTS/CodegenJavaScript.hs @@ -35,9 +35,14 @@ | JSForgotTy deriving Eq +data JSInteger = JSBigZero + | JSBigOne + | JSBigInt Integer + deriving Eq + data JSNum = JSInt Int | JSFloat Double - | JSInteger Integer + | JSInteger JSInteger deriving Eq data JS = JSRaw String @@ -149,9 +154,11 @@ show str compileJS (JSNum num) - | JSInt i <- num = show i - | JSFloat f <- num = show f - | JSInteger i <- num = show i + | JSInt i <- num = show i + | JSFloat f <- num = show f + | JSInteger JSBigZero <- num = "__IDRRT__ZERO" + | JSInteger JSBigOne <- num = "__IDRRT__ONE" + | JSInteger (JSBigInt i) <- num = show i compileJS (JSAssign lhs rhs) = compileJS lhs ++ "=" ++ compileJS rhs @@ -211,8 +218,8 @@ jsTypeTag obj = JSProj obj "type" jsBigInt :: JS -> JS -jsBigInt (JSString "0") = JSIdent "__IDRRT__ZERO" -jsBigInt (JSString "1") = JSIdent "__IDRRT__ONE" +jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero +jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val] jsVar :: Int -> String @@ -229,9 +236,11 @@ jsSubst :: String -> JS -> JS -> JS jsSubst var new (JSVar old) | var == translateVariableName old = new + | otherwise = JSVar old jsSubst var new (JSIdent old) | var == old = new + | otherwise = JSIdent old jsSubst var new (JSArray fields) = JSArray (map (jsSubst var new) fields) @@ -241,25 +250,47 @@ jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) = JSNew con [JSFunction [] ( - JSReturn $ JSApp fun (map (jsSubst var new) vars) + JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) vars) )] jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( JSReturn (JSApp fun args) )]) = JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( - JSReturn $ JSApp fun (map (jsSubst var new) args) + JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) args) )] +jsSubst var new (JSApp (JSProj obj field) args) = + JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args + jsSubst var new (JSApp (JSFunction [arg] body) vals) | var /= arg = JSApp (JSFunction [arg] ( jsSubst var new body )) $ map (jsSubst var new) vals + | otherwise = + JSApp (JSFunction [arg] ( + body + )) $ map (jsSubst var new) vals jsSubst var new (JSReturn ret) = JSReturn $ jsSubst var new ret +jsSubst var new (JSProj obj field) = + JSProj (jsSubst var new obj) field + +jsSubst var new (JSSeq body) = + JSSeq $ map (jsSubst var new) body + +jsSubst var new (JSOp op lhs rhs) = + JSOp op (jsSubst var new lhs) (jsSubst var new rhs) + +jsSubst var new (JSIndex obj field) = + JSIndex (jsSubst var new obj) (jsSubst var new field) + +jsSubst var new (JSCond conds) = + JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds) + jsSubst _ _ js = js inlineJS :: JS -> JS @@ -274,16 +305,12 @@ | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret , opt <- inlineJS val = JSNew con [JSFunction [] ( - JSReturn $ JSApp fun (map (jsSubst arg opt) vars) + JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) vars) )] - | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( - JSReturn (JSApp fun args) - )] <- ret + | JSApp (JSProj obj field) args <- ret , opt <- inlineJS val = - JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( - JSReturn $ JSApp fun (map (jsSubst arg opt) args) - )] + JSApp (JSProj (jsSubst arg opt obj) field) $ map (jsSubst arg opt) args | JSIndex (JSProj obj field) idx <- ret , opt <- inlineJS val = @@ -292,10 +319,19 @@ ) field ) (jsSubst arg opt idx) - | JSOp op lhs rhs <- ret = - JSOp op (jsSubst arg (inlineJS val) lhs) $ - (jsSubst arg (inlineJS val) rhs) + | JSOp op lhs rhs <- ret + , opt <- inlineJS val = + JSOp op (jsSubst arg opt lhs) $ + (jsSubst arg opt rhs) + | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( + JSReturn (JSApp fun args) + )] <- ret + , opt <- inlineJS val = + JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( + JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) args) + )] + inlineJS (JSApp fun args) = JSApp (inlineJS fun) (map inlineJS args) @@ -306,7 +342,7 @@ JSArray (map inlineJS fields) inlineJS (JSAssign lhs rhs) = - JSAssign lhs (inlineJS rhs) + JSAssign (inlineJS lhs) (inlineJS rhs) inlineJS (JSSeq seq) = JSSeq (map inlineJS seq) @@ -314,8 +350,8 @@ inlineJS (JSFunction args body) = JSFunction args (inlineJS body) -inlineJS (JSProj (JSFunction args body) "apply") = - JSProj (JSFunction args (inlineJS body)) "apply" +inlineJS (JSProj (JSFunction args body) field) = + JSProj (JSFunction args (inlineJS body)) field inlineJS (JSReturn js) = JSReturn $ inlineJS js @@ -401,7 +437,46 @@ removeIDCall _ js = js +reduceConstant :: JS -> JS +reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] ( + JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num]) + )]) = JSNum num +reduceConstant (JSReturn ret) = + JSReturn (reduceConstant ret) + +reduceConstant (JSApp fun args) = + JSApp (reduceConstant fun) (map reduceConstant args) + +reduceConstant (JSArray fields) = + JSArray (map reduceConstant fields) + +reduceConstant (JSAlloc name (Just val)) = + JSAlloc name $ Just (reduceConstant val) + +reduceConstant (JSNew con args) = + JSNew con (map reduceConstant args) + +reduceConstant (JSProj obj field) = + JSProj (reduceConstant obj) field + +reduceConstant (JSCond conds) = + JSCond $ map (reduceConstant *** reduceConstant) conds + +reduceConstant (JSSeq seq) = + JSSeq $ map reduceConstant seq + +reduceConstant (JSFunction args body) = + JSFunction args (reduceConstant body) + +reduceConstant js = js + +reduceConstants :: JS -> JS +reduceConstants js + | ret <- reduceConstant js + , ret /= js = reduceConstants ret + | otherwise = js + reduceLoop :: [String] -> ([JS], [JS]) -> [JS] reduceLoop reduced (cons, program) = case partition findConstructors program of @@ -513,7 +588,7 @@ functions :: [String] functions = - map compileJS ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def) + map (compileJS . reduceConstants) ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def) mainLoop :: String mainLoop = compileJS $ @@ -916,6 +991,9 @@ | LStrTail <- op , (arg:_) <- vars = let v = translateVariableName arg in JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)" + | LNullPtr <- op + , (_) <- vars = JSNull + where translateBinaryOp :: String -> LVar -> LVar -> JS translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs) @@ -969,7 +1047,7 @@ , JSArray $ map JSVar vars ] -translateExpression (SUpdate var e) = +translateExpression (SUpdate var@(Loc i) e) = JSAssign (JSVar var) (translateExpression e) translateExpression (SProj var i) = diff --git a/src/IRTS/CodegenLLVM.hs b/src/IRTS/CodegenLLVM.hs --- a/src/IRTS/CodegenLLVM.hs +++ b/src/IRTS/CodegenLLVM.hs @@ -22,6 +22,7 @@ import qualified LLVM.General.PassManager as PM import qualified LLVM.General.Module as MO import qualified LLVM.General.AST.IntegerPredicate as IPred +import qualified LLVM.General.AST.FloatingPointPredicate as FPred import qualified LLVM.General.AST.Linkage as L import qualified LLVM.General.AST.Visibility as V import qualified LLVM.General.AST.CallingConvention as CC @@ -94,6 +95,7 @@ defs <- ( "llvm" "libidris_rts.a") <$> getDataDir exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file] when (exit /= ExitSuccess) $ ierror "FAILURE: Linking" +outputModule _ _ MavenProject _ = ierror "FAILURE: unsupported output type" withTmpFile :: (FilePath -> IO a) -> IO a withTmpFile f = do @@ -123,6 +125,10 @@ , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpRealloc" , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpFree" ] + , Do $ Store False (ConstantOperand . C.GlobalReference . Name $ "__idris_argc") + (LocalReference (Name "argc")) Nothing 0 [] + , Do $ Store False (ConstantOperand . C.GlobalReference . Name $ "__idris_argv") + (LocalReference (Name "argv")) Nothing 0 [] , UnName 1 := idrCall "{runMain0}" [] ] (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []) ]} @@ -160,6 +166,38 @@ ] (Do $ Ret (Just (LocalReference (UnName 1))) []) ] + , GlobalDefinition $ globalVariableDefaults + { G.name = Name "__idris_floatFmtStr" + , G.linkage = L.Internal + , G.isConstant = True + , G.hasUnnamedAddr = True + , G.type' = ArrayType 5 (IntegerType 8) + , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%g" ++ [C.Int 8 0]) + } + , rtsFun "floatStr" ptrI8 [FloatingPointType 64 IEEE] + [ BasicBlock (UnName 0) + [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)] + , UnName 2 := simpleCall "snprintf" + [ LocalReference (UnName 1) + , ConstantOperand (C.Int (tgtWordSize tgt) 21) + , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_floatFmtStr") [C.Int 32 0, C.Int 32 0] + , LocalReference (UnName 0) + ] + ] + (Do $ Ret (Just (LocalReference (UnName 1))) []) + ] + , exfun "llvm.sin.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False + , exfun "llvm.cos.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False + , exfun "llvm.pow.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False + , exfun "llvm.ceil.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False + , exfun "llvm.floor.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False + , exfun "llvm.exp.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False + , exfun "llvm.log.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False + , exfun "llvm.sqrt.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False + , exfun "tan" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False + , exfun "asin" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False + , exfun "acos" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False + , exfun "atan" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False , exfun "llvm.trap" VoidType [] False -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i32" VoidType [ptrI8, ptrI8, IntegerType 32, IntegerType 32, IntegerType 1] False -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i64" VoidType [ptrI8, ptrI8, IntegerType 64, IntegerType 32, IntegerType 1] False @@ -183,6 +221,8 @@ , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False , exfun "__gmpz_fdiv_q_2exp" VoidType [pmpz, pmpz, intPtr] False , exfun "__gmpz_mul_2exp" VoidType [pmpz, pmpz, intPtr] False + , exfun "__gmpz_get_d" (FloatingPointType 64 IEEE) [pmpz] False + , exfun "__gmpz_set_d" VoidType [pmpz, FloatingPointType 64 IEEE] False , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False @@ -197,6 +237,8 @@ , exVar (stdinName tgt) ptrI8 , exVar (stdoutName tgt) ptrI8 , exVar (stderrName tgt) ptrI8 + , exVar "__idris_argc" (IntegerType 32) + , exVar "__idris_argv" (PointerType ptrI8 (AddrSpace 0)) , GlobalDefinition mainDef ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"] where @@ -215,7 +257,7 @@ , G.name = Name $ "__idris_" ++ name , G.basicBlocks = def } - + exfun :: String -> Type -> [Type] -> Bool -> Definition exfun name rty argtys vari = GlobalDefinition $ functionDefaults @@ -446,6 +488,7 @@ val <- cgExpr expr modify $ \s -> s { lexenv = replaceElt level val (lexenv s) } return val +cgExpr (SUpdate x expr) = cgExpr expr cgExpr (SCon tag name args) = do argSlots <- mapM var args case sequence argSlots of @@ -561,7 +604,7 @@ defExp = getDefExp =<< find isDefCase alts constAlts = filter isConstCase alts conAlts = filter isConCase alts - + isConstCase (SConstCase {}) = True isConstCase _ = False @@ -774,7 +817,8 @@ str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c) box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0]) cgConst c@(TT.BI i) = do - str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c) + let stringRepLen = (if i < 0 then 2 else 1) + fromInteger (numDigits 10 i) + str <- addGlobal' (ArrayType stringRepLen (IntegerType 8)) (cgConst' c) mpz <- alloc mpzTy inst $ simpleCall "__gmpz_init_set_str" [mpz , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0] @@ -805,8 +849,8 @@ , G.initializer = Just val } return . C.GlobalReference $ name - + ensureCDecl :: String -> FType -> [FType] -> Codegen Operand ensureCDecl name rty argtys = do syms <- gets foreignSyms @@ -834,10 +878,10 @@ ftyToTy (FArith (ATInt (ITVec e c))) = VectorType (fromIntegral c) (IntegerType (fromIntegral $ nativeTyWidth e)) ftyToTy (FArith (ATInt ITChar)) = IntegerType 32 +ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0) ftyToTy FUnit = VoidType ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0) -ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE ftyToTy FAny = valueType -- Only use when known not to be ITBig @@ -929,21 +973,70 @@ cgOp (LSGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y cgOp (LGe ity) [x,y] = iCmp ity IPred.UGE x y cgOp (LGt ity) [x,y] = iCmp ity IPred.UGT x y -cgOp (LPlus (ATInt ity)) [x,y] = ibin ity x y (Add False False) -cgOp (LMinus (ATInt ity)) [x,y] = ibin ity x y (Sub False False) -cgOp (LTimes (ATInt ity)) [x,y] = ibin ity x y (Mul False False) -cgOp (LSDiv (ATInt ity)) [x,y] = ibin ity x y (SDiv False) -cgOp (LSRem (ATInt ity)) [x,y] = ibin ity x y SRem -cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False) -cgOp (LURem ity) [x,y] = ibin ity x y URem -cgOp (LAnd ity) [x,y] = ibin ity x y And -cgOp (LOr ity) [x,y] = ibin ity x y Or -cgOp (LXOr ity) [x,y] = ibin ity x y Xor -cgOp (LCompl ity) [x] = iun ity x (Xor . ConstantOperand $ itConst ity (-1)) -cgOp (LSHL ity) [x,y] = ibin ity x y (Shl False False) -cgOp (LLSHR ity) [x,y] = ibin ity x y (LShr False) -cgOp (LASHR ity) [x,y] = ibin ity x y (AShr False) +cgOp (LPlus ty@(ATInt _)) [x,y] = binary ty x y (Add False False) +cgOp (LMinus ty@(ATInt _)) [x,y] = binary ty x y (Sub False False) +cgOp (LTimes ty@(ATInt _)) [x,y] = binary ty x y (Mul False False) +cgOp (LSDiv ty@(ATInt _)) [x,y] = binary ty x y (SDiv False) +cgOp (LSRem ty@(ATInt _)) [x,y] = binary ty x y SRem +cgOp (LUDiv ity) [x,y] = binary (ATInt ity) x y (UDiv False) +cgOp (LURem ity) [x,y] = binary (ATInt ity) x y URem +cgOp (LAnd ity) [x,y] = binary (ATInt ity) x y And +cgOp (LOr ity) [x,y] = binary (ATInt ity) x y Or +cgOp (LXOr ity) [x,y] = binary (ATInt ity) x y Xor +cgOp (LCompl ity) [x] = unary (ATInt ity) x (Xor . ConstantOperand $ itConst ity (-1)) +cgOp (LSHL ity) [x,y] = binary (ATInt ity) x y (Shl False False) +cgOp (LLSHR ity) [x,y] = binary (ATInt ity) x y (LShr False) +cgOp (LASHR ity) [x,y] = binary (ATInt ity) x y (AShr False) +cgOp (LSLt ATFloat) [x,y] = fCmp FPred.OLT x y +cgOp (LSLe ATFloat) [x,y] = fCmp FPred.OLE x y +cgOp (LEq ATFloat) [x,y] = fCmp FPred.OEQ x y +cgOp (LSGe ATFloat) [x,y] = fCmp FPred.OGE x y +cgOp (LSGt ATFloat) [x,y] = fCmp FPred.OGT x y +cgOp (LPlus ATFloat) [x,y] = binary ATFloat x y FAdd +cgOp (LMinus ATFloat) [x,y] = binary ATFloat x y FSub +cgOp (LTimes ATFloat) [x,y] = binary ATFloat x y FMul +cgOp (LSDiv ATFloat) [x,y] = binary ATFloat x y FDiv + +cgOp LFExp [x] = nunary ATFloat "llvm.exp.f64" x +cgOp LFLog [x] = nunary ATFloat "llvm.log.f64" x +cgOp LFSin [x] = nunary ATFloat "llvm.sin.f64" x +cgOp LFCos [x] = nunary ATFloat "llvm.cos.f64" x +cgOp LFTan [x] = nunary ATFloat "tan" x +cgOp LFASin [x] = nunary ATFloat "asin" x +cgOp LFACos [x] = nunary ATFloat "acos" x +cgOp LFATan [x] = nunary ATFloat "atan" x +cgOp LFSqrt [x] = nunary ATFloat "llvm.sqrt.f64" x +cgOp LFFloor [x] = nunary ATFloat "llvm.floor.f64" x +cgOp LFCeil [x] = nunary ATFloat "llvm.ceil.f64" x + +cgOp (LIntFloat ITBig) [x] = do + x' <- unbox (FArith (ATInt ITBig)) x + uflt <- inst $ simpleCall "__gmpz_get_d" [ x' ] + box (FArith ATFloat) uflt + +cgOp (LIntFloat ity) [x] = do + x' <- unbox (FArith (ATInt ity)) x + x'' <- inst $ SIToFP x' (FloatingPointType 64 IEEE) [] + box (FArith ATFloat) x'' + +cgOp (LFloatInt ITBig) [x] = do + x' <- unbox (FArith ATFloat) x + z <- alloc mpzTy + inst' $ simpleCall "__gmpz_init" [z] + inst' $ simpleCall "__gmpz_set_d" [ z, x' ] + box (FArith (ATInt ITBig)) z + +cgOp (LFloatInt ity) [x] = do + x' <- unbox (FArith ATFloat) x + x'' <- inst $ FPToSI x' (ftyToTy $ cmpResultTy ity) [] + box (FArith (ATInt ity)) x'' + +cgOp LFloatStr [x] = do + x' <- unbox (FArith ATFloat) x + ustr <- inst (idrCall "__idris_floatStr" [x']) + box FString ustr + cgOp LNoOp xs = return $ last xs cgOp (LMkVec ety c) xs | c == length xs = do @@ -1109,21 +1202,29 @@ end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) [] inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 [] box FString mem - -ibin :: IntTy -> Operand -> Operand + +binary :: ArithTy -> Operand -> Operand -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand -ibin ity x y instCon = do - nx <- unbox (FArith (ATInt ity)) x - ny <- unbox (FArith (ATInt ity)) y +binary ty x y instCon = do + nx <- unbox (FArith ty) x + ny <- unbox (FArith ty) y nr <- inst $ instCon nx ny [] - box (FArith (ATInt ity)) nr + box (FArith ty) nr -iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand -iun ity x instCon = do - nx <- unbox (FArith (ATInt ity)) x +unary :: ArithTy -> Operand + -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand +unary ty x instCon = do + nx <- unbox (FArith ty) x nr <- inst $ instCon nx [] - box (FArith (ATInt ity)) nr + box (FArith ty) nr +nunary :: ArithTy -> String + -> Operand -> Codegen Operand +nunary ty name x = do + nx <- unbox (FArith ty) x + nr <- inst $ simpleCall name [nx] + box (FArith ty) nr + iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand iCmp ity pred x y = do nx <- unbox (FArith (ATInt ity)) x @@ -1131,6 +1232,13 @@ nr <- inst $ ICmp pred nx ny [] nr' <- inst $ SExt nr (ftyToTy $ cmpResultTy ity) [] box (cmpResultTy ity) nr' + +fCmp :: FPred.FloatingPointPredicate -> Operand -> Operand -> Codegen Operand +fCmp pred x y = do + nx <- unbox (FArith ATFloat) x + ny <- unbox (FArith ATFloat) y + nr <- inst $ FCmp pred nx ny [] + box (FArith (ATInt (ITFixed IT32))) nr cmpResultTy :: IntTy -> FType cmpResultTy v@(ITVec _ _) = FArith (ATInt v) diff --git a/src/IRTS/Compiler.hs b/src/IRTS/Compiler.hs --- a/src/IRTS/Compiler.hs +++ b/src/IRTS/Compiler.hs @@ -19,6 +19,7 @@ import Idris.AbsSyntax import Idris.UnusedArgs +import Idris.Error import Core.TT import Core.Evaluate @@ -66,36 +67,35 @@ dumpDefun <- getDumpDefun case dumpCases of Nothing -> return () - Just f -> liftIO $ writeFile f (showCaseTrees tagged) + Just f -> runIO $ writeFile f (showCaseTrees defs) case dumpDefun of Nothing -> return () - Just f -> liftIO $ writeFile f (dumpDefuns defuns) + Just f -> runIO $ writeFile f (dumpDefuns defuns) triple <- targetTriple cpu <- targetCPU optimize <- optLevel iLOG "Building output" case checked of - OK c -> liftIO $ case codegen of - ViaC -> - codegenC c f outty hdrs - (concatMap mkObj objs) - (concatMap mkLib libs) - (concatMap mkFlag flags ++ - concatMap incdir impdirs) NONE - ViaJava -> - codegenJava [] c f hdrs libs outty - ViaJavaScript -> - codegenJavaScript JavaScript c f outty - ViaNode -> - codegenJavaScript Node c f outty - ViaLLVM -> codegenLLVM c triple cpu optimize f outty - - Bytecode -> dumpBC c f - Error e -> fail $ show e + OK c -> runIO $ case codegen of + ViaC -> + codegenC c f outty hdrs + (concatMap mkObj objs) + (concatMap mkLib libs) + (concatMap mkFlag flags ++ + concatMap incdir impdirs) NONE + ViaJava -> + codegenJava [] c f hdrs libs outty + ViaJavaScript -> + codegenJavaScript JavaScript c f outty + ViaNode -> + codegenJavaScript Node c f outty + ViaLLVM -> codegenLLVM c triple cpu optimize f outty + Bytecode -> dumpBC c f + Error e -> ierror e where checkMVs = do i <- getIState - case idris_metavars i \\ primDefs of + case map fst (idris_metavars i) \\ primDefs of [] -> return () - ms -> fail $ "There are undefined metavariables: " ++ show ms + ms -> ifail $ "There are undefined metavariables: " ++ show ms inDir d h = do let f = d h ex <- doesFileExist f if ex then return f else return h @@ -110,16 +110,8 @@ irMain tm = do i <- ir tm return $ LFun [] (MN 0 "runMain") [] (LForce i) -allNames :: [Name] -> Name -> Idris [Name] -allNames ns n | n `elem` ns = return [] -allNames ns n = do i <- getIState - case lookupCtxt n (idris_callgraph i) of - [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns')) - return (nub (n : concat more)) - _ -> return [n] - mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)] -mkDecls t used +mkDecls t used = do i <- getIState let ds = filter (\ (n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i) mapM traceUnused used @@ -129,10 +121,10 @@ showCaseTrees :: [(Name, LDecl)] -> String showCaseTrees ds = showSep "\n\n" (map showCT ds) where - showCT (n, LFun _ f args lexp) + 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 + ++ show lexp + showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a isCon (TyDecl _ _) = True isCon _ = False @@ -144,9 +136,9 @@ build (n, d) = do i <- getIState case lookup n (idris_scprims i) of - Just (ar, op) -> + Just (ar, op) -> let args = map (\x -> MN x "op") [0..] in - return (n, (LFun [] n (take ar args) + return (n, (LFun [] n (take ar args) (LOp op (map (LV . Glob) (take ar args))))) _ -> do def <- mkLDecl n d logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def @@ -154,18 +146,18 @@ getPrim :: IState -> Name -> [LExp] -> Maybe LExp getPrim i n args = case lookup n (idris_scprims i) of - Just (ar, op) -> - if (ar == length args) + Just (ar, op) -> + if (ar == length args) then return (LOp op args) else Nothing _ -> Nothing declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x -declArgs args inl n x = LFun (if inl then [Inline] else []) n args x +declArgs args inl n x = LFun (if inl then [Inline] else []) n args x mkLDecl n (Function tm _) = do e <- ir tm return (declArgs [] True n e) -mkLDecl n (CaseOp ci _ _ pats cd) +mkLDecl n (CaseOp ci _ _ pats cd) = let (args, sc) = cases_runtime cd in do e <- ir (args, sc) return (declArgs [] (case_inlinable ci) n e) @@ -173,14 +165,14 @@ mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a mkLDecl n _ = return (LFun [] n [] (LError ("Impossible declaration " ++ show n))) -instance ToIR (TT Name) where +instance ToIR (TT Name) where ir tm = ir' [] tm where ir' env tm@(App f a) | (P _ (UN "mkForeignPrim") _, args) <- unApply tm = doForeign env args | (P _ (UN "unsafePerformPrimIO") _, [_, arg]) <- unApply tm = ir' env arg - -- TMP HACK - until we get inlining. + -- TMP HACK - until we get inlining. | (P _ (UN "replace") _, [_, _, _, _, _, arg]) <- unApply tm = ir' env arg | (P _ (UN "lazy") _, [_, arg]) <- unApply tm @@ -198,11 +190,11 @@ -- = do v' <- ir' env v -- return v' -- | (P _ (UN "prim_io_bind") _, [_,_,v,Bind n (Lam _) sc]) <- unApply tm --- = do v' <- ir' env v +-- = do v' <- ir' env v -- sc' <- ir' (n:env) sc -- return (LLet n (LForce v') sc') -- | (P _ (UN "prim_io_bind") _, [_,_,v,k]) <- unApply tm --- = do v' <- ir' env v +-- = do v' <- ir' env v -- k' <- ir' env k -- return (LApp False k' [LForce v']) | (P _ (UN "malloc") _, [_,size,t]) <- unApply tm @@ -217,26 +209,28 @@ -- return (LOp LBPlus [k', LConst (BI 1)]) | (P (DCon t a) n _, args) <- unApply tm = irCon env t a n args + | (P (TCon t a) n _, args) <- unApply tm + = return LNothing | (P _ n _, args) <- unApply tm = do i <- getIState args' <- mapM (ir' env) args case getPrim i n args' of Just tm -> return tm _ -> do - let collapse - = case lookupCtxt n + let collapse + = case lookupCtxtExact n (idris_optimisation i) of [oi] -> collapsible oi _ -> False - let unused - = case lookupCtxt n + let unused + = case lookupCtxtExact n (idris_callgraph i) of - [CGInfo _ _ _ _ unusedpos] -> + [CGInfo _ _ _ _ unusedpos] -> unusedpos _ -> [] - if collapse + if collapse then return LNothing - else return (LApp False (LV (Glob n)) + else return (LApp False (LV (Glob n)) (mkUnused unused 0 args')) | (f, args) <- unApply tm = do f' <- ir' env f @@ -249,7 +243,7 @@ -- = return $ LConst (BI 0) ir' env (P _ n _) = return $ LV (Glob n) ir' env (V i) | i >= 0 && i < length env = return $ LV (Glob (env!!i)) - | otherwise = error $ "IR fail " ++ show i ++ " " ++ show tm + | otherwise = ifail $ "IR fail " ++ show i ++ " " ++ show tm ir' env (Bind n (Lam _) sc) = do let n' = uniqueName n env sc' <- ir' (n' : env) sc @@ -259,6 +253,10 @@ v' <- ir' env v return $ LLet n v' sc' ir' env (Bind _ _ _) = return $ LNothing + ir' env (Proj t i) | i == -1 + = do t' <- ir' env t + return $ LOp (LMinus (ATInt ITBig)) + [t', LConst (BI 1)] ir' env (Proj t i) = do t' <- ir' env t return $ LProj t' i ir' env (Constant c) = return $ LConst c @@ -270,10 +268,10 @@ irCon env t arity n args | length args == arity = buildApp env (LV (Glob n)) args | otherwise = let extra = satArgs (arity - length args) in - do sc' <- irCon env t arity n + do sc' <- irCon env t arity n (args ++ map (\n -> P Bound n undefined) extra) return $ LLam extra sc' - + satArgs n = map (\i -> MN i "sat") [1..n] buildApp env e [] = return e @@ -286,19 +284,19 @@ = let maybeTys = getFTypes fgnArgTys rty = mkIty' ret in case maybeTys of - Nothing -> fail $ "Foreign type specification is not a constant list: " ++ show (fgn:args) + Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args) Just tys -> do args' <- mapM (ir' env) (init args) -- wrap it in a prim__IO -- return $ con_ 0 @@ impossible @@ return $ -- LLazyExp $ LForeign LANG_C rty fgnName (zip tys args') - | otherwise = fail "Badly formed foreign function call" + | otherwise = ifail "Badly formed foreign function call" getFTypes :: TT Name -> Maybe [FType] getFTypes tm = case unApply tm of (nil, []) -> Just [] - (cons, [ty, xs]) -> + (cons, [ty, xs]) -> fmap (mkIty' ty :) (getFTypes xs) _ -> Nothing @@ -340,7 +338,7 @@ mkIntIty "IT64" = FArith (ATInt (ITFixed IT64)) zname = NS (UN "Z") ["Nat","Prelude"] -sname = NS (UN "S") ["Nat","Prelude"] +sname = NS (UN "S") ["Nat","Prelude"] instance ToIR ([Name], SC) where ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree @@ -367,9 +365,9 @@ -- = do n' <- ir n -- rhs' <- ir rhs -- return $ LDefaultCase --- (LLet arg (LOp LBMinus [n', LConst (BI 1)]) +-- (LLet arg (LOp LBMinus [n', LConst (BI 1)]) -- rhs') - mkIRAlt _ (ConCase n t args rhs) + mkIRAlt _ (ConCase n t args rhs) = do rhs' <- ir rhs return $ LConCase (-1) n args rhs' mkIRAlt _ (ConstCase x rhs) @@ -377,16 +375,16 @@ = do rhs' <- ir rhs return $ LConstCase x rhs' | matchableTy x - = do rhs' <- ir rhs + = do rhs' <- ir rhs return $ LDefaultCase rhs' - mkIRAlt tm (SucCase n rhs) + mkIRAlt tm (SucCase n rhs) = do rhs' <- ir rhs return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig)) [tm, LConst (BI 1)]) rhs') -- return $ LSucCase n rhs' - mkIRAlt _ (ConstCase c rhs) - = fail $ "Can't match on (" ++ show c ++ ")" + mkIRAlt _ (ConstCase c rhs) + = ifail $ "Can't match on (" ++ show c ++ ")" 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 @@ -1,4 +1,4 @@ -module IRTS.Defunctionalise(module IRTS.Defunctionalise, +module IRTS.Defunctionalise(module IRTS.Defunctionalise, module IRTS.Lang) where import IRTS.Lang @@ -37,8 +37,8 @@ type DDefs = Ctxt DDecl -defunctionalise :: Int -> LDefs -> DDefs -defunctionalise nexttag defs +defunctionalise :: Int -> LDefs -> DDefs +defunctionalise nexttag defs = let all = toAlist defs -- sort newcons so that EVAL and APPLY cons get sequential tags (allD, enames) = runState (mapM (addApps defs) all) [] @@ -51,7 +51,7 @@ getFn :: [(Name, LDecl)] -> [(Name, Int)] getFn xs = mapMaybe fnData xs - where fnData (n, LFun _ _ args _) = Just (n, length args) + where fnData (n, LFun _ _ args _) = Just (n, length args) fnData _ = Nothing -- To defunctionalise: @@ -68,9 +68,9 @@ -- 8 Add explicit EVAL to case, primitives, and foreign calls addApps :: LDefs -> (Name, LDecl) -> State [Name] (Name, DDecl) -addApps defs o@(n, LConstructor _ t a) - = return (n, DConstructor n t a) -addApps defs (n, LFun _ _ args e) +addApps defs o@(n, LConstructor _ t a) + = return (n, DConstructor n t a) +addApps defs (n, LFun _ _ args e) = do e' <- aa args e return (n, DFun n args e') where @@ -79,15 +79,15 @@ | otherwise = aa env (LApp False (LV (Glob n)) []) -- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e aa env (LApp tc (LV (Glob n)) args) - = do args' <- mapM (aa env) args - case lookupCtxt n defs of + = do args' <- mapM (aa env) args + case lookupCtxtExact n defs of [LConstructor _ i ar] -> return $ DApp tc n args' [LFun _ _ as _] -> let arity = length as in fixApply tc n args' arity [] -> return $ chainAPPLY (DV (Glob n)) args' aa env (LLazyApp n args) = do args' <- mapM (aa env) args - case lookupCtxt n defs of + case lookupCtxtExact n defs of [LConstructor _ i ar] -> return $ DApp False n args' [LFun _ _ as _] -> let arity = length as in fixLazyApply n args' arity @@ -96,9 +96,9 @@ aa env (LForce e) = liftM eEVAL (aa env e) aa env (LLet n v sc) = liftM2 (DLet n) (aa env v) (aa (n : env) sc) aa env (LCon i n args) = liftM (DC i n) (mapM (aa env) args) - aa env (LProj t@(LV (Glob n)) i) - = do t' <- aa env t - return $ DProj (DUpdate n (eEVAL t')) i + aa env (LProj t@(LV (Glob n)) i) + | n `elem` env = do t' <- aa env t + return $ DProj (DUpdate n (eEVAL t')) i aa env (LProj t i) = do t' <- aa env t return $ DProj (eEVAL t') i aa env (LCase e alts) = do e' <- aa env e @@ -115,33 +115,33 @@ aaF env (t, e) = do e' <- aa env e return (t, eEVAL e') - aaAlt env (LConCase i n args e) + aaAlt env (LConCase i n args e) = liftM (DConCase i n args) (aa (args ++ env) e) aaAlt env (LConstCase c e) = liftM (DConstCase c) (aa env e) aaAlt env (LDefaultCase e) = liftM DDefaultCase (aa env e) - fixApply tc n args ar - | length args == ar + fixApply tc n args ar + | length args == ar = return $ DApp tc n args - | length args < ar + | length args < ar = do ns <- get put $ nub (n : ns) return $ DApp tc (mkUnderCon n (ar - length args)) args - | length args > ar + | length args > ar = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args) - fixLazyApply n args ar - | length args == ar + fixLazyApply n args ar + | length args == ar = do ns <- get put $ nub (n : ns) return $ DApp False (mkFnCon n) args - | length args < ar + | length args < ar = do ns <- get put $ nub (n : ns) return $ DApp False (mkUnderCon n (ar - length args)) args - | length args > ar + | length args > ar = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args) - + chainAPPLY f [] = f chainAPPLY f (a : as) = chainAPPLY (DApp False (MN 0 "APPLY") [f, a]) as @@ -149,7 +149,7 @@ -- but we only want to do it once, rather than every time we project. preEval [] t = t - preEval (x : xs) t + preEval (x : xs) t | needsEval x t = DLet x (eEVAL (DV (Glob x))) (preEval xs t) | otherwise = preEval xs t @@ -163,7 +163,7 @@ where nec (DConCase _ _ _ e) = needsEval x e nec (DConstCase _ e) = needsEval x e nec (DDefaultCase e) = needsEval x e - needsEval x (DLet n v e) + needsEval x (DLet n v e) | x == n = needsEval x v | otherwise = needsEval x v || needsEval x e needsEval x (DForeign _ _ _ args) = or (map (needsEval x) (map snd args)) @@ -181,9 +181,9 @@ -- data constuctors, and whether to handle them in EVAL or APPLY toCons :: [Name] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)] -toCons ns (n, i) +toCons ns (n, i) | n `elem` ns - = (mkFnCon n, i, + = (mkFnCon n, i, EvalCase (\tlarg -> (DConCase (-1) (mkFnCon n) (take i (genArgs 0)) (dupdate tlarg @@ -193,11 +193,11 @@ where dupdate tlarg x = x mkApplyCase fname n ar | n == ar = [] -mkApplyCase fname n ar +mkApplyCase fname n ar = let nm = mkUnderCon fname (ar - n) in (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0)) - (DApp False (mkUnderCon fname (ar - (n + 1))) - (map (DV . Glob) (take n (genArgs 0) ++ + (DApp False (mkUnderCon fname (ar - (n + 1))) + (map (DV . Glob) (take n (genArgs 0) ++ [MN 0 "arg"]))))) : mkApplyCase fname (n + 1) ar @@ -207,7 +207,7 @@ (mapMaybe evalCase xs ++ [DDefaultCase (DV (Glob (MN 0 "arg")))]))) where - evalCase (n, t, EvalCase x) = Just (x (MN 0 "arg")) + evalCase (n, t, EvalCase x) = Just (x (MN 0 "arg")) evalCase _ = Nothing mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl) @@ -259,7 +259,7 @@ show' env (DError str) = "error " ++ show str show' env DNothing = "____" - showAlt env (DConCase _ n args e) + showAlt env (DConCase _ n args e) = show n ++ "(" ++ showSep ", " (map show args) ++ ") => " ++ show' env e showAlt env (DConstCase c e) = show c ++ " => " ++ show' env e @@ -268,7 +268,7 @@ -- Divide up a large case expression so that each has a maximum of -- 'max' branches -mkBigCase cn max arg branches +mkBigCase cn max arg branches | length branches <= max = DChkCase arg branches | otherwise = -- DChkCase arg branches -- until I think of something... -- divide the branches into groups of at most max (by tag), @@ -281,7 +281,7 @@ cs = map mkCase bss in DChkCase arg branches - where mkCase bs = DChkCase arg bs + where mkCase bs = DChkCase arg bs tagOrd (DConCase t _ _ _) (DConCase t' _ _ _) = compare t t' tagOrd (DConstCase c _) (DConstCase c' _) = compare c c' @@ -309,7 +309,7 @@ dumpDefuns :: DDefs -> String dumpDefuns ds = showSep "\n" $ map showDef (toAlist ds) - where showDef (x, DFun fn args exp) + 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/DumpBC.hs b/src/IRTS/DumpBC.hs --- a/src/IRTS/DumpBC.hs +++ b/src/IRTS/DumpBC.hs @@ -50,7 +50,7 @@ CALL x -> "CALL " ++ show x TAILCALL x -> "TAILCALL " ++ show x FOREIGNCALL r _ ret name args -> - "FOREIGNCALL " ++ serializeReg r ++ " \"" ++ name ++ "\" " ++ show ret ++ + "FOREIGNCALL " ++ serializeReg r ++ " \"" ++ name ++ "\" " ++ show ret ++ " [" ++ interMap args ", " (\(ty, r) -> serializeReg r ++ " : " ++ show ty) ++ "]" SLIDE n -> "SLIDE " ++ show n REBASE -> "REBASE" diff --git a/src/IRTS/Inliner.hs b/src/IRTS/Inliner.hs --- a/src/IRTS/Inliner.hs +++ b/src/IRTS/Inliner.hs @@ -4,13 +4,13 @@ import IRTS.Defunctionalise -inline :: DDefs -> DDefs +inline :: DDefs -> DDefs 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) +inl ds d@(n, DFun n' args exp) = case evalD ds exp of Just exp' -> (n, DFun n' args exp') _ -> d diff --git a/src/IRTS/Java/JTypes.hs b/src/IRTS/Java/JTypes.hs --- a/src/IRTS/Java/JTypes.hs +++ b/src/IRTS/Java/JTypes.hs @@ -218,6 +218,7 @@ | (LTrunc _ to) <- x = "LTrunc" ++ (suffixFor to) | (LFloatInt to) <- x = "LFloatInt" ++ (suffixFor to) | (LStrInt to) <- x = "LStrInt" ++ (suffixFor to) + | (LChInt to) <- x = "LChInt" ++ (suffixFor to) | otherwise = takeWhile ((/=) ' ') $ show x where suffixFor (ITFixed nt) = show nt @@ -293,6 +294,7 @@ sourceTypes (LFork) = [objectType] sourceTypes (LPar) = [objectType] sourceTypes (LVMPtr) = [] +sourceTypes (LNullPtr) = [objectType] sourceTypes (LNoOp) = repeat objectType diff --git a/src/IRTS/Java/Pom.hs b/src/IRTS/Java/Pom.hs new file mode 100644 --- /dev/null +++ b/src/IRTS/Java/Pom.hs @@ -0,0 +1,89 @@ +module IRTS.Java.Pom (pomString) where + +import Data.List (unfoldr) +import Text.XML.Light + +uattr :: String -> String -> Attr +uattr k v = Attr (QName k Nothing Nothing) v + +-- from http://stackoverflow.com/a/4978733/283260 +splitOn :: Eq a => a -> [a] -> [[a]] +splitOn chr = unfoldr sep where + sep [] = Nothing + sep l = Just . fmap (drop 1) . break (==chr) $ l + +parseToDep :: String -> Element +parseToDep tuple = + case splitOn ':' tuple of + [g, a, v] -> dependency g a v + _ -> blank_element + +dependency :: String -> String -> String -> Element +dependency g a v = unode "dependency" (groupArtifactVersion g a v) + +groupArtifactVersion :: String -> String -> String -> [Element] +groupArtifactVersion g a v = [ + unode "groupId" g, + unode "artifactId" a, + unode "version" v + ] + +pomString :: String -> String -> [String] -> String +pomString c a d = ppElement $ pom c a d + +pom :: String -> String -> [String] -> Element +pom clsName artifactName dependencies = unode "project" ([ + uattr "xmlns" "http://maven.apache.org/POM/4.0.0", + uattr "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance", + uattr "xsi:schemaLocation" "http://maven.apache.org/POM/4.0.0 http://maven.apache.org/maven-v4_0_0.xsd" + ], + [ + unode "modelVersion" "4.0.0", + unode "groupId" "org.idris-lang", + unode "artifactId" artifactName, + unode "packaging" "jar", + unode "version" "1.0", + unode "name" artifactName, + unode "properties" [ + unode "project.build.sourceEncoding" "UTF-8", + unode "skipTest" "true" + ], + unode "dependencies" ( + dependency "org.idris-lang" "idris" "0.9.10-alpha-2" : + map parseToDep dependencies + ), + unode "build" [ + unode "finalName" artifactName, + unode "plugins" [ + unode "plugin" ( + unode "configuration" [ + unode "source" "1.7", + unode "target" "1.7" + ] : groupArtifactVersion "org.apache.maven.plugins" "maven-compiler-plugin" "3.0" + ), + unode "plugin" ( + unode "configuration" ( + unode "skipTests" "${skipTests}" + ) : groupArtifactVersion "org.apache.maven.plugins" "maven-surefile-plugin" "2.14" + ), + unode "plugin" ( + unode "executions" [ + unode "execution" [ + unode "phase" "package", + unode "goals" ( + unode "goal" "shade" + ), + unode "configuration" ( + unode "transformers" ( + unode "transformer" ( + uattr "implementation" "org.apache.maven.plugins.shade.resource.ManifestResourceTransformer", + unode "mainClass" clsName + ) + ) + ) + ] + ] : groupArtifactVersion "org.apache.maven.plugins" "maven-shade-plugin" "2.1" + ) + ] + ] + ]) diff --git a/src/IRTS/LParser.hs b/src/IRTS/LParser.hs deleted file mode 100644 --- a/src/IRTS/LParser.hs +++ /dev/null @@ -1,275 +0,0 @@ -module IRTS.LParser where - -import Idris.AbsSyntaxTree -import Core.CoreParser -import Core.TT -import IRTS.Lang -import IRTS.Simplified -import IRTS.Bytecode -import IRTS.CodegenCommon -import IRTS.CodegenC -import IRTS.CodegenJava -import IRTS.CodegenJavaScript -import IRTS.Defunctionalise -import Paths_idris - -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Error -import Text.ParserCombinators.Parsec.Expr -import Text.ParserCombinators.Parsec.Language -import qualified Text.ParserCombinators.Parsec.Token as PTok - -import Data.List -import Control.Monad.State -import Debug.Trace -import Data.Maybe -import System.FilePath - -type TokenParser a = PTok.TokenParser a - -type LParser = GenParser Char () - -lexer :: TokenParser () -lexer = idrisLexer - -whiteSpace= PTok.whiteSpace lexer -lexeme = PTok.lexeme lexer -symbol = PTok.symbol lexer -natural = PTok.natural lexer -parens = PTok.parens lexer -semi = PTok.semi lexer -comma = PTok.comma lexer -identifier= PTok.identifier lexer -reserved = PTok.reserved lexer -operator = PTok.operator lexer -reservedOp= PTok.reservedOp lexer -integer = PTok.integer lexer -float = PTok.float lexer -strlit = PTok.stringLiteral lexer -chlit = PTok.charLiteral lexer -lchar = lexeme.char - -fovm :: Codegen -> OutputType -> FilePath -> IO () -fovm cgn outty f - = do defs <- parseFOVM f - let (nexttag, tagged) = addTags 0 (liftAll defs) - ctxtIn = addAlist tagged emptyContext - defuns = defunctionalise nexttag ctxtIn - putStrLn $ showSep "\n" (map show (toAlist defuns)) - let checked = checkDefs defuns (toAlist defuns) --- print checked - case checked of - OK c -> case cgn of - ViaC -> codegenC c "a.out" outty ["math.h"] "" "" "" TRACE - ViaJava -> codegenJava [] c "a.out" [] [] outty - Error e -> fail $ show e - -parseFOVM :: FilePath -> IO [(Name, LDecl)] -parseFOVM fname = do -- putStrLn $ "Reading " ++ fname - fp <- readFile fname - case runParser pProgram () fname fp of - Left err-> fail (show err) - Right x -> return x - -pProgram :: LParser [(Name, LDecl)] -pProgram = do fs <- many1 pLDecl - eof - return fs - -pLDecl :: LParser (Name, LDecl) -pLDecl = do reserved "data" - n <- iName [] - ar <- natural - return (n, LConstructor n (-1) (fromInteger ar)) - <|> do reserved "fun" - n <- iName [] - lchar '(' - args <- sepBy (iName []) (lchar ',') - lchar ')' - lchar '=' - def <- pLExp - return (n, LFun [] n args def) - -pLExp = buildExpressionParser optable pLExp' - -optable = [[binary "*" (\x y -> LOp (LTimes (ATInt ITNative)) [x,y]) AssocLeft, - binary "/" (\x y -> LOp (LSDiv (ATInt ITNative)) [x,y]) AssocLeft, - binary "*." (\x y -> LOp (LTimes ATFloat) [x,y]) AssocLeft, - binary "/." (\x y -> LOp (LSDiv ATFloat) [x,y]) AssocLeft, - binary "*:" (\x y -> LOp (LTimes (ATInt ITBig)) [x,y]) AssocLeft, - binary "/:" (\x y -> LOp (LSDiv (ATInt ITBig)) [x,y]) AssocLeft, - binary "*," (\x y -> LOp (LTimes (ATInt ITChar)) [x, y]) AssocLeft, - binary "/," (\x y -> LOp (LSDiv (ATInt ITChar)) [x, y]) AssocLeft - ], - [ - binary "+" (\x y -> LOp (LPlus (ATInt ITNative)) [x,y]) AssocLeft, - binary "-" (\x y -> LOp (LMinus (ATInt ITNative)) [x,y]) AssocLeft, - binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft, - binary "+." (\x y -> LOp (LPlus ATFloat) [x,y]) AssocLeft, - binary "-." (\x y -> LOp (LMinus ATFloat) [x,y]) AssocLeft, - binary "+:" (\x y -> LOp (LPlus (ATInt ITBig)) [x,y]) AssocLeft, - binary "-:" (\x y -> LOp (LMinus (ATInt ITBig)) [x,y]) AssocLeft, - binary "+," (\x y -> LOp (LPlus (ATInt ITChar)) [x,y]) AssocLeft, - binary "-," (\x y -> LOp (LMinus (ATInt ITChar)) [x,y]) AssocLeft - ], - [ - binary "==" (\x y -> LOp (LEq (ATInt ITNative)) [x, y]) AssocNone, - binary "==." (\x y -> LOp (LEq ATFloat) [x, y]) AssocNone, - binary "<" (\x y -> LOp (LSLt (ATInt ITNative)) [x, y]) AssocNone, - binary "<." (\x y -> LOp (LSLt ATFloat) [x, y]) AssocNone, - binary ">" (\x y -> LOp (LSGt (ATInt ITNative)) [x, y]) AssocNone, - binary ">." (\x y -> LOp (LSGt ATFloat) [x, y]) AssocNone, - binary "<=" (\x y -> LOp (LSLe (ATInt ITNative)) [x, y]) AssocNone, - binary "<=." (\x y -> LOp (LSLe ATFloat) [x, y]) AssocNone, - binary ">=" (\x y -> LOp (LSGe (ATInt ITNative)) [x, y]) AssocNone, - binary ">=." (\x y -> LOp (LSGe ATFloat) [x, y]) AssocNone, - - binary "==:" (\x y -> LOp (LEq (ATInt ITBig)) [x, y]) AssocNone, - binary "<:" (\x y -> LOp (LSLt (ATInt ITBig)) [x, y]) AssocNone, - binary ">:" (\x y -> LOp (LSGt (ATInt ITBig)) [x, y]) AssocNone, - binary "<=:" (\x y -> LOp (LSLe (ATInt ITBig)) [x, y]) AssocNone, - binary ">=:" (\x y -> LOp (LSGe (ATInt ITBig)) [x, y]) AssocNone, - - binary "==," (\x y -> LOp (LEq (ATInt ITChar)) [x, y]) AssocNone, - binary "<," (\x y -> LOp (LSLt (ATInt ITChar)) [x, y]) AssocNone, - binary ">," (\x y -> LOp (LSGt (ATInt ITChar)) [x, y]) AssocNone, - binary "<=," (\x y -> LOp (LSLe (ATInt ITChar)) [x, y]) AssocNone, - binary ">=," (\x y -> LOp (LSGe (ATInt ITChar)) [x, y]) AssocNone - ]] - -binary name f assoc = Infix (do reservedOp name; return f) assoc - -pLExp' :: LParser LExp -pLExp' = try (do lchar '%'; pCast) - <|> try (do lchar '%'; pPrim) - <|> try (do tc <- option False (do lchar '%'; reserved "tc"; return True) - x <- iName []; - lazy <- option False (do lchar '@'; return True) - lchar '(' - args <- sepBy pLExp (lchar ',') - lchar ')' - if null args - then if lazy then return (LLazyApp x []) - else return (LV (Glob x)) - else if lazy then return (LLazyApp x args) - else return (LApp tc (LV (Glob x)) args)) - <|> do lchar '('; e <- pLExp; lchar ')'; return e - <|> pLConst - <|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp - reserved "in"; e <- pLExp - return (LLet x v e) - <|> do lchar '\\'; xs <- sepBy (iName []) (lchar ',') - symbol "=>" - e <- pLExp - return (LLam xs e) - <|> do reserved "foreign"; l <- pLang; t <- pType - fname <- strlit - lchar '(' - fargs <- sepBy (do t' <- pType; e <- pLExp; return (t', e)) (lchar ',') - lchar ')' - return (LForeign l t fname fargs) - <|> pCase - <|> do x <- iName [] - return (LV (Glob x)) - -pLang = do reserved "C"; return LANG_C - -pType = do reserved "Int"; return (FArith (ATInt ITNative)) - <|> do reserved "Char"; return (FArith (ATInt ITChar)) - <|> do reserved "Float"; return (FArith ATFloat) - <|> do reserved "String"; return FString - <|> do reserved "Unit"; return FUnit - <|> do reserved "Ptr"; return FPtr - <|> do reserved "Any"; return FAny - -pCase :: LParser LExp -pCase = do reserved "case"; e <- pLExp; reserved "of" - lchar '{' - alts <- sepBy1 pAlt (lchar '|') - lchar '}' - return (LCase e alts) - -pCast :: LParser LExp -pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')' - return (LOp LFloatStr [e]) - <|> do reserved "StringFloat"; lchar '('; e <- pLExp; lchar ')' - return (LOp LStrFloat [e]) - <|> do reserved "FloatInt"; lchar '('; e <- pLExp; lchar ')' - return (LOp (LFloatInt ITNative) [e]) - <|> do reserved "IntFloat"; lchar '('; e <- pLExp; lchar ')' - return (LOp (LIntFloat ITNative) [e]) - <|> do reserved "StringInt"; lchar '('; e <- pLExp; lchar ')' - return (LOp (LStrInt ITNative) [e]) - <|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')' - return (LOp (LIntStr ITNative) [e]) - <|> do reserved "BigInt"; lchar '('; e <- pLExp; lchar ')' - return (LOp (LTrunc ITBig ITNative) [e]) - <|> do reserved "IntBig"; lchar '('; e <- pLExp; lchar ')' - return (LOp (LSExt ITNative ITBig) [e]) - <|> do reserved "BigString"; lchar '('; e <- pLExp; lchar ')' - return (LOp (LIntStr ITBig) [e]) - <|> do reserved "StringBig"; lchar '('; e <- pLExp; lchar ')' - return (LOp (LStrInt ITBig) [e]) - -pPrim :: LParser LExp -pPrim = do reserved "StrEq"; lchar '('; - e <- pLExp; lchar ','; - e' <- pLExp; lchar ')'; - return (LOp LStrEq [e, e']) - <|> do reserved "StrLt"; lchar '(' - e <- pLExp; lchar ','; e' <- pLExp; - lchar ')' - return (LOp LStrLt [e, e']) - <|> do reserved "StrLen"; lchar '('; e <- pLExp; lchar ')'; - return (LOp LStrLen [e]) - <|> do reserved "ReadString"; lchar '('; e <- pLExp; lchar ')'; - return (LOp LReadStr [e]) - <|> do reserved "WriteString"; lchar '('; - e <- pLExp; lchar ')' - return (LOp LPrintStr [e]) - <|> do reserved "WriteInt"; lchar '('; - e <- pLExp; lchar ')'; - return (LOp LPrintNum [e]) - <|> do reserved "lazy"; lchar '('; - e <- pLExp; lchar ')'; - return (LLazyExp e) - <|> do reserved "StrHead"; lchar '('; e <- pLExp; lchar ')'; - return (LOp LStrHead [e]) - <|> do reserved "StrTail"; lchar '('; e <- pLExp; lchar ')'; - return (LOp LStrTail [e]) - <|> do reserved "StrRev"; lchar '('; e <- pLExp; lchar ')'; - return (LOp LStrRev [e]) - <|> do reserved "StrCons"; lchar '('; x <- pLExp; lchar ','; - xs <- pLExp; lchar ')'; - return (LOp LStrCons [x, xs]) - <|> do reserved "StrIndex"; lchar '('; x <- pLExp; lchar ','; - i <- pLExp; lchar ')'; - return (LOp LStrIndex [x, i]) - -pAlt :: LParser LAlt -pAlt = try (do x <- iName [] - lchar '('; args <- sepBy1 (iName []) (lchar ','); lchar ')' - symbol "=>" - rhs <- pLExp - return (LConCase (-1) x args rhs)) - <|> do x <- iName []; - symbol "=>" - rhs <- pLExp - return (LConCase (-1) x [] rhs) - <|> do c <- natural - symbol "=>" - rhs <- pLExp - return (LConstCase (I (fromInteger c)) rhs) - <|> do symbol "_" - symbol "=>" - rhs <- pLExp - return (LDefaultCase rhs) - - -pLConst :: LParser LExp -pLConst = try (do f <- float; return $ LConst (Fl f)) - <|> try (do i <- natural; lchar ':'; return $ LConst (BI i)) - <|> try (do i <- natural; return $ LConst (I (fromInteger i))) - <|> try (do s <- strlit; return $ LConst (Str s)) - <|> try (do c <- chlit; return $ LConst (Ch c)) - diff --git a/src/IRTS/Lang.hs b/src/IRTS/Lang.hs --- a/src/IRTS/Lang.hs +++ b/src/IRTS/Lang.hs @@ -54,6 +54,7 @@ | LPar -- evaluate argument anywhere, possibly on another -- core or another machine. 'id' is a valid implementation | LVMPtr + | LNullPtr | LNoOp deriving (Show, Eq) diff --git a/src/IRTS/Simplified.hs b/src/IRTS/Simplified.hs --- a/src/IRTS/Simplified.hs +++ b/src/IRTS/Simplified.hs @@ -7,7 +7,7 @@ import Debug.Trace --- Simplified expressions, where functions/constructors can only be applied +-- Simplified expressions, where functions/constructors can only be applied -- to variables data SExp = SV LVar @@ -44,14 +44,14 @@ simplify :: Bool -> DExp -> State (DDefs, Int) SExp simplify tl (DV (Loc i)) = return (SV (Loc i)) -simplify tl (DV (Glob x)) +simplify tl (DV (Glob x)) = do ctxt <- ldefs case lookupCtxtExact x ctxt of [DConstructor _ t 0] -> return $ SCon t x [] _ -> return $ SV (Glob x) simplify tl (DApp tc n args) = do args' <- mapM sVar args mkapp (SApp (tl || tc) n) args' -simplify tl (DForeign lang ty fn args) +simplify tl (DForeign lang ty fn args) = do args' <- mapM sVar (map snd args) let fargs = zip (map fst args) args' mkfapp (SForeign lang ty fn) fargs @@ -69,21 +69,21 @@ 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 + case v of (x, Nothing) -> return (SCase x alts') - (Glob x, Just e) -> + (Glob x, Just e) -> return (SLet (Glob x) e (SCase (Glob x) alts')) -simplify tl (DChkCase e alts) +simplify tl (DChkCase e alts) = do v <- sVar e alts' <- mapM (sAlt tl) alts - case v of + case v of (x, Nothing) -> return (SChkCase x alts') - (Glob x, Just e) -> + (Glob x, Just e) -> return (SLet (Glob x) e (SChkCase (Glob x) alts')) 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 DNothing = return SNothing simplify tl (DError str) = return $ SError str sVar (DV (Glob x)) @@ -99,14 +99,14 @@ mkapp f args = mkapp' f args [] where mkapp' f [] args = return $ f (reverse args) mkapp' f ((x, Nothing) : xs) args = mkapp' f xs (x : args) - mkapp' f ((x, Just e) : xs) args + mkapp' f ((x, Just e) : xs) args = do sc <- mkapp' f xs (x : args) return (SLet x e sc) mkfapp f args = mkapp' f args [] where mkapp' f [] args = return $ f (reverse args) mkapp' f ((ty, (x, Nothing)) : xs) args = mkapp' f xs ((ty, x) : args) - mkapp' f ((ty, (x, Just e)) : xs) args + mkapp' f ((ty, (x, Just e)) : xs) args = do sc <- mkapp' f xs ((ty, x) : args) return (SLet x e sc) @@ -119,10 +119,10 @@ checkDefs :: DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)] checkDefs ctxt [] = return [] -checkDefs ctxt (con@(n, DConstructor _ _ _) : xs) +checkDefs ctxt (con@(n, DConstructor _ _ _) : xs) = do xs' <- checkDefs ctxt xs return xs' -checkDefs ctxt ((n, DFun n' args exp) : xs) +checkDefs ctxt ((n, DFun n' args exp) : xs) = do let sexp = evalState (simplify True exp) (ctxt, 0) (exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (length args) xs' <- checkDefs ctxt xs @@ -131,14 +131,14 @@ lvar v = do i <- get put (max i v) -scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp +scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp 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)) Nothing -> case lookupCtxtExact n ctxt of [DConstructor _ i ar] -> - if True -- ar == 0 + if True -- ar == 0 then return (SCon i n []) else fail $ "Codegen error: Constructor " ++ show n ++ " has arity " ++ show ar @@ -150,7 +150,7 @@ [DConstructor n tag ar] -> if True -- (ar == length args) then return $ SCon tag n args' - else fail $ "Codegen error: Constructor " ++ show f ++ + else fail $ "Codegen error: Constructor " ++ show f ++ " has arity " ++ show ar [_] -> return $ SApp tc f args' [] -> fail $ "Codegen error: No such variable " ++ show f @@ -164,7 +164,7 @@ [DConstructor n tag ar] -> if True -- (ar == length args) then return $ SCon tag n args' - else fail $ "Codegen error: Constructor " ++ show f ++ + else fail $ "Codegen error: Constructor " ++ show f ++ " has arity " ++ show ar _ -> fail $ "Codegen error: No such constructor " ++ show f sc env (SProj e i) @@ -201,15 +201,15 @@ [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) = do let env' = env ++ zip args [length env..] tag <- case lookupCtxtExact n ctxt of - [DConstructor _ i ar] -> - if True -- (length args == ar) + [DConstructor _ i ar] -> + if True -- (length args == ar) then return i else fail $ "Codegen error: Constructor " ++ show n ++ " has arity " ++ show ar diff --git a/src/Idris/AbsSyntax.hs b/src/Idris/AbsSyntax.hs --- a/src/Idris/AbsSyntax.hs +++ b/src/Idris/AbsSyntax.hs @@ -8,14 +8,15 @@ import Core.Elaborate hiding (Tactic(..)) import Core.Typecheck import Idris.AbsSyntaxTree -import Idris.IdeSlave import Idris.Colours +import Idris.IdeSlave import IRTS.CodegenCommon import Util.DynamicLinker import Paths_idris import System.Console.Haskeline +import System.IO import Control.Monad.State @@ -27,6 +28,9 @@ import Debug.Trace +import Control.Monad.Error (throwError, catchError) +import System.IO.Error(isUserError, ioeGetErrorString, tryIOError) + import Util.Pretty import Util.System @@ -60,7 +64,7 @@ case mapMaybe (findDyLib ls) libs of x:_ -> return (Left x) [] -> do - handle <- lift $ mapM (\l -> catchIO (tryLoadLib l) (\_ -> return Nothing)) $ libs + handle <- lift . lift $ mapM (\l -> catchIO (tryLoadLib l) (\_ -> return Nothing)) $ libs case msum handle of Nothing -> return (Right $ "Could not load dynamic alternatives \"" ++ concat (intersperse "," libs) ++ "\"") @@ -86,12 +90,17 @@ } addTrans :: (Term, Term) -> Idris () -addTrans t = do i <- getIState +addTrans t = do i <- getIState putIState $ i { idris_transforms = t : idris_transforms i } totcheck :: (FC, Name) -> Idris () totcheck n = do i <- getIState; putIState $ i { idris_totcheck = idris_totcheck i ++ [n] } +defer_totcheck :: (FC, Name) -> Idris () +defer_totcheck n + = do i <- getIState; + putIState $ i { idris_defertotcheck = nub (idris_defertotcheck i ++ [n]) } + clear_totcheck :: Idris () clear_totcheck = do i <- getIState; putIState $ i { idris_totcheck = [] } @@ -99,19 +108,19 @@ setFlags n fs = do i <- getIState; putIState $ i { idris_flags = addDef n fs (idris_flags i) } setAccessibility :: Name -> Accessibility -> Idris () -setAccessibility n a +setAccessibility n a = do i <- getIState let ctxt = setAccess n a (tt_ctxt i) putIState $ i { tt_ctxt = ctxt } setTotality :: Name -> Totality -> Idris () -setTotality n a +setTotality n a = do i <- getIState let ctxt = setTotal n a (tt_ctxt i) putIState $ i { tt_ctxt = ctxt } getTotality :: Name -> Idris Totality -getTotality n +getTotality n = do i <- getIState case lookupTotal n (tt_ctxt i) of [t] -> return t @@ -127,22 +136,34 @@ findCoercions t (n : ns) = let ps = case lookupTy n (tt_ctxt i) of [ty] -> case unApply (getRetTy ty) of - (t', _) -> + (t', _) -> if t == t' then [n] else [] _ -> [] in ps ++ findCoercions t ns addToCG :: Name -> CGInfo -> Idris () -addToCG n cg +addToCG n cg = do i <- getIState putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) } +-- Trace all the names in a call graph starting at the given name +getAllNames :: Name -> Idris [Name] +getAllNames n = allNames [] n + +allNames :: [Name] -> Name -> Idris [Name] +allNames ns n | n `elem` ns = return [] +allNames ns n = do i <- getIState + case lookupCtxtExact n (idris_callgraph i) of + [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns')) + return (nub (n : concat more)) + _ -> return [n] + addCoercion :: Name -> Idris () addCoercion n = do i <- getIState putIState $ i { idris_coercions = nub $ n : idris_coercions i } addDocStr :: Name -> String -> Idris () -addDocStr n doc +addDocStr n doc = do i <- getIState putIState $ i { idris_docstrings = addDef n doc (idris_docstrings i) } @@ -154,7 +175,7 @@ -- Dodgy hack 2: put constraint chasers (@@) last addInstance :: Bool -> Name -> Name -> Idris () -addInstance int n i +addInstance int n i = do ist <- getIState case lookupCtxt n (idris_classes ist) of [CI a b c d ins] -> @@ -174,7 +195,7 @@ chaser _ = False addClass :: Name -> ClassInfo -> Idris () -addClass n i +addClass n i = do ist <- getIState let i' = case lookupCtxt n (idris_classes ist) of [c] -> c { class_instances = class_instances i } @@ -182,7 +203,7 @@ putIState $ ist { idris_classes = addDef n i' (idris_classes ist) } addIBC :: IBCWrite -> Idris () -addIBC ibc@(IBCDef n) +addIBC ibc@(IBCDef n) = do i <- getIState when (notDef (ibc_write i)) $ putIState $ i { ibc_write = ibc : ibc_write i } @@ -221,22 +242,39 @@ putIState :: IState -> Idris () putIState = put +-- | A version of liftIO that puts errors into the exception type of the Idris monad +runIO :: IO a -> Idris a +runIO x = liftIO (tryIOError x) >>= either (throwError . Msg . show) return +-- TODO: create specific Idris exceptions for specific IO errors such as "openFile: does not exist" + getName :: Idris Int getName = do i <- getIState; let idx = idris_name i; putIState $ (i { idris_name = idx + 1 }) return idx +addInternalApp :: FilePath -> Int -> PTerm -> Idris () +addInternalApp fp l t + = do i <- getIState + putIState (i { idris_lineapps = ((fp, l), t) : idris_lineapps i }) + +getInternalApp :: FilePath -> Int -> Idris PTerm +getInternalApp fp l = do i <- getIState + case lookup (fp, l) (idris_lineapps i) of + Just n' -> return n' + Nothing -> return Placeholder + -- TODO: What if it's not there? + checkUndefined :: FC -> Name -> Idris () -checkUndefined fc n +checkUndefined fc n = do i <- getContext case lookupTy n i of - (_:_) -> fail $ show fc ++ ":" ++ + (_:_) -> fail $ show fc ++ ":" ++ show n ++ " already defined" _ -> return () isUndefined :: FC -> Name -> Idris Bool -isUndefined fc n +isUndefined fc n = do i <- getContext case lookupTy n i of (_:_) -> return False @@ -260,11 +298,12 @@ addDeferred = addDeferred' Ref addDeferredTyCon = addDeferred' (TCon 0 0) -addDeferred' :: NameType -> [(Name, Type)] -> Idris () -addDeferred' nt ns - = do mapM_ (\(n, t) -> updateContext (addTyDecl n nt (tidyNames [] t))) ns +addDeferred' :: NameType -> [(Name, (Int, Maybe Name, Type, Bool))] -> Idris () +addDeferred' nt ns + = do mapM_ (\(n, (i, _, t, _)) -> updateContext (addTyDecl n nt (tidyNames [] t))) ns i <- getIState - putIState $ i { idris_metavars = map fst ns ++ idris_metavars i } + putIState $ i { idris_metavars = map (\(n, (i, top, _, isTopLevel)) -> (n, (top, i, isTopLevel))) ns ++ + idris_metavars i } where tidyNames used (Bind (MN i x) b sc) = let n' = uniqueName (UN x) used in Bind n' b $ tidyNames (n':used) sc @@ -275,64 +314,64 @@ solveDeferred :: Name -> Idris () solveDeferred n = do i <- getIState - putIState $ i { idris_metavars = idris_metavars i \\ [n] } + putIState $ i { idris_metavars = + filter (\(n', _) -> n/=n') + (idris_metavars i) } -iResult :: String -> Idris () -iResult s = do i <- getIState - case idris_outputmode i of - RawOutput -> case s of - "" -> return () - s -> liftIO $ putStrLn s - IdeSlave n -> - let good = SexpList [SymbolAtom "ok", toSExp s] in - liftIO $ putStrLn $ convSExp "return" good n +ihPrintResult :: Handle -> String -> Idris () +ihPrintResult h s = do i <- getIState + case idris_outputmode i of + RawOutput -> case s of + "" -> return () + s -> runIO $ hPutStrLn h s + IdeSlave n -> + let good = SexpList [SymbolAtom "ok", toSExp s] in + runIO $ hPutStrLn h $ convSExp "return" good n -iFail :: String -> Idris () -iFail s = do i <- getIState - case idris_outputmode i of - RawOutput -> case s of - "" -> return () - s -> liftIO $ putStrLn s - IdeSlave n -> - let good = SexpList [SymbolAtom "error", toSExp s] in - liftIO . putStrLn $ convSExp "return" good n +ihPrintError :: Handle -> String -> Idris () +ihPrintError h s = do i <- getIState + case idris_outputmode i of + RawOutput -> case s of + "" -> return () + s -> runIO $ hPutStrLn h s + IdeSlave n -> + let good = SexpList [SymbolAtom "error", toSExp s] in + runIO . hPutStrLn h $ convSExp "return" good n -iputStrLn :: String -> Idris () -iputStrLn s = do i <- getIState - case idris_outputmode i of - RawOutput -> liftIO $ putStrLn s - IdeSlave n -> - case span (/=':') s of - (fn, ':':rest) -> case span isDigit rest of - ([], ':':msg) -> write - ([], msg) -> write - (num, ':':msg) -> iWarn (FC fn (read num)) msg - _ -> write - where write = liftIO . putStrLn $ convSExp "write-string" s n +ihputStrLn :: Handle -> String -> Idris () +ihputStrLn h s = do i <- getIState + case idris_outputmode i of + RawOutput -> runIO $ hPutStrLn h s + IdeSlave n -> runIO . hPutStrLn h $ convSExp "write-string" s n +iputStrLn = ihputStrLn stdout +iPrintError = ihPrintError stdout +iPrintResult = ihPrintResult stdout +iWarn = ihWarn stdout + ideslavePutSExp :: SExpable a => String -> a -> Idris () ideslavePutSExp cmd info = do i <- getIState case idris_outputmode i of - IdeSlave n -> liftIO . putStrLn $ convSExp cmd info n + IdeSlave n -> runIO . putStrLn $ convSExp cmd info n _ -> return () -- this needs some typing magic and more structured output towards emacs iputGoal :: String -> Idris () iputGoal s = do i <- getIState case idris_outputmode i of - RawOutput -> liftIO $ putStrLn s - IdeSlave n -> liftIO . putStrLn $ convSExp "write-goal" s n + RawOutput -> runIO $ putStrLn s + IdeSlave n -> runIO . putStrLn $ convSExp "write-goal" s n isetPrompt :: String -> Idris () isetPrompt p = do i <- getIState case idris_outputmode i of - IdeSlave n -> liftIO . putStrLn $ convSExp "set-prompt" p n + IdeSlave n -> runIO . putStrLn $ convSExp "set-prompt" p n -iWarn :: FC -> String -> Idris () -iWarn fc err = do i <- getIState - case idris_outputmode i of - RawOutput -> liftIO $ putStrLn (show fc ++ ":" ++ err) - IdeSlave n -> liftIO . putStrLn $ convSExp "warning" (fc_fname fc, fc_line fc, err) n +ihWarn :: Handle -> FC -> String -> Idris () +ihWarn h fc err = do i <- getIState + case idris_outputmode i of + RawOutput -> runIO $ hPutStrLn h (show fc ++ ":" ++ err) + IdeSlave n -> runIO $ hPutStrLn h $ convSExp "warning" (fc_fname fc, fc_line fc, err) n setLogLevel :: Int -> Idris () setLogLevel l = do i <- getIState @@ -387,6 +426,17 @@ let opt' = opts { opt_repl = t } putIState $ i { idris_options = opt' } +setNoBanner :: Bool -> Idris () +setNoBanner n = do i <- getIState + let opts = idris_options i + let opt' = opts {opt_nobanner = n} + putIState $ i { idris_options = opt' } + +getNoBanner :: Idris Bool +getNoBanner = do i <- getIState + let opts = idris_options i + return (opt_nobanner opts) + setQuiet :: Bool -> Idris () setQuiet q = do i <- getIState let opts = idris_options i @@ -420,7 +470,7 @@ setIdeSlave :: Bool -> Idris () setIdeSlave True = do i <- getIState - putIState $ i { idris_outputmode = (IdeSlave 0) } + putIState $ i { idris_outputmode = (IdeSlave 0), idris_colourRepl = False } setIdeSlave False = return () setTargetTriple :: String -> Idris () @@ -517,6 +567,10 @@ setColourise b = do i <- getIState putIState $ i { idris_colourRepl = b } +setOutH :: Handle -> Idris () +setOutH h = do i <- getIState + putIState $ i { idris_outh = h } + impShow :: Idris Bool impShow = do i <- getIState return (opt_showimp (idris_options i)) @@ -542,9 +596,12 @@ logLvl :: Int -> String -> Idris () logLvl l str = do i <- getIState let lvl = opt_logLevel (idris_options i) - when (lvl >= l) - $ do liftIO (putStrLn str) - putIState $ i { idris_log = idris_log i ++ str ++ "\n" } + when (lvl >= l) $ + case idris_outputmode i of + RawOutput -> do runIO $ putStrLn str + IdeSlave n -> + do let good = SexpList [IntegerAtom (toInteger l), toSExp str] + runIO $ putStrLn $ convSExp "log" good n cmdOptType :: Opt -> Idris Bool cmdOptType x = do i <- getIState @@ -568,11 +625,11 @@ -- For inferring types of things -bi = FC "builtin" 0 +bi = fileFC "builtin" inferTy = MN 0 "__Infer" inferCon = MN 0 "__infer" -inferDecl = PDatadecl inferTy +inferDecl = PDatadecl inferTy PType [("", inferCon, PPi impl (MN 0 "A") PType ( PPi expl (MN 0 "a") (PRef bi (MN 0 "A")) @@ -609,7 +666,7 @@ [("", pairCon, PPi impl (n "A") PType ( PPi impl (n "B") PType ( PPi expl (n "a") (PRef bi (n "A")) ( - PPi expl (n "b") (PRef bi (n "B")) + PPi expl (n "b") (PRef bi (n "B")) (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")), pexp (PRef bi (n "B"))])))), bi)] where n a = MN 0 a @@ -636,11 +693,11 @@ piBindp :: Plicity -> [(Name, PTerm)] -> PTerm -> PTerm piBindp p [] t = t -piBindp p ((n, ty):ns) t = PPi p n ty (piBind ns t) - +piBindp p ((n, ty):ns) t = PPi p n ty (piBindp p ns t) + -- Dealing with parameters -expandParams :: (Name -> Name) -> [(Name, PTerm)] -> +expandParams :: (Name -> Name) -> [(Name, PTerm)] -> [Name] -> -- all names [Name] -> -- names with no declaration PTerm -> PTerm @@ -651,7 +708,7 @@ -- binding and once to call the lifted functions. So we'll explicitly shadow -- it. (Yes, it's a hack. The alternative would be to resolve names earlier -- but we didn't...) - + mkShadow (UN n) = MN 0 n mkShadow (MN i n) = MN (i+1) n mkShadow (NS x s) = NS (mkShadow x) s @@ -661,18 +718,18 @@ = let n' = mkShadow n in PLam n' (en t) (en (shadow n n' s)) | otherwise = PLam n (en t) (en s) - en (PPi p n t s) + en (PPi p n t s) | n `elem` (map fst ps ++ ns) = let n' = mkShadow n in PPi p n' (en t) (en (shadow n n' s)) | otherwise = PPi p n (en t) (en s) - en (PLet n ty v s) + en (PLet n ty v s) | n `elem` (map fst ps ++ ns) = let n' = mkShadow n in PLet n' (en ty) (en v) (en (shadow n n' s)) | otherwise = PLet n (en ty) (en v) (en s) - -- FIXME: Should only do this in a type signature! - en (PDPair f (PRef f' n) t r) + -- FIXME: Should only do this in a type signature! + en (PDPair f (PRef f' n) t r) | n `elem` (map fst ps ++ ns) && t /= Placeholder = let n' = mkShadow n in PDPair f (PRef f' n') (en t) (en (shadow n n' r)) @@ -689,25 +746,31 @@ en (PProof ts) = PProof (map (fmap en) ts) en (PTactics ts) = PTactics (map (fmap en) ts) - en (PQuote (Var n)) + en (PQuote (Var n)) | n `nselem` ns = PQuote (Var (dec n)) en (PApp fc (PInferRef fc' n) as) - | n `nselem` ns = PApp fc (PInferRef fc' (dec n)) + | n `nselem` ns = PApp fc (PInferRef fc' (dec n)) (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as)) en (PApp fc (PRef fc' n) as) - | n `elem` infs = PApp fc (PInferRef fc' (dec n)) + | n `elem` infs = PApp fc (PInferRef fc' (dec n)) (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as)) - | n `nselem` 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 (PAppBind fc (PRef fc' n) as) + | n `elem` infs = PAppBind fc (PInferRef fc' (dec n)) + (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as)) + | n `nselem` ns = PAppBind fc (PRef fc' (dec n)) + (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as)) en (PRef fc n) - | n `elem` infs = PApp fc (PInferRef fc (dec n)) + | n `elem` infs = PApp fc (PInferRef fc (dec n)) (map (pexp . (PRef fc)) (map fst ps)) - | n `nselem` ns = PApp fc (PRef fc (dec n)) + | n `nselem` ns = PApp fc (PRef fc (dec n)) (map (pexp . (PRef fc)) (map fst ps)) en (PInferRef fc n) - | n `nselem` ns = PApp fc (PInferRef fc (dec n)) + | n `nselem` ns = PApp fc (PInferRef fc (dec n)) (map (pexp . (PRef fc)) (map fst ps)) en (PApp fc f as) = PApp fc (en f) (map (fmap en) as) + en (PAppBind fc f as) = PAppBind fc (en f) (map (fmap en) as) en (PCase fc c os) = PCase fc (en c) (map (pmap en) os) en t = t @@ -718,20 +781,20 @@ nseq x y = nsroot x == nsroot y expandParamsD :: Bool -> -- True = RHS only - IState -> + IState -> (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl -expandParamsD rhsonly ist dec ps ns (PTy doc syn fc o n ty) +expandParamsD rhsonly ist dec ps ns (PTy doc syn fc o n ty) = if n `elem` ns && (not rhsonly) then -- trace (show (n, expandParams dec ps ns ty)) $ - PTy doc syn fc o (dec n) (piBind ps (expandParams dec ps ns [] ty)) - else --trace (show (n, expandParams dec ps ns ty)) $ + PTy doc syn fc o (dec n) (piBindp expl_param ps (expandParams dec ps ns [] ty)) + else --trace (show (n, expandParams dec ps ns ty)) $ PTy doc syn fc o n (expandParams dec ps ns [] ty) -expandParamsD rhsonly ist dec ps ns (PPostulate doc syn fc o n ty) +expandParamsD rhsonly ist dec ps ns (PPostulate doc syn fc o n ty) = if n `elem` ns && (not rhsonly) then -- trace (show (n, expandParams dec ps ns ty)) $ - PPostulate doc syn fc o (dec n) (piBind ps + PPostulate doc syn fc o (dec n) (piBind ps (expandParams dec ps ns [] ty)) - else --trace (show (n, expandParams dec ps ns ty)) $ + else --trace (show (n, expandParams dec ps ns ty)) $ PPostulate doc syn fc o n (expandParams dec ps ns [] ty) expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs) = let n' = if n `elem` ns then dec n else n in @@ -741,7 +804,7 @@ = let -- ps' = updateps True (namesIn ist rhs) (zip ps [0..]) ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..]) lhs' = if rhsonly then lhs else (expandParams dec ps'' ns [] lhs) - n' = if n `elem` ns then dec n else n + n' = if n `elem` ns then dec n else n -- names bound on the lhs should not be expanded on the rhs ns' = removeBound lhs ns in PClause fc n' lhs' @@ -752,7 +815,7 @@ = let -- ps' = updateps True (namesIn ist wval) (zip ps [0..]) ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..]) lhs' = if rhsonly then lhs else (expandParams dec ps'' ns [] lhs) - n' = if n `elem` ns then dec n else n + n' = if n `elem` ns then dec n else n ns' = removeBound lhs ns in PWith fc n' lhs' (map (expandParams dec ps'' ns' []) ws) @@ -771,32 +834,32 @@ bnames (PDPair _ l Placeholder r) = bnames l ++ bnames r bnames _ = [] -expandParamsD rhs ist dec ps ns (PData doc syn fc co pd) +expandParamsD rhs ist dec ps ns (PData doc syn fc co pd) = PData doc syn fc co (expandPData pd) where -- just do the type decl, leave constructors alone (parameters will be -- added implicitly) - expandPData (PDatadecl n ty cons) + expandPData (PDatadecl n ty cons) = if n `elem` ns - then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty)) + 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 (doc, n, t, fc) + econ (doc, n, t, fc) = (doc, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc) expandParamsD rhs ist dec ps ns (PParams f params pds) - = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params) + = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params) (map (expandParamsD True ist dec ps ns) pds) --- (map (expandParamsD ist dec ps ns) pds) +-- (map (expandParamsD ist dec ps ns) pds) expandParamsD rhs ist dec ps ns (PMutual f pds) = PMutual f (map (expandParamsD rhs ist dec ps ns) pds) expandParamsD rhs ist dec ps ns (PClass doc info f cs n params decls) - = PClass doc info f + = PClass doc info f (map (expandParams dec ps ns []) cs) n (map (mapsnd (expandParams dec ps ns [])) params) (map (expandParamsD rhs ist dec ps ns) decls) expandParamsD rhs ist dec ps ns (PInstance info f cs n params ty cn decls) - = PInstance info f + = PInstance info f (map (expandParams dec ps ns []) cs) n (map (expandParams dec ps ns []) params) @@ -814,7 +877,7 @@ -- * finally, everything else (3) getPriority :: IState -> PTerm -> Int -getPriority i tm = 1 -- pri tm +getPriority i tm = 1 -- pri tm where pri (PRef _ n) = case lookupP n (tt_ctxt i) of @@ -828,8 +891,9 @@ pri (PRefl _ _) = 1 pri (PEq _ l r) = max 1 (max (pri l) (pri r)) pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r)) - pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as))) - pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as))) + pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as))) + pri (PAppBind _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as))) + pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as))) pri (PTyped l r) = pri l pri (PPair _ l r) = max 1 (max (pri l) (pri r)) pri (PDPair _ l t r) = max 1 (max (pri l) (max (pri t) (pri r))) @@ -841,24 +905,40 @@ addStatics :: Name -> Term -> PTerm -> Idris () addStatics n tm ptm = do let (statics, dynamics) = initStatics tm ptm - let stnames = nub $ concatMap freeNames (map snd statics) - let dnames = nub $ concatMap freeNames (map snd dynamics) - when (not (null statics)) $ - logLvl 7 $ show n ++ " " ++ show statics ++ "\n" ++ show dynamics - ++ "\n" ++ show stnames ++ "\n" ++ show dnames - let statics' = nub $ map fst statics ++ + let stnames = nub $ concatMap freeArgNames (map snd statics) + let dnames = nub $ concatMap freeArgNames (map snd dynamics) + -- also get the arguments which are 'uniquely inferrable' from + -- statics (see sec 4.2 of "Scrapping Your Inefficient Engine") + let statics' = nub $ map fst statics ++ filter (\x -> not (elem x dnames)) stnames let stpos = staticList statics' tm i <- getIState + when (not (null statics)) $ + logLvl 5 $ show n ++ " " ++ show statics' ++ "\n" ++ show dynamics + ++ "\n" ++ show stnames ++ "\n" ++ show dnames putIState $ i { idris_statics = addDef n stpos (idris_statics i) } addIBC (IBCStatic n) where initStatics (Bind n (Pi ty) sc) (PPi p _ _ s) = let (static, dynamic) = initStatics (instantiate (P Bound n ty) sc) s in if pstatic p == Static then ((n, ty) : static, dynamic) - else (static, (n, ty) : dynamic) + else if (not (searchArg p)) + then (static, (n, ty) : dynamic) + else (static, dynamic) initStatics t pt = ([], []) + freeArgNames (Bind n (Pi ty) sc) + = nub $ freeArgNames ty + freeArgNames tm = let (_, args) = unApply tm in + concatMap freeNames args + + -- if a name appears in a type class or tactic implicit index, it doesn't + -- affect its 'uniquely inferrable' from a static status since these are + -- resolved by searching. + searchArg (Constraint _ _ _) = True + searchArg (TacImp _ _ _ _) = True + searchArg _ = False + staticList sts (Bind n (Pi _) sc) = (n `elem` sts) : staticList sts sc staticList _ _ = [] @@ -867,7 +947,7 @@ -- Add constraint bindings from using block addUsingConstraints :: SyntaxInfo -> FC -> PTerm -> Idris PTerm -addUsingConstraints syn fc t +addUsingConstraints syn fc t = do ist <- get let ns = namesIn [] ist t let cs = getConstraints t -- check declared constraints @@ -882,12 +962,12 @@ doAdd [] _ t = t -- if all of args in ns, then add it doAdd (UConstraint c args : cs) ns t - | all (\n -> elem n ns) args + | all (\n -> elem n ns) args = PPi (Constraint False Dynamic "") (MN 0 "cu") (mkConst c args) (doAdd cs ns t) | otherwise = doAdd cs ns t - mkConst c args = PApp fc (PRef fc c) + mkConst c args = PApp fc (PRef fc c) (map (\n -> PExp 0 False (PRef fc n) "") args) getConstraints (PPi (Constraint _ _ _) _ c sc) @@ -895,7 +975,7 @@ getConstraints (PPi _ _ c sc) = getConstraints sc getConstraints _ = [] - getcapp (PApp _ (PRef _ c) args) + getcapp (PApp _ (PRef _ c) args) = do ns <- mapM getName args return (UConstraint c ns) getcapp _ = [] @@ -912,7 +992,7 @@ implicit syn n ptm = implicit' syn [] n ptm implicit' :: SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm -implicit' syn ignore n ptm +implicit' syn ignore n ptm = do i <- getIState let (tm', impdata) = implicitise syn ignore i ptm -- let (tm'', spos) = findStatics i tm' @@ -925,12 +1005,12 @@ implicitise :: SyntaxInfo -> [Name] -> IState -> PTerm -> (PTerm, [PArg]) implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $ - let (declimps, ns') = execState (imps True [] tm) ([], []) + let (declimps, ns') = execState (imps True [] tm) ([], []) ns = filter (\n -> implicitable n || elem n (map fst uvars)) $ - ns' \\ (map fst pvars ++ no_imp syn ++ ignore) + ns' \\ (map fst pvars ++ no_imp syn ++ ignore) nsOrder = filter (not . inUsing) ns ++ filter inUsing ns in - if null ns - then (tm, reverse declimps) + if null ns + then (tm, reverse declimps) else implicitise syn ignore ist (pibind uvars nsOrder tm) where uvars = map ipair (filter uimplicit (using syn)) @@ -950,18 +1030,18 @@ = do (decls, ns) <- get let isn = concatMap (namesIn uvars ist) (map getTm as) put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) - imps top env (PPi (Imp l _ doc) n ty sc) + imps top env (PPi (Imp l _ doc _) n ty sc) = do let isn = nub (namesIn uvars ist ty) `dropAll` [n] (decls , ns) <- get - put (PImp (getPriority ist ty) True l n ty doc : decls, + put (PImp (getPriority ist ty) True l n ty doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc - imps top env (PPi (Exp l _ doc) n ty sc) + imps top env (PPi (Exp l _ doc _) n ty sc) = do let isn = nub (namesIn uvars ist ty ++ case sc of (PRef _ x) -> namesIn uvars ist sc `dropAll` [n] _ -> []) (decls, ns) <- get -- ignore decls in HO types - put (PExp (getPriority ist ty) l ty doc : decls, + put (PExp (getPriority ist ty) l ty doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc imps top env (PPi (Constraint l _ doc) n ty sc) @@ -969,7 +1049,7 @@ (PRef _ x) -> namesIn uvars ist sc `dropAll` [n] _ -> []) (decls, ns) <- get -- ignore decls in HO types - put (PConstraint 10 l ty doc : decls, + put (PConstraint 10 l ty doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc imps top env (PPi (TacImp l _ scr doc) n ty sc) @@ -977,7 +1057,7 @@ (PRef _ x) -> namesIn uvars ist sc `dropAll` [n] _ -> []) (decls, ns) <- get -- ignore decls in HO types - put (PTacImplicit 10 l n scr ty doc : decls, + put (PTacImplicit 10 l n scr ty doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc imps top env (PEq _ l r) @@ -1000,14 +1080,14 @@ put (decls, nub (ns ++ (isn \\ (env ++ map fst (getImps decls))))) imps top env (PDPair _ l t r) = do (decls, ns) <- get - let isn = namesIn uvars ist l ++ namesIn uvars ist t ++ + let isn = namesIn uvars ist l ++ namesIn uvars ist t ++ namesIn uvars ist r put (decls, nub (ns ++ (isn \\ (env ++ map fst (getImps decls))))) imps top env (PAlternative a as) = do (decls, ns) <- get let isn = concatMap (namesIn uvars ist) as put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) - imps top env (PLam n ty sc) + imps top env (PLam n ty sc) = do imps False env ty imps False (n:env) sc imps top env (PHidden tm) = imps False env tm @@ -1016,10 +1096,10 @@ imps top env _ = return () pibind using [] sc = sc - pibind using (n:ns) sc + pibind using (n:ns) sc = case lookup n using of - Just ty -> PPi (Imp False Dynamic "") n ty (pibind using ns sc) - Nothing -> PPi (Imp False Dynamic "") n Placeholder + Just ty -> PPi (Imp False Dynamic "" False) n ty (pibind using ns sc) + Nothing -> PPi (Imp False Dynamic "" False) n Placeholder (pibind using ns sc) -- Add implicit arguments in function calls @@ -1041,7 +1121,7 @@ addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm where - ai env (PRef fc f) + ai env (PRef fc f) | f `elem` infns = PInferRef fc f | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat ist fc f [] ai env (PHidden (PRef fc f)) @@ -1065,16 +1145,16 @@ PDPair fc l' t' r' ai env (PAlternative a as) = let as' = map (ai env) as in PAlternative a as' - ai env (PApp fc (PInferRef _ f) as) + ai env (PApp fc (PInferRef _ f) as) = let as' = map (fmap (ai env)) as in - PApp fc (PInferRef fc f) as' - ai env (PApp fc ftm@(PRef _ f) as) + PApp fc (PInferRef fc f) as' + ai env (PApp fc ftm@(PRef _ f) as) | f `elem` infns = ai env (PApp fc (PInferRef fc f) as) | not (f `elem` map fst env) = let as' = map (fmap (ai env)) as in handleErr $ aiFn inpat False ist fc f as' | Just (Just ty) <- lookup f env - = let as' = map (fmap (ai env)) as + = let as' = map (fmap (ai env)) as arity = getPArity ty in mkPApp fc arity ftm as' ai env (PApp fc f as) = let f' = ai env f @@ -1115,19 +1195,22 @@ aiFn inpat True ist fc f [] = case lookupDef f (tt_ctxt ist) of [] -> Right $ PPatvar fc f - alts -> let ialts = lookupCtxt 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) + alts -> let ialts = lookupCtxtName 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 (conCaf (tt_ctxt ist)) ialts) +-- any constructor alts || any allImp ialts)) then aiFn inpat False ist fc f [] -- use it as a constructor else Right $ PPatvar fc f where imp (PExp _ _ _ _) = False imp _ = True - allImp [] = False +-- allImp [] = False allImp xs = all imp xs constructor (TyDecl (DCon _ _) _) = True constructor _ = False + conCaf ctxt (n, cia) = isDConName n ctxt && allImp cia + vname (UN n) = True -- non qualified vname _ = False @@ -1135,16 +1218,28 @@ | f `elem` primNames = Right $ PApp fc (PRef fc f) as aiFn inpat expat ist fc f as -- This is where namespaces get resolved by adding PAlternative - = case lookupCtxtName f (idris_implicits ist) of + = do let ns = lookupCtxtName f (idris_implicits ist) + let ns' = filter (\(n, _) -> notHidden n) ns + case ns' of [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as) - [] -> if f `elem` idris_metavars ist + [] -> if f `elem` (map fst (idris_metavars ist)) then Right $ PApp fc (PRef fc f) as else Right $ mkPApp fc (length as) (PRef fc f) as alts -> Right $ PAlternative True $ - map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f') + map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f') (insertImpl ns as)) alts where + notHidden n = case getAccessibility n of + Hidden -> False + _ -> True + + getAccessibility n + = case lookupDefAcc n False (tt_ctxt ist) of + [(n,t)] -> t + _ -> Public + + insertImpl :: [PArg] -> [PArg] -> [PArg] insertImpl (PExp p l ty _ : ps) (PExp _ _ tm d : given) = PExp p l tm d : insertImpl ps given @@ -1159,16 +1254,16 @@ insertImpl (PTacImplicit p l n sc ty d : ps) given = case find n given [] of Just (tm, given') -> PTacImplicit p l n sc tm "" : insertImpl ps given' - Nothing -> if inpat + Nothing -> if inpat then PTacImplicit p l n sc Placeholder "" : insertImpl ps given else PTacImplicit p l n sc sc "" : insertImpl ps given insertImpl expected [] = [] insertImpl _ given = given find n [] acc = Nothing - find n (PImp _ _ _ n' t _ : gs) acc + find n (PImp _ _ _ n' t _ : gs) acc | n == n' = Just (t, reverse acc ++ gs) - find n (PTacImplicit _ _ n' _ t _ : gs) acc + find n (PTacImplicit _ _ n' _ t _ : gs) acc | n == n' = Just (t, reverse acc ++ gs) find n (g : gs) acc = find n gs (g : acc) @@ -1177,9 +1272,9 @@ -- it is hard to get right! stripLinear :: IState -> PTerm -> PTerm -stripLinear i tm = evalState (sl tm) [] where +stripLinear i tm = evalState (sl tm) [] where sl :: PTerm -> State [Name] PTerm - sl (PRef fc f) + sl (PRef fc f) | (_:_) <- lookupTy f (tt_ctxt i) = return $ PRef fc f | otherwise = do ns <- get @@ -1187,7 +1282,7 @@ then return Placeholder else do put (f : ns) return (PRef fc f) - sl (PPatvar fc f) + sl (PPatvar fc f) = do ns <- get if (f `elem` ns) then return Placeholder @@ -1200,14 +1295,35 @@ return $ PImp p m l n t' d slA (PExp p l t d) = do t' <- sl t return $ PExp p l t' d - slA (PConstraint p l t d) + slA (PConstraint p l t d) = do t' <- sl t return $ PConstraint p l t' d - slA (PTacImplicit p l n sc t d) + slA (PTacImplicit p l n sc t d) = do t' <- sl t return $ PTacImplicit p l n sc t' d sl x = return x +-- Remove functions which aren't applied to anything, which must then +-- be resolved by unification. Assume names resolved and alternatives +-- filled in (so no ambiguity). + +stripUnmatchable :: IState -> PTerm -> PTerm +stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where + su :: PTerm -> PTerm + su (PRef fc f) + | (Bind n (Pi t) sc :_) <- lookupTy f (tt_ctxt i) + = Placeholder + su (PApp fc fn args) + = PApp fc fn (fmap (fmap su) args) + su (PAlternative b alts) + = let alts' = filter (/= Placeholder) (map su alts) in + if null alts' then Placeholder + else PAlternative b alts' + su (PPair fc l r) = PPair fc (su l) (su r) + su (PDPair fc l t r) = PDPair fc (su l) (su t) (su r) + su t = t +stripUnmatchable i tm = tm + mkPApp fc a f [] = f mkPApp fc a f as = let rest = drop a as in appRest fc (PApp fc f (take a as)) rest @@ -1216,7 +1332,7 @@ appRest fc f (a : as) = appRest fc (PApp fc f [a]) as -- Find 'static' argument positions --- (the declared ones, plus any names in argument position in the declared +-- (the declared ones, plus any names in argument position in the declared -- statics) -- FIXME: It's possible that this really has to happen after elaboration @@ -1234,7 +1350,7 @@ inOne n ns = length (filter id (map (elem n) ns)) == 1 - pos ns ss (PPi p n t sc) + pos ns ss (PPi p n t sc) | elem n ss = do sc' <- pos ns ss sc spos <- get put (True : spos) @@ -1251,16 +1367,16 @@ dumpDecls [] = "" dumpDecls (d:ds) = dumpDecl d ++ "\n" ++ dumpDecls ds -dumpDecl (PFix _ f ops) = show f ++ " " ++ showSep ", " ops +dumpDecl (PFix _ f ops) = show f ++ " " ++ showSep ", " ops dumpDecl (PTy _ _ _ _ n t) = "tydecl " ++ show n ++ " : " ++ showImp Nothing True False t dumpDecl (PClauses _ _ n cs) = "pat " ++ show n ++ "\t" ++ showSep "\n\t" (map (showCImp True) cs) 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 -dumpDecl (PClass _ _ _ cs n ps ds) +dumpDecl (PClass _ _ _ cs n ps ds) = "class " ++ show cs ++ " " ++ show n ++ " " ++ show ps ++ "\n" ++ dumpDecls ds -dumpDecl (PInstance _ _ cs n _ t _ ds) +dumpDecl (PInstance _ _ cs n _ t _ ds) = "instance " ++ show cs ++ " " ++ show n ++ " " ++ show t ++ "\n" ++ dumpDecls ds dumpDecl _ = "..." -- dumpDecl (PImport i) = "import " ++ i @@ -1277,7 +1393,7 @@ toEither (LeftErr e) = Left e toEither (RightOK ho) = Right ho --- syntactic match of a against b, returning pair of variables in a +-- syntactic match of a against b, returning pair of variables in a -- and what they match. Returns the pair that failed if not a match. matchClause :: IState -> PTerm -> PTerm -> Either (PTerm, PTerm) [(Name, PTerm)] @@ -1291,7 +1407,7 @@ fullApp x = x match' x y = match (fullApp x) (fullApp y) - match (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x]) x' + match (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x]) x' | PConstant (I _) <- getTm x = match (getTm x) x' match x' (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x]) | PConstant (I _) <- getTm x = match (getTm x) x' @@ -1309,17 +1425,19 @@ match xr (PPatvar f n) = match xr (PRef f n) match (PApp _ x []) (PRef f n) = match x (PRef f n) match (PRef _ n) tm@(PRef _ n') - | n == n' && not names && - (not (isConName n (tt_ctxt i)) || tm == Placeholder) + | n == n' && not names && + (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i)) + || tm == Placeholder) = return [(n, tm)] | n == n' = return [] - match (PRef _ n) tm - | not names && (not (isConName n (tt_ctxt i)) || tm == Placeholder) + match (PRef _ n) tm + | not names && (not (isConName n (tt_ctxt i) || + isFnName n (tt_ctxt i)) || tm == Placeholder) = return [(n, tm)] match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l' mr <- match' r r' return (ml ++ mr) - match (PRewrite _ l r _) (PRewrite _ l' r' _) + match (PRewrite _ l r _) (PRewrite _ l' r' _) = do ml <- match' l l' mr <- match' r r' return (ml ++ mr) @@ -1335,8 +1453,8 @@ mt <- match' t t' mr <- match' r r' return (ml ++ mt ++ mr) - match (PAlternative a as) (PAlternative a' as') - = do ms <- zipWithM match' as as' + match (PAlternative a as) (PAlternative a' as') + = do ms <- zipWithM match' as as' return (concat ms) match a@(PAlternative _ as) b = do let ms = zipWith match' as (repeat b) @@ -1376,9 +1494,9 @@ | otherwise = LeftErr (a, b) checkRpts (RightOK ms) = check ms where - check ((n,t):xs) + check ((n,t):xs) | Just t' <- lookup n xs = if t/=t' && t/=Placeholder && t'/=Placeholder - then Left (t, t') + then Left (t, t') else check xs check (_:xs) = check xs check [] = Right ms @@ -1389,7 +1507,7 @@ substMatchesShadow :: [(Name, PTerm)] -> [Name] -> PTerm -> PTerm substMatchesShadow [] shs t = t -substMatchesShadow ((n,tm):ns) shs t +substMatchesShadow ((n,tm):ns) shs t = substMatchShadow n shs tm (substMatchesShadow ns shs t) substMatch :: Name -> PTerm -> PTerm -> PTerm @@ -1399,11 +1517,11 @@ substMatchShadow n shs tm t = sm shs t where sm xs (PRef _ n') | n == n' = tm sm xs (PLam x t sc) = PLam x (sm xs t) (sm xs sc) - sm xs (PPi p x t sc) - | x `elem` xs + sm xs (PPi p x t sc) + | x `elem` xs = let x' = nextName x in - PPi p x' (sm (x':xs) (substMatch x (PRef (FC "" 0) x') t)) - (sm (x':xs) (substMatch x (PRef (FC "" 0) x') sc)) + PPi p x' (sm (x':xs) (substMatch x (PRef emptyFC x') t)) + (sm (x':xs) (substMatch x (PRef emptyFC x') sc)) | otherwise = PPi p x (sm xs t) (sm (x : xs) sc) sm xs (PApp f x as) = fullApp $ PApp f (sm xs x) (map (fmap (sm xs)) as) sm xs (PCase f x as) = PCase f (sm xs x) (map (pmap (sm xs)) as) diff --git a/src/Idris/AbsSyntaxTree.hs b/src/Idris/AbsSyntaxTree.hs --- a/src/Idris/AbsSyntaxTree.hs +++ b/src/Idris/AbsSyntaxTree.hs @@ -17,9 +17,10 @@ import Paths_idris import System.Console.Haskeline - +import System.IO import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Error import Data.List import Data.Char @@ -36,6 +37,7 @@ opt_errContext :: Bool, opt_repl :: Bool, opt_verbose :: Bool, + opt_nobanner :: Bool, opt_quiet :: Bool, opt_codegen :: Codegen, opt_outputTy :: OutputType, @@ -56,6 +58,7 @@ , opt_errContext = False , opt_repl = True , opt_verbose = True + , opt_nobanner = False , opt_quiet = False , opt_codegen = ViaC , opt_outputTy = Executable @@ -87,7 +90,7 @@ idris_statics :: Ctxt [Bool], idris_classes :: Ctxt ClassInfo, idris_dsls :: Ctxt DSL, - idris_optimisation :: Ctxt OptInfo, + idris_optimisation :: Ctxt OptInfo, idris_datatypes :: Ctxt TypeInfo, idris_patdefs :: Ctxt ([([Name], Term, Term)], [PTerm]), -- not exported -- ^ list of lhs/rhs, and a list of missing clauses @@ -95,11 +98,13 @@ idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos idris_calledgraph :: Ctxt [Name], idris_docstrings :: Ctxt String, - idris_totcheck :: [(FC, Name)], - idris_log :: String, + idris_totcheck :: [(FC, Name)], -- names to check totality on + idris_defertotcheck :: [(FC, Name)], -- names to check at the end idris_options :: IOption, idris_name :: Int, - idris_metavars :: [Name], -- ^ The currently defined but not proven metavariables + idris_lineapps :: [((FilePath, Int), PTerm)], + -- ^ Full application LHS on source line + idris_metavars :: [(Name, (Maybe Name, Int, Bool))], -- ^ The currently defined but not proven metavariables idris_coercions :: [Name], idris_transforms :: [(Term, Term)], syntax_rules :: [Syntax], @@ -124,13 +129,15 @@ idris_language_extensions :: [LanguageExt], idris_outputmode :: OutputMode, idris_colourRepl :: Bool, - idris_colourTheme :: ColourTheme + idris_colourTheme :: ColourTheme, + idris_outh :: Handle } data SizeChange = Smaller | Same | Bigger | Unknown deriving (Show, Eq) {-! deriving instance Binary SizeChange +deriving instance NFData SizeChange !-} type SCGEntry = (Name, [Maybe (Int, SizeChange)]) @@ -141,15 +148,16 @@ argsused :: [Name], unusedpos :: [Int] } deriving Show -{-! -deriving instance Binary CGInfo +{-! +deriving instance Binary CGInfo +deriving instance NFData CGInfo !-} -primDefs = [UN "unsafePerformPrimIO", - UN "mkLazyForeignPrim", - UN "mkForeignPrim", +primDefs = [UN "unsafePerformPrimIO", + UN "mkLazyForeignPrim", + UN "mkForeignPrim", UN "FalseElim"] - + -- information that needs writing for the current module's .ibc file data IBCWrite = IBCFix FixDecl | IBCImp Name @@ -175,19 +183,20 @@ | IBCDoc Name | IBCCoercion Name | IBCDef Name -- i.e. main context + | IBCLineApp FilePath Int PTerm deriving Show idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext - emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext - [] "" defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] + emptyContext emptyContext emptyContext emptyContext + [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput - True defaultTheme + True defaultTheme stdout --- | The monad for the main REPL - reading and processing files and updating +-- | The monad for the main REPL - reading and processing files and updating -- global state (hence the IO inner monad). --type Idris = WriterT [Either String (IO ())] (State IState a)) -type Idris = StateT IState IO +type Idris = StateT IState (ErrorT Err IO) -- Commands in the REPL @@ -207,9 +216,9 @@ | DocStr Name | TotCheck Name | Reload - | Load FilePath + | Load FilePath | ChangeDirectory FilePath - | ModImport String + | ModImport String | Edit | Compile Codegen String | Execute @@ -221,7 +230,6 @@ | ShowProof Name | Proofs | Universes - | TTShell | LogLvl Int | Spec PTerm | HNF PTerm @@ -234,6 +242,12 @@ | Pattelab PTerm | DebugInfo Name | Search PTerm + | CaseSplitAt Bool Int Name + | AddClauseFrom Bool Int Name + | AddProofClauseFrom Bool Int Name + | AddMissing Bool Int Name + | MakeWith Bool Int Name + | DoProofSearch Bool Int Name [Name] | SetOpt Opt | UnsetOpt Opt | NOP @@ -245,12 +259,15 @@ | Ver | Usage | Quiet + | NoBanner | ColourREPL Bool | Ideslave | ShowLibs | ShowLibdir | ShowIncs + | NoBasePkgs | NoPrelude + | NoBuiltins -- only for the really primitive stuff! | NoREPL | OLogging Int | Output String @@ -273,7 +290,6 @@ | BCAsm String | DumpDefun String | DumpCases String - | FOVM String | UseCodegen Codegen | OutputTy OutputType | Extension LanguageExt @@ -281,17 +297,19 @@ | TargetTriple String | TargetCPU String | OptLevel Word + | Client String deriving (Show, Eq) -- Parsed declarations -data Fixity = Infixl { prec :: Int } +data Fixity = Infixl { prec :: Int } | Infixr { prec :: Int } - | InfixN { prec :: Int } + | InfixN { prec :: Int } | PrefixN { prec :: Int } deriving Eq -{-! -deriving instance Binary Fixity +{-! +deriving instance Binary Fixity +deriving instance NFData Fixity !-} instance Show Fixity where @@ -300,14 +318,15 @@ show (InfixN i) = "infix " ++ show i show (PrefixN i) = "prefix " ++ show i -data FixDecl = Fix Fixity String +data FixDecl = Fix Fixity String deriving Eq instance Show FixDecl where show (Fix f s) = show f ++ " " ++ s -{-! -deriving instance Binary FixDecl +{-! +deriving instance Binary FixDecl +deriving instance NFData FixDecl !-} instance Ord FixDecl where @@ -316,17 +335,20 @@ data Static = Static | Dynamic deriving (Show, Eq) -{-! -deriving instance Binary Static +{-! +deriving instance Binary Static +deriving instance NFData Static !-} -- Mark bindings with their explicitness, and laziness data Plicity = Imp { plazy :: Bool, pstatic :: Static, - pdocstr :: String } + pdocstr :: String, + pparam :: Bool } | Exp { plazy :: Bool, pstatic :: Static, - pdocstr :: String } + pdocstr :: String, + pparam :: Bool } | Constraint { plazy :: Bool, pstatic :: Static, pdocstr :: String } @@ -337,18 +359,20 @@ deriving (Show, Eq) {-! -deriving instance Binary Plicity +deriving instance Binary Plicity +deriving instance NFData Plicity !-} -impl = Imp False Dynamic "" -expl = Exp False Dynamic "" +impl = Imp False Dynamic "" False +expl = Exp False Dynamic "" False +expl_param = Exp False Dynamic "" True constraint = Constraint False Dynamic "" tacimpl t = TacImp False Dynamic t "" data FnOpt = Inlinable -- always evaluate when simplifying | TotalFn | PartialFn - | Coinductive | AssertTotal - | Dictionary -- type class dictionary, eval only when + | Coinductive | AssertTotal + | Dictionary -- type class dictionary, eval only when -- a function argument, and further evaluation resutls | Implicit -- implicit coercion | CExport String -- export, with a C name @@ -357,6 +381,7 @@ deriving (Show, Eq) {-! deriving instance Binary FnOpt +deriving instance NFData FnOpt !-} type FnOpts = [FnOpt] @@ -379,7 +404,7 @@ | PParams FC [(Name, t)] [PDecl' t] -- ^ Params block | PNamespace String [PDecl' t] -- ^ New namespace | PRecord String SyntaxInfo FC Name t String Name t -- ^ Record declaration - | PClass String SyntaxInfo FC + | PClass String SyntaxInfo FC [t] -- constraints Name [(Name, t)] -- parameters @@ -404,17 +429,22 @@ deriving Functor {-! deriving instance Binary PDecl' +deriving instance NFData PDecl' !-} +-- For elaborator state +type ElabD a = Elab' [PDecl] a + -- | One clause of a top-level definition. Term arguments to constructors are: -- -- 1. The whole application (missing for PClauseR and PWithR because they're within a "with" clause) -- --- 2. The list of patterns +-- 2. The list of extra 'with' patterns -- -- 3. The right-hand side -- -- 4. The where block (PDecl' t) + data PClause' t = PClause FC Name t [t] t [PDecl' t] -- ^ A normal top-level definition. | PWith FC Name t [t] t [PDecl' t] | PClauseR FC [t] t [PDecl' t] @@ -422,6 +452,7 @@ deriving Functor {-! deriving instance Binary PClause' +deriving instance NFData PClause' !-} -- | Data declaration @@ -435,6 +466,7 @@ deriving Functor {-! deriving instance Binary PData' +deriving instance NFData PData' !-} -- Handy to get a free function for applying PTerm -> PTerm functions @@ -442,7 +474,7 @@ type PDecl = PDecl' PTerm type PData = PData' PTerm -type PClause = PClause' PTerm +type PClause = PClause' PTerm -- get all the names declared in a decl @@ -474,7 +506,7 @@ tldeclared (PRecord _ _ _ n _ _ c _) = [n, c] tldeclared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts where fstt (_, a, _, _) = a -tldeclared (PParams _ _ ds) = [] +tldeclared (PParams _ _ ds) = [] tldeclared (PMutual _ ds) = concatMap tldeclared ds tldeclared (PNamespace _ ds) = concatMap tldeclared ds tldeclared (PClass _ _ _ _ n _ ms) = concatMap tldeclared ms @@ -508,14 +540,14 @@ updateNs :: [(Name, Name)] -> PTerm -> PTerm updateNs [] t = t updateNs ns t = mapPT updateRef t - where updateRef (PRef fc f) = PRef fc (updateN ns f) + where updateRef (PRef fc f) = PRef fc (updateN ns f) updateRef t = t -- updateDNs :: [(Name, Name)] -> PDecl -> PDecl -- updateDNs [] t = t -- updateDNs ns (PTy s f n t) | Just n' <- lookup n ns = PTy s f n' t -- updateDNs ns (PClauses f n c) | Just n' <- lookup n ns = PClauses f n' (map updateCNs c) --- where updateCNs ns (PClause n l ts r ds) +-- where updateCNs ns (PClause n l ts r ds) -- = PClause (updateN ns n) (fmap (updateNs ns) l) -- (map (fmap (updateNs ns)) ts) -- (fmap (updateNs ns) r) @@ -532,6 +564,7 @@ | PLet Name PTerm PTerm PTerm | PTyped PTerm PTerm -- ^ Term with explicit type | PApp FC PTerm [PArg] + | PAppBind FC PTerm [PArg] -- ^ implicitly bound application | PMatchApp FC Name -- ^ Make an application by type matching | PCase FC PTerm [(PTerm, PTerm)] | PTrue FC @@ -558,10 +591,13 @@ | PImpossible -- ^ Special case for declaring when an LHS can't typecheck | PCoerced PTerm -- ^ To mark a coerced argument, so as not to coerce twice | PUnifyLog PTerm -- ^ dump a trace of unifications when building term - | PNoImplicits PTerm -- ^ never run implicit converions on the term - deriving Eq -{-! -deriving instance Binary PTerm + | PNoImplicits PTerm -- ^ never run implicit converions on the term + deriving Eq + + +{-! +deriving instance Binary PTerm +deriving instance NFData PTerm !-} mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm @@ -569,9 +605,10 @@ mpt (PLam n t s) = PLam n (mapPT f t) (mapPT f s) mpt (PPi p n t s) = PPi p n (mapPT f t) (mapPT f s) mpt (PLet n ty v s) = PLet n (mapPT f ty) (mapPT f v) (mapPT f s) - mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s) + mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s) (fmap (mapPT f) g) mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as) + mpt (PAppBind fc t as) = PAppBind fc (mapPT f t) (map (fmap (mapPT f)) as) mpt (PCase fc c os) = PCase fc (mapPT f c) (map (pmap (mapPT f)) os) mpt (PEq fc l r) = PEq fc (mapPT f l) (mapPT f r) mpt (PTyped l r) = PTyped (mapPT f l) (mapPT f r) @@ -589,11 +626,12 @@ data PTactic' t = Intro [Name] | Intros | Focus Name - | Refine Name [Bool] | Rewrite t + | Refine Name [Bool] | Rewrite t | Equiv t - | MatchRefine Name + | MatchRefine Name | LetTac Name t | LetTacTy Name t t | Exact t | Compute | Trivial + | ProofSearch (Maybe Name) Name [Name] | Solve | Attack | ProofState | ProofTerm | Undo @@ -605,8 +643,9 @@ | GoalType String (PTactic' t) | Qed | Abandon deriving (Show, Eq, Functor) -{-! -deriving instance Binary PTactic' +{-! +deriving instance Binary PTactic' +deriving instance NFData PTactic' !-} instance Sized a => Sized (PTactic' a) where @@ -640,8 +679,9 @@ | DoLet FC Name t t | DoLetP FC t t deriving (Eq, Functor) -{-! -deriving instance Binary PDo' +{-! +deriving instance Binary PDo' +deriving instance NFData PDo' !-} instance Sized a => Sized (PDo' a) where @@ -656,9 +696,8 @@ -- The priority gives a hint as to elaboration order. Best to elaborate -- things early which will help give a more concrete type to other -- variables, e.g. a before (interpTy a). --- TODO: priority no longer serves any purpose, drop it! -data PArg' t = PImp { priority :: Int, +data PArg' t = PImp { priority :: Int, machine_inf :: Bool, -- true if the machine inferred it lazyarg :: Bool, pname :: Name, getTm :: t, pargdoc :: String } @@ -669,9 +708,9 @@ lazyarg :: Bool, getTm :: t, pargdoc :: String } | PTacImplicit { priority :: Int, - lazyarg :: Bool, pname :: Name, + lazyarg :: Bool, pname :: Name, getScript :: t, - getTm :: t, + getTm :: t, pargdoc :: String } deriving (Show, Eq, Functor) @@ -681,8 +720,9 @@ size (PConstraint p l trm _) = 1 + size trm size (PTacImplicit p l nm scr trm _) = 1 + size nm + size scr + size trm -{-! -deriving instance Binary PArg' +{-! +deriving instance Binary PArg' +deriving instance NFData PArg' !-} pimp n t mach = PImp 1 mach True n t "" @@ -700,8 +740,9 @@ class_params :: [Name], class_instances :: [Name] } deriving Show -{-! -deriving instance Binary ClassInfo +{-! +deriving instance Binary ClassInfo +deriving instance NFData ClassInfo !-} data OptInfo = Optimise { collapsible :: Bool, @@ -709,20 +750,22 @@ forceable :: [Int], -- argument positions recursive :: [Int] } deriving Show -{-! -deriving instance Binary OptInfo +{-! +deriving instance Binary OptInfo +deriving instance NFData OptInfo !-} -data TypeInfo = TI { con_names :: [Name], +data TypeInfo = TI { con_names :: [Name], codata :: Bool, param_pos :: [Int] } deriving Show {-! deriving instance Binary TypeInfo +deriving instance NFData TypeInfo !-} --- Syntactic sugar info +-- Syntactic sugar info data DSL' t = DSL { dsl_bind :: t, dsl_return :: t, @@ -737,20 +780,23 @@ deriving (Show, Functor) {-! deriving instance Binary DSL' +deriving instance NFData DSL' !-} type DSL = DSL' PTerm data SynContext = PatternSyntax | TermSyntax | AnySyntax deriving Show -{-! -deriving instance Binary SynContext +{-! +deriving instance Binary SynContext +deriving instance NFData SynContext !-} data Syntax = Rule [SSymbol] PTerm SynContext deriving Show -{-! -deriving instance Binary Syntax +{-! +deriving instance Binary Syntax +deriving instance NFData Syntax !-} data SSymbol = Keyword Name @@ -759,11 +805,12 @@ | Expr Name | SimpleExpr Name deriving Show -{-! -deriving instance Binary SSymbol +{-! +deriving instance Binary SSymbol +deriving instance NFData SSymbol !-} -initDSL = DSL (PRef f (UN ">>=")) +initDSL = DSL (PRef f (UN ">>=")) (PRef f (UN "return")) (PRef f (UN "<$>")) (PRef f (UN "pure")) @@ -772,13 +819,14 @@ Nothing Nothing Nothing - where f = FC "(builtin)" 0 + where f = fileFC "(builtin)" data Using = UImplicit Name PTerm | UConstraint Name [Name] deriving (Show, Eq) {-! deriving instance Binary Using +deriving instance NFData Using !-} data SyntaxInfo = Syn { using :: [Using], @@ -791,6 +839,7 @@ dsl_info :: DSL } deriving Show {-! +deriving instance NFData SyntaxInfo deriving instance Binary SyntaxInfo !-} @@ -825,29 +874,29 @@ showDeclImp t (PPostulate _ _ _ _ n ty) = show n ++ " : " ++ showImp Nothing t False ty showDeclImp _ (PClauses _ _ n c) = showSep "\n" (map show c) showDeclImp _ (PData _ _ _ _ d) = show d -showDeclImp _ (PParams f ns ps) = "parameters " ++ show ns ++ "\n" ++ +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) +showCImp impl (PClause _ n l ws r w) = showImp Nothing impl False l ++ showWs ws ++ " = " ++ showImp Nothing impl False r - ++ " where " ++ show w + ++ " where " ++ show w where showWs [] = "" showWs (x : xs) = " | " ++ showImp Nothing impl False x ++ showWs xs -showCImp impl (PWith _ n l ws r w) +showCImp impl (PWith _ n l ws r w) = showImp Nothing impl False l ++ showWs ws ++ " with " ++ showImp Nothing impl False r - ++ " { " ++ show w ++ " } " + ++ " { " ++ show w ++ " } " where showWs [] = "" showWs (x : xs) = " | " ++ showImp Nothing impl False x ++ showWs xs showDImp :: Bool -> PData -> String -showDImp impl (PDatadecl n ty cons) +showDImp impl (PDatadecl n ty cons) = "data " ++ show n ++ " : " ++ showImp Nothing impl False ty ++ " where\n\t" - ++ showSep "\n\t| " + ++ showSep "\n\t| " (map (\ (_, n, t, _) -> show n ++ " : " ++ showImp Nothing impl False t) cons) getImps :: [PArg] -> [(Name, PTerm)] @@ -866,7 +915,7 @@ getConsts (_ : xs) = getConsts xs getAll :: [PArg] -> [PTerm] -getAll = map getTm +getAll = map getTm -- | Pretty-print a high-level Idris term prettyImp :: Bool -- ^^ whether to show implicits @@ -889,6 +938,7 @@ prettyBasic n@(UN _) = pretty n prettyBasic (MN _ s) = text s prettyBasic (NS n s) = (foldr (<>) empty (intersperse (text ".") (map text $ reverse s))) <> prettyBasic n + prettyBasic (SN sn) = text (show sn) prettySe p (PLam n ty sc) = bracket p 2 $ if size sc > breakingSize then @@ -903,7 +953,7 @@ else text "let" <+> pretty n <+> text "=" <+> prettySe 10 v <+> text "in" <+> prettySe 10 sc - prettySe p (PPi (Exp l s _) n ty sc) + prettySe p (PPi (Exp l s _ _) n ty sc) | n `elem` allNamesIn sc || impl = let open = if l then text "|" <> lparen else lparen in bracket p 2 $ @@ -924,7 +974,7 @@ case s of Static -> text "[static]" _ -> empty - prettySe p (PPi (Imp l s _) n ty sc) + prettySe p (PPi (Imp l s _ _) n ty sc) | impl = let open = if l then text "|" <> lbrace else lbrace in bracket p 2 $ @@ -956,6 +1006,8 @@ rbrace <+> text "->" <+> prettySe 10 sc prettySe p (PApp _ (PRef _ f) []) | not impl = pretty f + prettySe p (PAppBind _ (PRef _ f) []) + | not impl = text "!" <+> pretty f prettySe p (PApp _ (PRef _ op@(UN (f:_))) args) | length (getExps args) == 2 && (not impl) && (not $ isAlpha f) = let [l, r] = getExps args in @@ -1108,25 +1160,27 @@ | Just num <- snat p e = perhapsColourise colouriseData (show num) se p bnd (PRef fc n) = showName ist bnd impl colour n se p bnd (PLam n ty sc) = bracket p 2 $ "\\ " ++ perhapsColourise colouriseBound (show n) ++ - (if impl then " : " ++ se 10 bnd ty else "") ++ " => " + (if impl then " : " ++ se 10 bnd ty else "") ++ " => " ++ se 10 ((n, False):bnd) sc se p bnd (PLet n ty v sc) = bracket p 2 $ "let " ++ perhapsColourise colouriseBound (show n) ++ " = " ++ se 10 bnd v ++ " in " ++ se 10 ((n, False):bnd) sc - se p bnd (PPi (Exp l s _) n ty sc) + se p bnd (PPi (Exp l s _ param) n ty sc) | n `elem` allNamesIn sc || impl = bracket p 2 $ (if l then "|(" else "(") ++ perhapsColourise colouriseBound (show n) ++ " : " ++ se 10 bnd ty ++ - ") " ++ st ++ + ") " ++ + (if (impl && param) then "P" else "") ++ + st ++ "-> " ++ se 10 ((n, False):bnd) sc | otherwise = bracket p 2 $ se 0 bnd ty ++ " " ++ st ++ "-> " ++ se 10 bnd sc where st = case s of Static -> "[static] " _ -> "" - se p bnd (PPi (Imp l s _) n ty sc) + se p bnd (PPi (Imp l s _ _) n ty sc) | impl = bracket p 2 $ (if l then "|{" else "{") ++ - perhapsColourise colouriseBound (show n) ++ " : " ++ se 10 bnd ty ++ + perhapsColourise colouriseBound (show n) ++ " : " ++ se 10 bnd ty ++ "} " ++ st ++ "-> " ++ se 10 ((n, True):bnd) sc | otherwise = se 10 ((n, True):bnd) sc where st = case s of @@ -1141,14 +1195,21 @@ se p bnd (PMatchApp _ f) = "match " ++ show f se p bnd (PApp _ hd@(PRef _ f) []) | not impl = se p bnd hd + se p bnd (PAppBind _ hd@(PRef _ f) []) + | not impl = "!" ++ se p bnd hd se p bnd (PApp _ op@(PRef _ (UN (f:_))) args) - | length (getExps args) == 2 && not impl && not (isAlpha f) + | length (getExps args) == 2 && not impl && not (isAlpha f) = let [l, r] = getExps args in bracket p 1 $ se 1 bnd l ++ " " ++ se p bnd op ++ " " ++ se 0 bnd r se p bnd (PApp _ f as) + = -- let args = getExps as in + bracket p 1 $ se 1 bnd f ++ + if impl then concatMap (sArg bnd) as + else concatMap (suiArg impl bnd) as + se p bnd (PAppBind _ f as) = let args = getExps as in - bracket p 1 $ se 1 bnd f ++ if impl then concatMap (sArg bnd) as - else concatMap (seArg bnd) args + "!" ++ (bracket p 1 $ se 1 bnd f ++ if impl then concatMap (sArg bnd) as + else concatMap (seArg bnd) args) se p bnd (PCase _ scr opts) = "case " ++ se 10 bnd scr ++ " of " ++ showSep " | " (map sc opts) where sc (l, r) = se 10 bnd l ++ " => " ++ se 10 bnd r se p bnd (PHidden tm) = "." ++ se 0 bnd tm @@ -1185,7 +1246,7 @@ -- se p bnd x = "Not implemented" slist' p bnd (PApp _ (PRef _ nil) _) - | nsroot nil == UN "Nil" = Just [] + | not impl && nsroot nil == UN "Nil" = Just [] slist' p bnd (PApp _ (PRef _ cons) args) | nsroot cons == UN "::", (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args, @@ -1220,8 +1281,19 @@ sArg bnd (PConstraint _ _ tm _) = scArg bnd tm sArg bnd (PTacImplicit _ _ n _ tm _) = stiArg bnd (n, tm) + -- show argument, implicits given by the user also shown + suiArg impl bnd (PImp _ mi _ n tm _) + | impl || not mi = siArg bnd (n, tm) + suiArg impl bnd (PExp _ _ tm _) = seArg bnd tm + suiArg impl bnd _ = "" + seArg bnd arg = " " ++ se 0 bnd arg - siArg bnd (n, val) = " {" ++ show n ++ " = " ++ se 10 bnd val ++ "}" + siArg bnd (n, val) = + let n' = show n + val' = se 10 bnd val in + if (n' == val') + then " {" ++ n' ++ "}" + else " {" ++ n' ++ " = " ++ val' ++ "}" scArg bnd val = " {{" ++ se 10 bnd val ++ "}}" stiArg bnd (n, val) = " {auto " ++ show n ++ " = " ++ se 10 bnd val ++ "}" @@ -1237,6 +1309,7 @@ size (PLet name ty def bdy) = 1 + size ty + size def + size bdy size (PTyped trm ty) = 1 + size trm + size ty size (PApp fc name args) = 1 + size args + size (PAppBind fc name args) = 1 + size args size (PCase fc trm bdy) = 1 + size trm + size bdy size (PTrue fc) = 1 size (PFalse fc) = 1 @@ -1268,11 +1341,12 @@ -- Return all names, free or globally bound, in the given term. allNamesIn :: PTerm -> [Name] -allNamesIn tm = nub $ ni [] tm +allNamesIn tm = nub $ ni [] tm where - ni env (PRef _ n) + ni env (PRef _ n) | not (n `elem` env) = [n] ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) + ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os) ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc @@ -1291,14 +1365,15 @@ -- Return names which are free in the given term. namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name] -namesIn uvars ist tm = nub $ ni [] tm +namesIn uvars ist tm = nub $ ni [] tm where - ni env (PRef _ n) - | not (n `elem` env) + ni env (PRef _ n) + | not (n `elem` env) = case lookupTy n (tt_ctxt ist) of [] -> [n] _ -> if n `elem` (map fst uvars) then [n] else [] ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) + ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os) ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc @@ -1317,14 +1392,15 @@ -- Return which of the given names are used in the given term. usedNamesIn :: [Name] -> IState -> PTerm -> [Name] -usedNamesIn vars ist tm = nub $ ni [] tm +usedNamesIn vars ist tm = nub $ ni [] tm where - ni env (PRef _ n) - | n `elem` vars && not (n `elem` env) + ni env (PRef _ n) + | n `elem` vars && not (n `elem` env) = case lookupTy n (tt_ctxt ist) of [] -> [n] _ -> [] ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) + ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os) ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc diff --git a/src/Idris/CaseSplit.hs b/src/Idris/CaseSplit.hs new file mode 100644 --- /dev/null +++ b/src/Idris/CaseSplit.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE PatternGuards #-} + +module Idris.CaseSplit(splitOnLine, replaceSplits, + getClause, getProofClause, + mkWith, + getUniq, nameRoot) where + +-- splitting a variable in a pattern clause + +import Idris.AbsSyntax +import Idris.ElabDecls +import Idris.ElabTerm +import Idris.Delaborate +import Idris.Parser +import Idris.Error + +import Core.TT +import Core.Typecheck +import Core.Evaluate + +import Data.Maybe +import Data.Char +import Control.Monad +import Control.Monad.State.Strict + +import Text.Parser.Combinators +import Text.Parser.Char(anyChar) +import Text.Trifecta(Result(..), parseString) +import Text.Trifecta.Delta +import qualified Data.ByteString.UTF8 as UTF8 + +import Debug.Trace + +{- + +Given a pattern clause and a variable 'n', elaborate the clause and find the +type of 'n'. + +Make new pattern clauses by replacing 'n' with all the possibly constructors +applied to '_', and replacing all other variables with '_' in order to +resolve other dependencies. + +Finally, merge the generated patterns with the original, by matching. +Always take the "more specific" argument when there is a discrepancy, i.e. +names over '_', patterns over names, etc. +-} + +-- Given a variable to split, and a term application, return a list of +-- variable updates +split :: Name -> PTerm -> Idris [[(Name, PTerm)]] +split n t' + = do ist <- getIState + (tm, ty, pats) <- elabValBind toplevel True (addImplPat ist t') + logLvl 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats) +-- iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty)) +-- iputStrLn (show pats) + let t = mergeUserImpl (addImplPat ist t') (delab ist tm) + let ctxt = tt_ctxt ist + case lookup n pats of + Nothing -> fail $ show n ++ " is not a pattern variable" + Just ty -> + do let splits = findPats ist ty + iLOG ("New patterns " ++ showSep ", " + (map (showImp Nothing True False) splits)) + let newPats_in = zipWith (replaceVar ctxt n) splits (repeat t) + logLvl 4 ("Working from " ++ show t) + logLvl 4 ("Trying " ++ showSep "\n" + (map (showImp Nothing True False) newPats_in)) + newPats <- mapM elabNewPat newPats_in + logLvl 3 ("Original:\n" ++ show t) + logLvl 3 ("Split:\n" ++ + (showSep "\n" (map show (mapMaybe id newPats)))) + logLvl 3 "----" + let newPats' = mergeAllPats ctxt t (mapMaybe id newPats) + iLOG ("Name updates " ++ showSep "\n" + (map (\ (p, u) -> show u ++ " " ++ show p) newPats')) + return (map snd newPats') + +data MergeState = MS { namemap :: [(Name, Name)], + updates :: [(Name, PTerm)] } + +addUpdate n tm = do ms <- get + put (ms { updates = ((n, stripNS tm) : updates ms) } ) + +stripNS tm = mapPT dens tm where + dens (PRef fc n) = PRef fc (nsroot n) + dens t = t + +mergeAllPats :: Context -> PTerm -> [PTerm] -> [(PTerm, [(Name, PTerm)])] +mergeAllPats ctxt t [] = [] +mergeAllPats ctxt t (p : ps) + = let (p', MS _ u) = runState (mergePat ctxt t p) (MS [] []) + ps' = mergeAllPats ctxt t ps in + ((p, u) : ps') + +mergePat :: Context -> PTerm -> PTerm -> State MergeState PTerm +-- If any names are unified, make sure they stay unified. Always prefer +-- user provided name (first pattern) +mergePat ctxt (PPatvar fc n) new + = mergePat ctxt (PRef fc n) new +mergePat ctxt old (PPatvar fc n) + = mergePat ctxt old (PRef fc n) +mergePat ctxt orig@(PRef fc n) new@(PRef _ n') + | isDConName n' ctxt = do addUpdate n new; + return new + | otherwise + = do ms <- get + case lookup n' (namemap ms) of + Just x -> do addUpdate n (PRef fc x) + return (PRef fc x) + Nothing -> do put (ms { namemap = ((n', n) : namemap ms) }) + return (PRef fc n) +mergePat ctxt (PApp _ _ args) (PApp fc f args') + = do newArgs <- zipWithM mergeArg args args' + return (PApp fc f newArgs) + where mergeArg x y = do tm' <- mergePat ctxt (getTm x) (getTm y) + case x of + (PImp _ _ _ _ _ _) -> + return (y { machine_inf = machine_inf x, + getTm = tm' }) + _ -> return (y { getTm = tm' }) +mergePat ctxt (PRef fc n) t = do tm <- tidy t + addUpdate n tm + return tm +mergePat ctxt x y = return y + +mergeUserImpl :: PTerm -> PTerm -> PTerm +mergeUserImpl x y = x + +tidy orig@(PRef fc n) + = do ms <- get + case lookup n (namemap ms) of + Just x -> return (PRef fc x) + Nothing -> case n of + (UN _) -> return orig + _ -> return Placeholder +tidy (PApp fc f args) + = do args' <- mapM tidyArg args + return (PApp fc f args') + where tidyArg x = do tm' <- tidy (getTm x) + return (x { getTm = tm' }) +tidy tm = return tm + + +-- mapPT tidyVar tm +-- where tidyVar (PRef _ _) = Placeholder +-- tidyVar t = t + +elabNewPat :: PTerm -> Idris (Maybe PTerm) +elabNewPat t = idrisCatch (do (tm, ty) <- elabVal toplevel True t + i <- getIState + return (Just (delab i tm))) + (\e -> do i <- getIState + logLvl 5 $ "Not a valid split:\n" ++ pshow i e + return Nothing) + +findPats :: IState -> Type -> [PTerm] +findPats ist t | (P _ n _, _) <- unApply t + = case lookupCtxt n (idris_datatypes ist) of + [ti] -> map genPat (con_names ti) + _ -> [Placeholder] + where genPat n = case lookupCtxt n (idris_implicits ist) of + [args] -> PApp emptyFC (PRef emptyFC n) + (map toPlaceholder args) + _ -> error $ "Can't happen (genPat) " ++ show n + toPlaceholder tm = tm { getTm = Placeholder } +findPats ist t = [Placeholder] + +replaceVar :: Context -> Name -> PTerm -> PTerm -> PTerm +replaceVar ctxt n t (PApp fc f pats) = PApp fc f (map substArg pats) + where subst :: PTerm -> PTerm + subst orig@(PPatvar _ v) | v == n = t + | otherwise = Placeholder + subst orig@(PRef _ v) | v == n = t + | isDConName v ctxt = orig + subst (PRef _ _) = Placeholder + subst (PApp fc (PRef _ t) pats) + | isTConName t ctxt = Placeholder -- infer types + subst (PApp fc f pats) = PApp fc f (map substArg pats) + subst (PEq fc l r) = PEq fc (subst l) (subst r) + subst x = x + + substArg arg = arg { getTm = subst (getTm arg) } + +replaceVar ctxt n t pat = pat + +splitOnLine :: Int -- ^ line number + -> Name -- ^ variable + -> FilePath -- ^ name of file + -> Idris [[(Name, PTerm)]] +splitOnLine l n fn = do +-- let (before, later) = splitAt (l-1) (lines inp) +-- i <- getIState + cl <- getInternalApp fn l + logLvl 3 ("Working with " ++ showImp Nothing True False cl) + tms <- split n cl +-- iputStrLn (showSep "\n" (map show tms)) + return tms -- "" -- not yet done... + +replaceSplits :: String -> [[(Name, PTerm)]] -> Idris [String] +replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups) + where + rep str [] = str ++ "\n" + rep str ((n, tm) : ups) = rep (updatePat False (show n) (nshow False tm) str) ups + + updateRHSs i [] = return [] + updateRHSs i (x : xs) = do (x', i') <- updateRHS i x + xs' <- updateRHSs i' xs + return (x' : xs') + + updateRHS i ('?':'=':xs) = do (xs', i') <- updateRHS i xs + return ("?=" ++ xs', i') + updateRHS i ('?':xs) = do let (nm, rest) = span (not . isSpace) xs + (nm', i') <- getUniq nm i + return ('?':nm' ++ rest, i') + updateRHS i (x : xs) = do (xs', i') <- updateRHS i xs + return (x : xs', i') + updateRHS i [] = return ("", i) + + + -- TMP HACK: If there are Nats, we don't want to show as numerals since + -- this isn't supported in a pattern, so special case here + nshow brack (PRef _ (UN "Z")) = "Z" + nshow brack (PApp _ (PRef _ (UN "S")) [x]) = + if brack then "(S " else "S " ++ nshow True (getTm x) ++ + if brack then ")" else "" + nshow _ t = show t + + -- if there's any {n} replace with {n=n} + expandBraces ('{' : xs) + = let (brace, (_:rest)) = span (/= '}') xs in + if (not ('=' `elem` brace)) + then ('{' : brace ++ " = " ++ brace ++ "}") ++ + expandBraces rest + else ('{' : brace ++ "}") ++ expandBraces rest + expandBraces (x : xs) = x : expandBraces xs + expandBraces [] = [] + + updatePat start n tm [] = [] + updatePat start n tm ('{':rest) = + let (space, rest') = span isSpace rest in + '{' : space ++ updatePat False n tm rest' + updatePat True n tm xs@(c:rest) | length xs > length n + = let (before, after@(next:_)) = splitAt (length n) xs in + if (before == n && not (isAlpha next)) + then addBrackets tm ++ updatePat False n tm after + else c : updatePat (not (isAlpha c)) n tm rest + updatePat start n tm (c:rest) = c : updatePat (not (isAlpha c)) n tm rest + + addBrackets tm | ' ' `elem` tm = "(" ++ tm ++ ")" + | otherwise = tm + +getUniq nm i + = do ist <- getIState + let n = nameRoot [] nm ++ "_" ++ show i + case lookupTy (UN n) (tt_ctxt ist) of + [] -> return (n, i+1) + _ -> getUniq nm (i+1) + +nameRoot acc nm | all isDigit nm = showSep "_" acc +nameRoot acc nm = + case span (/='_') nm of + (before, ('_' : after)) -> nameRoot (acc ++ [before]) after + _ -> showSep "_" (acc ++ [nm]) + +getClause :: Int -> -- ^ Line type is declared on + Name -> -- ^ Function name + FilePath -> -- ^ Source file name + Idris String +getClause l fn fp = do ty <- getInternalApp fp l + let ap = mkApp ty [1..] + return (show fn ++ " " ++ ap ++ + "= ?" ++ show fn ++ "_rhs") + where mkApp (PPi (Exp _ _ _ False) (MN _ _) _ sc) (n : ns) + = "x" ++ show n ++ " " ++ mkApp sc ns + mkApp (PPi (Exp _ _ _ False) n _ sc) ns + = show n ++ " " ++ mkApp sc ns + mkApp (PPi _ _ _ sc) ns = mkApp sc ns + mkApp _ _ = "" + +getProofClause :: Int -> -- ^ Line type is declared on + Name -> -- ^ Function name + FilePath -> -- ^ Source file name + Idris String +getProofClause l fn fp + = do ty <- getInternalApp fp l + return (mkApp ty ++ " = ?" ++ show fn ++ "_rhs") + where mkApp (PPi _ _ _ sc) = mkApp sc + mkApp rt = "(" ++ show rt ++ ") <== " ++ show fn + +-- Purely syntactic - turn a pattern match clause into a with and a new +-- match clause + +mkWith :: String -> Name -> String +mkWith str n = let ind = getIndent str + str' = replicate ind ' ' ++ + replaceRHS str "with (_)" + newpat = replicate (ind + 2) ' ' ++ + replaceRHS str "| with_pat = ?" ++ show n ++ "_rhs" in + str' ++ "\n" ++ newpat + + where getIndent s = length (takeWhile isSpace s) + + replaceRHS [] str = str + replaceRHS ('?':'=': rest) str = str + replaceRHS ('=': rest) str = str + replaceRHS (x : rest) str = x : replaceRHS rest str diff --git a/src/Idris/Chaser.hs b/src/Idris/Chaser.hs --- a/src/Idris/Chaser.hs +++ b/src/Idris/Chaser.hs @@ -51,7 +51,7 @@ ibc (IBC _ _) = True ibc _ = False - + chkReload False p = p chkReload True (IBC fn src) = chkReload True src chkReload True p = p @@ -71,37 +71,37 @@ buildTree :: [FilePath] -> -- already guaranteed built FilePath -> Idris [ModuleTree] buildTree built fp = idrisCatch (btree [] fp) - (\e -> do now <- liftIO $ getCurrentTime + (\e -> do now <- runIO $ getCurrentTime return [MTree (IDR fp) True now []]) where - btree done f = + btree done f = do i <- getIState let file = takeWhile (/= ' ') f iLOG $ "CHASING " ++ show file ibcsd <- valIBCSubDir i - ids <- allImportDirs - fp <- liftIO $ findImport ids ibcsd file - mt <- liftIO $ getIModTime fp - if (file `elem` built) + ids <- allImportDirs + fp <- runIO $ findImport ids ibcsd file + mt <- runIO $ getIModTime fp + if (file `elem` built) then return [MTree fp False mt []] - else if file `elem` done + else if file `elem` done then return [] - else mkChildren fp + else mkChildren fp where mkChildren (LIDR fn) = do ms <- children True fn (f:done) - mt <- liftIO $ getModificationTime fn + mt <- runIO $ getModificationTime fn return [MTree (LIDR fn) True mt ms] mkChildren (IDR fn) = do ms <- children False fn (f:done) - mt <- liftIO $ getModificationTime fn + mt <- runIO $ getModificationTime fn return [MTree (IDR fn) True mt ms] - mkChildren (IBC fn src) - = do srcexist <- liftIO $ doesFileExist (getSrcFile src) + mkChildren (IBC fn src) + = do srcexist <- runIO $ doesFileExist (getSrcFile src) ms <- if srcexist then do [MTree _ _ _ ms'] <- mkChildren src return ms' else return [] - mt <- idrisCatch (liftIO $ getModificationTime fn) - (\c -> liftIO $ getIModTime src) + mt <- idrisCatch (runIO $ getModificationTime fn) + (\c -> runIO $ getIModTime src) ok <- checkIBCUpToDate fn src return [MTree (IBC fn src) ok mt ms] @@ -115,21 +115,21 @@ checkIBCUpToDate fn (LIDR src) = older fn src checkIBCUpToDate fn (IDR src) = older fn src - older ibc src = do exist <- liftIO $ doesFileExist src + older ibc src = do exist <- runIO $ doesFileExist src if exist then do - ibct <- liftIO $ getModificationTime ibc - srct <- liftIO $ getModificationTime src - return (srct > ibct) + ibct <- runIO $ getModificationTime ibc + srct <- runIO $ getModificationTime src + return (srct > ibct) else return False children :: Bool -> FilePath -> [FilePath] -> Idris [ModuleTree] children lit f done = idrisCatch - (do exist <- liftIO $ doesFileExist f + (do exist <- runIO $ doesFileExist f if exist then do - file_in <- liftIO $ readFile f + file_in <- runIO $ readFile f file <- if lit then tclift $ unlit f file_in else return file_in (_, modules, _) <- parseImports f file - ms <- mapM (btree done) modules + ms <- mapM (btree done) modules return (concat ms) else return []) -- IBC with no source available (\c -> return []) -- error, can't chase modules here diff --git a/src/Idris/Colours.hs b/src/Idris/Colours.hs --- a/src/Idris/Colours.hs +++ b/src/Idris/Colours.hs @@ -9,7 +9,7 @@ import System.Console.ANSI -data IdrisColour = IdrisColour { colour :: Color +data IdrisColour = IdrisColour { colour :: Maybe Color , vivid :: Bool , underline :: Bool , bold :: Bool @@ -18,7 +18,7 @@ deriving (Eq, Show) mkColour :: Color -> IdrisColour -mkColour c = IdrisColour c True False False False +mkColour c = IdrisColour (Just c) True False False False data ColourTheme = ColourTheme { keywordColour :: IdrisColour , boundVarColour :: IdrisColour @@ -31,22 +31,24 @@ deriving (Eq, Show) defaultTheme :: ColourTheme -defaultTheme = ColourTheme { keywordColour = IdrisColour Black True True True False +defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True True True False , boundVarColour = mkColour Magenta - , implicitColour = IdrisColour Magenta True True False False + , implicitColour = IdrisColour (Just Magenta) True True False False , functionColour = mkColour Green , typeColour = mkColour Blue , dataColour = mkColour Red - , promptColour = IdrisColour Black True False True False + , promptColour = IdrisColour Nothing True False True False } -- Set the colour of a string using POSIX escape codes colourise :: IdrisColour -> String -> String colourise (IdrisColour c v u b i) str = setSGRCode sgr ++ str ++ setSGRCode [Reset] - where sgr = [SetColor Foreground (if v then Vivid else Dull) c] ++ + where sgr = fg c ++ (if u then [SetUnderlining SingleUnderline] else []) ++ (if b then [SetConsoleIntensity BoldIntensity] else []) ++ (if i then [SetItalicized True] else []) + fg Nothing = [] + fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c] colouriseKwd :: ColourTheme -> String -> String colouriseKwd t = colourise (keywordColour t) diff --git a/src/Idris/Completion.hs b/src/Idris/Completion.hs --- a/src/Idris/Completion.hs +++ b/src/Idris/Completion.hs @@ -3,11 +3,11 @@ import Core.Evaluate (ctxtAlist) import Core.TT -import Core.CoreParser (opChars) import Idris.AbsSyntaxTree import Idris.Help import Idris.Colours +import Idris.ParseHelpers(opChars) import Control.Monad.State.Strict @@ -22,7 +22,7 @@ fst3 :: (a, b, c) -> a fst3 (a, b, c) = a -commands = concatMap fst3 help +commands = concatMap fst3 (help ++ extraHelp) -- | A specification of the arguments that tactics can take data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n @@ -71,7 +71,7 @@ metavars :: Idris [String] metavars = do i <- get - return . map (show . nsroot) $ idris_metavars i \\ primDefs + return . map (show . nsroot) $ map fst (filter (\(_, (_,_,t)) -> not t) (idris_metavars i)) \\ primDefs modules :: Idris [String] diff --git a/src/Idris/Coverage.hs b/src/Idris/Coverage.hs --- a/src/Idris/Coverage.hs +++ b/src/Idris/Coverage.hs @@ -31,7 +31,7 @@ return $ mkApp t' args' toTT _ = do v <- get put (v + 1) - return (P Bound (MN v "imp") Erased) + return (P Bound (MN v "imp") Erased) -- 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 @@ -49,7 +49,7 @@ logLvl 5 $ "COVERAGE of " ++ show n logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args) logLvl 10 $ show argss ++ "\n" ++ show all_args - logLvl 10 $ "Original: \n" ++ + logLvl 10 $ "Original: \n" ++ showSep "\n" (map (\t -> showImp Nothing True False (delab' i t True)) xs) -- add an infinite supply of explicit arguments to update the possible -- cases for (the return type may be variadic, or function type, sp @@ -61,13 +61,13 @@ let tryclauses = mkClauses parg all_args logLvl 2 $ show (length tryclauses) ++ " initially to check" logLvl 5 $ showSep "\n" (map (showImp Nothing True False) tryclauses) - let new = filter (noMatch i) (nub tryclauses) + let new = filter (noMatch i) (nub tryclauses) logLvl 1 $ show (length new) ++ " clauses to check for impossibility" logLvl 5 $ "New clauses: \n" ++ showSep "\n" (map (showImp Nothing True False) 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 + where getLHS i term | (f, args) <- unApply term = map (\t -> delab' i t True) args | otherwise = [] @@ -76,7 +76,7 @@ noMatch i tm = all (\x -> case matchClause i (delab' i x True) tm of Right _ -> False - Left miss -> True) xs + Left miss -> True) xs mkClauses :: [PArg] -> [[PTerm]] -> [PTerm] @@ -102,7 +102,7 @@ -- quick check for constructor equality quickEq :: PTerm -> PTerm -> Bool quickEq (PRef _ n) (PRef _ n') = n == n' -quickEq (PApp _ t as) (PApp _ t' as') +quickEq (PApp _ t as) (PApp _ t' as') | length as == length as' = quickEq t t' && and (zipWith quickEq (map getTm as) (map getTm as')) quickEq Placeholder Placeholder = True @@ -112,15 +112,15 @@ qelem x (y : ys) | x `quickEq` y = True | otherwise = qelem x ys --- FIXME: Just look for which one is the deepest, then generate all +-- FIXME: Just look for which one is the deepest, then generate all -- possibilities up to that depth. genAll :: IState -> [PTerm] -> [PTerm] -genAll i args +genAll i args = case filter (/=Placeholder) $ fnub (concatMap otherPats (fnub args)) of [] -> [Placeholder] xs -> inventConsts xs - where + where -- if they're constants, invent a new one to make sure that -- constants which are not explicitly handled are covered inventConsts cs@(PConstant c : _) = map PConstant (ic' (mapMaybe getConst cs)) @@ -128,21 +128,21 @@ getConst _ = Nothing inventConsts xs = xs - -- try constants until they're not in the list. - -- FIXME: It is, of course, possible that someone has enumerated all - -- the constants and matched on them (maybe in generated code) and this - -- will be really slow. This is sufficiently unlikely that we won't - -- worry for now... + -- try constants until they're not in the list. + -- FIXME: It is, of course, possible that someone has enumerated all + -- the constants and matched on them (maybe in generated code) and this + -- will be really slow. This is sufficiently unlikely that we won't + -- worry for now... - ic' xs@(I _ : _) = firstMissing xs (lotsOfNums I) + ic' xs@(I _ : _) = firstMissing xs (lotsOfNums I) ic' xs@(BI _ : _) = firstMissing xs (lotsOfNums BI) - ic' xs@(Fl _ : _) = firstMissing xs (lotsOfNums Fl) - ic' xs@(B8 _ : _) = firstMissing xs (lotsOfNums B8) - ic' xs@(B16 _ : _) = firstMissing xs (lotsOfNums B16) - ic' xs@(B32 _ : _) = firstMissing xs (lotsOfNums B32) - ic' xs@(B64 _ : _) = firstMissing xs (lotsOfNums B64) + ic' xs@(Fl _ : _) = firstMissing xs (lotsOfNums Fl) + ic' xs@(B8 _ : _) = firstMissing xs (lotsOfNums B8) + ic' xs@(B16 _ : _) = firstMissing xs (lotsOfNums B16) + ic' xs@(B32 _ : _) = firstMissing xs (lotsOfNums B32) + ic' xs@(B64 _ : _) = firstMissing xs (lotsOfNums B64) ic' xs@(Ch _ : _) = firstMissing xs lotsOfChars - ic' xs@(Str _ : _) = firstMissing xs lotsOfStrings + ic' xs@(Str _ : _) = firstMissing xs lotsOfStrings -- TODO: Bit vectors -- The rest are types with only one case ic' xs = xs @@ -166,16 +166,16 @@ otherPats o@(PApp _ (PRef fc n) xs) = ops fc n xs o otherPats o@(PPair fc l r) = ops fc pairCon - ([pimp (UN "A") Placeholder True, + ([pimp (UN "A") Placeholder True, pimp (UN "B") Placeholder True] ++ [pexp l, pexp r]) o - otherPats o@(PDPair fc t _ v) - = ops fc (UN "Ex_intro") - ([pimp (UN "a") Placeholder True, + otherPats o@(PDPair fc t _ v) + = ops fc (UN "Ex_intro") + ([pimp (UN "a") Placeholder True, pimp (UN "P") Placeholder True] ++ [pexp t,pexp v]) o otherPats o@(PConstant c) = return o - otherPats arg = return Placeholder + otherPats arg = return Placeholder ops fc n xs o | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef n (tt_ctxt i) @@ -202,7 +202,7 @@ [o] -> forceable o _ -> [] - dropForce force (x : xs) i | i `elem` force + dropForce force (x : xs) i | i `elem` force = upd Placeholder x : dropForce force xs (i + 1) dropForce force (x : xs) i = x : dropForce force xs (i + 1) dropForce _ [] _ = [] @@ -216,7 +216,7 @@ mkPat fc x = case lookupCtxt x (idris_implicits i) of (pargs : _) - -> PApp fc (PRef fc x) (map (upd Placeholder) pargs) + -> PApp fc (PRef fc x) (map (upd Placeholder) pargs) _ -> error "Can't happen - genAll" upd p' p = p { getTm = p' } @@ -225,7 +225,7 @@ -- and update the context accordingly checkPositive :: Name -> (Name, Type) -> Idris () -checkPositive n (cn, ty) +checkPositive n (cn, ty) = do let p = cp ty i <- getIState let tot = if p then Total (args ty) else Partial NotPositive @@ -245,20 +245,20 @@ posArg t = True calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality -calcProd i fc topn pats +calcProd i fc topn pats = cp topn pats [] where - -- every application of n must be in an argument of a coinductive + -- every application of n must be in an argument of a coinductive -- constructor, in every function reachable from here in the -- call graph. cp n pats done = do patsprod <- mapM (prodRec n done) pats - if (and patsprod) + if (and patsprod) then return Productive else return (Partial NotProductive) prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool prodRec n done _ | n `elem` done = return True - prodRec n done (_, _, tm) = prod n done False tm + prodRec n done (_, _, tm) = prod n done False tm prod :: Name -> [Name] -> Bool -> Term -> Idris Bool prod n done ok ap@(App _ _) @@ -269,26 +269,26 @@ let [ty] = lookupTy f ctxt -- must exist! let co = cotype nt f ty in if (not recOK) then return False else - if f == topn + if f == topn then do argsprod <- mapM (prod n done co) args return (and (ok : argsprod) ) else do argsprod <- mapM (prod n done co) args return (and argsprod) - prod n done ok (App f a) = liftM2 (&&) (prod n done False f) + prod n done ok (App f a) = liftM2 (&&) (prod n done False f) (prod n done False a) - prod n done ok (Bind _ (Let t v) sc) + prod n done ok (Bind _ (Let t v) sc) = liftM2 (&&) (prod n done False v) (prod n done False v) prod n done ok (Bind _ b sc) = prod n done ok sc - prod n done ok t = return True - + prod n done ok t = return True + checkProdRec :: [Name] -> Name -> Idris Bool - checkProdRec done f + checkProdRec done f = case lookupCtxt f (idris_patdefs i) of [(def, _)] -> do ok <- mapM (prodRec f done) def return (and ok) _ -> return True -- defined elsewhere, can't call topn - cotype (DCon _ _) n ty + cotype (DCon _ _) n ty | (P _ t _, _) <- unApply (getRetTy ty) = case lookupCtxt t (idris_datatypes i) of [TI _ True _] -> True @@ -297,26 +297,26 @@ calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality -calcTotality path fc n pats +calcTotality path fc n pats = do i <- getIState let opts = case lookupCtxt n (idris_flags i) of [fs] -> fs _ -> [] case mapMaybe (checkLHS i) (map (\ (_, l, r) -> l) pats) of (failure : _) -> return failure - _ -> if (Coinductive `elem` opts) + _ -> if (Coinductive `elem` opts) then calcProd i fc n pats else checkSizeChange n where - checkLHS i (P _ fn _) + checkLHS i (P _ fn _) = case lookupTotal fn (tt_ctxt i) of - [Partial _] -> return (Partial (Other [fn])) + [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 +checkTotality path fc n | n `elem` path = return (Partial (Mutual (n : path))) | otherwise = do t <- getTotality n @@ -326,10 +326,10 @@ let opts = case lookupCtxt n (idris_flags i) of [fs] -> fs _ -> [] - t' <- case t of - Unchecked -> + t' <- case t of + Unchecked -> case lookupDef n ctxt of - [CaseOp _ _ _ pats _] -> + [CaseOp _ _ _ pats _] -> do t' <- if AssertTotal `elem` opts then return $ Total [] else calcTotality path fc n pats @@ -338,10 +338,10 @@ -- if it's not total, it can't reduce, to keep -- typechecking decidable case t' of - p@(Partial _) -> - do setAccessibility n Frozen + p@(Partial _) -> + do setAccessibility n Frozen addIBC (IBCAccess n Frozen) - logLvl 5 $ "HIDDEN: " + logLvl 5 $ "HIDDEN: " ++ show n ++ show p _ -> return () return t' @@ -353,7 +353,7 @@ e -> do w <- cmdOptType WarnPartial if TotalFn `elem` opts then totalityError t' - else do when (w && not (PartialFn `elem` opts)) $ + else do when (w && not (PartialFn `elem` opts)) $ warnPartial n t' return t' where @@ -363,14 +363,14 @@ = do i <- getIState case lookupDef n (tt_ctxt i) of [x] -> do - iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t + 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) +checkDeclTotality (fc, n) = do logLvl 2 $ "Checking " ++ show n ++ " for totality" -- buildSCG (fc, n) -- logLvl 2 $ "Built SCG" @@ -383,7 +383,7 @@ -- 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 +-- sizechange1 ... sizechange2 is how their size has changed wrt the input -- to f -- Nothing, if the argument is unrelated to the input @@ -392,9 +392,9 @@ ist <- getIState case lookupCtxt n (idris_callgraph ist) of [cg] -> case lookupDef n (tt_ctxt ist) of - [CaseOp _ _ pats _ cd] -> + [CaseOp _ _ pats _ cd] -> let (args, sc) = cases_totcheck cd in - do logLvl 2 $ "Building SCG for " ++ show n ++ " from\n" + do logLvl 2 $ "Building SCG for " ++ show n ++ " from\n" ++ show pats ++ "\n" ++ show sc let newscg = buildSCG' ist (rights pats) args logLvl 5 $ show newscg @@ -411,19 +411,27 @@ | (P _ (UN "lazy") _, [_, arg]) <- unApply ap = findCalls arg pvs pargs | (P _ n _, args) <- unApply ap - = mkChange n args pargs ++ + = mkChange n args pargs ++ concatMap (\x -> findCalls x pvs pargs) args - findCalls (App f a) pvs pargs + findCalls (App f a) pvs pargs = findCalls f pvs pargs ++ findCalls a pvs pargs findCalls (Bind n (Let t v) e) pvs pargs = findCalls v pvs pargs ++ findCalls e (n : pvs) pargs findCalls (Bind n _ e) pvs pargs = findCalls e (n : pvs) pargs - findCalls (P _ f _ ) pvs pargs + findCalls (P _ f _ ) pvs pargs | not (f `elem` pvs) = [(f, [])] findCalls _ _ _ = [] - mkChange n args pargs = [(n, sizes args)] + expandToArity n args + = case lookupTy n (tt_ctxt ist) of + [ty] -> expand 0 (normalise (tt_ctxt ist) [] ty) args + _ -> args + where expand i (Bind n (Pi _) sc) (x : xs) = x : expand (i + 1) sc xs + expand i (Bind n (Pi _) sc) [] = Just (i, Same) : expand (i + 1) sc [] + expand i _ xs = xs + + mkChange n args pargs = [(n, expandToArity n (sizes args))] where sizes [] = [] sizes (a : as) = checkSize a pargs 0 : sizes as @@ -439,16 +447,16 @@ -- not be coinductive - so carry the type of the constructor we've -- gone under. - smaller (Just tyn) a (t, Just tyt) - | a == t = isInductive (fst (unApply (getRetTy tyn))) + smaller (Just tyn) a (t, Just tyt) + | a == t = isInductive (fst (unApply (getRetTy tyn))) (fst (unApply (getRetTy tyt))) smaller ty a (ap@(App f s), _) - | (P (DCon _ _) n _, args) <- unApply ap + | (P (DCon _ _) n _, args) <- unApply ap = let tyn = getType n in - any (smaller (ty `mplus` Just tyn) a) + any (smaller (ty `mplus` Just tyn) a) (zip args (map toJust (getArgTys tyn))) -- check higher order recursive arguments - smaller ty (App f s) a = smaller ty f a + smaller ty (App f s) a = smaller ty f a smaller _ _ _ = False toJust (n, t) = Just t @@ -472,19 +480,19 @@ patvars _ = [] {- -buildSCG' :: IState -> SC -> [Name] -> [SCGEntry] +buildSCG' :: IState -> SC -> [Name] -> [SCGEntry] buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $ - nub $ scg sc (zip args 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 + scg (Case x alts) vars szs = let x' = findTL x vars in concatMap (scgAlt x' vars szs) alts where - findTL x vars + findTL x vars | Just x' <- lookup x vars = if x' `elem` args then x' else findTL x' vars @@ -514,7 +522,7 @@ -- not coinductive) | Just tvar <- lookup x vars = let arel = argRels n - szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel + szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel ++ szs vars' = nub (zip args (repeat tvar) ++ vars) in scg sc vars' szs' @@ -529,7 +537,7 @@ = let rest = concatMap (\x -> scgTerm x vars szs) args in case lookup fn vars of Just _ -> rest - Nothing -> nub $ (fn, map (mkChange szs) args) : rest + Nothing -> nub $ (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 @@ -542,7 +550,7 @@ Nothing -> [(fn, [])] scgTerm _ _ _ = [] - mkChange :: [(Name, (Name, SizeChange))] -> Term + mkChange :: [(Name, (Name, SizeChange))] -> Term -> Maybe (Int, SizeChange) mkChange szs tm | (P _ (UN "lazy") _, [_, arg]) <- unApply tm = mkChange szs arg @@ -567,19 +575,23 @@ [cg] -> do let ms = mkMultiPaths ist [] (scg cg) logLvl 5 ("Multipath for " ++ show n ++ ":\n" ++ "from " ++ show (scg cg) ++ "\n" ++ - show (length ms) ++ "\n" ++ + show (length ms) ++ "\n" ++ showSep "\n" (map show ms)) logLvl 6 (show cg) - -- every multipath must have an infinitely descending + -- every multipath must have an infinitely descending -- thread, then the function terminates - -- also need to checks functions called are all total + -- 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 + let tot = map (checkMP ist (getArity ist n)) ms logLvl 4 $ "Generated " ++ show (length tot) ++ " paths" logLvl 6 $ "Paths for " ++ show n ++ " yield " ++ (show tot) return (noPartial tot) [] -> do logLvl 5 $ "No paths for " ++ show n return Unchecked + where getArity ist n + = case lookupTy n (tt_ctxt ist) of + [ty] -> arity (normalise (tt_ctxt ist) [] ty) + _ -> error "Can't happen: checkSizeChange.getArity" type MultiPath = [SCGEntry] @@ -587,11 +599,11 @@ mkMultiPaths ist path [] = [reverse path] mkMultiPaths ist path cg = concat (map extend cg) - where extend (nextf, args) + where extend (nextf, args) | (nextf, args) `elem` path = [ reverse ((nextf, args) : path) ] - | [Unchecked] <- lookupTotal nextf (tt_ctxt ist) + | [Unchecked] <- lookupTotal nextf (tt_ctxt ist) = case lookupCtxt nextf (idris_callgraph ist) of - [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg) + [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg) _ -> [ reverse ((nextf, args) : path) ] | otherwise = [ reverse ((nextf, args) : path) ] @@ -599,7 +611,7 @@ -- if ((nextf, args) `elem` path) -- then return (reverse ((nextf, args) : path)) -- else case lookupCtxt nextf (idris_callgraph ist) of --- [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg) +-- [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. @@ -608,20 +620,22 @@ -- that means there is an infinitely descending path from that argument. checkMP :: IState -> Int -> MultiPath -> Totality -checkMP ist i mp = if i > 0 - then collapse (map (tryPath 0 [] mp) [0..i-1]) +checkMP ist i mp = if i > 0 + then let paths = (map (tryPath 0 [] mp) [0..i-1]) in +-- trace ("Paths " ++ show paths) $ + collapse paths else tryPath 0 [] mp 0 where - tryPath' d path mp arg + tryPath' d path mp arg = let res = tryPath d path mp arg in trace (show mp ++ "\n" ++ show arg ++ " " ++ show res) res - tryPath :: Int -> [(SCGEntry, Int)] -> MultiPath -> Int -> Totality + tryPath :: Int -> [((SCGEntry, Int), Int)] -> MultiPath -> Int -> Totality tryPath desc path [] _ = Total [] -- tryPath desc path ((UN "believe_me", _) : _) arg -- = Partial BelieveMe -- if we get to a constructor, it's fine as long as it's strictly positive - tryPath desc path ((f, _) :es) arg + tryPath desc path ((f, _) : es) arg | [TyDecl (DCon _ _) _] <- lookupDef f (tt_ctxt ist) = case lookupTotal f (tt_ctxt ist) of [Total _] -> Unchecked -- okay so far @@ -632,57 +646,66 @@ tryPath desc path (e@(f, args) : es) arg | e `elem` es && allNothing args = Partial (Mutual [f]) tryPath desc path (e@(f, nextargs) : es) arg - | Just d <- lookup e path - = if desc > 0 + | Just d <- lookup (e, arg) path + = if desc > 0 then -- trace ("Descent " ++ show (desc - d) ++ " " - -- ++ show (path, e)) $ + -- ++ show (path, e)) $ Total [] - else Partial (Mutual (map (fst . fst) path ++ [f])) + else Partial (Mutual (map (fst . fst . fst) path ++ [f])) + | e `elem` map (fst . fst) path + && not (f `elem` map fst es) + = Partial (Mutual (map (fst . fst . fst) path ++ [f])) | [Unchecked] <- lookupTotal f (tt_ctxt ist) = - let argspos = collapseNothing (zip nextargs [0..]) in - collapse' Unchecked $ + let argspos = case collapseNothing (zip nextargs [0..]) of + [] -> [(Nothing, 0)] + x -> x +-- trace (show (argspos, nextargs, path)) $ + pathres = do (a, pos) <- argspos case a of Nothing -> -- don't know, but if the -- rest definitely terminates without -- any cycles with route so far, -- then we might yet be total - case collapse (map (tryPath (-10000) ((e, 0):path) es) + case collapse (map (tryPath 0 (((e, arg), 0):path) es) [0..length nextargs - 1]) of Total _ -> return Unchecked x -> return x Just (nextarg, sc) -> if nextarg == arg then case sc of - Same -> return $ tryPath desc ((e, desc) : path) + Same -> return $ tryPath desc (((e, arg), desc) : path) es pos - Smaller -> return $ tryPath (desc+1) - ((e, desc):path) + Smaller -> return $ tryPath (desc+1) + (((e, arg), desc) : path) es pos - _ -> trace ("Shouldn't happen " ++ show e) $ + _ -> trace ("Shouldn't happen " ++ show e) $ return (Partial Itself) - else return Unchecked + else return Unchecked in +-- trace (show (desc, argspos, path, es, pathres)) $ + collapse' Unchecked pathres + | [Total a] <- lookupTotal f (tt_ctxt ist) = Total a | [Partial _] <- lookupTotal f (tt_ctxt ist) = Partial (Other [f]) | otherwise = Unchecked allNothing xs = null (collapseNothing (zip xs [0..])) -collapseNothing ((Nothing, _) : xs) +collapseNothing ((Nothing, _) : xs) = filter (\ (x, _) -> case x of - Nothing -> False - _ -> True) xs + Nothing -> False + _ -> True) xs collapseNothing (x : xs) = x : collapseNothing xs collapseNothing [] = [] noPartial (Partial p : xs) = Partial p noPartial (_ : xs) = noPartial xs -noPartial [] = Total [] +noPartial [] = Total [] collapse xs = collapse' Unchecked xs collapse' def (Total r : xs) = Total r -collapse' def (Unchecked : xs) = collapse' def xs +collapse' def (Unchecked : xs) = collapse' def xs collapse' def (d : xs) = collapse' d xs -- collapse' Unchecked [] = Total [] collapse' def [] = def diff --git a/src/Idris/DSL.hs b/src/Idris/DSL.hs --- a/src/Idris/DSL.hs +++ b/src/Idris/DSL.hs @@ -5,35 +5,40 @@ import Idris.AbsSyntax import Paths_idris -import Core.CoreParser import Core.TT import Core.Evaluate +import Control.Monad.State import Debug.Trace +debindApp :: SyntaxInfo -> PTerm -> PTerm +debindApp syn t = debind (dsl_bind (dsl_info syn)) t + desugar :: SyntaxInfo -> IState -> PTerm -> PTerm desugar syn i t = let t' = expandDo (dsl_info syn) t in t' -- addImpl i t' expandDo :: DSL -> PTerm -> PTerm expandDo dsl (PLam n ty tm) - | Just lam <- dsl_lambda dsl - = let sc = PApp (FC "(dsl)" 0) lam [pexp (var dsl n tm 0)] in + | Just lam <- dsl_lambda dsl + = let sc = PApp (fileFC "(dsl)") lam [pexp (var dsl n tm 0)] in expandDo dsl sc expandDo dsl (PLam n ty tm) = PLam n (expandDo dsl ty) (expandDo dsl tm) expandDo dsl (PLet n ty v tm) | Just letb <- dsl_let dsl - = let sc = PApp (FC "(dsl)" 0) letb [pexp v, pexp (var dsl n tm 0)] in + = let sc = PApp (fileFC "(dsl)") letb [pexp v, pexp (var dsl n tm 0)] in expandDo dsl sc expandDo dsl (PLet n ty v tm) = PLet n (expandDo dsl ty) (expandDo dsl v) (expandDo dsl tm) expandDo dsl (PPi p n ty tm) = PPi p n (expandDo dsl ty) (expandDo dsl tm) expandDo dsl (PApp fc t args) = PApp fc (expandDo dsl t) (map (fmap (expandDo dsl)) args) +expandDo dsl (PAppBind fc t args) = PAppBind fc (expandDo dsl t) + (map (fmap (expandDo dsl)) args) expandDo dsl (PCase fc s opts) = PCase fc (expandDo dsl s) (map (pmap (expandDo dsl)) opts) expandDo dsl (PEq fc l r) = PEq fc (expandDo dsl l) (expandDo dsl r) expandDo dsl (PPair fc l r) = PPair fc (expandDo dsl l) (expandDo dsl r) -expandDo dsl (PDPair fc l t r) = PDPair fc (expandDo dsl l) (expandDo dsl t) +expandDo dsl (PDPair fc l t r) = PDPair fc (expandDo dsl l) (expandDo dsl t) (expandDo dsl r) expandDo dsl (PAlternative a as) = PAlternative a (map (expandDo dsl) as) expandDo dsl (PHidden t) = PHidden (expandDo dsl t) @@ -44,14 +49,15 @@ = PRewrite fc r (expandDo dsl t) ty expandDo dsl (PGoal fc r n sc) = PGoal fc (expandDo dsl r) n (expandDo dsl sc) -expandDo dsl (PDoBlock ds) = expandDo dsl $ block (dsl_bind dsl) ds +expandDo dsl (PDoBlock ds) + = expandDo dsl $ debind (dsl_bind dsl) (block (dsl_bind dsl) ds) where - block b [DoExp fc tm] = tm + block b [DoExp fc tm] = tm block b [a] = PElabError (Msg "Last statement in do block must be an expression") block b (DoBind fc n tm : rest) = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))] block b (DoBindP fc p tm : rest) - = PApp fc b [pexp tm, pexp (PLam (MN 0 "bpat") Placeholder + = PApp fc b [pexp tm, pexp (PLam (MN 0 "bpat") Placeholder (PCase fc (PRef fc (MN 0 "bpat")) [(p, block b rest)]))] block b (DoLet fc n ty tm : rest) @@ -59,8 +65,8 @@ block b (DoLetP fc p tm : rest) = PCase fc tm [(p, block b rest)] block b (DoExp fc tm : rest) - = PApp fc b - [pexp tm, + = PApp fc b + [pexp tm, pexp (PLam (MN 0 "bindx") Placeholder (block b rest))] block b _ = PElabError (Msg "Invalid statement in do block") @@ -69,7 +75,7 @@ var :: DSL -> Name -> PTerm -> Int -> PTerm var dsl n t i = v' i t where - v' i (PRef fc x) | x == n = + v' i (PRef fc x) | x == n = case dsl_var dsl of Nothing -> PElabError (Msg "No 'variable' defined in dsl") Just v -> PApp fc v [pexp (mkVar fc i)] @@ -100,7 +106,7 @@ Just f -> f mkVar fc n = case index_next dsl of Nothing -> PElabError (Msg "No index_next defined") - Just f -> PApp fc f [pexp (mkVar fc (n-1))] + Just f -> PApp fc f [pexp (mkVar fc (n-1))] unIdiom :: PTerm -> PTerm -> FC -> PTerm -> PTerm unIdiom ap pure fc e@(PApp _ _ _) = let f = getFn e in @@ -113,4 +119,49 @@ mkap (f, a:as) = mkap (PApp fc ap [pexp f, a], as) unIdiom ap pure fc e = PApp fc pure [pexp e] + +debind :: PTerm -> PTerm -> PTerm +-- For every arg which is an AppBind, lift it out +debind b tm = let (tm', (bs, _)) = runState (db' tm) ([], 0) in + bindAll (reverse bs) tm' + where + db' :: PTerm -> State ([(Name, FC, PTerm)], Int) PTerm + db' (PAppBind _ (PApp fc t args) []) + = db' (PAppBind fc t args) + db' (PAppBind fc t args) + = do args' <- dbs args + (bs, n) <- get + let nm = MN n ("bindApp" ++ show n) + put ((nm, fc, PApp fc t args') : bs, n+1) + return (PRef fc nm) + db' (PApp fc t args) + = do t' <- db' t + args' <- mapM dbArg args + return (PApp fc t' args') + db' (PLam n ty sc) = return (PLam n ty (debind b sc)) + db' (PLet n ty v sc) = do v' <- db' v + return (PLet n ty v' (debind b sc)) + db' (PCase fc s opts) = do s' <- db' s + return (PCase fc s' (map (pmap (debind b)) opts)) + db' (PPair fc l r) = do l' <- db' l + r' <- db' r + return (PPair fc l' r') + db' (PDPair fc l t r) = do l' <- db' l + r' <- db' r + return (PDPair fc l' t r') + db' t = return t + + dbArg a = do t' <- db' (getTm a) + return (a { getTm = t' }) + + dbs [] = return [] + dbs (a : as) = do let t = getTm a + t' <- db' t + as' <- dbs as + return (a { getTm = t' } : as') + + bindAll [] tm = tm + bindAll ((n, fc, t) : bs) tm + = PApp fc b [pexp t, pexp (PLam n Placeholder (bindAll bs tm))] + diff --git a/src/Idris/DataOpts.hs b/src/Idris/DataOpts.hs --- a/src/Idris/DataOpts.hs +++ b/src/Idris/DataOpts.hs @@ -28,11 +28,11 @@ where force :: IState -> Int -> Term -> [Int] force ist i (Bind _ (Pi ty) sc) - | collapsibleIn ist ty + | 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 + force _ _ sc@(App f a) + | (_, args) <- unApply sc = nub $ concatMap guarded args force _ _ _ = [] @@ -57,7 +57,7 @@ -- Calculate whether a collection of constructors is collapsible collapseCons :: Name -> [(Name, Type)] -> Idris () -collapseCons ty cons = +collapseCons ty cons = do i <- getIState let cons' = map (\ (n, t) -> (n, map snd (getArgTys t))) cons allFR <- mapM (forceRec i) cons' @@ -75,7 +75,7 @@ putIState (i { idris_optimisation = opts }) else return () _ -> return () - + checkNewType _ = return () setCollapsible :: Name -> Idris () @@ -101,12 +101,12 @@ checkFR fs i (t : xs) -- must be recursive or type is not collapsible = do let (rtf, rta) = unApply $ getRetTy t - if (ty `elem` freeNames rtf) + if (ty `elem` freeNames rtf) then checkFR fs (i+1) xs else return False detaggable :: [Type] -> Idris () - detaggable rtys + 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 @@ -204,7 +204,7 @@ applyDataOpt :: OptInfo -> Name -> [Raw] -> Raw applyDataOpt oi n args - = let args' = zipWith doForce (map (\x -> x `elem` (forceable oi)) [0..]) + = let args' = zipWith doForce (map (\x -> x `elem` (forceable oi)) [0..]) args in raw_apply (Var n) args' where @@ -221,9 +221,9 @@ applyOpts (App (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _) x) = applyOpts x applyOpts (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _) - = return (App (P Ref (NS (UN "id") ["Builtins"]) Erased) Erased) + = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased) applyOpts (P _ (NS (UN "toIntegerNat") ["Nat","Prelude"]) _) - = return (App (P Ref (NS (UN "id") ["Builtins"]) Erased) Erased) + = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased) applyOpts c@(P (DCon t arity) n _) = do i <- getIState case lookupCtxt n (idris_optimisation i) of @@ -248,6 +248,9 @@ stripCollapsed (Bind n (PVar x) t) | (P _ ty _, _) <- unApply x = do i <- getIState + -- NOTE: This assumes that 'ty' is in normal form, which it + -- has to be before now because we're not keeping track of + -- an environment so we can't do it here. case lookupCtxt ty (idris_optimisation i) of [oi] -> if collapsible oi then do t' <- stripCollapsed t @@ -267,7 +270,7 @@ applyDataOptRT oi n tag arity args | length args == arity = doOpts n args (collapsible oi) (forceable oi) | otherwise = let extra = satArgs (arity - length args) - tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra) + tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra) (collapsible oi) (forceable oi) in bind extra tm where @@ -279,7 +282,7 @@ -- Nat special cases -- TODO: Would be nice if this was configurable in idris source! doOpts (NS (UN "Z") ["Nat", "Prelude"]) [] _ _ = Constant (BI 0) - doOpts (NS (UN "S") ["Nat", "Prelude"]) [k] _ _ + doOpts (NS (UN "S") ["Nat", "Prelude"]) [k] _ _ = App (App (P Ref (UN "prim__addBigInt") Erased) k) (Constant (BI 1)) doOpts n args True f = Erased @@ -290,8 +293,8 @@ then case args' of [(_, val)] -> val _ -> error "Can't happen (not isnewtype)" - else - mkApp (P (DCon tag (arity - length forced)) n Erased) + else + mkApp (P (DCon tag (arity - length forced)) n Erased) (map snd args') keep (forced, _) = not forced diff --git a/src/Idris/DeepSeq.hs b/src/Idris/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/src/Idris/DeepSeq.hs @@ -0,0 +1,365 @@ +module Idris.DeepSeq where + +import Core.TT +import Idris.AbsSyntax + +import Control.DeepSeq + +-- All generated by 'derive' + +instance NFData Raw where + rnf (Var x1) = rnf x1 `seq` () + rnf (RBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf RType = () + rnf (RForce x1) = rnf x1 `seq` () + rnf (RConstant x1) = x1 `seq` () + +instance NFData FC where + rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + +instance NFData Name where + rnf (UN x1) = rnf x1 `seq` () + rnf (NS x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf NErased = () + rnf (SN x1) = rnf x1 `seq` () + +instance NFData SpecialName where + rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (MethodN x1) = rnf x1 `seq` () + rnf (CaseN x1) = rnf x1 `seq` () + +instance NFData IntTy where + rnf (ITFixed x1) = rnf x1 `seq` () + rnf ITNative = () + rnf ITBig = () + rnf ITChar = () + rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` () + + +instance NFData NativeTy where + rnf IT8 = () + rnf IT16 = () + rnf IT32 = () + rnf IT64 = () + + +instance NFData ArithTy where + rnf (ATInt x1) = rnf x1 `seq` () + rnf ATFloat = () + +instance NFData Err where + rnf (Msg x1) = rnf x1 `seq` () + rnf (InternalMsg x1) = rnf x1 `seq` () + rnf (CantUnify x1 x2 x3 x4 x5 x6) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () + rnf (InfiniteUnify x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (CantConvert x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (UnifyScope x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (CantInferType x1) = rnf x1 `seq` () + rnf (NonFunctionType x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (CantIntroduce x1) = rnf x1 `seq` () + rnf (NoSuchVariable x1) = rnf x1 `seq` () + rnf (NoTypeDecl x1) = rnf x1 `seq` () + rnf (NotInjective x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (CantResolve x1) = rnf x1 `seq` () + rnf (CantResolveAlts x1) = rnf x1 `seq` () + rnf (IncompleteTerm x1) = rnf x1 `seq` () + rnf UniverseError = () + rnf ProgramLineComment = () + rnf (Inaccessible x1) = rnf x1 `seq` () + rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` () + rnf (AlreadyDefined x1) = rnf x1 `seq` () + rnf (ProofSearchFail x1) = rnf x1 `seq` () + rnf (NoRewriting x1) = rnf x1 `seq` () + rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (Elaborating x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (ProviderError x1) = rnf x1 `seq` () + rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` () + +instance (NFData b) => NFData (Binder b) where + rnf (Lam x1) = rnf x1 `seq` () + rnf (Pi x1) = rnf x1 `seq` () + rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (Hole x1) = rnf x1 `seq` () + rnf (GHole x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (Guess x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PVar x1) = rnf x1 `seq` () + rnf (PVTy x1) = rnf x1 `seq` () + +instance NFData UExp where + rnf (UVar x1) = rnf x1 `seq` () + rnf (UVal x1) = rnf x1 `seq` () + +instance NFData NameType where + rnf Bound = () + rnf Ref = () + rnf (DCon x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` () + +instance (NFData n) => NFData (TT n) where + rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (V x1) = rnf x1 `seq` () + rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (Constant x1) = x1 `seq` () + rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf Erased = () + rnf Impossible = () + rnf (TType x1) = rnf x1 `seq` () + +instance NFData SizeChange where + rnf Smaller = () + rnf Same = () + rnf Bigger = () + rnf Unknown = () + +instance NFData CGInfo where + rnf (CGInfo x1 x2 x3 x4 x5) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` () + +instance NFData Fixity where + rnf (Infixl x1) = rnf x1 `seq` () + rnf (Infixr x1) = rnf x1 `seq` () + rnf (InfixN x1) = rnf x1 `seq` () + rnf (PrefixN x1) = rnf x1 `seq` () + +instance NFData FixDecl where + rnf (Fix x1 x2) = rnf x1 `seq` rnf x2 `seq` () + +instance NFData Static where + rnf Static = () + rnf Dynamic = () + +instance NFData Plicity where + rnf (Imp x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (Exp x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (Constraint x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (TacImp x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + +instance NFData FnOpt where + rnf Inlinable = () + rnf TotalFn = () + rnf PartialFn = () + rnf Coinductive = () + rnf AssertTotal = () + rnf Dictionary = () + rnf Implicit = () + rnf (CExport x1) = rnf x1 `seq` () + rnf Reflection = () + rnf (Specialise x1) = rnf x1 `seq` () + +instance (NFData t) => NFData (PDecl' t) where + rnf (PFix x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PTy x1 x2 x3 x4 x5 x6) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () + rnf (PPostulate x1 x2 x3 x4 x5 x6) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () + rnf (PClauses x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (PCAF x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PData x1 x2 x3 x4 x5) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` () + rnf (PParams x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PNamespace x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PRecord x1 x2 x3 x4 x5 x6 x7 x8) + = rnf x1 `seq` + rnf x2 `seq` + rnf x3 `seq` + rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` () + rnf (PClass x1 x2 x3 x4 x5 x6 x7) + = rnf x1 `seq` + rnf x2 `seq` + rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` () + rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8) + = rnf x1 `seq` + rnf x2 `seq` + rnf x3 `seq` + rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` () + rnf (PDSL x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PDirective x1) = () + rnf (PProvider x1 x2 x3 x4 x5) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` () + rnf (PTransform x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + +instance (NFData t) => NFData (PClause' t) where + rnf (PClause x1 x2 x3 x4 x5 x6) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () + rnf (PWith x1 x2 x3 x4 x5 x6) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () + rnf (PClauseR x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (PWithR x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + +instance (NFData t) => NFData (PData' t) where + rnf (PDatadecl x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PLaterdecl x1 x2) = rnf x1 `seq` rnf x2 `seq` () + +instance NFData PTerm where + rnf (PQuote x1) = rnf x1 `seq` () + rnf (PRef x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PInferRef x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PPatvar x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PLam x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PPi x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (PLet x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (PTyped x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PApp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PAppBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PMatchApp x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PCase x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PTrue x1) = rnf x1 `seq` () + rnf (PFalse x1) = rnf x1 `seq` () + rnf (PRefl x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PResolveTC x1) = rnf x1 `seq` () + rnf (PEq x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PRewrite x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (PPair x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PDPair x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (PAlternative x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PHidden x1) = rnf x1 `seq` () + rnf PType = () + rnf (PGoal x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (PConstant x1) = x1 `seq` () + rnf Placeholder = () + rnf (PDoBlock x1) = rnf x1 `seq` () + rnf (PIdiom x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PReturn x1) = rnf x1 `seq` () + rnf (PMetavar x1) = rnf x1 `seq` () + rnf (PProof x1) = rnf x1 `seq` () + rnf (PTactics x1) = rnf x1 `seq` () + rnf (PElabError x1) = rnf x1 `seq` () + rnf PImpossible = () + rnf (PCoerced x1) = rnf x1 `seq` () + rnf (PUnifyLog x1) = rnf x1 `seq` () + rnf (PNoImplicits x1) = rnf x1 `seq` () + +instance (NFData t) => NFData (PTactic' t) where + rnf (Intro x1) = rnf x1 `seq` () + rnf Intros = () + rnf (Focus x1) = rnf x1 `seq` () + rnf (Refine x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (Rewrite x1) = rnf x1 `seq` () + rnf (Equiv x1) = rnf x1 `seq` () + rnf (MatchRefine x1) = rnf x1 `seq` () + rnf (LetTac x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (LetTacTy x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (Exact x1) = rnf x1 `seq` () + rnf Compute = () + rnf Trivial = () + rnf (ProofSearch x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf Solve = () + rnf Attack = () + rnf ProofState = () + rnf ProofTerm = () + rnf Undo = () + rnf (Try x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (TSeq x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (ApplyTactic x1) = rnf x1 `seq` () + rnf (Reflect x1) = rnf x1 `seq` () + rnf (Fill x1) = rnf x1 `seq` () + rnf (GoalType x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf Qed = () + rnf Abandon = () + +instance (NFData t) => NFData (PDo' t) where + rnf (DoExp x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (DoBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (DoBindP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (DoLet x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + +instance (NFData t) => NFData (PArg' t) where + rnf (PImp x1 x2 x3 x4 x5 x6) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () + rnf (PExp x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (PConstraint x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (PTacImplicit x1 x2 x3 x4 x5 x6) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () + +instance NFData ClassInfo where + rnf (CI x1 x2 x3 x4 x5) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` () + +instance NFData OptInfo where + rnf (Optimise x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + +instance NFData TypeInfo where + rnf (TI x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + +instance (NFData t) => NFData (DSL' t) where + rnf (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9) + = rnf x1 `seq` + rnf x2 `seq` + rnf x3 `seq` + rnf x4 `seq` + rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` () + +instance NFData SynContext where + rnf PatternSyntax = () + rnf TermSyntax = () + rnf AnySyntax = () + +instance NFData Syntax where + rnf (Rule x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + +instance NFData SSymbol where + rnf (Keyword x1) = rnf x1 `seq` () + rnf (Symbol x1) = rnf x1 `seq` () + rnf (Binding x1) = rnf x1 `seq` () + rnf (Expr x1) = rnf x1 `seq` () + rnf (SimpleExpr x1) = rnf x1 `seq` () + +instance NFData Using where + rnf (UImplicit x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (UConstraint x1 x2) = rnf x1 `seq` rnf x2 `seq` () + + +instance NFData SyntaxInfo where + rnf (Syn x1 x2 x3 x4 x5 x6 x7 x8) + = rnf x1 `seq` + rnf x2 `seq` + rnf x3 `seq` + rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` () + + + diff --git a/src/Idris/Delaborate.hs b/src/Idris/Delaborate.hs --- a/src/Idris/Delaborate.hs +++ b/src/Idris/Delaborate.hs @@ -17,7 +17,7 @@ delab i tm = delab' i tm False delabTy :: IState -> Name -> PTerm -delabTy i n +delabTy i n = case lookupTy n (tt_ctxt i) of (ty:_) -> case lookupCtxt n (idris_implicits i) of (imps:_) -> delabTy' i imps ty False @@ -30,7 +30,7 @@ -> Term -> Bool -> PTerm delabTy' ist imps tm fullname = de [] imps tm where - un = FC "(val)" 0 + un = fileFC "(val)" de env _ (App f a) = deFn env f [a] de env _ (V i) | i < length env = PRef un (snd (env!!i)) @@ -39,18 +39,21 @@ | n == unitCon = PTrue un | n == falseTy = PFalse un | Just n' <- lookup n env = PRef un n' - | otherwise = PRef un (dens n) - de env _ (Bind n (Lam ty) sc) + | otherwise + = case lookup n (idris_metavars ist) of + Just (Just _, mi, _) -> mkMVApp (dens n) [] + _ -> PRef un (dens n) + de env _ (Bind n (Lam ty) sc) = PLam n (de env [] ty) (de ((n,n):env) [] sc) - de env (PImp _ _ _ _ _ _:is) (Bind n (Pi ty) sc) + de env (PImp _ _ _ _ _ _:is) (Bind n (Pi ty) sc) = PPi impl n (de env [] ty) (de ((n,n):env) is sc) - de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc) + de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc) = PPi constraint n (de env [] ty) (de ((n,n):env) is sc) - de env (PTacImplicit _ _ _ tac _ _:is) (Bind n (Pi ty) sc) + de env (PTacImplicit _ _ _ tac _ _:is) (Bind n (Pi ty) sc) = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc) - de env _ (Bind n (Pi ty) sc) + de env _ (Bind n (Pi ty) sc) = PPi expl n (de env [] ty) (de ((n,n):env) [] sc) - de env _ (Bind n (Let ty val) sc) + de env _ (Bind n (Let ty val) sc) = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc) de env _ (Bind n (Hole ty) sc) = de ((n, UN "[__]"):env) [] sc de env _ (Bind n (Guess ty val) sc) = de ((n, UN "[__]"):env) [] sc @@ -58,32 +61,41 @@ de env _ (Constant i) = PConstant i de env _ Erased = Placeholder de env _ Impossible = Placeholder - de env _ (TType i) = PType + de env _ (TType i) = PType dens x | fullname = x dens ns@(NS n _) = case lookupCtxt n (idris_implicits ist) of [_] -> n -- just one thing + [] -> n -- metavariables have no implicits _ -> ns dens n = n deFn env (App f a) args = deFn env f (a:args) - deFn env (P _ n _) [l,r] + deFn env (P _ n _) [l,r] | n == pairTy = PPair un (de env [] l) (de env [] r) | 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" + | n == UN "Exists" = PDPair un (PRef un x) (de env [] ty) (de ((x,x):env) [] (instantiate (P Bound x ty) r)) - deFn env (P _ n _) [_,_,l,r] + deFn env (P _ n _) [_,_,l,r] | n == pairCon = PPair un (de env [] l) (de env [] r) | n == eqTy = PEq un (de env [] l) (de env [] r) | n == UN "Ex_intro" = PDPair un (de env [] l) Placeholder (de env [] r) - deFn env (P _ n _) args = mkPApp (dens n) (map (de env []) args) + deFn env (P _ n _) args + = case lookup n (idris_metavars ist) of + Just (Just _, mi, _) -> + mkMVApp (dens n) (drop mi (map (de env []) args)) + _ -> mkPApp (dens n) (map (de env []) args) deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args)) - mkPApp n args + mkMVApp n [] + = PMetavar n + mkMVApp n args + = PApp un (PMetavar n) (map pexp args) + mkPApp n args | [imps] <- lookupCtxt n (idris_implicits ist) = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args) | otherwise = PApp un (PRef un n) (map pexp args) @@ -101,7 +113,7 @@ pshow :: IState -> Err -> String pshow i (Msg s) = s -pshow i (InternalMsg s) = "INTERNAL ERROR: " ++ show s ++ +pshow i (InternalMsg s) = "INTERNAL ERROR: " ++ show s ++ "\nThis is probably a bug, or a missing error message.\n" ++ "Please consider reporting at " ++ bugaddr pshow i (CantUnify _ x y e sc s) @@ -140,11 +152,11 @@ let colour = idris_colourRepl i in "Can't use lambda here: type is " ++ showImp (Just i) imps colour (delab i ty) pshow i (InfiniteUnify x tm env) - = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++ + = "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 " ++ + " when unifying " ++ show (delab i x) ++ " and " ++ show (delab i y) pshow i (CantResolve c) = "Can't resolve type class " ++ show (delab i c) pshow i (CantResolveAlts as) = "Can't disambiguate name: " ++ showSep ", " as @@ -154,15 +166,16 @@ 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 (NonCollapsiblePostulate n) +pshow i (NonCollapsiblePostulate n) = "The return type of postulate " ++ show n ++ " is not collapsible" pshow i (AlreadyDefined n) = show n ++ " is already defined" pshow i (ProofSearchFail e) = pshow i e pshow i (NoRewriting tm) = "rewrite did not change type " ++ show (delab i tm) pshow i (At f e) = show f ++ ":" ++ pshow i e -pshow i (Elaborating s n e) = "When elaborating " ++ s ++ +pshow i (Elaborating s n e) = "When elaborating " ++ s ++ showqual i n ++ ":\n" ++ pshow i e pshow i (ProviderError msg) = "Type provider error: " ++ msg +pshow i (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: " ++ pshow i e showSc i [] = "" showSc i xs = "\n\nIn context:\n" ++ showSep "\n" (map showVar (reverse xs)) diff --git a/src/Idris/Docs.hs b/src/Idris/Docs.hs --- a/src/Idris/Docs.hs +++ b/src/Idris/Docs.hs @@ -11,7 +11,7 @@ -- TODO: Only include names with public/abstract accessibility -data FunDoc = Doc Name String +data FunDoc = Doc Name String [(Name, PArg)] -- args PTerm -- function type (Maybe Fixity) @@ -23,7 +23,7 @@ [FunDoc] -- method docs showDoc "" = "" -showDoc x = " -- " ++ x +showDoc x = " -- " ++ x instance Show FunDoc where show (Doc n doc args ty f) @@ -35,7 +35,7 @@ else "" where showArg (n, arg@(PExp _ _ _ _)) - = Just $ showName n ++ show (getTm arg) ++ + = Just $ showName n ++ show (getTm arg) ++ showDoc (pargdoc arg) ++ "\n" showArg (n, arg@(PConstraint _ _ _ _)) = Just $ "Class constraint " ++ @@ -44,7 +44,7 @@ showArg (n, arg@(PImp _ _ _ _ _ doc)) | not (null doc) = Just $ "(implicit) " ++ - show n ++ " : " ++ show (getTm arg) + show n ++ " : " ++ show (getTm arg) ++ showDoc (pargdoc arg) ++ "\n" showArg (n, _) = Nothing @@ -57,13 +57,13 @@ show (DataDoc t args) = "Data type " ++ show t ++ "\nConstructors:\n\n" ++ showSep "\n" (map show args) - show (ClassDoc n doc meths) + show (ClassDoc n doc meths) = "Type class " ++ show n ++ -- parameters? "\nMethods:\n\n" ++ showSep "\n" (map show meths) getDocs :: Name -> Idris Doc -getDocs n +getDocs n = do i <- getIState case lookupCtxt n (idris_classes i) of [ci] -> docClass n ci @@ -73,7 +73,7 @@ return (FunDoc fd) docData :: Name -> TypeInfo -> Idris Doc -docData n ti +docData n ti = do tdoc <- docFun n cdocs <- mapM docFun (con_names ti) return (DataDoc tdoc cdocs) @@ -103,7 +103,7 @@ let fixdecls = filter (\(Fix _ x) -> x == funName n) infixes let f = case fixdecls of [] -> Nothing - (Fix x _:_) -> Just x + (Fix x _:_) -> Just x return (Doc n docstr args (delab i ty) f) where funName :: Name -> String diff --git a/src/Idris/ElabDecls.hs b/src/Idris/ElabDecls.hs --- a/src/Idris/ElabDecls.hs +++ b/src/Idris/ElabDecls.hs @@ -15,6 +15,7 @@ import Idris.Primitives import Idris.Inliner import Idris.PartialEval +import Idris.DeepSeq import IRTS.Lang import Paths_idris @@ -25,15 +26,16 @@ import Core.Typecheck import Core.CaseTree +import Control.DeepSeq import Control.Monad import Control.Monad.State import Data.List import Data.Maybe import Debug.Trace -recheckC fc env t +recheckC fc env t = do -- t' <- applyOpts (forget t) (doesn't work, or speed things up...) - ctxt <- getContext + ctxt <- getContext (tm, ty, cs) <- tclift $ case recheck ctxt env (forget t) t of Error e -> tfail (At fc e) OK x -> return x @@ -41,28 +43,36 @@ return (tm, ty) checkDef fc ns = do ctxt <- getContext - mapM (\(n, t) -> do (t', _) <- recheckC fc [] t - return (n, t')) ns + mapM (\(n, (i, top, t)) -> do (t', _) <- recheckC fc [] t + return (n, (i, top, t'))) ns -- | Elaborate a top-level type declaration - for example, "foo : Int -> Int". elabType :: ElabInfo -> SyntaxInfo -> String -> - FC -> FnOpts -> Name -> PTerm -> Idris () -elabType info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in - n = liftname info n_in in -} + FC -> FnOpts -> Name -> PTerm -> Idris Type +elabType = elabType' False + +elabType' :: Bool -> -- normalise it + ElabInfo -> SyntaxInfo -> String -> + FC -> FnOpts -> Name -> PTerm -> Idris Type +elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in + n = liftname info n_in in -} do checkUndefined fc n ctxt <- getContext i <- getIState + logLvl 3 $ show n ++ " pre-type " ++ showImp Nothing True False ty' ty' <- addUsingConstraints syn fc ty' ty' <- implicit syn n ty' + let ty = addImpl i ty' logLvl 2 $ show n ++ " type " ++ showImp Nothing True False ty - ((tyT, defer, is), log) <- + ((tyT, defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] (errAt "type of " n (erun fc (build i info False n ty))) ds <- checkDef fc defer - addDeferred ds - mapM_ (elabCaseBlock info opts) is + let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds + addDeferred ds' + mapM_ (elabCaseBlock info opts) is ctxt <- getContext logLvl 5 $ "Rechecking" logLvl 6 $ show tyT @@ -73,6 +83,11 @@ let nty = cty -- normalise ctxt [] cty -- if the return type is something coinductive, freeze the definition let nty' = normalise ctxt [] nty + + -- Add normalised type to internals + addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')) + addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))) + let (t, _) = unApply (getRetTy nty') let corec = case t of P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of @@ -80,9 +95,11 @@ _ -> False _ -> False let opts' = if corec then (Coinductive : opts) else opts - ds <- checkDef fc [(n, nty)] + let usety = if norm then nty' else nty + ds <- checkDef fc [(n, (-1, Nothing, usety))] addIBC (IBCDef n) - addDeferred ds + let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds + addDeferred ds' setFlags n opts' addDocStr n doc addIBC (IBCDoc n) @@ -91,7 +108,17 @@ addIBC (IBCCoercion n) when corec $ do setAccessibility n Frozen addIBC (IBCAccess n Frozen) + return usety + where + -- for making an internalapp, we only want the explicit ones, and don't + -- want the parameters, so just take the arguments which correspond to the + -- user declared explicit ones + mergeTy (PPi e n ty sc) (PPi e' _ _ sc') + | e == e' = PPi e n ty (mergeTy sc sc') + | otherwise = mergeTy sc sc' + mergeTy _ sc = sc + elabPostulate :: ElabInfo -> SyntaxInfo -> String -> FC -> FnOpts -> Name -> PTerm -> Idris () elabPostulate info syn doc fc opts n ty @@ -127,7 +154,8 @@ ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] (erun fc (build i info False n t)) def' <- checkDef fc defer - addDeferredTyCon def' + let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def' + addDeferredTyCon def'' mapM_ (elabCaseBlock info []) is (cty, _) <- recheckC fc [] t' logLvl 2 $ "---> " ++ show cty @@ -140,20 +168,21 @@ i <- getIState t_in <- implicit syn n t_in let t = addImpl i t_in - ((t', defer, is), log) <- + ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] (errAt "data declaration " n (erun fc (build i info False n t))) def' <- checkDef fc defer - addDeferredTyCon def' + let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def' + addDeferredTyCon def'' mapM_ (elabCaseBlock info []) is (cty, _) <- recheckC fc [] t' logLvl 2 $ "---> " ++ show cty -- temporary, to check cons - when undef $ updateContext (addTyDecl n (TCon 0 0) cty) + when undef $ updateContext (addTyDecl n (TCon 0 0) cty) cons <- mapM (elabCon info syn n codata) dcons ttag <- getName i <- getIState - let as = map (const Nothing) (getArgTys cty) + let as = map (const Nothing) (getArgTys cty) let params = findParams (map snd cons) logLvl 2 $ "Parameters : " ++ show params putIState (i { idris_datatypes = addDef n (TI (map fst cons) codata params) @@ -165,7 +194,7 @@ collapseCons n cons updateContext (addDatatype (Data n ttag cty cons)) mapM_ (checkPositive n) cons - where + where -- parameters are names which are unchanged across the structure, -- which appear exactly once in the return type of a constructor @@ -177,14 +206,14 @@ paramPos allapps paramPos [] = [] - paramPos (args : rest) + paramPos (args : rest) = dropNothing $ keepSame (zip [0..] args) rest dropNothing [] = [] dropNothing ((x, Nothing) : ts) = dropNothing ts dropNothing ((x, _) : ts) = x : dropNothing ts - keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] -> + keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] -> [(Int, Maybe Name)] keepSame as [] = as keepSame as (args : rest) = keepSame (update as args) rest @@ -204,14 +233,14 @@ getDataApp _ = [] -- keep the arguments which are single names, which don't appear - -- elsewhere + -- elsewhere mParam args [] = [] mParam args (P Bound n _ : rest) - | count n args == 1 + | count n args == 1 = Just n : mParam args rest where count n [] = 0 - count n (t : ts) + count n (t : ts) | n `elem` freeNames t = 1 + count n ts | otherwise = count n ts mParam args (_ : rest) = Nothing : mParam args rest @@ -220,7 +249,7 @@ elabPrims :: Idris () elabPrims = do mapM_ (elabDecl EAll toplevel) - (map (PData "" defaultSyntax (FC "builtin" 0) False) + (map (PData "" defaultSyntax (fileFC "builtin") False) [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]) mapM_ elabPrim primitives -- Special case prim__believe_me because it doesn't work on just constants @@ -246,7 +275,7 @@ believeTy = Bind (UN "a") (Pi (TType (UVar (-2)))) (Bind (UN "b") (Pi (TType (UVar (-2)))) (Bind (UN "x") (Pi (V 1)) (V 1))) - elabBelieveMe + elabBelieveMe = do let prim__believe_me = (UN "prim__believe_me") updateContext (addOperator prim__believe_me believeTy 3 p_believeMe) setTotality prim__believe_me (Partial NotCovering) @@ -272,7 +301,7 @@ (Bind (UN "y") (Pi (V 1)) (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased) [V 3, V 2, V 1, V 0]])))) - elabSynEq + elabSynEq = do let synEq = UN "prim__syntactic_eq" updateContext (addOperator synEq synEqTy 4 p_synEq) @@ -289,21 +318,21 @@ = do i <- getIState -- Ensure that the experimental extension is enabled unless (TypeProviders `elem` idris_language_extensions i) $ - fail $ "Failed to define type provider \"" ++ show n ++ - "\".\nYou must turn on the TypeProviders extension." + ifail $ "Failed to define type provider \"" ++ show n ++ + "\".\nYou must turn on the TypeProviders extension." ctxt <- getContext -- First elaborate the expected type (and check that it's a type) (ty', typ) <- elabVal toplevel False ty unless (isTType typ) $ - fail ("Expected a type, got " ++ show ty' ++ " : " ++ show typ) + ifail ("Expected a type, got " ++ show ty' ++ " : " ++ show typ) -- Elaborate the provider term to TT and check that the type matches (e, et) <- elabVal toplevel False tm unless (isProviderOf ty' et) $ - fail $ "Expected provider type IO (Provider (" ++ - show ty' ++ "))" ++ ", got " ++ show et ++ " instead." + ifail $ "Expected provider type IO (Provider (" ++ + show ty' ++ "))" ++ ", got " ++ show et ++ " instead." -- Create the top-level type declaration elabType info syn "" fc [] n ty @@ -357,7 +386,7 @@ erun fc (build i info False (UN "transform") rhs) erun fc $ psolve lhs_tm tt <- get_term - let (tm, ds) = runState (collectDeferred tt) [] + let (tm, ds) = runState (collectDeferred Nothing tt) [] return (tm, ds)) (crhs_tm, crhs_ty) <- recheckC fc [] rhs' logLvl 3 ("Transform RHS " ++ show crhs_tm) @@ -368,15 +397,15 @@ addIBC (IBCTrans (clhs_tm, crhs_tm)) -elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name -> +elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name -> PTerm -> String -> Name -> PTerm -> Idris () elabRecord info syn doc fc tyn ty cdoc cn cty - = do elabData info syn doc fc False (PDatadecl tyn ty [(cdoc, cn, cty, fc)]) + = do elabData info syn doc fc False (PDatadecl tyn ty [(cdoc, cn, cty, fc)]) cty' <- implicit syn cn cty i <- getIState cty <- case lookupTy cn (tt_ctxt i) of [t] -> return (delab i t) - _ -> fail "Something went inexplicably wrong" + _ -> ifail "Something went inexplicably wrong" cimp <- case lookupCtxt cn (idris_implicits i) of [imps] -> return imps let ptys = getProjs [] (renameBs cimp cty) @@ -401,15 +430,15 @@ = do i <- getIState idrisCatch (do elabDecl' EAll info ty elabDecl' EAll info val) - (\v -> do iputStrLn $ show fc ++ - ":Warning - can't generate setter for " ++ + (\v -> do iputStrLn $ show fc ++ + ":Warning - can't generate setter for " ++ show fn ++ " (" ++ show ty ++ ")" putIState i) - getImplB k (PPi (Imp l s _) n Placeholder sc) + getImplB k (PPi (Imp l s _ _) n Placeholder sc) = getImplB k sc - getImplB k (PPi (Imp l s d) n ty sc) - = getImplB (\x -> k (PPi (Imp l s d) n ty x)) sc + getImplB k (PPi (Imp l s d p) n ty sc) + = getImplB (\x -> k (PPi (Imp l s d p) n ty x)) sc getImplB k (PPi _ n ty sc) = getImplB k sc getImplB k _ = k @@ -452,9 +481,9 @@ let lhs = PApp fc (PRef fc pn) [pexp (PApp fc (PRef fc cn) iargs)] let rhs = PRef fc (mkp pn) - let pclause = PClause fc pn lhs [] rhs [] + let pclause = PClause fc pn lhs [] rhs [] return [pfnTy, PClauses fc [] pn [pclause]] - + implicitise (pa, t) = pa { getTm = t } mkUpdate recty k num ((pn, pty), pos) @@ -477,7 +506,7 @@ (map pexp rhsArgs)) [] return (pn, pfnTy, PClauses fc [] setname [pclause]) -elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool -> +elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool -> (String, Name, PTerm, FC) -> Idris (Name, Type) elabCon info syn tn codata (doc, n, t_in, fc) = do checkUndefined fc n @@ -486,12 +515,13 @@ 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 Nothing True False t - ((t', defer, is), log) <- + ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] (errAt "constructor " n (erun fc (build i info False n t))) logLvl 2 $ "Rechecking " ++ show t' def' <- checkDef fc defer - addDeferred def' + let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def' + addDeferred def'' mapM_ (elabCaseBlock info []) is ctxt <- getContext (cty, _) <- recheckC fc [] t' @@ -505,8 +535,8 @@ return (n, cty') where tyIs (Bind n b sc) = tyIs sc - tyIs t | (P _ n' _, _) <- unApply t - = if n' /= tn then tclift $ tfail (At fc (Msg (show n' ++ " is not " ++ show tn))) + tyIs t | (P _ n' _, _) <- unApply t + = if n' /= tn then tclift $ tfail (At fc (Msg (show n' ++ " is not " ++ show tn))) else return () tyIs t = tclift $ tfail (At fc (Msg (show t ++ " is not " ++ show tn))) @@ -516,7 +546,7 @@ -- | Elaborate a collection of left-hand and right-hand pairs - that is, a -- top-level definition. elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris () -elabClauses info fc opts n_in cs = let n = liftname info n_in in +elabClauses info fc opts n_in cs = let n = liftname info n_in in do ctxt <- getContext -- Check n actually exists, with no definition yet let tys = lookupTy n ctxt @@ -528,7 +558,7 @@ -- question: CAFs in where blocks? tclift $ tfail $ At fc (NoTypeDecl n) [ty] -> return ty - pats_in <- mapM (elabClause info opts) + pats_in <- mapM (elabClause info opts) (zip [0..] cs) logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in @@ -546,9 +576,9 @@ _ -> False solveDeferred n ist <- getIState - when doNothing $ + when doNothing $ case lookupCtxt n (idris_optimisation ist) of - [oi] -> do let opts = addDef n (oi { collapsible = True }) + [oi] -> do let opts = addDef n (oi { collapsible = True }) (idris_optimisation ist) putIState (ist { idris_optimisation = opts }) _ -> do let opts = addDef n (Optimise True False [] []) @@ -556,10 +586,10 @@ putIState (ist { idris_optimisation = opts }) addIBC (IBCOpt n) ist <- getIState - let pats = doTransforms ist pats_in + let pats = map (simple_lhs (tt_ctxt ist)) $ doTransforms ist pats_in - -- logLvl 3 (showSep "\n" (map (\ (l,r) -> - -- show l ++ " = " ++ + -- logLvl 3 (showSep "\n" (map (\ (l,r) -> + -- show l ++ " = " ++ -- show r) pats)) let tcase = opt_typecase (idris_options ist) @@ -575,12 +605,18 @@ -- pdef is the compile-time pattern definition. -- This will get further optimised for run-time, and, separately, -- further inlined to help with totality checking. - let pdef = map debind $ map (simple_lhs (tt_ctxt ist)) pats - - logLvl 5 $ "Initial typechecked patterns:\n" ++ show pdef + let pdef = map debind pats - -- TODO: Inlining on initial definition happens here. + logLvl 5 $ "Initial typechecked patterns:\n" ++ show pats + logLvl 5 $ "Initial typechecked pattern def:\n" ++ show pdef + -- Look for 'static' names and generate new specialised + -- definitions for them + + mapM_ (\ e -> case e of + Left _ -> return () + Right (l, r) -> elabPE info fc n r) pats + -- NOTE: Need to store original definition so that proofs which -- rely on its structure aren't affected by any changes to the -- inliner. Just use the inlined version to generate pdef' and to @@ -593,7 +629,7 @@ -- patterns after collapsing optimisation applied -- (i.e. check if the function should do nothing at run time) - optpats <- if doNothing + optpats <- if doNothing then return $ [Right (mkApp (P Bound n Erased) (take numArgs (repeat Erased)), Erased)] else stripCollapsed pats @@ -602,23 +638,23 @@ Just _ -> logLvl 5 $ "Partially evaluated:\n" ++ show pats _ -> return () - let optpdef = map debind $ map (simple_lhs (tt_ctxt ist)) optpats - tree@(CaseDef scargs sc _) <- tclift $ + let optpdef = map debind optpats -- $ map (simple_lhs (tt_ctxt ist)) optpats + tree@(CaseDef scargs sc _) <- tclift $ simpleCase tcase False reflect CompileTime fc pdef cov <- coverage pmissing <- - if cov + if cov then do missing <- genClauses fc n (map getLHS pdef) cs - -- missing <- genMissing n scargs sc + -- missing <- genMissing n scargs sc missing' <- filterM (checkPossible info fc True n) missing let clhs = map getLHS pdef - logLvl 2 $ "Must be unreachable:\n" ++ + logLvl 2 $ "Must be unreachable:\n" ++ showSep "\n" (map (showImp Nothing True False) missing') ++ "\nAgainst: " ++ showSep "\n" (map (\t -> showImp Nothing True False (delab ist t)) (map getLHS pdef)) -- filter out anything in missing' which is -- matched by any of clhs. This might happen since - -- unification may force a variable to take a + -- unification may force a variable to take a -- particular form, rather than force a case -- to be impossible. return (filter (noMatch ist clhs) missing') @@ -626,7 +662,9 @@ let pcover = null pmissing -- pdef' is the version that gets compiled for run-time - pdef' <- applyOpts optpdef + pdef_in' <- applyOpts optpdef + let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in' + logLvl 5 $ "After data structure transformations:\n" ++ show pdef' ist <- getIState @@ -634,8 +672,8 @@ let tot = if pcover || AssertTotal `elem` opts then Unchecked -- finish checking later else Partial NotCovering -- already know it's not total - -- case lookupCtxt (namespace info) n (idris_flags ist) of - -- [fs] -> if TotalFn `elem` fs + -- case lookupCtxt (namespace info) n (idris_flags ist) of + -- [fs] -> if TotalFn `elem` fs -- then case tot of -- Total _ -> return () -- t -> tclift $ tfail (At fc (Msg (show n ++ " is " ++ show t))) @@ -645,7 +683,7 @@ CaseDef _ _ [] -> return () CaseDef _ _ xs -> mapM_ (\x -> iputStrLn $ show fc ++ - ":warning - Unreachable case: " ++ + ":warning - Unreachable case: " ++ show (delab ist x)) xs let knowncovering = (pcover && cov) || AssertTotal `elem` opts @@ -655,19 +693,20 @@ logLvl 3 $ "Optimised: " ++ show tree' ctxt <- getContext ist <- getIState - putIState (ist { idris_patdefs = addDef n (pdef', pmissing) + putIState (ist { idris_patdefs = addDef n (force pdef', force pmissing) (idris_patdefs ist) }) let caseInfo = CaseInfo (inlinable opts) (dictionary opts) case lookupTy n ctxt of [ty] -> do updateContext (addCasedef n caseInfo - tcase knowncovering + tcase knowncovering reflect (AssertTotal `elem` opts) pats pdef pdef pdef_inl pdef' ty) addIBC (IBCDef n) setTotality n tot - when (not reflect) $ totcheck (fc, n) + when (not reflect) $ do totcheck (fc, n) + defer_totcheck (fc, n) when (tot /= Unchecked) $ addIBC (IBCTotal n tot) i <- getIState case lookupDef n (tt_ctxt i) of @@ -691,14 +730,14 @@ where noMatch i cs tm = all (\x -> case matchClause i (delab' i x True) tm of Right _ -> False - Left miss -> True) cs + Left miss -> True) cs checkUndefined n ctxt = case lookupDef n ctxt of [] -> return () [TyDecl _ _] -> return () _ -> tclift $ tfail (At fc (AlreadyDefined n)) - debind (Right (x, y)) = let (vs, x') = depat [] 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 @@ -706,32 +745,125 @@ depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc) depat acc x = (acc, x) - + getLHS (_, l, _) = l - simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y) + simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, + force (normalisePats ctxt [] y)) simple_lhs ctxt t = t + simple_rt ctxt (p, x, y) = (p, x, force (rt_simplify ctxt [] y)) + + -- this is so pattern types are in the right form for erasure + normalisePats ctxt env (Bind n (PVar t) sc) + = let t' = normalise ctxt env t in + Bind n (PVar t') (normalisePats ctxt ((n, PVar t') : env) sc) + normalisePats ctxt env (Bind n (PVTy t) sc) + = let t' = normalise ctxt env t in + Bind n (PVTy t') (normalisePats ctxt ((n, PVar t') : env) sc) + normalisePats ctxt env t = t + specNames [] = Nothing specNames (Specialise ns : _) = Just ns specNames (_ : xs) = specNames xs - sameLength ((_, x, _) : xs) + sameLength ((_, x, _) : xs) = do l <- sameLength xs let (f, as) = unApply x if (null xs || l == length as) then return (length as) else tfail (At fc (Msg "Clauses have differing numbers of arguments ")) sameLength [] = return 0 - -- apply all transformations (just specialisation for now, add + -- apply all transformations (just specialisation for now, add -- user defined transformation rules later) - doTransforms ist pats = + doTransforms ist pats = case specNames opts of - Nothing -> pats - Just ns -> partial_eval (tt_ctxt ist) ns pats + Nothing -> pats + Just ns -> partial_eval (tt_ctxt ist) ns pats -elabVal :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type) -elabVal info aspat tm_in +-- Find 'static' applications in a term and partially evaluate them +elabPE :: ElabInfo -> FC -> Name -> Term -> Idris () +elabPE info fc caller r = + do ist <- getIState + let sa = getSpecApps ist [] r + mapM_ (mkSpecialised ist) sa + where + -- TODO: Add a PTerm level transformation rule, which is basically the + -- new definition in reverse (before specialising it). + -- RHS => LHS where implicit arguments are left blank in the + -- transformation. + + -- Apply that transformation after every PClauses elaboration + + mkSpecialised ist specapp_in = do + let (specTy, specapp) = getSpecTy ist specapp_in + let (n, newnm, [(lhs, rhs)]) = getSpecClause ist specapp + let undef = case lookupDef newnm (tt_ctxt ist) of + [] -> True + _ -> False + logLvl 5 $ show (newnm, map (concreteArg ist) (snd specapp)) + idrisCatch + (when (undef && all (concreteArg ist) (snd specapp)) $ do + cgns <- getAllNames n + let opts = [Specialise (map (\x -> (x, Nothing)) cgns ++ + mapMaybe specName (snd specapp))] + logLvl 3 $ "Specialising application: " ++ show specapp + logLvl 2 $ "New name: " ++ show newnm + iLOG $ "PE definition type : " ++ (show specTy) + ++ "\n" ++ show opts + logLvl 2 $ "PE definition " ++ show newnm ++ ":\n" ++ + (showImp Nothing True False lhs ++ " = " ++ + showImp Nothing True False rhs) + elabType info defaultSyntax "" fc opts newnm specTy + let def = [PClause fc newnm lhs [] rhs []] + elabClauses info fc opts newnm def + logLvl 1 $ "Specialised " ++ show newnm) + -- if it doesn't work, just don't specialise. Could happen for lots + -- of valid reasons (e.g. local variables in scope which can't be + -- lifted out). + (\e -> logLvl 4 $ "Couldn't specialise: " ++ (pshow ist e)) + + specName (ImplicitS, tm) + | (P Ref n _, _) <- unApply tm = Just (n, Just 1) + specName (ExplicitS, tm) + | (P Ref n _, _) <- unApply tm = Just (n, Just 1) + specName _ = Nothing + + concreteArg ist (ImplicitS, tm) = concreteTm ist tm + concreteArg ist (ExplicitS, tm) = concreteTm ist tm + concreteArg ist _ = True + + concreteTm ist tm | (P _ n _, _) <- unApply tm = + case lookupTy n (tt_ctxt ist) of + [] -> False + _ -> True + concreteTm ist (Constant _) = True + concreteTm ist _ = False + + -- get the type of a specialised application + getSpecTy ist (n, args) + = case lookupTy n (tt_ctxt ist) of + [ty] -> let (specty_in, args') = specType args (explicitNames ty) + specty = normalise (tt_ctxt ist) [] (finalise specty_in) + t = mkPE_TyDecl ist args' (explicitNames specty) in + (t, (n, args')) +-- (normalise (tt_ctxt ist) [] (specType args ty)) + _ -> error "Can't happen (getSpecTy)" + + getSpecClause ist (n, args) + = let newnm = UN ("__"++show (nsroot n) ++ "_" ++ + showSep "_" (map showArg args)) in + -- UN (show n ++ show (map snd args)) in + (n, newnm, mkPE_TermDecl ist newnm n args) + where showArg (ExplicitS, n) = show n + showArg (ImplicitS, n) = show n + showArg _ = "" + + +-- Elaborate a value, returning any new bindings created (this will only +-- happen if elaborating as a pattern clause) +elabValBind :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type, [(Name, Type)]) +elabValBind info aspat tm_in = do ctxt <- getContext i <- getIState let tm = addImpl i tm_in @@ -740,22 +872,32 @@ -- * ordinary elaboration -- * elaboration as a Type -- * elaboration as a function a -> b - - ((tm', defer, is), _) <- --- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) [] + + ((tm', defer, is), _) <- +-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) [] -- (build i info aspat (MN 0 "val") tm)) tclift (elaborate ctxt (MN 0 "val") infP [] (build i info aspat (MN 0 "val") (infTerm tm))) - def' <- checkDef (FC "(input)" 0) defer - addDeferred def' + let vtm = orderPats (getInferTerm tm') + + def' <- checkDef (fileFC "(input)") defer + let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def' + addDeferred def'' mapM_ (elabCaseBlock info []) is - logLvl 3 ("Value: " ++ show tm') - recheckC (FC "(input)" 0) [] tm' - let vtm = getInferTerm tm' - logLvl 2 (show vtm) - recheckC (FC "(input)" 0) [] vtm + logLvl 3 ("Value: " ++ show vtm) +-- recheckC (fileFC "(input)") [] tm' +-- logLvl 2 (show vtm) + (vtm, vty) <- recheckC (fileFC "(input)") [] vtm + let bargs = getPBtys vtm + return (vtm, vty, bargs) + +elabVal :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type) +elabVal info aspat tm_in + = do (tm, ty, _) <- elabValBind info aspat tm_in + return (tm, ty) + -- checks if the clause is a possible left hand side. Returns the term if -- possible, otherwise Nothing. @@ -778,18 +920,19 @@ -- trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b) err@(Error _) -> return False -elabClause :: ElabInfo -> FnOpts -> (Int, PClause) -> +elabClause :: ElabInfo -> FnOpts -> (Int, PClause) -> Idris (Either Term (Term, Term)) elabClause info opts (_, PClause fc fname lhs_in [] PImpossible []) = do let tcgen = Dictionary `elem` opts b <- checkPossible info fc tcgen fname lhs_in case b of - True -> fail $ show fc ++ ":" ++ show lhs_in ++ " is a possible case" + True -> ifail $ show fc ++ ":" ++ show lhs_in ++ " is a possible case" False -> do ptm <- mkPatTm lhs_in return (Left ptm) -elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock) +elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock) = do let tcgen = Dictionary `elem` opts ctxt <- getContext + -- Build the LHS as an "Infer", and pull out its type and -- pattern bindings i <- getIState @@ -799,21 +942,28 @@ _ -> error "Can't happen (elabClause function type)" let fn_is = case lookupCtxt fname (idris_implicits i) of [t] -> t - _ -> [] + _ -> [] let params = getParamsInType i [] fn_is fn_ty - let lhs = addImplPat i (propagateParams params (stripLinear i lhs_in)) + let lhs = stripUnmatchable i $ + addImplPat i (propagateParams params (stripLinear i lhs_in)) logLvl 5 ("LHS: " ++ show fc ++ " " ++ showImp Nothing True False lhs) logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is)) - ((lhs', dlhs, []), _) <- + + ((lhs', dlhs, []), _) <- tclift $ elaborate ctxt (MN 0 "patLHS") infP [] - (errAt "left hand side of " fname + (errAt "left hand side of " fname (erun fc (buildTC i info True tcgen fname (infTerm lhs)))) let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs' logLvl 3 ("Elaborated: " ++ show lhs_tm) logLvl 3 ("Elaborated type: " ++ show lhs_ty) + (clhs_c, clhsty) <- recheckC fc [] lhs_tm let clhs = normalise ctxt [] clhs_c + + addInternalApp (fc_fname fc) (fc_line fc) (delab i clhs) + addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delab i clhs)) + logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty) -- Elaborate where block ist <- getIState @@ -823,7 +973,7 @@ let defs = nub (decls ++ concatMap defined whereblock) let newargs = pvars ist lhs_tm let wb = map (expandParamsD False ist decorate newargs defs) whereblock - + -- Split the where block into declarations with a type, and those -- without -- Elaborate those with a type *before* RHS, those without *after* @@ -839,22 +989,26 @@ logLvl 2 $ "RHS: " ++ showImp Nothing True False rhs ctxt <- getContext -- new context with where block added logLvl 5 "STARTING CHECK" - ((rhs', defer, is), _) <- + ((rhs', defer, is), _) <- tclift $ elaborate ctxt (MN 0 "patRHS") clhsty [] (do pbinds lhs_tm - (_, _, is) <- errAt "right hand side of " fname + (_, _, is) <- errAt "right hand side of " fname (erun fc (build i info False fname rhs)) - errAt "right hand side of " fname + errAt "right hand side of " fname (erun fc $ psolve lhs_tm) tt <- get_term - let (tm, ds) = runState (collectDeferred tt) [] + let (tm, ds) = runState (collectDeferred (Just fname) tt) [] return (tm, ds, is)) logLvl 5 "DONE CHECK" logLvl 2 $ "---> " ++ show rhs' when (not (null defer)) $ iLOG $ "DEFERRED " ++ show defer def' <- checkDef fc defer - addDeferred def' + let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def' + addDeferred def'' + when (not (null def')) $ do + mapM_ defer_totcheck (map (\x -> (fc, fst x)) def'') + -- Now the remaining deferred (i.e. no type declarations) clauses -- from the where block @@ -872,10 +1026,10 @@ checkInferred fc (delab' i crhs True) rhs return $ Right (clhs, crhs) where - decorate (NS x ns) - = NS (SN (WhereN cnum fname x)) ns -- ++ [show cnum]) + decorate (NS x ns) + = NS (SN (WhereN cnum fname x)) ns -- ++ [show cnum]) -- = NS (UN ('#':show x)) (ns ++ [show cnum, show fname]) - decorate x + decorate x = SN (WhereN cnum fname x) -- = NS (SN (WhereN cnum fname x)) [show cnum] -- = NS (UN ('#':show x)) [show cnum, show fname] @@ -884,18 +1038,18 @@ sepBlocks' ns (d@(PTy _ _ _ _ n t) : bs) = let (bf, af) = sepBlocks' (n : ns) bs in (d : bf, af) - sepBlocks' ns (d@(PClauses _ _ n _) : bs) + sepBlocks' ns (d@(PClauses _ _ n _) : bs) | not (n `elem` ns) = let (bf, af) = sepBlocks' ns bs in (bf, d : af) sepBlocks' ns (b : bs) = let (bf, af) = sepBlocks' ns bs in (b : bf, af) sepBlocks' ns [] = ([], []) - pinfo ns ps i + pinfo ns ps i = let ds = concatMap declared ps newps = params info ++ ns dsParams = map (\n -> (n, map fst newps)) ds - newb = addAlist dsParams (inblock info) + newb = addAlist dsParams (inblock info) l = liftname info in info { params = newps, inblock = newb, @@ -904,24 +1058,24 @@ -- _ -> MN i (show n)) . l } - getParamsInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc) + getParamsInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc) = getParamsInType i env is (instantiate (P Bound n t) sc) - getParamsInType i env (_ : is) (Bind n (Pi t) sc) + getParamsInType i env (_ : is) (Bind n (Pi t) sc) = getParamsInType i (n : env) is (instantiate (P Bound n t) sc) getParamsInType i env is tm@(App f a) - | (P _ tn _, args) <- unApply tm + | (P _ tn _, args) <- unApply tm = case lookupCtxt tn (idris_datatypes i) of [t] -> nub $ paramNames args env (param_pos t) ++ - getParamsInType i env is f ++ + getParamsInType i env is f ++ getParamsInType i env is a - [] -> nub $ getParamsInType i env is f ++ + [] -> nub $ getParamsInType i env is f ++ getParamsInType i env is a - | otherwise = nub $ getParamsInType i env is f ++ + | otherwise = nub $ getParamsInType i env is f ++ getParamsInType i env is a getParamsInType i _ _ _ = [] paramNames args env [] = [] - paramNames args env (p : ps) + paramNames args env (p : ps) | length args > p = case args!!p of P _ n _ -> if n `elem` env then n : paramNames args env ps @@ -939,15 +1093,15 @@ = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps) propagateParams ps x = x -elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock) +elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock) = do let tcgen = Dictionary `elem` opts ctxt <- getContext -- Build the LHS as an "Infer", and pull out its type and -- pattern bindings i <- getIState - let lhs = addImplPat i lhs_in + let lhs = addImplPat i lhs_in logLvl 5 ("LHS: " ++ showImp Nothing True False lhs) - ((lhs', dlhs, []), _) <- + ((lhs', dlhs, []), _) <- tclift $ elaborate ctxt (MN 0 "patLHS") infP [] (errAt "left hand side of with in " fname (erun fc (buildTC i info True tcgen fname (infTerm lhs))) ) @@ -961,18 +1115,19 @@ let wval = addImplBound i (map fst bargs) wval_in logLvl 5 ("Checking " ++ showImp Nothing True False wval) -- Elaborate wval in this context - ((wval', defer, is), _) <- - tclift $ elaborate ctxt (MN 0 "withRHS") + ((wval', defer, is), _) <- + tclift $ elaborate ctxt (MN 0 "withRHS") (bindTyArgs PVTy bargs infP) [] (do pbinds lhs_tm -- TODO: may want where here - see winfo abpve - (_', d, is) <- errAt "with value in " fname + (_', d, is) <- errAt "with value in " fname (erun fc (build i info False fname (infTerm wval))) erun fc $ psolve lhs_tm tt <- get_term return (tt, d, is)) def' <- checkDef fc defer - addDeferred def' + let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def' + addDeferred def'' mapM_ (elabCaseBlock info opts) is (cwval, cwvalty) <- recheckC fc [] (getInferTerm wval') let cwvaltyN = explicitNames cwvalty @@ -983,26 +1138,28 @@ -- rather than a de Bruijn index. let pdeps = usedNamesIn pvars i (delab i cwvalty) let (bargs_pre, bargs_post) = split pdeps bargs [] - logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++ + logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++ " depends on " ++ show pdeps ++ " from " ++ show pvars) logLvl 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post) windex <- getName -- build a type declaration for the new function: - -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty + -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty let wargval = getRetTy cwvalN let wargtype = getRetTy cwvaltyN logLvl 5 ("Abstract over " ++ show wargval) - let wtype = bindTyArgs Pi (bargs_pre ++ - (MN 0 "warg", wargtype) : - map (abstract (MN 0 "warg") wargval wargtype) bargs_post) + let wtype = bindTyArgs Pi (bargs_pre ++ + (MN 0 "warg", wargtype) : + map (abstract (MN 0 "warg") wargval wargtype) bargs_post) (substTerm wargval (P Bound (MN 0 "warg") wargtype) ret_ty) logLvl 3 ("New function type " ++ show wtype) let wname = MN windex (show fname) + let imps = getImps wtype -- add to implicits context putIState (i { idris_implicits = addDef wname imps (idris_implicits i) }) addIBC (IBCDef wname) - def' <- checkDef fc [(wname, wtype)] - addDeferred def' + def' <- checkDef fc [(wname, (-1, Nothing, wtype))] + let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def' + addDeferred def'' -- in the subdecls, lhs becomes: -- fname pats | wpat [rest] @@ -1015,8 +1172,8 @@ mapM_ (elabDecl EAll info) wb -- rhs becomes: fname' ps wval - let rhs = PApp fc (PRef fc wname) - (map (pexp . (PRef fc) . fst) bargs_pre ++ + let rhs = PApp fc (PRef fc wname) + (map (pexp . (PRef fc) . fst) bargs_pre ++ pexp wval : (map (pexp . (PRef fc) . fst) bargs_post)) logLvl 5 ("New RHS " ++ showImp Nothing True False rhs) @@ -1030,7 +1187,8 @@ tt <- get_term return (tt, d, is)) def' <- checkDef fc defer - addDeferred def' + let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def' + addDeferred def'' mapM_ (elabCaseBlock info opts) is logLvl 5 ("Checked RHS " ++ show rhs') (crhs, crhsty) <- recheckC fc [] rhs' @@ -1042,42 +1200,45 @@ mkAuxC wname lhs ns ns' (PClauses fc o n cs) | True = do cs' <- mapM (mkAux wname lhs ns ns') cs return $ PClauses fc o wname cs' - | otherwise = fail $ show fc ++ "with clause uses wrong function name " ++ show n + | otherwise = ifail $ show fc ++ "with clause uses wrong function name " ++ show n mkAuxC wname lhs ns ns' d = return $ d mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres) = do i <- getIState let tm = addImplPat i tm_in - logLvl 2 ("Matching " ++ showImp Nothing True False tm ++ " against " ++ + logLvl 2 ("Matching " ++ showImp Nothing True False tm ++ " against " ++ showImp Nothing True False toplhs) case matchClause i toplhs tm of - Left f -> fail $ show fc ++ ":with clause does not match top level" - Right mvars -> + Left (a,b) -> trace ("matchClause: " ++ show a ++ " =/= " ++ show b) (ifail $ show fc ++ ":with clause does not match top level") + Right mvars -> do logLvl 3 ("Match vars : " ++ show mvars) lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w return $ PClause fc wname lhs ws rhs wheres mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs) = do i <- getIState let tm = addImplPat i tm_in - logLvl 2 ("Matching " ++ showImp Nothing True False tm ++ " against " ++ + logLvl 2 ("Matching " ++ showImp Nothing True False tm ++ " against " ++ showImp Nothing True False toplhs) withs' <- mapM (mkAuxC wname toplhs ns ns') withs case matchClause i toplhs tm of - Left _ -> fail $ show fc ++ "with clause does not match top level" - Right mvars -> + Left (a,b) -> trace ("matchClause: " ++ show a ++ " =/= " ++ show b) (ifail $ show fc ++ "with clause does not match top level") + Right mvars -> do lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w return $ PWith fc wname lhs ws wval withs' mkAux wname toplhs ns ns' c - = fail $ show fc ++ "badly formed with clause" + = ifail $ show fc ++ "badly formed with clause" + addArg (PApp fc f args) w = PApp fc f (args ++ [pexp w]) + addArg (PRef fc f) w = PApp fc (PRef fc f) [pexp w] + updateLHS n wname mvars ns_in ns_in' (PApp fc (PRef fc' n') args) w = let ns = map (keepMvar (map fst mvars) fc') ns_in ns' = map (keepMvar (map fst mvars) fc') ns_in' in - return $ substMatches mvars $ - PApp fc (PRef fc' wname) + return $ substMatches mvars $ + PApp fc (PRef fc' wname) (map pexp ns ++ pexp w : (map pexp ns')) - updateLHS n wname mvars ns ns' tm w - = fail $ "Not implemented match " ++ show tm + updateLHS n wname mvars ns ns' tm w + = ifail $ "Not implemented match " ++ show tm keepMvar mvs fc v | v `elem` mvs = PRef fc v | otherwise = Placeholder @@ -1089,16 +1250,16 @@ split deps ((n, ty) : rest) pre | n `elem` deps = split (deps \\ [n]) rest ((n, ty) : pre) | otherwise = split deps rest ((n, ty) : pre) - split deps [] pre = (reverse pre, []) + split deps [] pre = (reverse pre, []) abstract wn wv wty (n, argty) = (n, substTerm wv (P Bound wn wty) argty) data MArgTy = IA | EA | CA deriving Show elabClass :: ElabInfo -> SyntaxInfo -> String -> - FC -> [PTerm] -> + FC -> [PTerm] -> Name -> [(Name, PTerm)] -> [PDecl] -> Idris () -elabClass info syn doc fc constraints tn ps ds +elabClass info syn doc fc constraints tn ps ds = do let cn = UN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn) let tty = pibind ps PType let constraint = PApp fc (PRef fc tn) @@ -1108,20 +1269,17 @@ let mnames = map getMName mdecls logLvl 2 $ "Building methods " ++ show mnames ims <- mapM (tdecl mnames) mdecls - defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint) + defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint) (filter clause ds) - let (methods, imethods) + let (methods, imethods) = unzip (map (\ ( x,y,z) -> (x, y)) ims) let defaults = map (\ (x, (y, z)) -> (x,y)) defs - addClass tn (CI cn (map nodoc imethods) defaults (map fst ps) []) + addClass tn (CI cn (map nodoc imethods) defaults (map fst ps) []) -- build instance constructor type -- decorate names of functions to ensure they can't be referred -- to elsewhere in the class declaration - -- TODO: Remove mdec to make it a dependent record, which would - -- allow dependent type classes, but building instances will - -- then need some attention. - let cty = impbind ps $ conbind constraints - $ pibind (map (\ (n, ty) -> (mdec n, ty)) methods) + let cty = impbind ps $ conbind constraints + $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods) constraint let cons = [("", cn, cty, fc)] let ddecl = PDatadecl tn tty cons @@ -1129,7 +1287,7 @@ elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc False ddecl -- for each constraint, build a top level function to chase it logLvl 5 $ "Building functions" - let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps + let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps ++ using syn } fns <- mapM (cfun cn constraint usyn (map fst imethods)) constraints mapM_ (elabDecl EAll info) (concat fns) @@ -1143,37 +1301,37 @@ where nodoc (n, (_, o, t)) = (n, (o, t)) pibind [] x = x - pibind ((n, ty): ns) x = PPi expl n ty (pibind ns x) + pibind ((n, ty): ns) x = PPi expl n ty (pibind ns x) mdec (UN n) = SN (MethodN (UN n)) mdec (NS x n) = NS (mdec x) n mdec x = x impbind [] x = x - impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x) + impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x) conbind (ty : ns) x = PPi constraint (MN 0 "class") ty (conbind ns x) conbind [] x = x getMName (PTy _ _ _ _ n _) = nsroot n - tdecl allmeths (PTy doc syn _ o n t) + tdecl allmeths (PTy doc syn _ o n t) = do t' <- implicit' syn allmeths n t logLvl 5 $ "Method " ++ show n ++ " : " ++ showImp Nothing True False t' return ( (n, (toExp (map fst ps) Exp t')), (n, (doc, o, (toExp (map fst ps) Imp t'))), (n, (syn, o, t) ) ) - tdecl _ _ = fail "Not allowed in a class declaration" + tdecl _ _ = ifail "Not allowed in a class declaration" - -- Create default definitions + -- Create default definitions defdecl mtys c d@(PClauses fc opts n cs) = case lookup n mtys of Just (syn, o, ty) -> do let ty' = insertConstraint c ty let ds = map (decorateid defaultdec) - [PTy "" syn fc [] n ty', + [PTy "" syn fc [] n ty', PClauses fc (o ++ opts) n cs] iLOG (show ds) return (n, ((defaultdec n, ds!!1), ds)) - _ -> fail $ show n ++ " is not a method" - defdecl _ _ _ = fail "Can't happen (defdecl)" + _ -> ifail $ show n ++ " is not a method" + defdecl _ _ _ = ifail "Can't happen (defdecl)" defaultdec (UN n) = UN ("default#" ++ n) defaultdec (NS n ns) = NS (defaultdec n) ns @@ -1185,12 +1343,12 @@ -- Generate a function for chasing a dictionary constraint cfun cn c syn all con - = do let cfn = UN ('@':'@':show cn ++ "#" ++ show con) + = do let cfn = UN ('@':'@':show cn ++ "#" ++ show con) -- SN (ParentN cn (show con)) let mnames = take (length all) $ map (\x -> MN x "meth") [0..] let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames) let lhs = PApp fc (PRef fc cfn) [pconst capp] - let rhs = PResolveTC (FC "HACK" 0) + let rhs = PResolveTC (fileFC "HACK") let ty = PPi constraint (MN 0 "pc") c con iLOG (showImp Nothing True False ty) iLOG (showImp Nothing True False lhs ++ " = " ++ showImp Nothing True False rhs) @@ -1209,7 +1367,7 @@ -- Generate a top level function which looks up a method in a given -- dictionary (this is inlinable, always) - tfun cn c syn all (m, (doc, o, ty)) + tfun cn c syn all (m, (doc, o, ty)) = do let ty' = insertConstraint c ty let mnames = take (length all) $ map (\x -> MN x "meth") [0..] let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames) @@ -1223,74 +1381,79 @@ return [PTy doc syn fc o m ty', PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]] - getMArgs (PPi (Imp _ _ _) n ty sc) = IA : getMArgs sc - getMArgs (PPi (Exp _ _ _) n ty sc) = EA : getMArgs sc + getMArgs (PPi (Imp _ _ _ _) n ty sc) = IA : getMArgs sc + getMArgs (PPi (Exp _ _ _ _) n ty sc) = EA : getMArgs sc getMArgs (PPi (Constraint _ _ _) n ty sc) = CA : getMArgs sc getMArgs _ = [] getMeth (m:ms) (a:as) x | x == a = PRef fc m | otherwise = getMeth ms as x - lhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : lhsArgs xs ns - lhsArgs (IA : xs) ns = lhsArgs xs ns + lhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : lhsArgs xs ns + lhsArgs (IA : xs) ns = lhsArgs xs ns lhsArgs (CA : xs) ns = lhsArgs xs ns lhsArgs [] _ = [] - rhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : rhsArgs xs ns - rhsArgs (IA : xs) ns = pexp Placeholder : rhsArgs xs ns + rhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : rhsArgs xs ns + rhsArgs (IA : xs) ns = pexp Placeholder : rhsArgs xs ns rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns rhsArgs [] _ = [] - insertConstraint c (PPi p@(Imp _ _ _) n ty sc) + insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc) = PPi p n ty (insertConstraint c sc) insertConstraint c sc = PPi constraint (MN 0 "class") c sc -- make arguments explicit and don't bind class parameters - toExp ns e (PPi (Imp l s _) n ty sc) + toExp ns e (PPi (Imp l s _ p) n ty sc) | n `elem` ns = toExp ns e sc - | otherwise = PPi (e l s "") n ty (toExp ns e sc) + | otherwise = PPi (e l s "" p) n ty (toExp ns e sc) toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc) toExp ns e sc = sc -elabInstance :: ElabInfo -> SyntaxInfo -> +elabInstance :: ElabInfo -> SyntaxInfo -> FC -> [PTerm] -> -- constraints - Name -> -- the class - [PTerm] -> -- class parameters (i.e. instance) + Name -> -- the class + [PTerm] -> -- class parameters (i.e. instance) PTerm -> -- full instance type Maybe Name -> -- explicit name [PDecl] -> Idris () elabInstance info syn fc cs n ps t expn ds - = do i <- getIState + = do i <- getIState (n, ci) <- case lookupCtxtName n (idris_classes i) of [c] -> return c - _ -> fail $ show fc ++ ":" ++ show n ++ " is not a type class" + _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class" let constraint = PApp fc (PRef fc n) (map pexp ps) let iname = case expn of - Nothing -> SN (InstanceN n (map show ps)) + Nothing -> SN (InstanceN n (map show ps)) -- UN ('@':show n ++ "$" ++ show ps) Just nm -> nm + nty <- elabType' True info syn "" fc [] iname t -- if the instance type matches any of the instances we have already, -- and it's not a named instance, then it's overlapping, so report an error case expn of - Nothing -> do mapM_ (checkNotOverlapping i t) (class_instances ci) + Nothing -> do mapM_ (checkNotOverlapping i (delab i nty)) + (class_instances ci) addInstance intInst n iname - Just _ -> addInstance intInst n iname - elabType info syn "" fc [] iname t + Just _ -> addInstance intInst n iname let ips = zip (class_params ci) ps let ns = case n of NS n ns' -> ns' _ -> [] - -- get the implicit parameters that need passing through to the + -- get the implicit parameters that need passing through to the -- where block wparams <- mapM (\p -> case p of PApp _ _ args -> getWParams args _ -> return []) ps let pnames = map pname (concat (nub wparams)) - let mtys = map (\ (n, (op, t)) -> - let t' = substMatchesShadow ips pnames t in - (decorate ns iname n, - op, coninsert cs t', t')) - (class_methods ci) + let all_meths = map (nsroot . fst) (class_methods ci) + let mtys = map (\ (n, (op, t)) -> + let t_in = substMatchesShadow ips pnames t + mnamemap = map (\n -> (n, PRef fc (decorate ns iname n))) + all_meths + t' = substMatchesShadow mnamemap pnames t_in in + (decorate ns iname n, + op, coninsert cs t', t')) + (class_methods ci) logLvl 3 (show (mtys, ips)) let ds' = insertDefaults i iname (class_defaults ci) ns ds iLOG ("Defaults inserted: " ++ show ds' ++ "\n" ++ show ci) @@ -1300,12 +1463,12 @@ let wbVals = map (decorateid (decorate ns iname)) ds' let wb = wbTys ++ wbVals logLvl 3 $ "Method types " ++ showSep "\n" (map (showDeclImp True . mkTyDecl) mtys) - logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++ + logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++ show (concat (nub wparams)) let lhs = PRef fc iname let rhs = PApp fc (PRef fc (instanceName ci)) (map (pexp . mkMethApp) mtys) - let idecls = [PClauses fc [Dictionary] iname + let idecls = [PClauses fc [Dictionary] iname [PClause fc iname lhs [] rhs wb]] iLOG (show idecls) mapM (elabDecl EAll info) idecls @@ -1326,28 +1489,28 @@ [t'] -> let tret = getRetType t tret' = getRetType (delab i t') in case matchClause i tret' tret of - Right _ -> overlapping tret tret' + Right ms -> overlapping tret tret' Left _ -> case matchClause i tret tret' of - Right _ -> overlapping tret tret' + Right ms -> overlapping tret tret' Left _ -> return () _ -> return () - overlapping t t' = tclift $ tfail (At fc (Msg $ + overlapping t t' = tclift $ tfail (At fc (Msg $ "Overlapping instance: " ++ show t' ++ " already defined")) getRetType (PPi _ _ _ sc) = getRetType sc getRetType t = t - mkMethApp (n, _, _, ty) + mkMethApp (n, _, _, ty) = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty)) - lamBind i (PPi (Constraint _ _ _) _ _ sc) sc' + lamBind i (PPi (Constraint _ _ _) _ _ sc) sc' = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc') - lamBind i (PPi _ n ty sc) sc' + lamBind i (PPi _ n ty sc) sc' = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc') lamBind i _ sc = sc - methArgs i (PPi (Imp _ _ _) n ty sc) + methArgs i (PPi (Imp _ _ _ _) n ty sc) = PImp 0 True False n (PRef fc (MN i "meth")) "" : methArgs (i+1) sc - methArgs i (PPi (Exp _ _ _) n ty sc) + methArgs i (PPi (Exp _ _ _ _) n ty sc) = PExp 0 False (PRef fc (MN i "meth")) "" : methArgs (i+1) sc - methArgs i (PPi (Constraint _ _ _) n ty sc) + methArgs i (PPi (Constraint _ _ _) n ty sc) = PConstraint 0 False (PResolveTC fc) "" : methArgs (i+1) sc methArgs i _ = [] @@ -1355,8 +1518,8 @@ papp fc f as = PApp fc f as getWParams [] = return [] - getWParams (p : ps) - | PRef _ n <- getTm p + getWParams (p : ps) + | PRef _ n <- getTm p = do ps' <- getWParams ps ctxt <- getContext case lookupP n ctxt of @@ -1372,20 +1535,20 @@ conbind (ty : ns) x = PPi constraint (MN 0 "class") ty (conbind ns x) conbind [] x = x - coninsert cs (PPi p@(Imp _ _ _) n t sc) = PPi p n t (coninsert cs sc) + 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, (Name, PDecl))] -> [String] -> + [(Name, (Name, PDecl))] -> [String] -> [PDecl] -> [PDecl] insertDefaults i iname [] ns ds = ds - insertDefaults i iname ((n,(dn, clauses)) : defs) ns 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 iname decls | null $ filter (clauseFor meth iname ns) decls = let newd = expandParamsD False i (\n -> meth) [] [def] clauses in - -- trace (show newd) $ + -- trace (show newd) $ decls ++ [newd] | otherwise = decls @@ -1396,12 +1559,12 @@ checkInClass ns meth | not (null (filter (eqRoot meth) ns)) = return () - | otherwise = tclift $ tfail (At fc (Msg $ + | otherwise = tclift $ tfail (At fc (Msg $ show meth ++ " not a method of class " ++ show n)) eqRoot x y = nsroot x == nsroot y - clauseFor m iname ns (PClauses _ _ m' _) + clauseFor m iname ns (PClauses _ _ m' _) = decorate ns iname m == decorate ns iname m' clauseFor m iname ns _ = False @@ -1431,16 +1594,17 @@ -} decorateid decorate (PTy doc s f o n t) = PTy doc s f o (decorate n) t -decorateid decorate (PClauses f o n cs) +decorateid decorate (PClauses f o n cs) = PClauses f o (decorate n) (map dc cs) where dc (PClause fc n t as w ds) = PClause fc (decorate n) (dappname t) as w ds - dc (PWith fc n t as w ds) = PWith fc (decorate n) (dappname t) as w - (map (decorateid decorate) ds) + dc (PWith fc n t as w ds) + = PWith fc (decorate n) (dappname t) as w + (map (decorateid decorate) ds) dappname (PApp fc (PRef fc' n) as) = PApp fc (PRef fc' (decorate n)) as dappname t = t -pbinds (Bind n (PVar t) sc) = do attack; patbind n +pbinds (Bind n (PVar t) sc) = do attack; patbind n pbinds sc pbinds tm = return () @@ -1465,32 +1629,30 @@ -- mapM_ (elabDecl EDefns info) ds elabDecl :: ElabWhat -> ElabInfo -> PDecl -> Idris () -elabDecl what info d - = idrisCatch (elabDecl' what info d) - (\e -> do let msg = show e - setErrLine (getErrLine msg) - iputStrLn msg) +elabDecl what info d + = idrisCatch (elabDecl' what info d) (setAndReport) elabDecl' _ info (PFix _ _ _) = return () -- nothing to elaborate -elabDecl' _ info (PSyntax _ p) +elabDecl' _ info (PSyntax _ p) = return () -- nothing to elaborate -elabDecl' what info (PTy doc s f o n ty) +elabDecl' what info (PTy doc s f o n ty) | what /= EDefns = do iLOG $ "Elaborating type decl " ++ show n ++ show o elabType info s doc f o n ty -elabDecl' what info (PPostulate doc s f o n ty) + return () +elabDecl' what info (PPostulate doc s f o n ty) | what /= EDefns = do iLOG $ "Elaborating postulate " ++ show n ++ show o elabPostulate info s doc f o n ty -elabDecl' what info (PData doc s f co d) +elabDecl' what info (PData doc s f co d) | what /= ETypes = do iLOG $ "Elaborating " ++ show (d_name d) elabData info s doc f co d - | otherwise + | otherwise = do iLOG $ "Elaborating [type of] " ++ show (d_name d) elabData info s doc f co (PLaterdecl (d_name d) (d_tcon d)) -elabDecl' what info d@(PClauses f o n ps) +elabDecl' what info d@(PClauses f o n ps) | what /= ETypes = do iLOG $ "Elaborating clause " ++ show n i <- getIState -- get the type options too @@ -1498,7 +1660,7 @@ [fs] -> fs [] -> [] elabClauses info f (o ++ o') n ps -elabDecl' what info (PMutual f ps) +elabDecl' what info (PMutual f ps) = do mapM_ (elabDecl ETypes info) ps mapM_ (elabDecl EDefns info) ps -- Do totality checking after entire mutual block @@ -1510,32 +1672,32 @@ mapM_ checkDeclTotality (idris_totcheck i) clear_totcheck -elabDecl' what info (PParams f ns ps) +elabDecl' what info (PParams f ns ps) = do i <- getIState iLOG $ "Expanding params block with " ++ show ns ++ " decls " ++ show (concatMap tldeclared ps) let nblock = pblock i - mapM_ (elabDecl' what info) nblock + mapM_ (elabDecl' what info) nblock where pinfo = let ds = concatMap tldeclared ps newps = params info ++ ns dsParams = map (\n -> (n, map fst newps)) ds - newb = addAlist dsParams (inblock info) in + newb = addAlist dsParams (inblock info) in info { params = newps, inblock = newb } - pblock i = map (expandParamsD False i id ns + pblock i = map (expandParamsD False i id ns (concatMap tldeclared 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' what info (PClass doc s f cs n ps ds) + Just ns -> info { namespace = Just (n:ns) } +elabDecl' what info (PClass doc s f cs n ps ds) | what /= EDefns = do iLOG $ "Elaborating class " ++ show n elabClass info (s { syn_params = [] }) doc f cs n ps ds -elabDecl' what info (PInstance s f cs n ps t expn ds) +elabDecl' what info (PInstance s f cs n ps t expn ds) | what /= ETypes = do iLOG $ "Elaborating instance " ++ show n elabInstance info s f cs n ps t expn ds @@ -1543,27 +1705,27 @@ | what /= ETypes = do iLOG $ "Elaborating record " ++ show tyn elabRecord info s doc f tyn ty cdoc cn cty - | otherwise + | otherwise = do iLOG $ "Elaborating [type of] " ++ show tyn elabData info s doc f False (PLaterdecl tyn ty) elabDecl' _ info (PDSL n dsl) = do i <- getIState - putIState (i { idris_dsls = addDef n dsl (idris_dsls i) }) + putIState (i { idris_dsls = addDef n dsl (idris_dsls i) }) addIBC (IBCDSL n) -elabDecl' what info (PDirective i) +elabDecl' what info (PDirective i) | what /= EDefns = i elabDecl' what info (PProvider syn fc n tp tm) | what /= EDefns = do iLOG $ "Elaborating type provider " ++ show n elabProvider info syn fc n tp tm elabDecl' what info (PTransform fc safety old new) - = elabTransform info fc safety old new -elabDecl' _ _ _ = return () -- skipped this time + = elabTransform info fc safety old new +elabDecl' _ _ _ = return () -- skipped this time -elabCaseBlock info opts d@(PClauses f o n ps) +elabCaseBlock info opts d@(PClauses f o n ps) = do addIBC (IBCDef n) logLvl 6 $ "CASE BLOCK: " ++ show (n, d) - elabDecl' EAll info (PClauses f (nub (o ++ opts)) n ps ) + elabDecl' EAll info (PClauses f (nub (o ++ opts)) n ps ) -- elabDecl' info (PImport i) = loadModule i @@ -1577,9 +1739,9 @@ showImp Nothing True False user logLvl 10 $ "Checking match" i <- getIState - tclift $ case matchClause' True i user inf of + tclift $ case matchClause' True i user inf of _ -> return () --- Left (x, y) -> tfail $ At fc +-- Left (x, y) -> tfail $ At fc -- (Msg $ "The type-checked term and given term do not match: " -- ++ show x ++ " and " ++ show y) logLvl 10 $ "Checked match" @@ -1593,7 +1755,7 @@ do i <- getIState logLvl 6 $ "Checked to\n" ++ showImp Nothing True False inf ++ "\n" ++ showImp Nothing True False user - tclift $ case matchClause' True i user inf of + tclift $ case matchClause' True i user inf of Right vs -> return False Left (x, y) -> return True diff --git a/src/Idris/ElabTerm.hs b/src/Idris/ElabTerm.hs --- a/src/Idris/ElabTerm.hs +++ b/src/Idris/ElabTerm.hs @@ -5,6 +5,7 @@ import Idris.AbsSyntax import Idris.DSL import Idris.Delaborate +import Idris.ProofSearch import Core.Elaborate hiding (Tactic(..)) import Core.TT @@ -26,8 +27,6 @@ toplevel = EInfo [] emptyContext id Nothing -type ElabD a = Elab' [PDecl] a - -- Using the elaborator, convert a term in raw syntax to a fully -- elaborated, typechecked term. -- @@ -36,9 +35,9 @@ -- Also find deferred names in the term and their types -build :: IState -> ElabInfo -> Bool -> Name -> PTerm -> - ElabD (Term, [(Name, Type)], [PDecl]) -build ist info pattern fn tm +build :: IState -> ElabInfo -> Bool -> Name -> PTerm -> + ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl]) +build ist info pattern fn tm = do elab ist info pattern False fn tm ivs <- get_instances hs <- get_holes @@ -46,25 +45,26 @@ -- Resolve remaining type classes. Two passes - first to get the -- default Num instances, second to clean up the rest when (not pattern) $ - mapM_ (\n -> when (n `elem` hs) $ + mapM_ (\n -> when (n `elem` hs) $ do focus n try (resolveTC 7 fn ist) (movelast n)) ivs ivs <- get_instances hs <- get_holes when (not pattern) $ - mapM_ (\n -> when (n `elem` hs) $ + mapM_ (\n -> when (n `elem` hs) $ do focus n resolveTC 7 fn ist) ivs - probs <- get_probs tm <- get_term ctxt <- get_context + when (not pattern) $ do matchProblems; unifyProblems + probs <- get_probs case probs of [] -> return () ((_,_,_,e):es) -> lift (Error e) is <- getAux tt <- get_term - let (tm, ds) = runState (collectDeferred tt) [] + let (tm, ds) = runState (collectDeferred (Just fn) tt) [] log <- getLog if (log /= "") then trace log $ return (tm, ds, is) else return (tm, ds, is) @@ -73,9 +73,9 @@ -- (Separate, so we don't go overboard resolving things that we don't -- know about yet on the LHS of a pattern def) -buildTC :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm -> - ElabD (Term, [(Name, Type)], [PDecl]) -buildTC ist info pattern tcgen fn tm +buildTC :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm -> + ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl]) +buildTC ist info pattern tcgen fn tm = do elab ist info pattern tcgen fn tm probs <- get_probs tm <- get_term @@ -84,7 +84,7 @@ ((_,_,_,e):es) -> lift (Error e) is <- getAux tt <- get_term - let (tm, ds) = runState (collectDeferred tt) [] + let (tm, ds) = runState (collectDeferred (Just fn) tt) [] log <- getLog if (log /= "") then trace log $ return (tm, ds, is) else return (tm, ds, is) @@ -92,9 +92,9 @@ -- Returns the set of declarations we need to add to complete the definition -- (most likely case blocks to elaborate) -elab :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm -> +elab :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm -> ElabD () -elab ist info pattern tcgen fn tm +elab ist info pattern tcgen fn tm = do let loglvl = opt_logLevel (idris_options ist) when (loglvl > 5) $ unifyLog True compute -- expand type synonyms, etc @@ -125,15 +125,15 @@ elabE ina t = {- do g <- goal tm <- get_term - trace ("Elaborating " ++ show t ++ " : " ++ show g ++ "\n\tin " ++ show tm) - $ -} + trace ("Elaborating " ++ show t ++ " : " ++ show g ++ "\n\tin " ++ show tm) + $ -} do t' <- insertCoerce ina t g <- goal tm <- get_term ps <- get_probs hs <- get_holes -- trace ("Elaborating " ++ show t' ++ " in " ++ show g --- -- ++ "\n" ++ show tm +-- -- ++ "\n" ++ show tm -- ++ "\nholes " ++ show hs -- ++ "\nproblems " ++ show ps -- ++ "\n-----------\n") $ @@ -149,24 +149,24 @@ elab' ina (PTrue fc) = try (elab' ina (PRef fc unitCon)) (elab' ina (PRef fc unitTy)) elab' ina (PFalse fc) = elab' ina (PRef fc falseTy) - elab' ina (PResolveTC (FC "HACK" _)) -- for chasing parent classes + elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes = resolveTC 5 fn ist - elab' ina (PResolveTC fc) + elab' ina (PResolveTC fc) | True = do c <- unique_hole (MN 0 "class") instanceArg c | otherwise = do g <- goal try (resolveTC 2 fn ist) (do c <- unique_hole (MN 0 "class") instanceArg c) - elab' ina (PRefl fc t) + elab' ina (PRefl fc t) = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder True, pimp (MN 0 "x") t False]) - elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy) + elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy) [pimp (MN 0 "a") Placeholder True, pimp (MN 0 "b") Placeholder False, pexp l, pexp r]) - elab' ina@(_, a) (PPair fc l r) - = do hnf_compute + elab' ina@(_, a) (PPair fc l r) + = do hnf_compute g <- goal case g of TType _ -> elabE (True, a) (PApp fc (PRef fc pairTy) @@ -176,8 +176,8 @@ pimp (MN 0 "B") Placeholder True, pexp l, pexp r]) elab' ina (PDPair fc l@(PRef _ n) t r) - = case t of - Placeholder -> + = case t of + Placeholder -> do hnf_compute g <- goal case g of @@ -195,7 +195,7 @@ [pimp (MN 0 "a") t False, pimp (MN 0 "P") Placeholder True, pexp l, pexp r]) - elab' ina (PAlternative True as) + elab' ina (PAlternative True as) = do hnf_compute ty <- goal ctxt <- get_context @@ -207,13 +207,13 @@ tryAll (zip (map (elab' ina) as') (map showHd as')) where showHd (PApp _ h _) = show h showHd x = show x - elab' ina (PAlternative False as) + elab' ina (PAlternative False as) = trySeq as where -- if none work, take the error from the first trySeq (x : xs) = let e1 = elab' ina x in try' e1 (trySeq' e1 xs) True trySeq' deferr [] = proofFail deferr - trySeq' deferr (x : xs) + trySeq' deferr (x : xs) = try' (elab' ina x) (trySeq' deferr xs) True elab' ina (PPatvar fc n) | pattern = patvar n elab' (ina, guarded) (PRef fc n) | pattern && not (inparamBlock n) @@ -239,8 +239,8 @@ ptm <- get_term g <- goal checkPiGoal n - attack; intro (Just n); - -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm) + attack; intro (Just n); + -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm) elabE (True, a) sc; solve where repN n n' (PRef fc x) | x == n' = PRef fc n' repN _ _ t = t @@ -254,7 +254,7 @@ ptm <- get_term hs <- get_holes -- trace ("BEFORE:\n" ++ show hsin ++ "\n" ++ show ptmin ++ - -- "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $ + -- "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $ introTy (Var tyn) (Just n) -- end_unify focus tyn @@ -265,10 +265,10 @@ solve elab' ina@(_,a) (PPi _ n Placeholder sc) = do attack; arg n (MN 0 "ty"); elabE (True, a) sc; solve - elab' ina@(_,a) (PPi _ n ty sc) + elab' ina@(_,a) (PPi _ n ty sc) = do attack; tyn <- unique_hole (MN 0 "ty") claim tyn RType - n' <- case n of + n' <- case n of MN _ _ -> unique_hole n _ -> return n forall n' (Var tyn) @@ -310,8 +310,8 @@ computeLet n elabE (True, a) sc solve --- elab' ina (PLet n Placeholder --- (PApp fc r [pexp (delab ist rty)]) sc) +-- elab' ina (PLet n Placeholder +-- (PApp fc r [pexp (delab ist rty)]) sc) elab' ina tm@(PApp fc (PInferRef _ f) args) = do rty <- goal ds <- get_deferred @@ -330,10 +330,10 @@ mapM_ elabIArg (zip argTys args) where claimArgTys env [] = return [] claimArgTys env (arg : xs) | Just n <- localVar env (getTm arg) - = do nty <- get_type (Var n) + = do nty <- get_type (Var n) ans <- claimArgTys env xs return ((n, (False, forget nty)) : ans) - claimArgTys env (_ : xs) + claimArgTys env (_ : xs) = do an <- unique_hole (MN 0 "inf_argTy") aval <- unique_hole (MN 0 "inf_arg") claim an RType @@ -343,15 +343,15 @@ fnTy [] ret = forget ret fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi xt) (fnTy xs ret) - localVar env (PRef _ x) + localVar env (PRef _ x) = case lookup x env of Just _ -> Just x _ -> Nothing localVar env _ = Nothing - elabIArg ((n, (True, ty)), def) = do focus n; elabE ina (getTm def) + elabIArg ((n, (True, ty)), def) = do focus n; elabE ina (getTm def) elabIArg _ = return () -- already done, just a name - + mkN n@(NS _ _) = n mkN n@(SN _) = n mkN n = case namespace info of @@ -365,7 +365,7 @@ ns <- match_apply (Var fn') (map (\x -> (x,0)) imps) solve -- if f is local, just do a simple_app - elab' (ina, g) tm@(PApp fc (PRef _ f) args') + 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') _ -> -} args' @@ -373,11 +373,11 @@ env <- get_env if (f `elem` map fst env && length args' == 1) then -- simple app, as below - do simple_app (elabE (ina, g) (PRef fc f)) + do simple_app (elabE (ina, g) (PRef fc f)) (elabE (True, g) (getTm (head args'))) (show tm) solve - else + else do ivs <- get_instances ps <- get_probs -- HACK: we shouldn't resolve type classes if we're defining an instance @@ -393,8 +393,9 @@ ns <- apply (Var f) (map isph args) ptm <- get_term g <- goal - let (ns', eargs) = unzip $ - sortBy (\(_,x) (_,y) -> + -- Sort so that the implicit tactics go last + let (ns', eargs) = unzip $ + sortBy (\(_,x) (_,y) -> compare (priority x) (priority y)) (zip ns args) elabArgs (ina || not isinf, guarded) @@ -415,7 +416,7 @@ -- let insts = filter tcname $ map fst (ctxtAlist (tt_ctxt ist)) then try (resolveTC 7 fn ist) (movelast n) - else movelast n) + else movelast n) (ivs' \\ ivs) where tcArg (n, PConstraint _ _ Placeholder _) = True tcArg _ = False @@ -429,7 +430,7 @@ setInjective _ = return () elab' ina@(_, a) tm@(PApp fc f [arg]) - = erun fc $ + = erun fc $ do simple_app (elabE ina f) (elabE (True, a) (getTm arg)) (show tm) solve @@ -442,18 +443,18 @@ Just xs@(_:_) -> NS n xs _ -> n elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts - elab' ina (PTactics ts) + elab' ina (PTactics ts) | not pattern = do mapM_ (runTac False ist) ts | otherwise = elab' ina Placeholder elab' ina (PElabError e) = fail (pshow ist e) - elab' ina (PRewrite fc r sc newg) + elab' ina (PRewrite fc r sc newg) = do attack tyn <- unique_hole (MN 0 "rty") claim tyn RType valn <- unique_hole (MN 0 "rval") claim valn (Var tyn) letn <- unique_hole (MN 0 "rewrite_rule") - letbind letn (Var tyn) (Var valn) + letbind letn (Var tyn) (Var valn) focus valn elab' ina r compute @@ -493,7 +494,7 @@ cname <- unique_hole' True (mkCaseName fn) let cname' = mkN cname elab' ina (PMetavar cname') - let newdef = PClauses fc [] cname' + let newdef = PClauses fc [] cname' (caseBlock fc cname' (reverse args) opts) -- elaborate case env <- get_env @@ -505,7 +506,6 @@ mkCaseName n = SN (CaseN n) -- mkCaseName (UN x) = UN (x ++ "_case") -- mkCaseName (MN i x) = MN i (x ++ "_case") --- mkCaseName (SN s) = mkN n@(NS _ _) = n mkN n = case namespace info of Just xs@(_:_) -> NS n xs @@ -513,26 +513,31 @@ elab' ina (PUnifyLog t) = do unifyLog True elab' ina t unifyLog False - elab' ina x = fail $ "Something's gone wrong. Did you miss a semi-colon somewhere?" + elab' ina x = fail $ "Unelaboratable syntactic form " ++ show x - caseBlock :: FC -> Name -> [(Name, Binder Term)] -> + caseBlock :: FC -> Name -> [(Name, Binder Term)] -> [(PTerm, PTerm)] -> [PClause] - caseBlock fc n env opts + caseBlock fc n env opts = let args = map mkarg (map fst (init env)) in map (mkClause args) opts where -- mkarg (MN _ _) = Placeholder mkarg n = PRef fc n -- may be shadowed names in the new pattern - so replace the -- old ones with an _ - mkClause args (l, r) + mkClause args (l, r) = let args' = map (shadowed (allNamesIn l)) args - lhs = PApp fc (PRef fc n) + lhs = PApp (getFC fc l) (PRef (getFC fc l) n) (map pexp args' ++ [pexp l]) in - PClause fc n lhs [] r [] + PClause (getFC fc l) n lhs [] r [] shadowed new (PRef _ n) | n `elem` new = Placeholder shadowed new t = t + getFC d (PApp fc _ _) = fc + getFC d (PRef fc _) = fc + getFC d (PAlternative _ (x:_)) = getFC d x + getFC d x = d + insertCoerce ina t = do ty <- goal -- Check for possible coercions to get to the goal @@ -546,26 +551,26 @@ (_, cs) -> PAlternative False [t , PAlternative True (map (mkCoerce t) cs)] return t' - where - mkCoerce t n = let fc = FC "Coercion" 0 in -- line never appears! + where + mkCoerce t n = let fc = fileFC "Coercion" in -- line never appears! addImpl ist (PApp fc (PRef fc n) [pexp (PCoerced t)]) elabArgs ina failed fc retry [] _ -- | retry = let (ns, ts) = unzip (reverse failed) in -- elabArgs ina [] False ns ts | otherwise = return () - elabArgs ina failed fc r (n:ns) ((_, Placeholder) : args) + elabArgs ina failed fc r (n:ns) ((_, Placeholder) : args) = elabArgs ina failed fc r ns args elabArgs ina failed fc r (n:ns) ((lazy, t) : args) | lazy && not pattern = do elabArg n (PApp bi (PRef bi (UN "lazy")) [pimp (UN "a") Placeholder True, - pexp t]); + pexp t]); | otherwise = elabArg n t - where elabArg n t + where elabArg n t = do hs <- get_holes tm <- get_term - failed' <- -- trace (show (n, t, hs, tm)) $ + failed' <- -- trace (show (n, t, hs, tm)) $ -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $ case n `elem` hs of True -> @@ -582,7 +587,7 @@ pruneAlt :: [PTerm] -> [PTerm] pruneAlt xs = map prune xs where - prune (PApp fc1 (PRef fc2 f) as) + prune (PApp fc1 (PRef fc2 f) as) = PApp fc1 (PRef fc2 f) (fmap (fmap (choose f)) as) prune t = t @@ -602,11 +607,11 @@ -- Rule out alternatives that don't return the same type as the head of the goal -- (If there are none left as a result, do nothing) pruneByType :: Term -> Context -> [PTerm] -> [PTerm] -pruneByType (P _ n _) c as +pruneByType (P _ n _) c as -- if the goal type is polymorphic, keep e | [] <- lookupTy n c = as - | otherwise - = let asV = filter (headIs True n) as + | otherwise + = let asV = filter (headIs True n) as as' = filter (headIs False n) as in case as' of [] -> case asV of @@ -619,7 +624,7 @@ headIs var f (PPi _ _ _ sc) = headIs var f sc headIs _ _ _ = True -- keep if it's not an application - typeHead var f f' + typeHead var f f' = case lookupTy f' c of [ty] -> let ty' = normalise c [] ty in case unApply (getRetTy ty') of @@ -630,44 +635,30 @@ pruneByType t _ as = as -trivial :: IState -> ElabD () -trivial ist = try' (do elab ist toplevel False False (MN 0 "tac") - (PRefl (FC "prf" 0) Placeholder) - return ()) - (do env <- get_env - g <- goal - tryAll env - return ()) True - where - tryAll [] = fail "No trivial solution" - tryAll ((x, b):xs) - = do -- if type of x has any holes in it, move on - hs <- get_holes - g <- goal - if all (\n -> not (n `elem` hs)) (freeNames (binderTy b)) - then try' (elab ist toplevel False False - (MN 0 "tac") (PRef (FC "prf" 0) x)) - (tryAll xs) True - else tryAll xs - findInstances :: IState -> Term -> [Name] -findInstances ist t - | (P _ n _, _) <- unApply t +findInstances ist t + | (P _ n _, _) <- unApply t = case lookupCtxt n (idris_classes ist) of [CI _ _ _ _ ins] -> ins _ -> [] | otherwise = [] +trivial' ist + = trivial (elab ist toplevel False False (MN 0 "tac")) ist +proofSearch' ist top n hints + = proofSearch (elab ist toplevel False False (MN 0 "tac")) top n hints ist + + resolveTC :: Int -> Name -> IState -> ElabD () resolveTC 0 fn ist = fail $ "Can't resolve type class" -resolveTC 1 fn ist = try' (trivial ist) (resolveTC 0 fn ist) True -resolveTC depth fn ist +resolveTC 1 fn ist = try' (trivial' ist) (resolveTC 0 fn ist) True +resolveTC depth fn ist = do hnf_compute g <- goal ptm <- get_term - hs <- get_holes + hs <- get_holes if True -- all (\n -> not (n `elem` hs)) (freeNames g) - then try' (trivial ist) + then try' (trivial' ist) (do t <- goal let (tc, ttypes) = unApply t scopeOnly <- needsDefault t tc ttypes @@ -680,7 +671,7 @@ -- if scopeOnly then fail "Can't resolve" else let depth' = if scopeOnly then 2 else depth blunderbuss t depth' insts) True - else do try' (trivial ist) + else do try' (trivial' ist) (do g <- goal fail $ "Can't resolve " ++ show g) True -- tm <- get_term @@ -696,7 +687,7 @@ chaser (NS n _) = chaser n chaser _ = False - needsDefault t num@(P _ (NS (UN "Num") ["Builtins"]) _) [P Bound a _] + needsDefault t num@(P _ (NS (UN "Num") ["Classes","Prelude"]) _) [P Bound a _] = do focus a fill (RConstant (AType (ATInt ITBig))) -- default Integer solve @@ -711,24 +702,26 @@ blunderbuss t d [] = do -- c <- get_env -- ps <- get_probs lift $ tfail $ CantResolve t - blunderbuss t d (n:ns) + blunderbuss t d (n:ns) | n /= fn && tcname n = try' (resolve n d) (blunderbuss t d ns) True | otherwise = blunderbuss t d ns resolve n depth | depth == 0 = fail $ "Can't resolve type class" - | otherwise + | otherwise = do t <- goal let (tc, ttypes) = unApply t --- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist +-- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist -- else do -- if there's a hole in the goal, don't even try let imps = case lookupCtxtName n (idris_implicits ist) of [] -> [] [args] -> map isImp (snd args) -- won't be overloaded! ps <- get_probs - args <- match_apply (Var n) imps + tm <- get_term + args <- try' (match_apply (Var n) imps) + (apply (Var n) imps) True ps' <- get_probs when (length ps < length ps') $ fail "Can't apply type class" -- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $ @@ -736,7 +729,7 @@ t' <- goal let (tc', ttype) = unApply t' let depth' = if t == t' then depth - 1 else depth - resolveTC depth' fn ist) + resolveTC depth' fn ist) (filter (\ (x, y) -> not x) (zip (map fst imps) args)) -- if there's any arguments left, we've failed to resolve hs <- get_holes @@ -744,29 +737,30 @@ where isImp (PImp p _ _ _ _ _) = (True, p) isImp arg = (False, priority arg) -collectDeferred :: Term -> State [(Name, Type)] Term -collectDeferred (Bind n (GHole t) app) = +collectDeferred :: Maybe Name -> + Term -> State [(Name, (Int, Maybe Name, Type))] Term +collectDeferred top (Bind n (GHole i t) app) = do ds <- get - when (not (n `elem` map fst ds)) $ put ((n, t) : ds) - collectDeferred app -collectDeferred (Bind n b t) = do b' <- cdb b - t' <- collectDeferred t - return (Bind n b' t') + when (not (n `elem` map fst ds)) $ put ((n, (i, top, t)) : ds) + collectDeferred top app +collectDeferred top (Bind n b t) = do b' <- cdb b + t' <- collectDeferred top t + return (Bind n b' t') where - cdb (Let t v) = liftM2 Let (collectDeferred t) (collectDeferred v) - cdb (Guess t v) = liftM2 Guess (collectDeferred t) (collectDeferred v) - cdb b = do ty' <- collectDeferred (binderTy b) + cdb (Let t v) = liftM2 Let (collectDeferred top t) (collectDeferred top v) + cdb (Guess t v) = liftM2 Guess (collectDeferred top t) (collectDeferred top v) + cdb b = do ty' <- collectDeferred top (binderTy b) return (b { binderTy = ty' }) -collectDeferred (App f a) = liftM2 App (collectDeferred f) (collectDeferred a) -collectDeferred t = return t +collectDeferred top (App f a) = liftM2 App (collectDeferred top f) (collectDeferred top a) +collectDeferred top t = return t -- Running tactics directly -- if a tactic adds unification problems, return an error runTac :: Bool -> IState -> PTactic -> ElabD () -runTac autoSolve ist tac +runTac autoSolve ist tac = do env <- get_env - no_errors $ runT (fmap (addImplBound ist (map fst env)) tac) + no_errors $ runT (fmap (addImplBound ist (map fst env)) tac) where runT (Intro []) = do g <- goal attack; intro (bname g) @@ -783,8 +777,8 @@ bname _ = Nothing runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm when autoSolve solveAll - runT (MatchRefine fn) - = do fnimps <- + runT (MatchRefine fn) + = do fnimps <- case lookupCtxtName fn (idris_implicits ist) of [] -> do a <- envArgs fn return [(fn, a)] @@ -799,8 +793,8 @@ Just t -> return $ map (const False) (getArgTys (binderTy t)) _ -> return [] - runT (Refine fn []) - = do fnimps <- + runT (Refine fn []) + = do fnimps <- case lookupCtxtName fn (idris_implicits ist) of [] -> do a <- envArgs fn return [(fn, a)] @@ -819,7 +813,7 @@ _ -> return [] runT (Refine fn imps) = do ns <- apply (Var fn) (map (\x -> (x,0)) imps) when autoSolve solveAll - runT (Equiv tm) -- let bind tm, then + runT (Equiv tm) -- let bind tm, then = do attack tyn <- unique_hole (MN 0 "ety") claim tyn RType @@ -839,7 +833,7 @@ valn <- unique_hole (MN 0 "rval") claim valn (Var tyn) letn <- unique_hole (MN 0 "rewrite_rule") - letbind letn (Var tyn) (Var valn) + letbind letn (Var tyn) (Var valn) focus valn elab ist toplevel False False (MN 0 "tac") tm rewrite (Var letn) @@ -869,7 +863,9 @@ elab ist toplevel False False (MN 0 "tac") tm when autoSolve solveAll runT Compute = compute - runT Trivial = do trivial ist; when autoSolve solveAll + runT Trivial = do trivial' ist; when autoSolve solveAll + runT (ProofSearch top n hints) + = do proofSearch' ist top n hints; when autoSolve solveAll runT (Focus n) = focus n runT Solve = solve runT (Try l r) = do try' (runT l) (runT r) True @@ -889,7 +885,7 @@ restac <- unique_hole (MN 0 "restac") claim restac tacticTy focus restac - fill (raw_apply (forget script') + fill (raw_apply (forget script') [reflectEnv tenv, reflect tgoal]) restac' <- get_guess solve @@ -901,9 +897,9 @@ runReflected tactic where tacticTy = Var (reflm "Tactic") listTy = Var (NS (UN "List") ["List", "Prelude"]) - scriptTy = (RBind (UN "__pi_arg") + scriptTy = (RBind (UN "__pi_arg") (Pi (RApp listTy envTupleType)) - (RBind (UN "__pi_arg1") + (RBind (UN "__pi_arg1") (Pi (Var $ reflm "TT")) tacticTy)) runT (Reflect v) = do attack -- let x = reflect v in ... @@ -937,11 +933,13 @@ runTac autoSolve ist (Exact $ PQuote rawValue) runT (GoalType n tac) = do g <- goal case unApply g of - (P _ n' _, _) -> + (P _ n' _, _) -> if nsroot n' == UN n then runT tac else fail "Wrong goal type" _ -> fail "Wrong goal type" + runT ProofState = do g <- goal + trace (show g) $ return () runT x = fail $ "Not implemented " ++ show x runReflected t = do t' <- reify ist t @@ -972,7 +970,7 @@ | t == reflm "GoalType" = liftM (GoalType n) (reify ist x) reifyApp _ t [Constant (Str n)] | t == reflm "Intro" = return $ Intro [UN n] -reifyApp ist t [t'] +reifyApp ist t [t'] | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t') reifyApp ist t [t'] | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t') @@ -1074,9 +1072,9 @@ reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args)) reifyTTNamespace :: Term -> ElabD [String] -reifyTTNamespace t@(App _ _) +reifyTTNamespace t@(App _ _) = case unApply t of - (P _ f _, [Constant StrType]) + (P _ f _, [Constant StrType]) | f == NS (UN "Nil") ["List", "Prelude"] -> return [] (P _ f _, [Constant StrType, Constant (Str n), ns]) | f == NS (UN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns) @@ -1097,7 +1095,7 @@ reifyTTBinder :: (Term -> ElabD a) -> Name -> Term -> ElabD (Binder a) reifyTTBinder reificator binderType t@(App _ _) = case unApply t of - (P _ f _, bt:args) | forget bt == Var binderType + (P _ f _, bt:args) | forget bt == Var binderType -> reifyTTBinderApp reificator f args _ -> fail ("Mismatching binder reflection: " ++ show t) reifyTTBinder _ _ t = fail ("Unknown reflection binder: " ++ show t) @@ -1114,7 +1112,7 @@ reifyTTBinderApp reif f [t] | f == reflm "Hole" = liftM Hole (reif t) reifyTTBinderApp reif f [t] - | f == reflm "GHole" = liftM GHole (reif t) + | f == reflm "GHole" = liftM (GHole 0) (reif t) reifyTTBinderApp reif f [x, y] | f == reflm "Guess" = liftM2 Guess (reif x) (reif y) reifyTTBinderApp reif f [t] @@ -1171,14 +1169,14 @@ -- | Create a reflected call to a named function/constructor reflCall :: String -> [Raw] -> Raw -reflCall funName args +reflCall funName args = raw_apply (Var (reflm funName)) args -- | Lift a term into its Language.Reflection.TT representation reflect :: Term -> Raw -reflect (P nt n t) +reflect (P nt n t) = reflCall "P" [reflectNameType nt, reflectName n, reflect t] -reflect (V n) +reflect (V n) = reflCall "V" [RConstant (I n)] reflect (Bind n b x) = reflCall "Bind" [reflectName n, reflectBinder b, reflect x] @@ -1195,24 +1193,24 @@ reflectNameType :: NameType -> Raw reflectNameType (Bound) = Var (reflm "Bound") reflectNameType (Ref) = Var (reflm "Ref") -reflectNameType (DCon x y) +reflectNameType (DCon x y) = reflCall "DCon" [RConstant (I x), RConstant (I y)] -reflectNameType (TCon x y) +reflectNameType (TCon x y) = reflCall "TCon" [RConstant (I x), RConstant (I y)] reflectName :: Name -> Raw -reflectName (UN str) +reflectName (UN str) = reflCall "UN" [RConstant (Str str)] reflectName (NS n ns) = reflCall "NS" [ reflectName n - , foldr (\ n s -> + , foldr (\ n s -> raw_apply ( Var $ NS (UN "::") ["List", "Prelude"] ) [ RConstant StrType, RConstant (Str n), s ]) ( raw_apply ( Var $ NS (UN "Nil") ["List", "Prelude"] ) [ RConstant StrType ]) - ns - ] -reflectName (MN i n) + ns + ] +reflectName (MN i n) = reflCall "MN" [RConstant (I i), RConstant (Str n)] reflectName (NErased) = Var (reflm "NErased") reflectName n = Var (reflm "NErased") -- special name, not yet implemented @@ -1228,7 +1226,7 @@ = reflCall "NLet" [Var (reflm "TT"), reflect x, reflect y] reflectBinder (Hole t) = reflCall "Hole" [Var (reflm "TT"), reflect t] -reflectBinder (GHole t) +reflectBinder (GHole _ t) = reflCall "GHole" [Var (reflm "TT"), reflect t] reflectBinder (Guess x y) = reflCall "Guess" [Var (reflm "TT"), reflect x, reflect y] @@ -1273,16 +1271,16 @@ = raw_apply (Var (NS (UN "::") ["List", "Prelude"])) [ envTupleType , raw_apply (Var pairCon) [ (Var $ reflm "TTName") - , (RApp (Var $ reflm "Binder") + , (RApp (Var $ reflm "Binder") (Var $ reflm "TT")) - , reflectName n + , reflectName n , reflectBinder b ] , l ] emptyEnvList :: Raw - emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"])) + emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"])) [envTupleType] -- | Reflect an error into the internal datatype of Idris -- TODO @@ -1292,8 +1290,8 @@ reflectErr x = trace ("Couldn't reflect error " ++ show x) raw_apply (Var (NS (UN "Msg") ["Reflection", "Language"])) [reflectConstant (Str $ show x)] envTupleType :: Raw -envTupleType - = raw_apply (Var pairTy) [ (Var $ reflm "TTName") +envTupleType + = raw_apply (Var pairTy) [ (Var $ reflm "TTName") , (RApp (Var $ reflm "Binder") (Var $ reflm "TT")) ] @@ -1325,7 +1323,7 @@ let g' = g -- specialise ctxt env ntimes g return tm' -- trace (show t ++ "\n" ++ --- show ntimes ++ "\n" ++ +-- show ntimes ++ "\n" ++ -- show (delab i g) ++ "\n" ++ show (delab i g')) $ return tm' -- TODO else return tm' where @@ -1333,7 +1331,7 @@ cg = idris_callgraph i staticFnNames tm | (P _ f _, as) <- unApply tm - = if not (isFnName f ctxt) then [] + = if not (isFnName f ctxt) then [] else case lookupCtxt f cg of [ns] -> f : f : [] --(ns \\ [f]) [] -> [f,f] diff --git a/src/Idris/Error.hs b/src/Idris/Error.hs --- a/src/Idris/Error.hs +++ b/src/Idris/Error.hs @@ -13,6 +13,7 @@ import System.Console.Haskeline import System.Console.Haskeline.MonadException import Control.Monad.State +import Control.Monad.Error (throwError, catchError) import System.IO.Error(isUserError, ioeGetErrorString) import Data.Char import Data.Typeable @@ -21,53 +22,52 @@ iucheck = do tit <- typeInType when (not tit) $ do ist <- getIState - idrisCatch (tclift $ ucheck (idris_constraints ist)) - (\e -> do let msg = show e - setErrLine (getErrLine msg) - iputStrLn msg) + (tclift $ ucheck (idris_constraints ist)) `idrisCatch` + (\e -> do setErrLine (getErrLine e) + iputStrLn (pshow ist e)) +showErr :: Err -> Idris String +showErr e = getIState >>= return . flip pshow e + + report :: IOError -> String report e - | isUserError e = ioeGetErrorString e + | isUserError e = ioeGetErrorString e | otherwise = show e -idrisCatch :: Idris a -> (SomeException -> Idris a) -> Idris a -idrisCatch = catch - -data IdrisErr = IErr String - deriving Typeable - -instance Show IdrisErr where - show (IErr s) = s +idrisCatch :: Idris a -> (Err -> Idris a) -> Idris a +idrisCatch = catchError -instance Exception IdrisErr +setAndReport :: Err -> Idris () +setAndReport e = do ist <- getIState + let h = idris_outh ist + case e of + At fc@(FC f l c) e -> do setErrLine l + ihWarn h fc $ pshow ist e + _ -> do setErrLine (getErrLine e) + ihputStrLn h $ pshow ist e -ifail :: String -> Idris () -ifail str = throwIO (IErr str) +ifail :: String -> Idris a +ifail = throwError . Msg ierror :: Err -> Idris a -ierror err = do i <- getIState - throwIO (IErr $ pshow i err) +ierror = throwError tclift :: TC a -> Idris a -tclift tc = case tc of - OK v -> return v - Error err -> do i <- getIState - case err of - At (FC f l) e -> setErrLine l - _ -> return () - throwIO (IErr $ pshow i err) +tclift (OK v) = return v +tclift (Error err@(At (FC f l c) e)) = do setErrLine l ; throwError err +tclift (Error err) = throwError err tctry :: TC a -> TC a -> Idris a -tctry tc1 tc2 +tctry tc1 tc2 = case tc1 of OK v -> return v Error err -> tclift tc2 -getErrLine str - = case span (/=':') str of - (_, ':':rest) -> case span isDigit rest of - ([], _) -> 0 - (num, _) -> read num - _ -> 0 +getErrLine :: Err -> Int +getErrLine (At (FC _ l _) _) = l +getErrLine _ = 0 +getErrColumn :: Err -> Int +getErrColumn (At (FC _ _ c) _) = c +getErrColumn _ = 0 diff --git a/src/Idris/Help.hs b/src/Idris/Help.hs --- a/src/Idris/Help.hs +++ b/src/Idris/Help.hs @@ -1,4 +1,4 @@ -module Idris.Help (CmdArg(..), help) where +module Idris.Help (CmdArg(..), help, extraHelp) where data CmdArg = ExprArg -- ^ The command takes an expression | NameArg -- ^ The command takes a name @@ -26,6 +26,7 @@ [ ([""], NoArg, "Evaluate an expression"), ([":t"], ExprArg, "Check the type of an expression"), ([":miss", ":missing"], NameArg, "Show missing clauses"), + ([":doc"], NameArg, "Show internal documentation"), ([":i", ":info"], NameArg, "Display information about a type class"), ([":total"], NameArg, "Check the totality of a name"), ([":r",":reload"], NoArg, "Reload current file"), @@ -51,3 +52,20 @@ ([":colour", ":color"], ColourArg, "Turn REPL colours on or off; set a specific colour"), ([":q",":quit"], NoArg, "Exit the Idris system") ] + +-- | Use these for completion, but don't show them in :help +extraHelp ::[([String], CmdArg, String)] +extraHelp = + [ ([":casesplit", ":cs"], NoArg, ":cs splits the pattern variable on the line") + , ([":casesplit!", ":cs!"], NoArg, ":cs! destructively splits the pattern variable on the line") + , ([":addclause", ":ac"], NoArg, ":ac adds a clause for the definition of the name on the line") + , ([":addclause!", ":ac!"], NoArg, ":ac! destructively adds a clause for the definition of the name on the line") + , ([":addmissing", ":am"], NoArg, ":am adds all missing pattern matches for the name on the line") + , ([":addmissing!", ":am!"], NoArg, ":am! destructively adds all missing pattern matches for the name on the line") + , ([":makewith", ":mw"], NoArg, ":mw adds a with clause for the definition of the name on the line") + , ([":makewith!", ":mw!"], NoArg, ":mw! destructively adds a with clause for the definition of the name on the line") + , ([":proofsearch", ":ps"], NoArg, ":ps does proof search for name on line, with names as hints") + , ([":proofsearch!", ":ps!"], NoArg, ":ps! destructively does proof search for name on line, with names as hints") + , ([":addproofclause", ":apc"], NoArg, ":apc adds a pattern-matching proof clause to name on line") + , ([":addproofclause!", ":apc!"], NoArg, ":apc! destructively adds a pattern-matching proof clause to name on line") + ] diff --git a/src/Idris/IBC.hs b/src/Idris/IBC.hs --- a/src/Idris/IBC.hs +++ b/src/Idris/IBC.hs @@ -23,7 +23,7 @@ import Paths_idris ibcVersion :: Word8 -ibcVersion = 41 +ibcVersion = 44 data IBCFile = IBCFile { ver :: Word8, sourcefile :: FilePath, @@ -50,31 +50,32 @@ ibc_defs :: [(Name, Def)], ibc_docstrings :: [(Name, String)], ibc_transforms :: [(Term, Term)], - ibc_coercions :: [Name] + ibc_coercions :: [Name], + ibc_lineapps :: [(FilePath, Int, PTerm)] } deriving Show -{-! -deriving instance Binary IBCFile +{-! +deriving instance Binary IBCFile !-} initIBC :: IBCFile -initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] +initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] loadIBC :: FilePath -> Idris () loadIBC fp = do iLOG $ "Loading ibc " ++ fp - ibcf <- liftIO $ (decodeFile fp :: IO IBCFile) + ibcf <- runIO $ (decodeFile fp :: IO IBCFile) process ibcf fp writeIBC :: FilePath -> FilePath -> Idris () -writeIBC src f +writeIBC src f = do iLOG $ "Writing ibc " ++ show f i <- getIState - case idris_metavars i \\ primDefs of - (_:_) -> fail "Can't write ibc when there are unsolved metavariables" + case (Data.List.map fst (idris_metavars i)) \\ primDefs of + (_:_) -> ifail "Can't write ibc when there are unsolved metavariables" [] -> return () - ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src }) - idrisCatch (do liftIO $ createDirectoryIfMissing True (dropFileName f) - liftIO $ encodeFile f ibcf + ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src }) + idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f) + runIO $ encodeFile f ibcf iLOG "Written") (\c -> do iLOG $ "Failed " ++ show c) return () @@ -86,31 +87,32 @@ f' <- ibc ist i f mkIBC is f' -ibc i (IBCFix d) f = return f { ibc_fixes = d : ibc_fixes f } +ibc :: IState -> IBCWrite -> IBCFile -> Idris IBCFile +ibc i (IBCFix d) f = return f { ibc_fixes = d : ibc_fixes f } ibc i (IBCImp n) f = case lookupCtxt n (idris_implicits i) of [v] -> return f { ibc_implicits = (n,v): ibc_implicits f } - _ -> fail "IBC write failed" -ibc i (IBCStatic n) f + _ -> ifail "IBC write failed" +ibc i (IBCStatic n) f = case lookupCtxt n (idris_statics i) of [v] -> return f { ibc_statics = (n,v): ibc_statics f } - _ -> fail "IBC write failed" -ibc i (IBCClass n) f + _ -> ifail "IBC write failed" +ibc i (IBCClass n) f = case lookupCtxt n (idris_classes i) of [v] -> return f { ibc_classes = (n,v): ibc_classes f } - _ -> fail "IBC write failed" -ibc i (IBCInstance int n ins) f + _ -> ifail "IBC write failed" +ibc i (IBCInstance int n ins) f = return f { ibc_instances = (int,n,ins): ibc_instances f } -ibc i (IBCDSL n) f +ibc i (IBCDSL n) f = case lookupCtxt n (idris_dsls i) of [v] -> return f { ibc_dsls = (n,v): ibc_dsls f } - _ -> fail "IBC write failed" -ibc i (IBCData n) f + _ -> ifail "IBC write failed" +ibc i (IBCData n) f = case lookupCtxt n (idris_datatypes i) of [v] -> return f { ibc_datatypes = (n,v): ibc_datatypes f } - _ -> fail "IBC write failed" + _ -> ifail "IBC write failed" ibc i (IBCOpt n) f = case lookupCtxt n (idris_optimisation i) of [v] -> return f { ibc_optimise = (n,v): ibc_optimise f } - _ -> fail "IBC write failed" + _ -> ifail "IBC write failed" ibc i (IBCSyntax n) f = return f { ibc_syntax = n : ibc_syntax f } ibc i (IBCKeyword n) f = return f { ibc_keywords = n : ibc_keywords f } ibc i (IBCImport n) f = return f { ibc_imports = n : ibc_imports f } @@ -121,26 +123,28 @@ ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f } ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of [v] -> return f { ibc_defs = (n,v) : ibc_defs f } - _ -> fail "IBC write failed" + _ -> ifail "IBC write failed" ibc i (IBCDoc n) f = case lookupCtxt n (idris_docstrings i) of [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f } - _ -> fail "IBC write failed" + _ -> ifail "IBC write failed" ibc i (IBCCG n) f = case lookupCtxt n (idris_callgraph i) of [v] -> return f { ibc_cg = (n,v) : ibc_cg f } - _ -> fail "IBC write failed" + _ -> ifail "IBC write failed" ibc i (IBCCoercion n) f = return f { ibc_coercions = n : ibc_coercions f } ibc i (IBCAccess n a) f = return f { ibc_access = (n,a) : ibc_access f } ibc i (IBCFlags n a) f = return f { ibc_flags = (n,a) : ibc_flags f } ibc i (IBCTotal n a) f = return f { ibc_total = (n,a) : ibc_total f } ibc i (IBCTrans t) f = return f { ibc_transforms = t : ibc_transforms f } +ibc i (IBCLineApp fp l t) f + = return f { ibc_lineapps = (fp,l,t) : ibc_lineapps f } process :: IBCFile -> FilePath -> Idris () process i fn | ver i /= ibcVersion = do iLOG "ibc out of date" - fail "Incorrect ibc version --- please rebuild" + ifail "Incorrect ibc version --- please rebuild" | otherwise = - do srcok <- liftIO $ doesFileExist (sourcefile i) - when srcok $ liftIO $ timestampOlder (sourcefile i) fn + do srcok <- runIO $ doesFileExist (sourcefile i) + when srcok $ runIO $ timestampOlder (sourcefile i) fn v <- verbose quiet <- getQuiet -- when (v && srcok && not quiet) $ iputStrLn $ "Skipping " ++ sourcefile i @@ -167,6 +171,7 @@ pDocs (ibc_docstrings i) pCoercions (ibc_coercions i) pTrans (ibc_transforms i) + pLineApps (ibc_lineapps i) timestampOlder :: FilePath -> FilePath -> IO () timestampOlder src ibc = do srct <- getModificationTime src @@ -176,26 +181,26 @@ else return () pImports :: [FilePath] -> Idris () -pImports fs +pImports fs = do mapM_ (\f -> do i <- getIState ibcsd <- valIBCSubDir i ids <- allImportDirs - fp <- liftIO $ findImport ids ibcsd f + fp <- runIO $ findImport ids ibcsd f if (f `elem` imported i) then iLOG $ "Already read " ++ f else do putIState (i { imported = f : imported i }) - case fp of + case fp of LIDR fn -> do iLOG $ "Failed at " ++ fn - fail "Must be an ibc" + ifail "Must be an ibc" IDR fn -> do iLOG $ "Failed at " ++ fn - fail "Must be an ibc" - IBC fn src -> loadIBC fn) + ifail "Must be an ibc" + IBC fn src -> loadIBC fn) fs pImps :: [(Name, [PArg])] -> Idris () -pImps imps = mapM_ (\ (n, imp) -> +pImps imps = mapM_ (\ (n, imp) -> do i <- getIState - putIState (i { idris_implicits + putIState (i { idris_implicits = addDef n imp (idris_implicits i) })) imps @@ -211,7 +216,7 @@ ss pClasses :: [(Name, ClassInfo)] -> Idris () -pClasses cs = mapM_ (\ (n, c) -> +pClasses cs = mapM_ (\ (n, c) -> do i <- getIState -- Don't lose instances from previous IBCs, which -- could have loaded in any order @@ -258,7 +263,7 @@ pObjs :: [(Codegen, FilePath)] -> Idris () pObjs os = mapM_ (\ (cg, obj) -> do dirs <- allImportDirs - o <- liftIO $ findInPath dirs obj + o <- runIO $ findInPath dirs obj addObjectFile cg o) os pLibs :: [(Codegen, String)] -> Idris () @@ -272,17 +277,17 @@ mapM_ checkLoad res return () where checkLoad (Left _) = return () - checkLoad (Right err) = fail err + checkLoad (Right err) = ifail err pHdrs :: [(Codegen, String)] -> Idris () pHdrs hs = mapM_ (uncurry addHdr) hs pDefs :: [(Name, Def)] -> Idris () -pDefs ds = mapM_ (\ (n, d) -> +pDefs ds = mapM_ (\ (n, d) -> do i <- getIState logLvl 5 $ "Added " ++ show (n, d) putIState (i { tt_ctxt = addCtxtDef n d (tt_ctxt i) })) - ds + ds pDocs :: [(Name, String)] -> Idris () pDocs ds = mapM_ (\ (n, a) -> addDocStr n a) ds @@ -311,6 +316,9 @@ pTrans :: [(Term, Term)] -> Idris () pTrans ts = mapM_ addTrans ts +pLineApps :: [(FilePath, Int, PTerm)] -> Idris () +pLineApps ls = mapM_ (\ (f, i, t) -> addInternalApp f i t) ls + ----- Generated by 'derive' instance Binary SizeChange where @@ -345,15 +353,17 @@ return (CGInfo x1 x2 x3 x4 x5) instance Binary FC where - put (FC x1 x2) + put (FC x1 x2 x3) = do put x1 put x2 + put x3 get = do x1 <- get x2 <- get - return (FC x1 x2) + x3 <- get + return (FC x1 x2 x3) - + instance Binary Name where put x = case x of @@ -498,7 +508,7 @@ _ -> error "Corrupted binary data for Const" - + instance Binary Raw where put x = case x of @@ -535,7 +545,7 @@ return (RForce x1) _ -> error "Corrupted binary data for Raw" - + instance (Binary b) => Binary (Binder b) where put x = case x of @@ -551,8 +561,9 @@ put x2 Hole x1 -> do putWord8 4 put x1 - GHole x1 -> do putWord8 5 - put x1 + GHole x1 x2 -> do putWord8 5 + put x1 + put x2 Guess x1 x2 -> do putWord8 6 put x1 put x2 @@ -576,7 +587,8 @@ 4 -> do x1 <- get return (Hole x1) 5 -> do x1 <- get - return (GHole x1) + x2 <- get + return (GHole x1 x2) 6 -> do x1 <- get x2 <- get return (Guess x1 x2) @@ -586,7 +598,7 @@ return (PVTy x1) _ -> error "Corrupted binary data for Binder" - + instance Binary NameType where put x = case x of @@ -614,7 +626,7 @@ instance {-(Binary n) =>-} Binary (TT Name) where put x - = {-# SCC "putTT" #-} + = {-# SCC "putTT" #-} case x of P x1 x2 x3 -> do putWord8 0 put x1 @@ -693,12 +705,12 @@ 3 -> do x1 <- get return (UnmatchedCase x1) 4 -> return ImpossibleCase - _ -> error "Corrupted binary data for SC" + _ -> error "Corrupted binary data for SC" - + instance Binary CaseAlt where put x - = {-# SCC "putCaseAlt" #-} + = {-# SCC "putCaseAlt" #-} case x of ConCase x1 x2 x3 x4 -> do putWord8 0 put x1 @@ -757,10 +769,10 @@ get = do x1 <- get x2 <- get return (CaseInfo x1 x2) - + instance Binary Def where put x - = {-# SCC "putDef" #-} + = {-# SCC "putDef" #-} case x of Function x1 x2 -> do putWord8 0 put x1 @@ -858,8 +870,8 @@ _ -> error "Corrupted binary data for Totality" instance Binary IBCFile where - put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26) - = {-# SCC "putIBCFile" #-} + put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27) + = {-# SCC "putIBCFile" #-} do put x1 put x2 put x3 @@ -886,9 +898,10 @@ put x24 put x25 put x26 + put x27 get = do x1 <- get - if x1 == ibcVersion then + if x1 == ibcVersion then do x2 <- get x3 <- get x4 <- get @@ -914,9 +927,10 @@ x24 <- get x25 <- get x26 <- get - return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26) + x27 <- get + return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27) else return (initIBC { ver = x1 }) - + instance Binary FnOpt where put x = case x of @@ -969,7 +983,7 @@ return (PrefixN x1) _ -> error "Corrupted binary data for Fixity" - + instance Binary FixDecl where put (Fix x1 x2) = do put x1 @@ -979,7 +993,7 @@ x2 <- get return (Fix x1 x2) - + instance Binary Static where put x = case x of @@ -992,26 +1006,28 @@ 1 -> return Dynamic _ -> error "Corrupted binary data for Static" - + instance Binary Plicity where put x = case x of - Imp x1 x2 x3 -> + Imp x1 x2 x3 x4 -> do putWord8 0 put x1 put x2 put x3 - Exp x1 x2 x3 -> + put x4 + Exp x1 x2 x3 x4 -> do putWord8 1 put x1 put x2 put x3 - Constraint x1 x2 x3 -> + put x4 + Constraint x1 x2 x3 -> do putWord8 2 put x1 put x2 put x3 - TacImp x1 x2 x3 x4 -> + TacImp x1 x2 x3 x4 -> do putWord8 3 put x1 put x2 @@ -1023,11 +1039,13 @@ 0 -> do x1 <- get x2 <- get x3 <- get - return (Imp x1 x2 x3) + x4 <- get + return (Imp x1 x2 x3 x4) 1 -> do x1 <- get x2 <- get x3 <- get - return (Exp x1 x2 x3) + x4 <- get + return (Exp x1 x2 x3 x4) 2 -> do x1 <- get x2 <- get x3 <- get @@ -1039,7 +1057,7 @@ return (TacImp x1 x2 x3 x4) _ -> error "Corrupted binary data for Plicity" - + instance (Binary t) => Binary (PDecl' t) where put x = case x of @@ -1060,7 +1078,7 @@ put x2 put x3 put x4 - PData x1 x2 x3 x4 x5 -> + PData x1 x2 x3 x4 x5 -> do putWord8 3 put x1 put x2 @@ -1074,7 +1092,7 @@ PNamespace x1 x2 -> do putWord8 5 put x1 put x2 - PRecord x1 x2 x3 x4 x5 x6 x7 x8 -> + PRecord x1 x2 x3 x4 x5 x6 x7 x8 -> do putWord8 6 put x1 put x2 @@ -1313,92 +1331,105 @@ PRef x1 x2 -> do putWord8 1 put x1 put x2 - PLam x1 x2 x3 -> do putWord8 2 + PInferRef x1 x2 -> do putWord8 2 + put x1 + put x2 + PPatvar x1 x2 -> do putWord8 3 put x1 put x2 + PLam x1 x2 x3 -> do putWord8 4 + put x1 + put x2 put x3 - PPi x1 x2 x3 x4 -> do putWord8 3 + PPi x1 x2 x3 x4 -> do putWord8 5 put x1 put x2 put x3 put x4 - PLet x1 x2 x3 x4 -> do putWord8 4 + PLet x1 x2 x3 x4 -> do putWord8 6 put x1 put x2 put x3 put x4 - PTyped x1 x2 -> do putWord8 5 + PTyped x1 x2 -> do putWord8 7 put x1 put x2 - PApp x1 x2 x3 -> do putWord8 6 + PApp x1 x2 x3 -> do putWord8 8 put x1 put x2 put x3 - PCase x1 x2 x3 -> do putWord8 7 + PAppBind x1 x2 x3 -> do putWord8 9 + put x1 + put x2 + put x3 + PMatchApp x1 x2 -> do putWord8 10 + put x1 + put x2 + PCase x1 x2 x3 -> do putWord8 11 put x1 put x2 put x3 - PTrue x1 -> do putWord8 8 + PTrue x1 -> do putWord8 12 put x1 - PFalse x1 -> do putWord8 9 + PFalse x1 -> do putWord8 13 put x1 - PRefl x1 x2 -> do putWord8 10 + PRefl x1 x2 -> do putWord8 14 put x1 put x2 - PResolveTC x1 -> do putWord8 11 + PResolveTC x1 -> do putWord8 15 put x1 - PEq x1 x2 x3 -> do putWord8 12 + PEq x1 x2 x3 -> do putWord8 16 put x1 put x2 put x3 - PPair x1 x2 x3 -> do putWord8 13 + PRewrite x1 x2 x3 x4 -> do putWord8 17 + put x1 + put x2 + put x3 + put x4 + PPair x1 x2 x3 -> do putWord8 18 put x1 put x2 put x3 - PDPair x1 x2 x3 x4 -> do putWord8 14 + PDPair x1 x2 x3 x4 -> do putWord8 19 put x1 put x2 put x3 put x4 - PAlternative x1 x2 -> do putWord8 15 + PAlternative x1 x2 -> do putWord8 20 put x1 put x2 - PHidden x1 -> do putWord8 16 + PHidden x1 -> do putWord8 21 put x1 - PType -> putWord8 17 - PConstant x1 -> do putWord8 18 + PType -> putWord8 22 + PGoal x1 x2 x3 x4 -> do putWord8 23 + put x1 + put x2 + put x3 + put x4 + PConstant x1 -> do putWord8 24 put x1 - Placeholder -> putWord8 19 - PDoBlock x1 -> do putWord8 20 + Placeholder -> putWord8 25 + PDoBlock x1 -> do putWord8 26 put x1 - PIdiom x1 x2 -> do putWord8 21 + PIdiom x1 x2 -> do putWord8 27 put x1 put x2 - PReturn x1 -> do putWord8 22 + PReturn x1 -> do putWord8 28 put x1 - PMetavar x1 -> do putWord8 23 + PMetavar x1 -> do putWord8 29 put x1 - PProof x1 -> do putWord8 24 + PProof x1 -> do putWord8 30 put x1 - PTactics x1 -> do putWord8 25 + PTactics x1 -> do putWord8 31 put x1 - PImpossible -> putWord8 27 - PPatvar x1 x2 -> do putWord8 28 - put x1 - put x2 - PInferRef x1 x2 -> do putWord8 29 + PImpossible -> putWord8 33 + PCoerced x1 -> do putWord8 34 + put x1 + PUnifyLog x1 -> do putWord8 35 + put x1 + PNoImplicits x1 -> do putWord8 36 put x1 - put x2 - PRewrite x1 x2 x3 x4 -> do putWord8 30 - put x1 - put x2 - put x3 - put x4 - PGoal x1 x2 x3 x4 -> do putWord8 31 - put x1 - put x2 - put x3 - put x4 get = do i <- getWord8 case i of @@ -1409,92 +1440,105 @@ return (PRef x1 x2) 2 -> do x1 <- get x2 <- get + return (PInferRef x1 x2) + 3 -> do x1 <- get + x2 <- get + return (PPatvar x1 x2) + 4 -> do x1 <- get + x2 <- get x3 <- get return (PLam x1 x2 x3) - 3 -> do x1 <- get + 5 -> do x1 <- get x2 <- get x3 <- get x4 <- get return (PPi x1 x2 x3 x4) - 4 -> do x1 <- get + 6 -> do x1 <- get x2 <- get x3 <- get x4 <- get return (PLet x1 x2 x3 x4) - 5 -> do x1 <- get + 7 -> do x1 <- get x2 <- get return (PTyped x1 x2) - 6 -> do x1 <- get + 8 -> do x1 <- get x2 <- get x3 <- get return (PApp x1 x2 x3) - 7 -> do x1 <- get + 9 -> do x1 <- get x2 <- get x3 <- get - return (PCase x1 x2 x3) - 8 -> do x1 <- get - return (PTrue x1) - 9 -> do x1 <- get - return (PFalse x1) + return (PAppBind x1 x2 x3) 10 -> do x1 <- get x2 <- get - return (PRefl x1 x2) + return (PMatchApp x1 x2) 11 -> do x1 <- get - return (PResolveTC x1) + x2 <- get + x3 <- get + return (PCase x1 x2 x3) 12 -> do x1 <- get + return (PTrue x1) + 13 -> do x1 <- get + return (PFalse x1) + 14 -> do x1 <- get x2 <- get + return (PRefl x1 x2) + 15 -> do x1 <- get + return (PResolveTC x1) + 16 -> do x1 <- get + x2 <- get x3 <- get return (PEq x1 x2 x3) - 13 -> do x1 <- get + 17 -> do x1 <- get x2 <- get x3 <- get + x4 <- get + return (PRewrite x1 x2 x3 x4) + 18 -> do x1 <- get + x2 <- get + x3 <- get return (PPair x1 x2 x3) - 14 -> do x1 <- get + 19 -> do x1 <- get x2 <- get x3 <- get x4 <- get return (PDPair x1 x2 x3 x4) - 15 -> do x1 <- get + 20 -> do x1 <- get x2 <- get return (PAlternative x1 x2) - 16 -> do x1 <- get + 21 -> do x1 <- get return (PHidden x1) - 17 -> return PType - 18 -> do x1 <- get + 22 -> return PType + 23 -> do x1 <- get + x2 <- get + x3 <- get + x4 <- get + return (PGoal x1 x2 x3 x4) + 24 -> do x1 <- get return (PConstant x1) - 19 -> return Placeholder - 20 -> do x1 <- get + 25 -> return Placeholder + 26 -> do x1 <- get return (PDoBlock x1) - 21 -> do x1 <- get + 27 -> do x1 <- get x2 <- get return (PIdiom x1 x2) - 22 -> do x1 <- get - return (PReturn x1) - 23 -> do x1 <- get - return (PMetavar x1) - 24 -> do x1 <- get - return (PProof x1) - 25 -> do x1 <- get - return (PTactics x1) - 27 -> return PImpossible 28 -> do x1 <- get - x2 <- get - return (PPatvar x1 x2) + return (PReturn x1) 29 -> do x1 <- get - x2 <- get - return (PInferRef x1 x2) + return (PMetavar x1) 30 -> do x1 <- get - x2 <- get - x3 <- get - x4 <- get - return (PRewrite x1 x2 x3 x4) + return (PProof x1) 31 -> do x1 <- get - x2 <- get - x3 <- get - x4 <- get - return (PGoal x1 x2 x3 x4) + return (PTactics x1) + 33 -> return PImpossible + 34 -> do x1 <- get + return (PCoerced x1) + 35 -> do x1 <- get + return (PUnifyLog x1) + 36 -> do x1 <- get + return (PNoImplicits x1) _ -> error "Corrupted binary data for PTerm" - + instance (Binary t) => Binary (PTactic' t) where put x = case x of @@ -1531,7 +1575,7 @@ Reflect x1 -> do putWord8 17 put x1 Fill x1 -> do putWord8 18 - put x1 + put x1 get = do i <- getWord8 case i of @@ -1624,7 +1668,7 @@ instance (Binary t) => Binary (PArg' t) where put x = case x of - PImp x1 x2 x3 x4 x5 x6 -> + PImp x1 x2 x3 x4 x5 x6 -> do putWord8 0 put x1 put x2 @@ -1632,19 +1676,19 @@ put x4 put x5 put x6 - PExp x1 x2 x3 x4 -> + PExp x1 x2 x3 x4 -> do putWord8 1 put x1 put x2 put x3 put x4 - PConstraint x1 x2 x3 x4 -> + PConstraint x1 x2 x3 x4 -> do putWord8 2 put x1 put x2 put x3 put x4 - PTacImplicit x1 x2 x3 x4 x5 x6 -> + PTacImplicit x1 x2 x3 x4 x5 x6 -> do putWord8 3 put x1 put x2 @@ -1681,7 +1725,7 @@ return (PTacImplicit x1 x2 x3 x4 x5 x6) _ -> error "Corrupted binary data for PArg'" - + instance Binary ClassInfo where put (CI x1 x2 x3 x4 _) = do put x1 @@ -1731,7 +1775,7 @@ 2 -> return AnySyntax _ -> error "Corrupted binary data for SynContext" - + instance Binary Syntax where put (Rule x1 x2 x3) = do put x1 @@ -1765,7 +1809,7 @@ x8 <- get x9 <- get return (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9) - + instance Binary SSymbol where put x = case x of diff --git a/src/Idris/IdeSlave.hs b/src/Idris/IdeSlave.hs --- a/src/Idris/IdeSlave.hs +++ b/src/Idris/IdeSlave.hs @@ -1,15 +1,19 @@ -{-# LANGUAGE FlexibleInstances, IncoherentInstances #-} +{-# LANGUAGE FlexibleInstances, IncoherentInstances, PatternGuards #-} module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..), SExpable) where import Text.Printf import Numeric import Data.List +import qualified Data.ByteString.UTF8 as UTF8 -- import qualified Data.Text as T -import Text.Parsec +import Text.Trifecta hiding (Err) +import Text.Trifecta.Delta import Core.TT +import Control.Applicative + data SExp = SexpList [SExp] | StringAtom String | BoolAtom Bool @@ -73,9 +77,10 @@ return (SexpList xs) <|> atom -atom = do char ':'; x <- atomC; return x +atom = do string "nil"; return (SexpList []) + <|> do char ':'; x <- atomC; return x <|> do char '"'; xs <- many quotedChar; char '"'; return (StringAtom xs) - <|> do ints <- many1 digit + <|> do ints <- some digit case readDec ints of ((num, ""):_) -> return (IntegerAtom (toInteger num)) _ -> return (StringAtom ints) @@ -88,37 +93,54 @@ <|> try (string "\\\"" >> return '"') <|> noneOf "\"" -parseSExp :: String -> Either ParseError SExp -parseSExp = parse pSExp "(unknown)" +parseSExp :: String -> Result SExp +parseSExp = parseString pSExp (Directed (UTF8.fromString "(unknown)") 0 0 0 0) data IdeSlaveCommand = REPLCompletions String | Interpret String + | TypeOf String + | CaseSplit Int String + | AddClause Int String + | AddProofClause Int String + | AddMissing Int String + | MakeWithBlock Int String + | ProofSearch Int String [String] | LoadFile String deriving Show sexpToCommand :: SExp -> Maybe IdeSlaveCommand -sexpToCommand (SexpList (x:[])) = sexpToCommand x -sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd) -sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix) -sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename]) = Just (LoadFile filename) -sexpToCommand _ = Nothing +sexpToCommand (SexpList (x:[])) = sexpToCommand x +sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd) +sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix) +sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename]) = Just (LoadFile filename) +sexpToCommand (SexpList [SymbolAtom "type-of", StringAtom name]) = Just (TypeOf name) +sexpToCommand (SexpList [SymbolAtom "case-split", IntegerAtom line, StringAtom name]) = Just (CaseSplit (fromInteger line) name) +sexpToCommand (SexpList [SymbolAtom "add-clause", IntegerAtom line, StringAtom name]) = Just (AddClause (fromInteger line) name) +sexpToCommand (SexpList [SymbolAtom "add-proof-clause", IntegerAtom line, StringAtom name]) = Just (AddProofClause (fromInteger line) name) +sexpToCommand (SexpList [SymbolAtom "add-missing", IntegerAtom line, StringAtom name]) = Just (AddMissing (fromInteger line) name) +sexpToCommand (SexpList [SymbolAtom "make-with", IntegerAtom line, StringAtom name]) = Just (MakeWithBlock (fromInteger line) name) +sexpToCommand (SexpList [SymbolAtom "proof-search", IntegerAtom line, StringAtom name, SexpList hintexp]) | Just hints <- getHints hintexp = Just (ProofSearch (fromInteger line) name hints) + where getHints = mapM (\h -> case h of + StringAtom s -> Just s + _ -> Nothing) +sexpToCommand _ = Nothing -parseMessage :: String -> (SExp, Integer) +parseMessage :: String -> Either Err (SExp, Integer) parseMessage x = case receiveString x of - (SexpList [cmd, (IntegerAtom id)]) -> - (cmd, id) + Right (SexpList [cmd, (IntegerAtom id)]) -> Right (cmd, id) + Left err -> Left err -receiveString :: String -> SExp +receiveString :: String -> Either Err SExp receiveString x = case readHex (take 6 x) of ((num, ""):_) -> let msg = drop 6 x in if (length msg) /= (num - 1) - then error "bad input length" + then Left . Msg $ "bad input length" else (case parseSExp msg of - Left _ -> error "parse failure" - Right r -> r) - _ -> error "readHex failed" + Failure _ -> Left . Msg $ "parse failure" + Success r -> Right r) + _ -> Left . Msg $ "readHex failed" convSExp :: SExpable a => String -> a -> Integer -> String convSExp pre s id = diff --git a/src/Idris/Imports.hs b/src/Idris/Imports.hs --- a/src/Idris/Imports.hs +++ b/src/Idris/Imports.hs @@ -9,7 +9,7 @@ import System.Directory import Control.Monad.State -data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType +data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType deriving (Show, Eq) srcPath :: FilePath -> FilePath @@ -60,7 +60,7 @@ else IDR idrp if ibc then return (IBC ibcp isrc) - else if (idr || lidr) + else if (idr || lidr) then return isrc else findImport ds ibcsd fp diff --git a/src/Idris/Inliner.hs b/src/Idris/Inliner.hs --- a/src/Idris/Inliner.hs +++ b/src/Idris/Inliner.hs @@ -15,13 +15,13 @@ -- (Dictionaries are inlinable in an argument, not otherwise) -- - If so, try inlining without reducing its arguments -- + If successful, then continue on the result (top level) --- + If not, reduce the arguments (argument level) and try again +-- + If not, reduce the arguments (argument level) and try again -- - If not, inline all the arguments (top level) inlineTerm :: IState -> Term -> Term inlineTerm ist tm = inl tm where inl orig@(P _ n _) = inlApp n [] orig - inl orig@(App f a) + inl orig@(App f a) | (P _ fn _, args) <- unApply orig = inlApp fn args orig inl (Bind n (Let t v) sc) = Bind n (Let t (inl v)) (inl sc) inl (Bind n b sc) = Bind n b (inl sc) diff --git a/src/Idris/ParseData.hs b/src/Idris/ParseData.hs --- a/src/Idris/ParseData.hs +++ b/src/Idris/ParseData.hs @@ -38,7 +38,7 @@ DocComment Accessibility? 'record' FnName TypeSig 'where' OpenBlock Constructor KeepTerminator CloseBlock; -} record :: SyntaxInfo -> IdrisParser PDecl -record syn = do (doc, acc) <- try (do +record syn = do (doc, acc) <- try (do doc <- option "" (docComment '|') acc <- optional accessibility reserved "record" diff --git a/src/Idris/ParseExpr.hs b/src/Idris/ParseExpr.hs --- a/src/Idris/ParseExpr.hs +++ b/src/Idris/ParseExpr.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-} +{-# OPTIONS_GHC -O0 #-} module Idris.ParseExpr where import Prelude hiding (pi) @@ -31,6 +32,8 @@ import qualified Data.Text as T import qualified Data.ByteString.UTF8 as UTF8 +import Debug.Trace + -- | Allow implicit type declarations allowImp :: SyntaxInfo -> SyntaxInfo allowImp syn = syn { implicitAllowed = True } @@ -46,7 +49,7 @@ fullExpr syn = do x <- expr syn eof i <- get - return $ desugar syn i x + return $ debindApp syn (desugar syn i x) {- |Parses an expression @@ -138,6 +141,7 @@ update ns (PLet n ty val sc) = PLet (updateB ns n) (update ns ty) (update ns val) (update (dropn n ns) sc) update ns (PApp fc t args) = PApp fc (update ns t) (map (fmap (update ns)) args) + update ns (PAppBind fc t args) = PAppBind fc (update ns t) (map (fmap (update ns)) args) update ns (PCase fc c opts) = PCase fc (update ns c) (map (pmap (update ns)) opts) update ns (PPair fc l r) = PPair fc (update ns l) (update ns r) update ns (PDPair fc l t r) = PDPair fc (update ns l) (update ns t) (update ns r) @@ -257,7 +261,7 @@ simpleExpr :: SyntaxInfo -> IdrisParser PTerm simpleExpr syn = {-try (do symbol "!["; t <- term; lchar ']'; return $ PQuote t) - <|>-} do lchar '?'; x <- name; return (PMetavar x) + <|>-} do x <- try (lchar '?' *> name); return (PMetavar x) <|> do lchar '%'; fc <- getFC; reserved "instance"; return (PResolveTC fc) <|> do reserved "refl"; fc <- getFC; tm <- option Placeholder (do lchar '{'; t <- expr syn; lchar '}'; @@ -267,6 +271,9 @@ <|> tacticsExpr syn <|> caseExpr syn <|> do reserved "Type"; return PType + <|> do c <- constant + fc <- getFC + return (modifyConst syn fc (PConstant c)) <|> do fc <- getFC x <- fnName return (PRef fc x) @@ -274,11 +281,12 @@ <|> try (comprehension syn) <|> alt syn <|> idiom syn + <|> do lchar '!' + s <- simpleExpr syn + fc <- getFC + return (PAppBind fc s []) <|> do lchar '(' bracketed (disallowImp syn) - <|> do c <- constant - fc <- getFC - return (modifyConst syn fc (PConstant c)) <|> do symbol "_|_" fc <- getFC return (PFalse fc) @@ -306,7 +314,7 @@ <|> try (do l <- expr syn lchar ')' - return l) + return l) <|> do (l, fc) <- try (do l <- expr syn fc <- getFC @@ -479,7 +487,10 @@ fc <- getFC args <- some (do notEndApp; arg syn) i <- get - return (dslify i $ PApp fc f args) +-- case f of +-- PAppBind fc ref [] -> +-- return (dslify i (PAppBind fc ref args)) + return (dslify i (PApp fc f args)) "function application" where dslify :: IState -> PTerm -> PTerm @@ -675,7 +686,6 @@ | '|'? Static? '{' TypeDeclList '}' '->' Expr | '{' 'auto' TypeDeclList '}' '->' Expr | '{' 'default' TypeDeclList '}' '->' Expr - | '{' 'static' '}' Expr' '->' Expr ; -} @@ -689,7 +699,7 @@ doc <- option "" (docComment '^') symbol "->" sc <- expr syn - return (bindList (PPi (Exp lazy st doc)) xt sc)) <|> (do + return (bindList (PPi (Exp lazy st doc False)) xt sc)) <|> (do lchar '{' (do reserved "auto" when (lazy || (st == Static)) $ fail "auto type constraints can not be lazy or static" @@ -698,7 +708,8 @@ symbol "->" sc <- expr syn return (bindList (PPi - (TacImp False Dynamic (PTactics [Trivial]) "")) xt sc)) <|> (do + (TacImp False Dynamic (PTactics [Trivial]) "")) xt sc)) + <|> (do reserved "default" when (lazy || (st == Static)) $ fail "default tactic constraints can not be lazy or static" script <- simpleExpr syn @@ -706,19 +717,13 @@ lchar '}' symbol "->" sc <- expr syn - return (bindList (PPi (TacImp False Dynamic script "")) xt sc)) <|> (do - reserved "static" - lchar '}' - t <- expr' syn - symbol "->" - sc <- expr syn - return (PPi (Exp False Static "") (MN 42 "__pi_arg") t sc)) <|> ( - if implicitAllowed syn then do + return (bindList (PPi (TacImp False Dynamic script "")) xt sc)) + <|> (if implicitAllowed syn then do xt <- typeDeclList syn lchar '}' symbol "->" sc <- expr syn - return (bindList (PPi (Imp lazy st "")) xt sc) + return (bindList (PPi (Imp lazy st "" False)) xt sc) else do fail "no implicit arguments allowed here")) "dependent type signature" @@ -966,49 +971,49 @@ -} tactic :: SyntaxInfo -> IdrisParser PTactic -tactic syn = do reserved "intro"; ns <- sepBy name (lchar ',') +tactic syn = do reserved "intro"; ns <- sepBy (indentPropHolds gtProp *> name) (lchar ',') return $ Intro ns <|> do reserved "intros"; return Intros - <|> try (do reserved "refine"; n <- name + <|> try (do reserved "refine"; n <- (indentPropHolds gtProp *> name) imps <- some imp return $ Refine n imps) - <|> do reserved "refine"; n <- name + <|> do reserved "refine"; n <- (indentPropHolds gtProp *> name) i <- get return $ Refine n [] - <|> do reserved "mrefine"; n <- name + <|> do reserved "mrefine"; n <- (indentPropHolds gtProp *> name) i <- get return $ MatchRefine n - <|> do reserved "rewrite"; t <- expr syn; + <|> do reserved "rewrite"; t <- (indentPropHolds gtProp *> expr syn); i <- get return $ Rewrite (desugar syn i t) - <|> do reserved "equiv"; t <- expr syn; + <|> do reserved "equiv"; t <- (indentPropHolds gtProp *> expr syn); i <- get return $ Equiv (desugar syn i t) - <|> try (do reserved "let"; n <- name; lchar ':'; - ty <- expr' syn; lchar '='; t <- expr syn; + <|> try (do reserved "let"; n <- (indentPropHolds gtProp *> name); (indentPropHolds gtProp *> lchar ':'); + ty <- (indentPropHolds gtProp *> expr' syn); (indentPropHolds gtProp *> lchar '='); t <- (indentPropHolds gtProp *> expr syn); i <- get return $ LetTacTy n (desugar syn i ty) (desugar syn i t)) - <|> try (do reserved "let"; n <- name; lchar '='; - t <- expr syn; + <|> try (do reserved "let"; n <- (indentPropHolds gtProp *> name); (indentPropHolds gtProp *> lchar '='); + t <- (indentPropHolds gtProp *> expr syn); i <- get return $ LetTac n (desugar syn i t)) - <|> do reserved "focus"; n <- name + <|> do reserved "focus"; n <- (indentPropHolds gtProp *> name) return $ Focus n - <|> do reserved "exact"; t <- expr syn; + <|> do reserved "exact"; t <- (indentPropHolds gtProp *> expr syn); i <- get return $ Exact (desugar syn i t) - <|> do reserved "applyTactic"; t <- expr syn; + <|> do reserved "applyTactic"; t <- (indentPropHolds gtProp *> expr syn); i <- get return $ ApplyTactic (desugar syn i t) - <|> do reserved "reflect"; t <- expr syn; + <|> do reserved "reflect"; t <- (indentPropHolds gtProp *> expr syn); i <- get return $ Reflect (desugar syn i t) - <|> do reserved "fill"; t <- expr syn; + <|> do reserved "fill"; t <- (indentPropHolds gtProp *> expr syn); i <- get return $ Fill (desugar syn i t) - <|> do reserved "try"; t <- tactic syn; + <|> do reserved "try"; t <- (indentPropHolds gtProp *> tactic syn); lchar '|'; - t1 <- tactic syn + t1 <- (indentPropHolds gtProp *> tactic syn) return $ Try t t1 <|> do lchar '{' t <- tactic syn; diff --git a/src/Idris/ParseHelpers.hs b/src/Idris/ParseHelpers.hs --- a/src/Idris/ParseHelpers.hs +++ b/src/Idris/ParseHelpers.hs @@ -43,6 +43,10 @@ -- | Generalized monadic parsing constraint type type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m) +-- | Helper to run Idris inner parser based stateT parsers +runparser :: StateT st IdrisInnerParser res -> st -> String -> String -> Result res +runparser p i inputname = parseString (runInnerParser (evalStateT p i)) (Directed (UTF8.fromString inputname) 0 0 0 0) + {- * Space, comments and literals (token/lexing like parsers) -} -- | Consumes any simple whitespace (any character which satisfies Char.isSpace) @@ -152,12 +156,9 @@ "case", "of", "total", "partial", "mutual", "infix", "infixl", "infixr", "rewrite", "where", "with", "syntax", "proof", "postulate", - "using", "namespace", "class", "instance", + "using", "namespace", "class", "instance", "parameters", "public", "private", "abstract", "implicit", - "quoteGoal", - "Int", "Integer", "Float", "Char", "String", "Ptr", - "Bits8", "Bits16", "Bits32", "Bits64", - "Bits8x16", "Bits16x8", "Bits32x4", "Bits64x2"] + "quoteGoal"] char :: MonadicParsing m => Char -> m Char char = Chr.char @@ -235,8 +236,11 @@ (x, "") -> [x] (x, '.':y) -> x : parseNS y +opChars :: String +opChars = ":!#$%&*+./<=>?@\\^|-~" + operatorLetter :: MonadicParsing m => m Char -operatorLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" +operatorLetter = oneOf opChars -- | Parses an operator operator :: MonadicParsing m => m String @@ -254,13 +258,19 @@ lineNum :: Delta -> Int lineNum (Lines l _ _ _) = fromIntegral l + 1 lineNum (Directed _ l _ _ _) = fromIntegral l + 1 +lineNum _ = 0 +{- | Get column number from position -} +columnNum :: Delta -> Int +columnNum pos = fromIntegral (column pos) + 1 + + {- | Get file position as FC -} getFC :: MonadicParsing m => m FC getFC = do s <- position let (dir, file) = splitFileName (fileName s) let f = if dir == addTrailingPathSeparator "." then file else fileName s - return $ FC f (lineNum s) + return $ FC f (lineNum s) (columnNum s) {-* Syntax helpers-} -- | Bind constraints to term @@ -397,6 +407,38 @@ when (i < lvl || isParen) (fail "end of block") _ -> return () +-- | Representation of an operation that can compare the current indentation with the last indentation, and an error message if it fails +data IndentProperty = IndentProperty (Int -> Int -> Bool) String + +-- | Allows comparison of indent, and fails if property doesn't hold +indentPropHolds :: IndentProperty -> IdrisParser() +indentPropHolds (IndentProperty op msg) = do + li <- lastIndent + i <- indent + when (not $ op i li) $ fail ("Wrong indention: " ++ msg) + +-- | Greater-than indent property +gtProp :: IndentProperty +gtProp = IndentProperty (>) "should be greater than context indentation" + +-- | Greater-than or equal to indent property +gteProp :: IndentProperty +gteProp = IndentProperty (>=) "should be greater than or equal context indentation" + +-- | Equal indent property +eqProp :: IndentProperty +eqProp = IndentProperty (==) "should be equal to context indentation" + +-- | Less-than indent property +ltProp :: IndentProperty +ltProp = IndentProperty (<) "should be less than context indentation" + +-- | Less-than or equal to indent property +lteProp :: IndentProperty +lteProp = IndentProperty (<=) "should be less than or equal to context indentation" + + +-- | Checks that there are no braces that are not closed notOpenBraces :: IdrisParser () notOpenBraces = do ist <- get when (hasNothing $ brace_stack ist) $ fail "end of input" @@ -452,9 +494,9 @@ collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds collect (PNamespace ns ps : ds) = PNamespace ns (collect ps) : collect ds -collect (PClass doc f s cs n ps ds : ds') +collect (PClass doc f s cs n ps ds : ds') = PClass doc f s cs n ps (collect ds) : collect ds' -collect (PInstance f s cs n ps t en ds : ds') +collect (PInstance f s cs n ps t en ds : ds') = PInstance f s cs n ps t en (collect ds) : collect ds' collect (d : ds) = d : collect ds collect [] = [] diff --git a/src/Idris/Parser.hs b/src/Idris/Parser.hs --- a/src/Idris/Parser.hs +++ b/src/Idris/Parser.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-} -module Idris.Parser(module Idris.Parser, +{-# OPTIONS_GHC -O0 #-} +module Idris.Parser(module Idris.Parser, module Idris.ParseExpr, module Idris.ParseData, module Idris.ParseHelpers, @@ -15,6 +16,8 @@ import qualified Text.Parser.Char as Chr import qualified Text.Parser.Token.Highlight as Hi +import Text.PrettyPrint.ANSI.Leijen (Doc, plain) + import Idris.AbsSyntax import Idris.DSL import Idris.Imports @@ -54,6 +57,8 @@ import Debug.Trace import System.FilePath +import System.IO + {- grammar shortcut notation: ~CHARSEQ = complement of char sequence (i.e. any character except CHARSEQ) @@ -137,7 +142,7 @@ declBody' :: IdrisParser [PDecl] declBody' = do d <- decl' syn i <- get - let d' = fmap (desugar syn i) d + let d' = fmap (debindApp syn . (desugar syn i)) d return [d'] {- | Parses a top-level declaration with possible syntax sugar @@ -243,13 +248,11 @@ FunDecl ::= FunDecl'; -} fnDecl :: SyntaxInfo -> IdrisParser [PDecl] -fnDecl syn - = try (do notEndBlock - d <- fnDecl' syn - i <- get - let d' = fmap (desugar syn i) d - return [d']) - "function declaration" +fnDecl syn = try (do notEndBlock + d <- fnDecl' syn + i <- get + let d' = fmap (desugar syn i) d + return [d']) "function declaration" {- Parses a function declaration FunDecl' ::= @@ -260,7 +263,8 @@ ; -} fnDecl' :: SyntaxInfo -> IdrisParser PDecl -fnDecl' syn = do (doc, fc, opts', n, acc) <- try (do +fnDecl' syn = checkFixity $ + do (doc, fc, opts', n, acc) <- try (do doc <- option "" (docComment '|') pushIndent ist <- get @@ -283,7 +287,22 @@ <|> caf syn <|> pattern syn "function declaration" - + where checkFixity :: IdrisParser PDecl -> IdrisParser PDecl + checkFixity p = do decl <- p + case getName decl of + Nothing -> return decl + Just n -> do fOk <- fixityOK n + unless fOk . fail $ + "Missing fixity declaration for " ++ show n + return decl + getName (PTy _ _ _ _ n _) = Just n + getName _ = Nothing + fixityOK (NS n _) = fixityOK n + fixityOK (UN n) | all (flip elem opChars) n = + do fixities <- fmap idris_infixes get + return . elem n . map (\ (Fix _ op) -> op) $ fixities + | otherwise = return True + fixityOK _ = return True {- Parses function options given initial options FnOpts ::= 'total' @@ -441,7 +460,7 @@ ; -} class_ :: SyntaxInfo -> IdrisParser [PDecl] -class_ syn = do (doc, acc) <- try (do +class_ syn = do (doc, acc) <- try (do doc <- option "" (docComment '|') acc <- optional accessibility return (doc, acc)) @@ -643,11 +662,12 @@ ist <- get put (ist { lastParse = Just n }) return $ PClause fc n capp [] r wheres - <|> do (l, op) <- try (do + <|> do (l, op) <- try (do pushIndent l <- argExpr syn op <- operator - when (op == "=" || op == "?=" ) (fail "infix clause definition with \"=\" and \"?=\" not supported ") + when (op == "=" || op == "?=" ) $ + fail "infix clause definition with \"=\" and \"?=\" not supported " return (l, op)) let n = expandNS syn (UN op) r <- argExpr syn @@ -797,7 +817,7 @@ <|> do try (lchar '%' *> reserved "include"); cgn <- codegen_; hdr <- stringLiteral; return [PDirective (do addHdr cgn hdr addIBC (IBCHeader cgn hdr))] - <|> do try (lchar '%' *> reserved "hide"); n <- iName [] + <|> do try (lchar '%' *> reserved "hide"); n <- fnName return [PDirective (do setAccessibility n Hidden addIBC (IBCAccess n Hidden))] <|> do try (lchar '%' *> reserved "freeze"); n <- iName [] @@ -867,11 +887,11 @@ {- * Loading and parsing -} {- | Parses an expression from input -} parseExpr :: IState -> String -> Result PTerm -parseExpr st = parseString (runInnerParser (evalStateT (fullExpr defaultSyntax) st)) (Directed (UTF8.fromString "(input)") 0 0 0 0) +parseExpr st = runparser (fullExpr defaultSyntax) st "(input)" {- | Parses a tactic from input -} parseTactic :: IState -> String -> Result PTactic -parseTactic st = parseString (runInnerParser (evalStateT (fullTactic defaultSyntax) st)) (Directed (UTF8.fromString "(input)") 0 0 0 0) +parseTactic st = runparser (fullTactic defaultSyntax) st "(input)" -- | Parse module header and imports parseImports :: FilePath -> String -> Idris ([String], [String], Maybe Delta) @@ -894,6 +914,12 @@ i <- get return ((mname, ps, mrk'), i) +-- | There should be a better way of doing this... +findFC :: Doc -> (FC, String) +findFC x = let s = show (plain x) in + case span (/= ':') s of + (failname, ':':rest) -> case span isDigit rest of + (line, ':':rest') -> (FC failname (read line) 0, drop 2 (dropWhile (/= ':') rest')) -- | A program is a list of declarations, possibly with associated -- documentation strings. @@ -901,12 +927,15 @@ Idris [PDecl] parseProg syn fname input mrk = do i <- getIState - case parseString (runInnerParser (evalStateT mainProg i)) (Directed (UTF8.fromString fname) 0 0 0 0) input of - Failure doc -> do iputStrLn (show doc) - -- FIXME: Get error location from trifecta - --let errl = sourceLine (errorPos err) + case runparser mainProg i fname input of + Failure doc -> do -- FIXME: Get error location from trifecta + -- this can't be the solution! + let (fc, msg) = findFC doc i <- getIState - putIState (i { errLine = Just 0 }) -- Just errl }) + case idris_outputmode i of + RawOutput -> ihputStrLn (idris_outh i) (show doc) + IdeSlave n -> ihWarn (idris_outh i) fc msg + putIState (i { errLine = Just (fc_line fc) }) -- Just errl }) return [] Success (x, i) -> do putIState i return $ collect x @@ -919,62 +948,69 @@ i' <- get return (ds, i') -{- | Load idris module -} -loadModule :: FilePath -> Idris String -loadModule f - = idrisCatch (do i <- getIState - let file = takeWhile (/= ' ') f - ibcsd <- valIBCSubDir i - ids <- allImportDirs - fp <- liftIO $ findImport ids ibcsd file - if file `elem` imported i - then iLOG $ "Already read " ++ file - else do putIState (i { imported = file : imported i }) - case fp of - IDR fn -> loadSource False fn - LIDR fn -> loadSource True fn - IBC fn src -> - idrisCatch (loadIBC fn) - (\c -> do iLOG $ fn ++ " failed " ++ show c - case src of - IDR sfn -> loadSource False sfn - LIDR sfn -> loadSource True sfn) - let (dir, fh) = splitFileName file - return (dropExtension fh)) - (\e -> do let msg = show e - setErrLine (getErrLine msg) - iputStrLn msg +{- | Load idris module and show error if something wrong happens -} +loadModule :: Handle -> FilePath -> Idris String +loadModule outh f + = idrisCatch (loadModule' outh f) + (\e -> do setErrLine (getErrLine e) + ist <- getIState + msg <- showErr e + ihputStrLn outh msg return "") +{- | Load idris module -} +loadModule' :: Handle -> FilePath -> Idris String +loadModule' outh f + = do i <- getIState + let file = takeWhile (/= ' ') f + ibcsd <- valIBCSubDir i + ids <- allImportDirs + fp <- liftIO $ findImport ids ibcsd file + if file `elem` imported i + then iLOG $ "Already read " ++ file + else do putIState (i { imported = file : imported i }) + case fp of + IDR fn -> loadSource outh False fn + LIDR fn -> loadSource outh True fn + IBC fn src -> + idrisCatch (loadIBC fn) + (\c -> do iLOG $ fn ++ " failed " ++ show c + case src of + IDR sfn -> loadSource outh False sfn + LIDR sfn -> loadSource outh True sfn) + let (dir, fh) = splitFileName file + return (dropExtension fh) + + {- | Load idris code from file -} -loadFromIFile :: IFileType -> Idris () -loadFromIFile i@(IBC fn src) +loadFromIFile :: Handle -> IFileType -> Idris () +loadFromIFile h i@(IBC fn src) = do iLOG $ "Skipping " ++ getSrcFile i idrisCatch (loadIBC fn) - (\c -> do fail $ fn ++ " failed " ++ show c) + (\err -> ierror $ LoadingFailed fn err) where getSrcFile (IDR fn) = fn getSrcFile (LIDR fn) = fn getSrcFile (IBC f src) = getSrcFile src -loadFromIFile (IDR fn) = loadSource' False fn -loadFromIFile (LIDR fn) = loadSource' True fn +loadFromIFile h (IDR fn) = loadSource' h False fn +loadFromIFile h (LIDR fn) = loadSource' h True fn {-| Load idris source code and show error if something wrong happens -} -loadSource' :: Bool -> FilePath -> Idris () -loadSource' lidr r - = idrisCatch (loadSource lidr r) - (\e -> do let msg = show e - setErrLine (getErrLine msg) - iputStrLn msg) +loadSource' :: Handle -> Bool -> FilePath -> Idris () +loadSource' h lidr r + = idrisCatch (loadSource h lidr r) + (\e -> do setErrLine (getErrLine e) + msg <- showErr e + ihputStrLn h msg) {- | Load Idris source code-} -loadSource :: Bool -> FilePath -> Idris () -loadSource lidr f +loadSource :: Handle -> Bool -> FilePath -> Idris () +loadSource h lidr f = do iLOG ("Reading " ++ f) i <- getIState let def_total = default_total i - file_in <- liftIO $ readFile f + file_in <- runIO $ readFile f file <- if lidr then tclift $ unlit f file_in else return file_in (mname, modules, pos) <- parseImports f file i <- getIState @@ -991,7 +1027,7 @@ logLvl 3 (show (idris_infixes i)) -- Now add all the declarations to the context v <- verbose - when v $ iputStrLn $ "Type checking " ++ f + when v $ ihputStrLn h $ "Type checking " ++ f -- we totality check after every Mutual block, so if -- anything is a single definition, wrap it in a -- mutual block on its own @@ -1007,6 +1043,14 @@ i <- getIState mapM_ buildSCG (idris_totcheck i) mapM_ checkDeclTotality (idris_totcheck i) + + -- Redo totality check for deferred names + let deftots = idris_defertotcheck i + iLOG $ "Totality checking " ++ show deftots + mapM_ (\x -> setTotality x Unchecked) (map snd deftots) + mapM_ buildSCG deftots + mapM_ checkDeclTotality deftots + iLOG ("Finished " ++ f) ibcsd <- valIBCSubDir i iLOG "Universe checking" @@ -1031,7 +1075,7 @@ toMutual :: PDecl -> PDecl toMutual m@(PMutual _ d) = m toMutual (PNamespace x ds) = PNamespace x (map toMutual ds) - toMutual x = let r = PMutual (FC "single mutual" 0) [x] in + toMutual x = let r = PMutual (fileFC "single mutual") [x] in case x of PClauses _ _ _ _ -> r PClass _ _ _ _ _ _ _ -> r diff --git a/src/Idris/PartialEval.hs b/src/Idris/PartialEval.hs --- a/src/Idris/PartialEval.hs +++ b/src/Idris/PartialEval.hs @@ -1,13 +1,18 @@ -module Idris.PartialEval(partial_eval) where +{-# LANGUAGE PatternGuards #-} +module Idris.PartialEval(partial_eval, getSpecApps, specType, + mkPE_TyDecl, mkPE_TermDecl, PEArgType(..)) where + import Idris.AbsSyntax +import Idris.Delaborate import Core.TT import Core.Evaluate +import Control.Monad.State import Debug.Trace -partial_eval :: Context -> [(Name, Maybe Int)] -> +partial_eval :: Context -> [(Name, Maybe Int)] -> [Either Term (Term, Term)] -> [Either Term (Term, Term)] partial_eval ctxt ns tms = map peClause tms where @@ -18,3 +23,128 @@ toLimit (n, Nothing) = (n, 65536) -- somewhat arbitrary reduction limit toLimit (n, Just l) = (n, l) + +specType :: [(PEArgType, Term)] -> Type -> (Type, [(PEArgType, Term)]) +specType args ty = let (t, args') = runState (unifyEq args ty) [] in + (st (map fst args') t, map fst args') + where + st ((ExplicitS, v) : xs) (Bind n (Pi t) sc) + = Bind n (Let t v) (st xs sc) + st ((ImplicitS, v) : xs) (Bind n (Pi t) sc) + = Bind n (Let t v) (st xs sc) + st ((UnifiedD, _) : xs) (Bind n (Pi t) sc) + = st xs sc + st (_ : xs) (Bind n (Pi t) sc) + = Bind n (Pi t) (st xs sc) + st _ t = t + + unifyEq (imp@(ImplicitD, v) : xs) (Bind n (Pi t) sc) + = do amap <- get + case lookup imp amap of + Just n' -> + do put (amap ++ [((UnifiedD, Erased), n)]) + sc' <- unifyEq xs (subst n (P Bound n' Erased) sc) + return (Bind n (Pi t) sc') -- erase later + _ -> do put (amap ++ [(imp, n)]) + sc' <- unifyEq xs sc + return (Bind n (Pi t) sc') + unifyEq (x : xs) (Bind n (Pi t) sc) + = do args <- get + put (args ++ [(x, n)]) + sc' <- unifyEq xs sc + return (Bind n (Pi t) sc') + unifyEq xs t = do args <- get + put (args ++ (zip xs (repeat (UN "_")))) + return t + +mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm +mkPE_TyDecl ist args ty = mkty args ty + where + mkty ((ExplicitD, v) : xs) (Bind n (Pi t) sc) + = PPi expl n (delab ist t) (mkty xs sc) + mkty ((ImplicitD, v) : xs) (Bind n (Pi t) sc) + | concreteClass ist t = mkty xs sc + | classConstraint ist t + = PPi constraint n (delab ist t) (mkty xs sc) + | otherwise = PPi impl n (delab ist t) (mkty xs sc) + mkty (_ : xs) t + = mkty xs t + mkty [] t = delab ist t + +classConstraint ist v + | (P _ c _, args) <- unApply v = case lookupCtxt c (idris_classes ist) of + [_] -> True + _ -> False + | otherwise = False + +concreteClass ist v + | not (classConstraint ist v) = False + | (P _ c _, args) <- unApply v = all concrete args + | otherwise = False + where concrete (Constant _) = True + concrete tm | (P _ n _, args) <- unApply tm + = case lookupTy n (tt_ctxt ist) of + [_] -> all concrete args + _ -> False + | otherwise = False + +mkPE_TermDecl :: IState -> Name -> Name -> + [(PEArgType, Term)] -> [(PTerm, PTerm)] +mkPE_TermDecl ist newname sname ns + = let lhs = PApp emptyFC (PRef emptyFC newname) (map pexp (mkp ns)) + rhs = eraseImps $ delab ist (mkApp (P Ref sname Erased) (map snd ns)) in + [(lhs, rhs)] where + mkp [] = [] + mkp ((ExplicitD, tm) : tms) = delab ist tm : mkp tms + mkp (_ : tms) = mkp tms + + eraseImps tm = mapPT deImp tm + + deImp (PApp fc t as) = PApp fc t (map deImpArg as) + deImp t = t + + deImpArg a@(PImp _ _ _ _ _ _) = a { getTm = Placeholder } + deImpArg a = a + +data PEArgType = ImplicitS | ImplicitD + | ExplicitS | ExplicitD + | UnifiedD + deriving (Eq, Show) + +getSpecApps :: IState -> [Name] -> Term -> + [(Name, [(PEArgType, Term)])] +getSpecApps ist env tm = ga env (explicitNames tm) where + +-- staticArg env True _ tm@(P _ n _) _ | n `elem` env = Just (True, tm) +-- staticArg env True _ tm@(App f a) _ | (P _ n _, args) <- unApply tm, +-- n `elem` env = Just (True, tm) + staticArg env x imp tm n + | x && imparg imp = (ImplicitS, tm) + | x = (ExplicitS, tm) + | imparg imp = (ImplicitD, tm) + | otherwise = (ExplicitD, (P Ref (UN (show n ++ "arg")) Erased)) + + imparg (PExp _ _ _ _) = False + imparg _ = True + + buildApp env [] [] _ _ = [] + buildApp env (s:ss) (i:is) (a:as) (n:ns) + = let s' = staticArg env s i a n + ss' = buildApp env ss is as ns in + (s' : ss') + + ga env tm@(App f a) | (P _ n _, args) <- unApply tm = + ga env f ++ ga env a ++ + case (lookupCtxt n (idris_statics ist), + lookupCtxt n (idris_implicits ist)) of + ([statics], [imps]) -> + if (length statics == length args && or statics) then + case buildApp env statics imps args [0..] of + args -> [(n, args)] +-- _ -> [] + else [] + _ -> [] + ga env (Bind n t sc) = ga (n : env) sc + ga env t = [] + + diff --git a/src/Idris/Primitives.hs b/src/Idris/Primitives.hs --- a/src/Idris/Primitives.hs +++ b/src/Idris/Primitives.hs @@ -131,7 +131,7 @@ (1, LFloatStr) total, Prim (UN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp) - (1, LFExp) total, + (1, LFExp) total, Prim (UN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog) (1, LFLog) total, Prim (UN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin) @@ -169,7 +169,9 @@ (0, LVMPtr) total, -- Streams Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce) - (0, LStdIn) partial + (0, LStdIn) partial, + Prim (UN "prim__null") (ty [] PtrType) 0 (p_cantreduce) + (0, LNullPtr) total ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar] ++ concatMap vecOps vecTypes ++ vecBitcasts vecTypes @@ -191,7 +193,7 @@ intCmps :: IntTy -> [Prim] intCmps ITNative = intSCmps ITNative -intCmps ity = +intCmps ity = intSCmps ity ++ [ iCmp ity "lt" False (bCmp ity (cmpOp ity (<))) LLt total , iCmp ity "lte" False (bCmp ity (cmpOp ity (<=))) LLe total diff --git a/src/Idris/ProofSearch.hs b/src/Idris/ProofSearch.hs new file mode 100644 --- /dev/null +++ b/src/Idris/ProofSearch.hs @@ -0,0 +1,99 @@ +module Idris.ProofSearch(trivial, proofSearch) where + +import Core.Elaborate hiding (Tactic(..)) +import Core.TT +import Core.Evaluate +import Core.CaseTree +import Core.Typecheck + +import Idris.AbsSyntax +import Idris.Delaborate +import Idris.Error + +import Control.Monad +import Debug.Trace + +-- Pass in a term elaborator to avoid a cyclic dependency with ElabTerm + +trivial :: (PTerm -> ElabD ()) -> IState -> ElabD () +trivial elab ist = try' (do elab (PRefl (fileFC "prf") Placeholder) + return ()) + (do env <- get_env + g <- goal + tryAll env + return ()) True + where + tryAll [] = fail "No trivial solution" + tryAll ((x, b):xs) + = do -- if type of x has any holes in it, move on + hs <- get_holes + g <- goal + if all (\n -> not (n `elem` hs)) (freeNames (binderTy b)) + then try' (elab (PRef (fileFC "prf") x)) + (tryAll xs) True + else tryAll xs + +proofSearch :: (PTerm -> ElabD ()) -> Maybe Name -> Name -> [Name] -> + IState -> ElabD () +proofSearch elab fn nroot hints ist = psRec maxDepth + where + maxDepth = 6 + + psRec 0 = do attack; defer nroot; solve --fail "Maximum depth reached" + psRec d = try' (trivial elab ist) + (try' (try' (resolveByCon (d - 1)) (resolveByLocals (d - 1)) + True) + -- if all else fails, make a new metavariable + (do attack; defer nroot; solve) True) True + + getFn d Nothing = [] + getFn d (Just f) | d < maxDepth-1 = [f] + | otherwise = [] + + resolveByCon d + = do t <- goal + let (f, _) = unApply t + case f of + P _ n _ -> case lookupCtxt n (idris_datatypes ist) of + [t] -> tryCons d (hints ++ con_names t ++ + getFn d fn) + _ -> fail "Not a data type" + _ -> fail "Not a data type" + + -- if there are local variables which have a function type, try + -- applying them too + resolveByLocals d + = do env <- get_env + tryLocals d env + + tryLocals d [] = fail "Locals failed" + tryLocals d ((x, t) : xs) = try' (tryLocal d x t) (tryLocals d xs) True + + tryCons d [] = fail "Constructors failed" + tryCons d (c : cs) = try' (tryCon d c) (tryCons d cs) True + + tryLocal d n t = do let a = getPArity (delab ist (binderTy t)) + tryLocalArg d n a + + tryLocalArg d n 0 = elab (PRef (fileFC "prf") n) + tryLocalArg d n i = simple_app (tryLocalArg d n (i - 1)) + (psRec d) "proof search local apply" + + -- Like type class resolution, but searching with constructors + tryCon d n = + do let imps = case lookupCtxtName n (idris_implicits ist) of + [] -> [] + [args] -> map isImp (snd args) + _ -> fail "Ambiguous name" + ps <- get_probs + args <- apply (Var n) imps + ps' <- get_probs + when (length ps < length ps') $ fail "Can't apply constructor" + mapM_ (\ (_, h) -> do focus h + psRec d) + (filter (\ (x, y) -> not x) (zip (map fst imps) args)) + solve + + isImp (PImp p _ _ _ _ _) = (True, p) + isImp arg = (False, priority arg) + diff --git a/src/Idris/Prover.hs b/src/Idris/Prover.hs --- a/src/Idris/Prover.hs +++ b/src/Idris/Prover.hs @@ -30,13 +30,13 @@ do ctxt <- getContext i <- getIState case lookupTy x ctxt of - [t] -> if elem x (idris_metavars i) + [t] -> if elem x (map fst (idris_metavars i)) then prove ctxt lit x t - else fail $ show x ++ " is not a metavariable" + else ifail $ show x ++ " is not a metavariable" _ -> fail "No such metavariable" showProof :: Bool -> Name -> [String] -> String -showProof lit n ps +showProof lit n ps = bird ++ show n ++ " = proof" ++ break ++ showSep break (map (\x -> " " ++ x) ps) ++ break ++ "\n" @@ -65,9 +65,9 @@ ideslavePutSExp "end-proof-mode" n let proofs = proof_list i putIState (i { proof_list = (n, prf) : proofs }) - let tree = simpleCase False True False CompileTime (FC "proof" 0) [([], P Ref n ty, tm)] + let tree = simpleCase False True False CompileTime (fileFC "proof") [([], P Ref n ty, tm)] logLvl 3 (show tree) - (ptm, pty) <- recheckC (FC "proof" 0) [] tm + (ptm, pty) <- recheckC (fileFC "proof") [] tm logLvl 5 ("Proof type: " ++ show pty ++ "\n" ++ "Expected type:" ++ show ty) case converts ctxt [] ty pty of @@ -84,8 +84,7 @@ elabStep :: ElabState [PDecl] -> ElabD a -> Idris (a, ElabState [PDecl]) elabStep st e = do case runStateT e st of OK (a, st') -> return (a, st') - Error a -> do i <- getIState - fail (pshow i a) + Error a -> ierror a dumpState :: IState -> ProofState -> Idris () dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _) = @@ -106,7 +105,7 @@ prettyPs ((n, Let t v) : bs) = nest nestingSize (pretty n <+> text "=" <+> tPretty v <> colon <+> tPretty t $$ prettyPs bs) - prettyPs ((n, b) : bs) = + prettyPs ((n, b) : bs) = pretty n <+> colon <+> tPretty (binderTy b) $$ prettyPs bs prettyG (Guess t v) = tPretty t <+> text "=?=" <+> tPretty v @@ -137,8 +136,10 @@ receiveInput :: ElabState [PDecl] -> Idris (Maybe String) receiveInput e = do i <- getIState - l <- liftIO $ getLine - let (sexp, id) = parseMessage l + l <- runIO $ getLine + (sexp, id) <- case parseMessage l of + Left err -> ierror err + Right (sexp, id) -> return (sexp, id) putIState $ i { idris_outputmode = (IdeSlave id) } case sexpToCommand sexp of Just (REPLCompletions prefix) -> @@ -168,33 +169,33 @@ i <- receiveInput e return (i, h) (cmd, step) <- case x of - Nothing -> do iFail ""; fail "Abandoned" + Nothing -> do iPrintError ""; fail "Abandoned" Just input -> do return (parseTactic i input, input) case cmd of - Success Abandon -> do iFail ""; fail "Abandoned" + Success Abandon -> do iPrintError ""; fail "Abandoned" _ -> return () (d, st, done, prf') <- idrisCatch (case cmd of - Failure err -> do iFail (show err) + Failure err -> do iPrintError (show err) return (False, e, False, prf) Success Undo -> do (_, st) <- elabStep e loadState - iResult "" + iPrintResult "" return (True, st, False, init prf) - Success ProofState -> do iResult "" + Success ProofState -> do iPrintResult "" return (True, e, False, prf) Success ProofTerm -> do tm <- lifte e get_term - iResult $ "TT: " ++ show tm ++ "\n" + iPrintResult $ "TT: " ++ show tm ++ "\n" return (False, e, False, prf) Success Qed -> do hs <- lifte e get_holes - when (not (null hs)) $ fail "Incomplete proof" - iResult "Proof completed!" + when (not (null hs)) $ ifail "Incomplete proof" + iPrintResult "Proof completed!" return (False, e, True, prf) Success tac -> do (_, e) <- elabStep e saveState (_, st) <- elabStep e (runTac True i tac) -- trace (show (problems (proof st))) $ - iResult "" + iPrintResult "" return (True, st, False, prf ++ [step])) - (\err -> do iFail (show err) + (\err -> do iPrintError (pshow i err) return (False, e, False, prf)) ideslavePutSExp "write-proof-state" (prf', length prf') if done then do (tm, _) <- elabStep st get_term diff --git a/src/Idris/Providers.hs b/src/Idris/Providers.hs --- a/src/Idris/Providers.hs +++ b/src/Idris/Providers.hs @@ -19,9 +19,9 @@ , (P _ (NS (UN "Error") ["Providers"]) _, [_, err]) <- unApply result = case err of Constant (Str msg) -> ierror . ProviderError $ msg - _ -> fail "Internal error in type provider, non-normalised error" + _ -> ifail "Internal error in type provider, non-normalised error" | (P _ (UN "prim_io_return") _, [tp, result]) <- unApply tm , (P _ (NS (UN "Provide") ["Providers"]) _, [_, res]) <- unApply result = return res - | otherwise = fail $ "Internal type provider error: result was not " ++ - "IO (Provider a), or perhaps missing normalisation." + | otherwise = ifail $ "Internal type provider error: result was not " ++ + "IO (Provider a), or perhaps missing normalisation." diff --git a/src/Idris/REPL.hs b/src/Idris/REPL.hs --- a/src/Idris/REPL.hs +++ b/src/Idris/REPL.hs @@ -17,24 +17,25 @@ import Idris.Docs import Idris.Help import Idris.Completion -import Idris.IdeSlave +import qualified Idris.IdeSlave as IdeSlave import Idris.Chaser import Idris.Imports import Idris.Colours import Idris.Inliner +import Idris.CaseSplit +import Idris.DeepSeq import Paths_idris import Util.System import Util.DynamicLinker +import Util.Net (listenOnLocalhost) import Core.Evaluate import Core.Execute (execute) -import Core.ProofShell import Core.TT import Core.Constraints import IRTS.Compiler -import IRTS.LParser import IRTS.CodegenCommon import Text.Trifecta.Result(Result(..)) @@ -56,13 +57,18 @@ import System.Directory import System.IO import Control.Monad -import Control.Monad.Trans.State.Strict ( StateT, execStateT, get, put ) -import Control.Monad.Trans ( liftIO, lift ) +import Control.Monad.Trans.Error (ErrorT(..)) +import Control.Monad.Trans.State.Strict ( StateT, execStateT, evalStateT, get, put ) +import Control.Monad.Trans ( lift ) +import Control.Concurrent.MVar +import Network +import Control.Concurrent import Data.Maybe import Data.List import Data.Char import Data.Version import Data.Word (Word) +import Control.DeepSeq import qualified Text.PrettyPrint.ANSI.Leijen as ANSI @@ -70,12 +76,14 @@ -- | Run the REPL repl :: IState -- ^ The initial state + -> MVar IState -- ^ Server's MVar -> [FilePath] -- ^ The loaded modules -> InputT Idris () -repl orig mods +repl orig stvar mods = H.catch (do let quiet = opt_quiet (idris_options orig) i <- lift getIState + lift $ runIO $ swapMVar stvar i -- update shared state let colour = idris_colourRepl i let theme = idris_colourTheme i let prompt = if quiet @@ -87,16 +95,91 @@ Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye") return () Just input -> H.catch - (do ms <- lift $ processInput input orig mods + (do ms <- lift $ processInput stvar input orig mods case ms of - Just mods -> repl orig mods + Just mods -> repl orig stvar mods Nothing -> return ()) ctrlC) ctrlC where ctrlC :: SomeException -> InputT Idris () ctrlC e = do lift $ iputStrLn (show e) - repl orig mods + repl orig stvar mods +-- | Run the REPL server +startServer :: IState -> MVar IState -> [FilePath] -> Idris () +startServer orig stvar fn_in = do tid <- runIO $ forkOS serverLoop + return () + where serverLoop :: IO () + -- TODO: option for port number + serverLoop = withSocketsDo $ + do sock <- listenOnLocalhost $ PortNumber 4294 + i <- readMVar stvar + loop fn i sock + + fn = case fn_in of + (f:_) -> f + _ -> "" + + loop fn ist sock + = do (h,host,_) <- accept sock + -- just use the local part of the hostname + -- for the "localhost.localdomain" case + if ((takeWhile (/= '.') host) == "localhost" || + host == "127.0.0.1") + then do + cmd <- hGetLine h + takeMVar stvar + (ist', fn) <- processNetCmd stvar orig ist h fn cmd + putMVar stvar ist' + hClose h + loop fn ist' sock + else do + putStrLn $ "Closing connection attempt from non-localhost " ++ host + hClose h + +processNetCmd :: MVar IState -> + IState -> IState -> Handle -> FilePath -> String -> + IO (IState, FilePath) +processNetCmd stvar orig i h fn cmd + = do res <- case parseCmd i "(net)" cmd of + Failure err -> return (Left (Msg " invalid command")) + Success c -> runErrorT $ evalStateT (processNet fn c) i + case res of + Right x -> return x + Left err -> do hPutStrLn h (show err) + return (i, fn) + where + processNet fn Reload = processNet fn (Load fn) + processNet fn (Load f) = + do let ist = orig { idris_options = idris_options i + , idris_colourTheme = idris_colourTheme i + , idris_colourRepl = False + } + putIState ist + setErrContext True + setOutH h + setQuiet True + setVerbose False + mods <- loadInputs h [f] + ist <- getIState + return (ist, f) + processNet fn c = do process h fn c + ist <- getIState + return (ist, fn) + +-- | Run a command on the server on localhost +runClient :: String -> IO () +runClient str = withSocketsDo $ do + h <- connectTo "localhost" (PortNumber 4294) + hPutStrLn h str + resp <- hGetResp "" h + putStr resp + hClose h + where hGetResp acc h = do eof <- hIsEOF h + if eof then return acc + else do l <- hGetLine h + hGetResp (acc ++ l ++ "\n") h + -- | Run the IdeSlave ideslaveStart :: IState -> [FilePath] -> Idris () ideslaveStart orig mods @@ -110,97 +193,122 @@ ideslave :: IState -> [FilePath] -> Idris () ideslave orig mods = do idrisCatch - (do l <- liftIO $ getLine - let (sexp, id) = parseMessage l + (do l <- runIO $ getLine + (sexp, id) <- case IdeSlave.parseMessage l of + Left err -> ierror err + Right (sexp, id) -> return (sexp, id) i <- getIState putIState $ i { idris_outputmode = (IdeSlave id) } - case sexpToCommand sexp of - Just (Interpret cmd) -> - do let fn = case mods of - (f:_) -> f - _ -> "" - c <- colourise - case parseCmd i "(input)" cmd of - Failure err -> iFail $ show (fixColour c err) - Success (Prove n') -> do iResult "" - idrisCatch - (do process fn (Prove n')) - (\e -> do iFail $ show e) - isetPrompt (mkPrompt mods) - Success cmd -> idrisCatch - (do ideslaveProcess fn cmd) - (\e -> do iFail $ show e) - Just (REPLCompletions str) -> - do (unused, compls) <- replCompletion (reverse str, "") - let good = SexpList [SymbolAtom "ok", toSExp (map replacement compls, reverse unused)] - liftIO $ putStrLn $ convSExp "return" good id - Just (LoadFile filename) -> - do clearErr - putIState (orig { idris_options = idris_options i, - idris_outputmode = (IdeSlave id) }) - loadModule filename - iucheck - isetPrompt (mkPrompt [filename]) - - -- Report either success or failure - i <- getIState - case (errLine i) of - Nothing -> iResult $ "loaded " ++ filename - Just x -> iFail $ "didn't load " ++ filename - ideslave orig [filename] - Nothing -> do iFail "did not understand") - (\e -> do iFail $ show e) + idrisCatch -- to report correct id back! + (do let fn = case mods of + (f:_) -> f + _ -> "" + case IdeSlave.sexpToCommand sexp of + Just (IdeSlave.Interpret cmd) -> + do c <- colourise + case parseCmd i "(input)" cmd of + Failure err -> iPrintError $ show (fixColour c err) + Success (Prove n') -> do iPrintResult "" + idrisCatch + (process stdout fn (Prove n')) + (\e -> getIState >>= iPrintError . flip pshow e) + isetPrompt (mkPrompt mods) + Success cmd -> idrisCatch + (ideslaveProcess fn cmd) + (\e -> getIState >>= iPrintError . flip pshow e) + Just (IdeSlave.REPLCompletions str) -> + do (unused, compls) <- replCompletion (reverse str, "") + let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok", IdeSlave.toSExp (map replacement compls, reverse unused)] + runIO $ putStrLn $ IdeSlave.convSExp "return" good id + Just (IdeSlave.LoadFile filename) -> + do clearErr + putIState (orig { idris_options = idris_options i, + idris_outputmode = (IdeSlave id) }) + idrisCatch (do mod <- loadModule' stdout filename + return ()) + (setAndReport) + isetPrompt (mkPrompt [filename]) + -- Report either success or failure + i <- getIState + case (errLine i) of + Nothing -> iPrintResult $ "loaded " ++ filename + Just x -> iPrintError $ "didn't load " ++ filename + ideslave orig [filename] + Just (IdeSlave.TypeOf name) -> + process stdout "(ideslave)" (Check (PRef (FC "(ideslave)" 0 0) (UN name))) + Just (IdeSlave.CaseSplit line name) -> + process stdout fn (CaseSplitAt False line (UN name)) + Just (IdeSlave.AddClause line name) -> + process stdout fn (AddClauseFrom False line (UN name)) + Just (IdeSlave.AddProofClause line name) -> + process stdout fn (AddProofClauseFrom False line (UN name)) + Just (IdeSlave.AddMissing line name) -> + process stdout fn (AddMissing False line (UN name)) + Just (IdeSlave.MakeWithBlock line name) -> + process stdout fn (MakeWith False line (UN name)) + Just (IdeSlave.ProofSearch line name hints) -> + process stdout fn (DoProofSearch False line (UN name) (map UN hints)) + Nothing -> do iPrintError "did not understand") + (\e -> do iPrintError $ show e)) + (\e -> do iPrintError $ show e) ideslave orig mods ideslaveProcess :: FilePath -> Command -> Idris () -ideslaveProcess fn Help = process fn Help -ideslaveProcess fn (ChangeDirectory f) = do process fn (ChangeDirectory f) - iResult "changed directory to" -ideslaveProcess fn (Eval t) = process fn (Eval t) -ideslaveProcess fn (ExecVal t) = process fn (ExecVal t) -ideslaveProcess fn (Check (PRef x n)) = process fn (Check (PRef x n)) -ideslaveProcess fn (Check t) = process fn (Check t) -ideslaveProcess fn (DocStr n) = process fn (DocStr n) -ideslaveProcess fn Universes = process fn Universes -ideslaveProcess fn (Defn n) = do process fn (Defn n) - iResult "" -ideslaveProcess fn (TotCheck n) = process fn (TotCheck n) -ideslaveProcess fn (DebugInfo n) = do process fn (DebugInfo n) - iResult "" -ideslaveProcess fn (Info n) = process fn (Info n) -ideslaveProcess fn (Search t) = process fn (Search t) -ideslaveProcess fn (Spec t) = process fn (Spec t) +ideslaveProcess fn Help = process stdout fn Help +ideslaveProcess fn (ChangeDirectory f) = do process stdout fn (ChangeDirectory f) + iPrintResult "changed directory to" +ideslaveProcess fn (Eval t) = process stdout fn (Eval t) +ideslaveProcess fn (ExecVal t) = process stdout fn (ExecVal t) +ideslaveProcess fn (Check (PRef x n)) = process stdout fn (Check (PRef x n)) +ideslaveProcess fn (Check t) = process stdout fn (Check t) +ideslaveProcess fn (DocStr n) = process stdout fn (DocStr n) +ideslaveProcess fn Universes = process stdout fn Universes +ideslaveProcess fn (Defn n) = do process stdout fn (Defn n) + iPrintResult "" +ideslaveProcess fn (TotCheck n) = process stdout fn (TotCheck n) +ideslaveProcess fn (DebugInfo n) = do process stdout fn (DebugInfo n) + iPrintResult "" +ideslaveProcess fn (Info n) = process stdout fn (Info n) +ideslaveProcess fn (Search t) = process stdout fn (Search t) +ideslaveProcess fn (Spec t) = process stdout fn (Spec t) -- RmProof and AddProof not supported! -ideslaveProcess fn (ShowProof n') = process fn (ShowProof n') -ideslaveProcess fn (HNF t) = process fn (HNF t) ---ideslaveProcess fn TTShell = process fn TTShell -- need some prove mode! +ideslaveProcess fn (ShowProof n') = process stdout fn (ShowProof n') +ideslaveProcess fn (HNF t) = process stdout fn (HNF t) +--ideslaveProcess fn TTShell = process stdout fn TTShell -- need some prove mode! +ideslaveProcess fn (TestInline t) = process stdout fn (TestInline t) --that most likely does not work, since we need to wrap --input/output of the executed binary... -ideslaveProcess fn Execute = do process fn Execute - iResult "" -ideslaveProcess fn (Compile codegen f) = do process fn (Compile codegen f) - iResult "" -ideslaveProcess fn (LogLvl i) = do process fn (LogLvl i) - iResult "" -ideslaveProcess fn (Pattelab t) = process fn (Pattelab t) -ideslaveProcess fn (Missing n) = process fn (Missing n) -ideslaveProcess fn (DynamicLink l) = do process fn (DynamicLink l) - iResult "" -ideslaveProcess fn ListDynamic = do process fn ListDynamic - iResult "" -ideslaveProcess fn Metavars = process fn Metavars -ideslaveProcess fn (SetOpt ErrContext) = do process fn (SetOpt ErrContext) - iResult "" -ideslaveProcess fn (UnsetOpt ErrContext) = do process fn (UnsetOpt ErrContext) - iResult "" -ideslaveProcess fn (SetOpt ShowImpl) = do process fn (SetOpt ShowImpl) - iResult "" -ideslaveProcess fn (UnsetOpt ShowImpl) = do process fn (UnsetOpt ShowImpl) - iResult "" -ideslaveProcess fn (SetOpt x) = process fn (SetOpt x) -ideslaveProcess fn (UnsetOpt x) = process fn (UnsetOpt x) -ideslaveProcess fn _ = iFail "command not recognized or not supported" +ideslaveProcess fn Execute = do process stdout fn Execute + iPrintResult "" +ideslaveProcess fn (Compile codegen f) = do process stdout fn (Compile codegen f) + iPrintResult "" +ideslaveProcess fn (LogLvl i) = do process stdout fn (LogLvl i) + iPrintResult "" +ideslaveProcess fn (Pattelab t) = process stdout fn (Pattelab t) +ideslaveProcess fn (Missing n) = process stdout fn (Missing n) +ideslaveProcess fn (DynamicLink l) = do process stdout fn (DynamicLink l) + iPrintResult "" +ideslaveProcess fn ListDynamic = do process stdout fn ListDynamic + iPrintResult "" +ideslaveProcess fn Metavars = process stdout fn Metavars +ideslaveProcess fn (SetOpt ErrContext) = do process stdout fn (SetOpt ErrContext) + iPrintResult "" +ideslaveProcess fn (UnsetOpt ErrContext) = do process stdout fn (UnsetOpt ErrContext) + iPrintResult "" +ideslaveProcess fn (SetOpt ShowImpl) = do process stdout fn (SetOpt ShowImpl) + iPrintResult "" +ideslaveProcess fn (UnsetOpt ShowImpl) = do process stdout fn (UnsetOpt ShowImpl) + iPrintResult "" +ideslaveProcess fn (SetOpt x) = process stdout fn (SetOpt x) +ideslaveProcess fn (UnsetOpt x) = process stdout fn (UnsetOpt x) +ideslaveProcess fn (CaseSplitAt False pos str) = process stdout fn (CaseSplitAt False pos str) +ideslaveProcess fn (AddProofClauseFrom False pos str) = process stdout fn (AddProofClauseFrom False pos str) +ideslaveProcess fn (AddClauseFrom False pos str) = process stdout fn (AddClauseFrom False pos str) +ideslaveProcess fn (AddMissing False pos str) = process stdout fn (AddMissing False pos str) +ideslaveProcess fn (MakeWith False pos str) = process stdout fn (MakeWith False pos str) +ideslaveProcess fn (DoProofSearch False pos str xs) = process stdout fn (DoProofSearch False pos str xs) +ideslaveProcess fn _ = iPrintError "command not recognized or not supported" -- | The prompt consists of the currently loaded modules, or "Idris" if there are none @@ -213,8 +321,9 @@ (_, ".lidr") -> True _ -> False -processInput :: String -> IState -> [FilePath] -> Idris (Maybe [FilePath]) -processInput cmd orig inputs +processInput :: MVar IState -> String -> + IState -> [FilePath] -> Idris (Maybe [FilePath]) +processInput stvar cmd orig inputs = do i <- getIState let opts = idris_options i let quiet = opt_quiet opts @@ -223,34 +332,35 @@ _ -> "" c <- colourise case parseCmd i "(input)" cmd of - Failure err -> do liftIO $ print (fixColour c err) + Failure err -> do runIO $ print (fixColour c err) return (Just inputs) Success Reload -> do putIState $ orig { idris_options = idris_options i , idris_colourTheme = idris_colourTheme i } clearErr - mods <- loadInputs inputs + mods <- loadInputs stdout inputs return (Just inputs) Success (Load f) -> do putIState orig { idris_options = idris_options i , idris_colourTheme = idris_colourTheme i } clearErr - mod <- loadModule f + mod <- loadModule stdout f return (Just [f]) - Success (ModImport f) -> + Success (ModImport f) -> do clearErr - fmod <- loadModule f + fmod <- loadModule stdout f return (Just (inputs ++ [fmod])) - Success Edit -> do edit fn orig + Success Edit -> do -- takeMVar stvar + edit fn orig return (Just inputs) Success Proofs -> do proofs orig return (Just inputs) Success Quit -> do when (not quiet) (iputStrLn "Bye bye") return Nothing - Success cmd -> do idrisCatch (process fn cmd) - (\e -> iputStrLn (show e)) + Success cmd -> do idrisCatch (process stdout fn cmd) + (\e -> do msg <- showErr e ; iputStrLn msg) return (Just inputs) resolveProof :: Name -> Idris Name @@ -260,7 +370,7 @@ n <- case lookupNames n' ctxt of [x] -> return x [] -> return n' - ns -> fail $ pshow i (CantResolveAlts (map show ns)) + ns -> ierror (CantResolveAlts (map show ns)) return n removeProof :: Name -> Idris () @@ -274,25 +384,28 @@ edit "" orig = iputStrLn "Nothing to edit" edit f orig = do i <- getIState - env <- liftIO $ getEnvironment + env <- runIO $ getEnvironment let editor = getEditor env let line = case errLine i of Just l -> " +" ++ show l ++ " " Nothing -> " " - let cmd = editor ++ line ++ f - liftIO $ system cmd + let cmd = editor ++ line ++ fixName f + runIO $ system cmd clearErr putIState $ orig { idris_options = idris_options i , idris_colourTheme = idris_colourTheme i } - loadInputs [f] + loadInputs stdout [f] iucheck return () where getEditor env | Just ed <- lookup "EDITOR" env = ed | Just ed <- lookup "VISUAL" env = ed | otherwise = "vi" + fixName file | map toLower (takeExtension file) `elem` [".lidr", ".idr"] = file + | otherwise = addExtension file "idr" + proofs :: IState -> Idris () proofs orig = do i <- getIState @@ -307,26 +420,26 @@ = p : "" : prf : xs insertScript prf (x : xs) = x : insertScript prf xs -process :: FilePath -> Command -> Idris () -process fn Help = iResult displayHelp -process fn (ChangeDirectory f) - = do liftIO $ setCurrentDirectory f +process :: Handle -> FilePath -> Command -> Idris () +process h fn Help = iPrintResult displayHelp +process h fn (ChangeDirectory f) + = do runIO $ setCurrentDirectory f return () -process fn (Eval t) +process h fn (Eval t) = do (tm, ty) <- elabVal toplevel False t ctxt <- getContext - ist <- getIState - let tm' = normaliseAll ctxt [] tm - let ty' = normaliseAll ctxt [] ty + let tm' = force (normaliseAll ctxt [] tm) + let ty' = force (normaliseAll ctxt [] ty) -- Add value to context, call it "it" updateContext (addCtxtDef (UN "it") (Function ty' tm')) + ist <- getIState logLvl 3 $ "Raw: " ++ show (tm', ty') logLvl 10 $ "Debug: " ++ showEnvDbg [] tm' imp <- impShow c <- colourise - iResult (showImp (Just ist) imp c (delab ist tm') ++ " : " ++ + ihPrintResult h (showImp (Just ist) imp c (delab ist tm') ++ " : " ++ showImp (Just ist) imp c (delab ist ty')) -process fn (ExecVal t) +process h fn (ExecVal t) = do ctxt <- getContext ist <- getIState (tm, ty) <- elabVal toplevel False t @@ -335,19 +448,43 @@ res <- execute tm imp <- impShow c <- colourise - iResult (showImp (Just ist) imp c (delab ist res) ++ " : " ++ + ihPrintResult h (showImp (Just ist) imp c (delab ist res) ++ " : " ++ showImp (Just ist) imp c (delab ist ty')) -process fn (Check (PRef _ n)) +process h fn (Check (PRef _ n)) = do ctxt <- getContext ist <- getIState imp <- impShow c <- colourise case lookupNames n ctxt of - ts@(_:_) -> do mapM_ (\n -> iputStrLn $ showName (Just ist) [] False c n ++ " : " ++ - showImp (Just ist) imp c (delabTy ist n)) ts - iResult "" - [] -> iFail $ "No such variable " ++ show n -process fn (Check t) + ts@(t:_) -> + case lookup t (idris_metavars ist) of + Just (_, i, _) -> ihPrintResult h (showMetavarInfo c imp ist n i) + Nothing -> ihPrintResult h $ + concat . intersperse "\n" . map (\n -> showName (Just ist) [] False c n ++ " : " ++ + showImp (Just ist) imp c (delabTy ist n)) $ ts + [] -> ihPrintError h $ "No such variable " ++ show n + where + showMetavarInfo c imp ist n i + = case lookupTy n (tt_ctxt ist) of + (ty:_) -> putTy c imp ist i (delab ist ty) + putTy c imp ist 0 sc = putGoal c imp ist sc + putTy c imp ist i (PPi _ n t sc) + = let current = " " ++ + (case n of + MN _ _ -> "_" + UN ('_':'_':_) -> "_" + _ -> showName (Just ist) [] False c n) ++ + " : " ++ showImp (Just ist) imp c t ++ "\n" + in + current ++ putTy c imp ist (i-1) sc + putTy c imp ist _ sc = putGoal c imp ist sc + putGoal c imp ist g + = "--------------------------------------\n" ++ + showName (Just ist) [] False c n ++ " : " ++ + showImp (Just ist) imp c g + + +process h fn (Check t) = do (tm, ty) <- elabVal toplevel False t ctxt <- getContext ist <- getIState @@ -355,28 +492,31 @@ c <- colourise let ty' = normaliseC ctxt [] ty case tm of - TType _ -> iResult ("Type : Type 1") - _ -> iResult (showImp (Just ist) imp c (delab ist tm) ++ " : " ++ - showImp (Just ist) imp c (delab ist ty)) + TType _ -> ihPrintResult h ("Type : Type 1") + _ -> ihPrintResult h (showImp (Just ist) imp c (delab ist tm) ++ " : " ++ + showImp (Just ist) imp c (delab ist ty)) -process fn (DocStr n) = do i <- getIState +process h fn (DocStr n) + = do i <- getIState case lookupCtxtName n (idris_docstrings i) of - [] -> iFail $ "No documentation for " ++ show n + [] -> iPrintError $ "No documentation for " ++ show n ns -> do mapM_ showDoc ns - iResult "" + iPrintResult "" where showDoc (n, d) = do doc <- getDocs n iputStrLn $ show doc -process fn Universes = do i <- getIState +process h fn Universes + = do i <- getIState let cs = idris_constraints i -- iputStrLn $ showSep "\n" (map show cs) iputStrLn $ show (map fst cs) let n = length cs iputStrLn $ "(" ++ show n ++ " constraints)" case ucheck cs of - Error e -> iFail $ pshow i e - OK _ -> iResult "Universes OK" -process fn (Defn n) = do i <- getIState + Error e -> iPrintError $ pshow i e + OK _ -> iPrintResult "Universes OK" +process h fn (Defn n) + = do i <- getIState iputStrLn "Compiled patterns:\n" iputStrLn $ show (lookupDef n (tt_ctxt i)) case lookupCtxt n (idris_patdefs i) of @@ -390,12 +530,20 @@ = do c <- colourise iputStrLn (showImp (Just i) True c (delab i lhs) ++ " = " ++ showImp (Just i) True c (delab i rhs)) -process fn (TotCheck n) = do i <- getIState - case lookupTotal n (tt_ctxt i) of - [t] -> iResult (showTotal t i) - _ -> do iFail "" - return () -process fn (DebugInfo n) +process h fn (TotCheck n) + = do i <- getIState + case lookupNameTotal n (tt_ctxt i) of + [] -> ihPrintError h $ "Unknown operator " ++ show n + ts -> do ist <- getIState + c <- colourise + imp <- impShow + let showN = showName (Just ist) [] imp c + ihPrintResult h . concat . intersperse "\n" . + map (\(n, t) -> showN n ++ " is " ++ showTotal t i) $ + ts + + +process h fn (DebugInfo n) = do i <- getIState let oi = lookupCtxtName n (idris_optimisation i) when (not (null oi)) $ iputStrLn (show oi) @@ -413,18 +561,185 @@ iputStrLn $ "Size change: " ++ show sc when (not (null cg')) $ do iputStrLn "Call graph:\n" iputStrLn (show cg') -process fn (Info n) = do i <- getIState +process h fn (Info n) + = do i <- getIState case lookupCtxt n (idris_classes i) of [c] -> classInfo c - _ -> iFail "Not a class" -process fn (Search t) = iFail "Not implemented" -process fn (Spec t) = do (tm, ty) <- elabVal toplevel False t + _ -> iPrintError "Not a class" +process h fn (Search t) = iPrintError "Not implemented" +-- FIXME: There is far too much repetition in the cases below! +process h fn (CaseSplitAt updatefile l n) + = do src <- runIO $ readFile fn + res <- splitOnLine l n fn + iLOG (showSep "\n" (map show res)) + let (before, (ap : later)) = splitAt (l-1) (lines src) + res' <- replaceSplits ap res + let new = concat res' + if updatefile + then do let fb = fn ++ "~" -- make a backup! + runIO $ writeFile fb (unlines before ++ new ++ unlines later) + runIO $ copyFile fb fn + else -- do ihputStrLn h (show res) + ihPrintResult h new +process h fn (AddClauseFrom updatefile l n) + = do src <- runIO $ readFile fn + let (before, tyline : later) = splitAt (l-1) (lines src) + let indent = getIndent 0 (show n) tyline + cl <- getClause l n fn + -- add clause before first blank line in 'later' + let (nonblank, rest) = span (not . all isSpace) (tyline:later) + if updatefile + then do let fb = fn ++ "~" + runIO $ writeFile fb (unlines (before ++ nonblank) ++ + replicate indent ' ' ++ + cl ++ "\n" ++ + unlines rest) + runIO $ copyFile fb fn + else ihPrintResult h cl + where + getIndent i n [] = 0 + getIndent i n xs | take (length n) xs == n = i + getIndent i n (x : xs) = getIndent (i + 1) n xs +process h fn (AddProofClauseFrom updatefile l n) + = do src <- runIO $ readFile fn + let (before, tyline : later) = splitAt (l-1) (lines src) + let indent = getIndent 0 (show n) tyline + cl <- getProofClause l n fn + -- add clause before first blank line in 'later' + let (nonblank, rest) = span (not . all isSpace) (tyline:later) + if updatefile + then do let fb = fn ++ "~" + runIO $ writeFile fb (unlines (before ++ nonblank) ++ + replicate indent ' ' ++ + cl ++ "\n" ++ + unlines rest) + runIO $ copyFile fb fn + else ihPrintResult h cl + where + getIndent i n [] = 0 + getIndent i n xs | take (length n) xs == n = i + getIndent i n (x : xs) = getIndent (i + 1) n xs +process h fn (AddMissing updatefile l n) + = do src <- runIO $ readFile fn + let (before, tyline : later) = splitAt (l-1) (lines src) + let indent = getIndent 0 (show n) tyline + i <- getIState + cl <- getInternalApp fn l + let n' = getAppName cl + + extras <- case lookupCtxt n' (idris_patdefs i) of + [] -> return "" + [(_, tms)] -> showNew (show n ++ "_rhs") 1 indent tms + let (nonblank, rest) = span (not . all isSpace) (tyline:later) + if updatefile + then do let fb = fn ++ "~" + runIO $ writeFile fb (unlines (before ++ nonblank) + ++ extras ++ unlines rest) + runIO $ copyFile fb fn + else ihPrintResult h extras + where showPat = show . stripNS + stripNS tm = mapPT dens tm where + dens (PRef fc n) = PRef fc (nsroot n) + dens t = t + + nsroot (NS n _) = nsroot n + nsroot (SN (WhereN _ _ n)) = nsroot n + nsroot n = n + + getAppName (PApp _ r _) = getAppName r + getAppName (PRef _ r) = r + getAppName _ = n + + showNew nm i ind (tm : tms) + = do (nm', i') <- getUniq nm i + rest <- showNew nm i' ind tms + return (replicate ind ' ' ++ + showPat tm ++ " = ?" ++ nm' ++ + "\n" ++ rest) + showNew nm i _ [] = return "" + + getIndent i n [] = 0 + getIndent i n xs | take (length n) xs == n = i + getIndent i n (x : xs) = getIndent (i + 1) n xs + +process h fn (MakeWith updatefile l n) + = do src <- runIO $ readFile fn + let (before, tyline : later) = splitAt (l-1) (lines src) + let with = mkWith tyline n + -- add clause before first blank line in 'later' + let (nonblank, rest) = span (not . all isSpace) later + if updatefile then + do let fb = fn ++ "~" + runIO $ writeFile fb (unlines (before ++ nonblank) + ++ with ++ "\n" ++ + unlines rest) + runIO $ copyFile fb fn + else ihPrintResult h with +process h fn (DoProofSearch updatefile l n hints) + = do src <- runIO $ readFile fn + let (before, tyline : later) = splitAt (l-1) (lines src) + ctxt <- getContext + mn <- case lookupNames n ctxt of + [x] -> return x + [] -> return n + ns -> ierror (CantResolveAlts (map show ns)) + i <- getIState + let (top, envlen, _) = case lookup mn (idris_metavars i) of + Just (t, e, False) -> (t, e, False) + _ -> (Nothing, 0, True) + let fc = fileFC fn + let body t = PProof [Try (TSeq Intros (ProofSearch t n hints)) + (ProofSearch t n hints)] + let def = PClause fc mn (PRef fc mn) [] (body top) [] + newmv <- idrisCatch + (do elabDecl' EAll toplevel (PClauses fc [] mn [def]) + (tm, ty) <- elabVal toplevel False (PRef fc mn) + ctxt <- getContext + i <- getIState + return $ show (stripNS + (dropCtxt envlen + (delab i (specialise ctxt [] [(mn, 1)] tm))))) + (\e -> return ("?" ++ show n)) + if updatefile then + do let fb = fn ++ "~" + runIO $ writeFile fb (unlines before ++ + updateMeta tyline (show n) newmv ++ "\n" + ++ unlines later) + runIO $ copyFile fb fn + else ihPrintResult h newmv + where dropCtxt 0 sc = sc + dropCtxt i (PPi _ _ _ sc) = dropCtxt (i - 1) sc + dropCtxt i (PLet _ _ _ sc) = dropCtxt (i - 1) sc + dropCtxt i (PLam _ _ sc) = dropCtxt (i - 1) sc + dropCtxt _ t = t + + stripNS tm = mapPT dens tm where + dens (PRef fc n) = PRef fc (nsroot n) + dens t = t + + nsroot (NS n _) = nsroot n + nsroot (SN (WhereN _ _ n)) = nsroot n + nsroot n = n + + updateMeta ('?':cs) n new + | length cs >= length n + = case splitAt (length n) cs of + (mv, c:cs) -> + if (isSpace c && mv == n) + then new ++ (c : cs) + else '?' : mv ++ c : updateMeta cs n new + (mv, []) -> if (mv == n) then new else '?' : mv + updateMeta (c:cs) n new = c : updateMeta cs n new + updateMeta [] n new = "" + +process h fn (Spec t) + = do (tm, ty) <- elabVal toplevel False t ctxt <- getContext ist <- getIState let tm' = simplify ctxt [] {- (idris_statics ist) -} tm - iResult (show (delab ist tm')) + iPrintResult (show (delab ist tm')) -process fn (RmProof n') +process h fn (RmProof n') = do i <- getIState n <- resolveProof n' let proofs = proof_list i @@ -438,152 +753,157 @@ insertMetavar n = do i <- getIState let ms = idris_metavars i - putIState $ i { idris_metavars = n : ms } + putIState $ i { idris_metavars = (n, (Nothing, 0, False)) : ms } -process fn' (AddProof prf) +process h fn' (AddProof prf) = do fn <- do - ex <- liftIO $ doesFileExist fn' + ex <- runIO $ doesFileExist fn' let fnExt = fn' <.> "idr" - exExt <- liftIO $ doesFileExist fnExt + exExt <- runIO $ doesFileExist fnExt if ex then return fn' else if exExt then return fnExt - else fail $ "Neither \""++fn'++"\" nor \""++fnExt++"\" exist" + else ifail $ "Neither \""++fn'++"\" nor \""++fnExt++"\" exist" let fb = fn ++ "~" - liftIO $ copyFile fn fb -- make a backup in case something goes wrong! - prog <- liftIO $ readFile fb + runIO $ copyFile fn fb -- make a backup in case something goes wrong! + prog <- runIO $ readFile fb i <- getIState let proofs = proof_list i n' <- case prf of Nothing -> case proofs of - [] -> fail "No proof to add" + [] -> ifail "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 - liftIO $ writeFile fn (unlines prog') + runIO $ writeFile fn (unlines prog') removeProof n iputStrLn $ "Added proof " ++ show n where ls = (lines prog) -process fn (ShowProof n') +process h fn (ShowProof n') = do i <- getIState n <- resolveProof n' let proofs = proof_list i case lookup n proofs of - Nothing -> iFail "No proof to show" - Just p -> iResult $ showProof False n p + Nothing -> iPrintError "No proof to show" + Just p -> iPrintResult $ showProof False n p -process fn (Prove n') +process h fn (Prove n') = do ctxt <- getContext ist <- getIState - n <- case lookupNames n' ctxt of - [x] -> return x - [] -> return n' - ns -> fail $ pshow ist (CantResolveAlts (map show ns)) + let ns = lookupNames n' ctxt + let metavars = mapMaybe (\n -> do c <- lookup n (idris_metavars ist); return (n, c)) ns + n <- case metavars of + [] -> ierror (Msg $ "Cannot find metavariable " ++ show n') + [(n, (_,_,False))] -> return n + [(_, (_,_,True))] -> ierror (Msg $ "Declarations not solvable using prover") + ns -> ierror (CantResolveAlts (map show ns)) prover (lit fn) n -- recheck totality i <- getIState - totcheck (FC "(input)" 0, n) + totcheck (fileFC "(input)", n) mapM_ (\ (f,n) -> setTotality n Unchecked) (idris_totcheck i) mapM_ checkDeclTotality (idris_totcheck i) -process fn (HNF t) = do (tm, ty) <- elabVal toplevel False t +process h fn (HNF t) + = do (tm, ty) <- elabVal toplevel False t ctxt <- getContext ist <- getIState let tm' = hnf ctxt [] tm - iResult (show (delab ist tm')) -process fn (TestInline t) = do (tm, ty) <- elabVal toplevel False t + iPrintResult (show (delab ist tm')) +process h fn (TestInline t) + = do (tm, ty) <- elabVal toplevel False t ctxt <- getContext ist <- getIState let tm' = inlineTerm ist tm imp <- impShow c <- colourise - iResult (showImp (Just ist) imp c (delab ist tm')) -process fn TTShell = do ist <- getIState - let shst = initState (tt_ctxt ist) - runShell shst - return () -process fn Execute = do (m, _) <- elabVal toplevel False + iPrintResult (showImp (Just ist) imp c (delab ist tm')) +process h fn Execute + = do (m, _) <- elabVal toplevel False (PApp fc (PRef fc (UN "run__IO")) [pexp $ PRef fc (NS (UN "main") ["Main"])]) -- (PRef (FC "main" 0) (NS (UN "main") ["main"])) - (tmpn, tmph) <- liftIO tempfile - liftIO $ hClose tmph + (tmpn, tmph) <- runIO tempfile + runIO $ hClose tmph t <- codegen compile t tmpn m - liftIO $ system tmpn + runIO $ system tmpn return () - where fc = FC "main" 0 -process fn (Compile codegen f) + where fc = fileFC "main" +process h fn (Compile codegen f) = do (m, _) <- elabVal toplevel False (PApp fc (PRef fc (UN "run__IO")) [pexp $ PRef fc (NS (UN "main") ["Main"])]) compile codegen f m - where fc = FC "main" 0 -process fn (LogLvl i) = setLogLevel i + where fc = fileFC "main" +process h fn (LogLvl i) = setLogLevel i -- Elaborate as if LHS of a pattern (debug command) -process fn (Pattelab t) +process h fn (Pattelab t) = do (tm, ty) <- elabVal toplevel True t - iResult $ show tm ++ "\n\n : " ++ show ty + iPrintResult $ show tm ++ "\n\n : " ++ show ty -process fn (Missing n) +process h fn (Missing n) = do i <- getIState c <- colourise case lookupCtxt n (idris_patdefs i) of [] -> return () [(_, tms)] -> - iResult (showSep "\n" (map (showImp (Just i) True c) tms)) - _ -> iFail $ "Ambiguous name" -process fn (DynamicLink l) = do i <- getIState + iPrintResult (showSep "\n" (map (showImp (Just i) True c) tms)) + _ -> iPrintError $ "Ambiguous name" +process h fn (DynamicLink l) + = do i <- getIState let lib = trim l - handle <- lift $ tryLoadLib lib + handle <- lift . lift $ tryLoadLib lib case handle of - Nothing -> iFail $ "Could not load dynamic lib \"" ++ l ++ "\"" + Nothing -> iPrintError $ "Could not load dynamic lib \"" ++ l ++ "\"" Just x -> do let libs = idris_dynamic_libs i if x `elem` libs then do iLOG ("Tried to load duplicate library " ++ lib_name x) return () else putIState $ i { idris_dynamic_libs = x:libs } where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace -process fn ListDynamic = do i <- getIState +process h fn ListDynamic + = do i <- getIState iputStrLn "Dynamic libraries:" showLibs $ idris_dynamic_libs i where showLibs [] = return () showLibs ((Lib name _):ls) = do iputStrLn $ "\t" ++ name; showLibs ls -process fn Metavars +process h fn Metavars = do ist <- getIState - let mvs = idris_metavars ist \\ primDefs + let mvs = map fst (idris_metavars ist) \\ primDefs case mvs of - [] -> iFail "No global metavariables to solve" - _ -> iResult $ "Global metavariables:\n\t" ++ show mvs -process fn NOP = return () + [] -> iPrintError "No global metavariables to solve" + _ -> iPrintResult $ "Global metavariables:\n\t" ++ show mvs +process h fn NOP = return () -process fn (SetOpt ErrContext) = setErrContext True -process fn (UnsetOpt ErrContext) = setErrContext False -process fn (SetOpt ShowImpl) = setImpShow True -process fn (UnsetOpt ShowImpl) = setImpShow False +process h fn (SetOpt ErrContext) = setErrContext True +process h fn (UnsetOpt ErrContext) = setErrContext False +process h fn (SetOpt ShowImpl) = setImpShow True +process h fn (UnsetOpt ShowImpl) = setImpShow False -process fn (SetOpt _) = iFail "Not a valid option" -process fn (UnsetOpt _) = iFail "Not a valid option" -process fn (SetColour ty c) = setColour ty c -process fn ColourOn = do ist <- getIState +process h fn (SetOpt _) = iPrintError "Not a valid option" +process h fn (UnsetOpt _) = iPrintError "Not a valid option" +process h fn (SetColour ty c) = setColour ty c +process h fn ColourOn + = do ist <- getIState putIState $ ist { idris_colourRepl = True } -process fn ColourOff = do ist <- getIState +process h fn ColourOff + = do ist <- getIState putIState $ ist { idris_colourRepl = False } - classInfo :: ClassInfo -> Idris () classInfo ci = do iputStrLn "Methods:\n" mapM_ dumpMethod (class_methods ci) iputStrLn "" iputStrLn "Instances:\n" mapM_ dumpInstance (class_instances ci) - iResult "" + iPrintResult "" dumpMethod :: (Name, (FnOpts, PTerm)) -> Idris () dumpMethod (n, (_, t)) = iputStrLn $ show n ++ " : " ++ show t @@ -595,6 +915,7 @@ case lookupTy n ctxt of ts -> mapM_ (\t -> iputStrLn $ showImp Nothing imp False (delab i t)) ts +showTotal :: Totality -> IState -> String showTotal t@(Partial (Other ns)) i = show t ++ "\n\t" ++ showSep "\n\t" (map (showTotalN i) ns) showTotal t i = show t @@ -607,9 +928,9 @@ "--------------" ++ map (\x -> '-') vstr ++ "\n\n" ++ concatMap cmdInfo helphead ++ concatMap cmdInfo help - where cmdInfo (cmds, args, text) = " " ++ col 16 12 (showSep " " cmds) (show args) text - col c1 c2 l m r = - l ++ take (c1 - length l) (repeat ' ') ++ + where cmdInfo (cmds, args, text) = " " ++ col 16 12 (showSep " " cmds) (show args) text + col c1 c2 l m r = + l ++ take (c1 - length l) (repeat ' ') ++ m ++ take (c2 - length m) (repeat ' ') ++ r ++ "\n" parseCodegen :: String -> Codegen @@ -623,10 +944,14 @@ parseArgs :: [String] -> [Opt] parseArgs [] = [] +parseArgs ("--nobanner":ns) = NoBanner : (parseArgs ns) parseArgs ("--quiet":ns) = Quiet : (parseArgs ns) parseArgs ("--ideslave":ns) = Ideslave : (parseArgs ns) +parseArgs ("--client":ns) = [Client (showSep " " ns)] parseArgs ("--log":lvl:ns) = OLogging (read lvl) : (parseArgs ns) +parseArgs ("--nobasepkgs":ns) = NoBasePkgs : (parseArgs ns) parseArgs ("--noprelude":ns) = NoPrelude : (parseArgs ns) +parseArgs ("--nobuiltins":ns) = NoBuiltins : NoPrelude : (parseArgs ns) parseArgs ("--check":ns) = NoREPL : (parseArgs ns) parseArgs ("-o":n:ns) = NoREPL : Output n : (parseArgs ns) parseArgs ("--typecase":ns) = TypeCase : (parseArgs ns) @@ -651,9 +976,9 @@ parseArgs ("--install":n:ns) = PkgInstall n : (parseArgs ns) parseArgs ("--clean":n:ns) = PkgClean n : (parseArgs ns) parseArgs ("--bytecode":n:ns) = NoREPL : BCAsm n : (parseArgs ns) -parseArgs ("--fovm":n:ns) = NoREPL : FOVM n : (parseArgs ns) parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns) parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns) +parseArgs ("--mvn":ns) = OutputTy MavenProject : (parseArgs ns) parseArgs ("--dumpdefuns":n:ns) = DumpDefun n : (parseArgs ns) parseArgs ("--dumpcases":n:ns) = DumpCases n : (parseArgs ns) parseArgs ("--codegen":n:ns) = UseCodegen (parseCodegen n) : (parseArgs ns) @@ -686,34 +1011,38 @@ } -- invoke as if from command line -idris :: [Opt] -> IO IState -idris opts = execStateT (idrisMain opts) idrisInit +idris :: [Opt] -> IO () +idris opts = do res <- runErrorT $ execStateT (idrisMain opts) idrisInit + case res of + Left err -> putStrLn $ pshow idrisInit err + Right ist -> return () -loadInputs :: [FilePath] -> Idris () -loadInputs inputs + +loadInputs :: Handle -> [FilePath] -> Idris () +loadInputs h inputs = do ist <- getIState -- if we're in --check and not outputting anything, don't bother - -- loading, as it gets really slow if there's lots of modules in + -- loading, as it gets really slow if there's lots of modules in -- a package (instead, reload all at the end to check for -- consistency only) opts <- getCmdLine let loadCode = case opt getOutput opts of - [] -> not (NoREPL `elem` opts) + [] -> not (NoREPL `elem` opts) _ -> True -- For each ifile list, check it and build ibcs in the same clean IState -- so that they don't interfere with each other when checking let ninputs = zip [1..] inputs - ifiles <- mapM (\(num, input) -> + ifiles <- mapM (\(num, input) -> do putIState ist v <- verbose --- when v $ iputStrLn $ "(" ++ show num ++ "/" ++ +-- when v $ iputStrLn $ "(" ++ show num ++ "/" ++ -- show (length inputs) ++ --- ") " ++ input - modTree <- buildTree - (map snd (take (num-1) ninputs)) +-- ") " ++ input + modTree <- buildTree + (map snd (take (num-1) ninputs)) input let ifiles = getModuleFiles modTree iLOG ("MODULE TREE : " ++ show modTree) @@ -744,7 +1073,7 @@ where -- load all files, stop if any fail tryLoad :: [IFileType] -> Idris () tryLoad [] = return () - tryLoad (f : fs) = do loadFromIFile f + tryLoad (f : fs) = do loadFromIFile h f inew <- getIState case errLine inew of Nothing -> tryLoad fs @@ -757,22 +1086,22 @@ idrisMain opts = do let inputs = opt getFile opts let quiet = Quiet `elem` opts + let nobanner = NoBanner `elem` opts let idesl = Ideslave `elem` opts let runrepl = not (NoREPL `elem` opts) let output = opt getOutput opts let ibcsubdir = opt getIBCSubDir opts let importdirs = opt getImportDir opts let bcs = opt getBC opts - let vm = opt getFOVM opts let pkgdirs = opt getPkgDir opts let optimize = case opt getOptLevel opts of [] -> 2 xs -> last xs trpl <- case opt getTriple opts of - [] -> liftIO $ getDefaultTargetTriple + [] -> runIO $ getDefaultTargetTriple xs -> return (last xs) tcpu <- case opt getCPU opts of - [] -> liftIO $ getHostCPUName + [] -> runIO $ getHostCPUName xs -> return (last xs) let outty = case opt getOutputTy opts of [] -> Executable @@ -783,7 +1112,7 @@ script <- case opt getExecScript opts of [] -> return Nothing x:y:xs -> do iputStrLn "More than one interpreter expression found." - liftIO $ exitWith (ExitFailure 1) + runIO $ exitWith (ExitFailure 1) [expr] -> return (Just expr) when (DefaultTotal `elem` opts) $ do i <- getIState putIState (i { default_total = True }) @@ -801,46 +1130,56 @@ setOptLevel optimize when (Verbose `elem` opts) $ setVerbose True mapM_ makeOption opts - -- if we have the --fovm flag, drop into the first order VM testing - case vm of - [] -> return () - xs -> liftIO $ mapM_ (fovm cgn outty) xs -- if we have the --bytecode flag, drop into the bytecode assembler case bcs of [] -> return () - xs -> return () -- liftIO $ mapM_ bcAsm xs + xs -> return () -- runIO $ mapM_ bcAsm xs case ibcsubdir of [] -> setIBCSubDir "" (d:_) -> setIBCSubDir d setImportDirs importdirs - addPkgDir "base" + when (not (NoBasePkgs `elem` opts)) $ do + addPkgDir "prelude" + addPkgDir "base" mapM_ addPkgDir pkgdirs elabPrims - when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude" + when (not (NoBuiltins `elem` opts)) $ do x <- loadModule stdout "Builtins" + return () + when (not (NoPrelude `elem` opts)) $ do x <- loadModule stdout "Prelude" return () - when (runrepl && not quiet && not idesl && not (isJust script)) $ iputStrLn banner + when (runrepl && not quiet && not idesl && not (isJust script) && not nobanner) $ iputStrLn banner ist <- getIState - loadInputs inputs + loadInputs stdout inputs - liftIO $ hSetBuffering stdout LineBuffering + runIO $ hSetBuffering stdout LineBuffering ok <- noErrors when ok $ case output of [] -> return () - (o:_) -> process "" (Compile cgn o) + (o:_) -> idrisCatch (process stdout "" (Compile cgn o)) + (\e -> do ist <- getIState ; iputStrLn $ pshow ist e) case script of Nothing -> return () Just expr -> execScript expr + -- Create Idris data dir + repl history and config dir + idrisCatch (do dir <- getIdrisUserDataDir + exists <- runIO $ doesDirectoryExist dir + unless exists $ iLOG ("Creating " ++ dir) + runIO $ createDirectoryIfMissing True (dir "repl")) + (\e -> return ()) + historyFile <- fmap ( "repl" "history") getIdrisUserDataDir - when runrepl $ initScript - when (runrepl && not idesl) $ runInputT (replSettings (Just historyFile)) $ repl ist inputs + when (runrepl && not idesl) $ initScript + stvar <- runIO $ newMVar ist + when (runrepl && not idesl) $ startServer ist stvar inputs + when (runrepl && not idesl) $ runInputT (replSettings (Just historyFile)) $ repl ist stvar inputs when (idesl) $ ideslaveStart ist inputs ok <- noErrors - when (not ok) $ liftIO (exitWith (ExitFailure 1)) + when (not ok) $ runIO (exitWith (ExitFailure 1)) where makeOption (OLogging i) = setLogLevel i makeOption TypeCase = setTypeCase True @@ -850,7 +1189,7 @@ makeOption _ = return () addPkgDir :: String -> Idris () - addPkgDir p = do ddir <- liftIO $ getDataDir + addPkgDir p = do ddir <- runIO $ getDataDir addImportDir (ddir p) execScript :: String -> Idris () @@ -858,11 +1197,11 @@ c <- colourise case parseExpr i expr of Failure err -> do iputStrLn $ show (fixColour c err) - liftIO $ exitWith (ExitFailure 1) + runIO $ exitWith (ExitFailure 1) Success term -> do ctxt <- getContext (tm, _) <- elabVal toplevel False term res <- execute tm - liftIO $ exitWith ExitSuccess + runIO $ exitWith ExitSuccess -- | Check if the coloring matches the options and corrects if necessary fixColour :: Bool -> ANSI.Doc -> ANSI.Doc @@ -871,7 +1210,7 @@ -- | Get the platform-specific, user-specific Idris dir getIdrisUserDataDir :: Idris FilePath -getIdrisUserDataDir = liftIO $ getAppUserDataDirectory "idris" +getIdrisUserDataDir = runIO $ getAppUserDataDirectory "idris" -- | Locate the platform-specific location for the init script getInitScript :: Idris FilePath @@ -881,31 +1220,31 @@ -- | Run the initialisation script initScript :: Idris () initScript = do script <- getInitScript - idrisCatch (do go <- liftIO $ doesFileExist script + idrisCatch (do go <- runIO $ doesFileExist script when go $ do - h <- liftIO $ openFile script ReadMode + h <- runIO $ openFile script ReadMode runInit h - liftIO $ hClose h) - (\e -> iFail $ "Error reading init file: " ++ show e) + runIO $ hClose h) + (\e -> iPrintError $ "Error reading init file: " ++ show e) where runInit :: Handle -> Idris () - runInit h = do eof <- lift (hIsEOF h) + runInit h = do eof <- lift . lift $ hIsEOF h ist <- getIState unless eof $ do - line <- liftIO $ hGetLine h + line <- runIO $ hGetLine h script <- getInitScript c <- colourise processLine ist line script c runInit h processLine i cmd input clr = case parseCmd i input cmd of - Failure err -> liftIO $ print (fixColour clr err) - Success Reload -> iFail "Init scripts cannot reload the file" - Success (Load f) -> iFail "Init scripts cannot load files" - Success (ModImport f) -> iFail "Init scripts cannot import modules" - Success Edit -> iFail "Init scripts cannot invoke the editor" + Failure err -> runIO $ print (fixColour clr err) + Success Reload -> iPrintError "Init scripts cannot reload the file" + Success (Load f) -> iPrintError "Init scripts cannot load files" + Success (ModImport f) -> iPrintError "Init scripts cannot import modules" + Success Edit -> iPrintError "Init scripts cannot invoke the editor" Success Proofs -> proofs i - Success Quit -> iFail "Init scripts cannot quit Idris" - Success cmd -> process [] cmd + Success Quit -> iPrintError "Init scripts cannot quit Idris" + Success cmd -> process stdout [] cmd getFile :: Opt -> Maybe String getFile (Filename str) = Just str @@ -915,10 +1254,6 @@ getBC (BCAsm str) = Just str getBC _ = Nothing -getFOVM :: Opt -> Maybe String -getFOVM (FOVM str) = Just str -getFOVM _ = Nothing - getOutput :: Opt -> Maybe String getOutput (Output str) = Just str getOutput _ = Nothing @@ -981,10 +1316,10 @@ ver = showVersion version -banner = " ____ __ _ \n" ++ +banner = " ____ __ _ \n" ++ " / _/___/ /____(_)____ \n" ++ " / // __ / ___/ / ___/ Version " ++ ver ++ "\n" ++ " _/ // /_/ / / / (__ ) http://www.idris-lang.org/ \n" ++ - " /___/\\__,_/_/ /_/____/ Type :? for help \n" + " /___/\\__,_/_/ /_/____/ Type :? for help \n" diff --git a/src/Idris/REPLParser.hs b/src/Idris/REPLParser.hs --- a/src/Idris/REPLParser.hs +++ b/src/Idris/REPLParser.hs @@ -23,7 +23,7 @@ import qualified Data.ByteString.UTF8 as UTF8 parseCmd :: IState -> String -> String -> Result Command -parseCmd i inputname = parseString (P.runInnerParser (evalStateT pCmd i)) (Directed (UTF8.fromString inputname) 0 0 0 0) +parseCmd i inputname = P.runparser pCmd i inputname cmd :: [String] -> P.IdrisParser () cmd xs = do P.lchar ':'; docmd (sortBy (\x y -> compare (length y) (length x)) xs) @@ -34,20 +34,14 @@ pCmd = do P.whiteSpace; 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 <- P.identifier; eof; + <|> try (do cmd ["module"]; f <- P.identifier; eof; return (ModImport (toPath f))) <|> try (do cmd ["e", "edit"]; eof; return Edit) <|> try (do cmd ["exec", "execute"]; eof; return Execute) - <|> try (do cmd ["ttshell"]; eof; return TTShell) <|> try (do cmd ["c", "compile"]; f <- P.identifier; eof; return (Compile ViaC f)) <|> try (do cmd ["jc", "newcompile"]; f <- P.identifier; eof; return (Compile ViaJava f)) <|> try (do cmd ["js", "javascript"]; f <- P.identifier; eof; return (Compile ViaJavaScript f)) - <|> try (do cmd ["m", "metavars"]; eof; return Metavars) <|> try (do cmd ["proofs"]; eof; return Proofs) - <|> try (do cmd ["p", "prove"]; n <- P.name; eof; return (Prove n)) - <|> try (do cmd ["a", "addproof"]; do n <- option Nothing (do x <- P.name; - return (Just x)) - eof; return (AddProof n)) <|> try (do cmd ["rmproof"]; n <- P.name; eof; return (RmProof n)) <|> try (do cmd ["showproof"]; n <- P.name; eof; return (ShowProof n)) <|> try (do cmd ["log"]; i <- P.natural; eof; return (LogLvl (fromIntegral i))) @@ -70,6 +64,36 @@ <|> try (do cmd ["set"]; o <-pOption; return (SetOpt o)) <|> try (do cmd ["unset"]; o <-pOption; return (UnsetOpt o)) <|> try (do cmd ["s", "search"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Search t)) + <|> try (do cmd ["cs", "casesplit"]; P.whiteSpace; + upd <- option False (do P.lchar '!'; return True) + l <- P.natural; n <- P.name; + return (CaseSplitAt upd (fromInteger l) n)) + <|> try (do cmd ["apc", "addproofclause"]; P.whiteSpace; + upd <- option False (do P.lchar '!'; return True) + l <- P.natural; n <- P.name; + return (AddProofClauseFrom upd (fromInteger l) n)) + <|> try (do cmd ["ac", "addclause"]; P.whiteSpace; + upd <- option False (do P.lchar '!'; return True) + l <- P.natural; n <- P.name; + return (AddClauseFrom upd (fromInteger l) n)) + <|> try (do cmd ["am", "addmissing"]; P.whiteSpace; + upd <- option False (do P.lchar '!'; return True) + l <- P.natural; n <- P.name; + return (AddMissing upd (fromInteger l) n)) + <|> try (do cmd ["mw", "makewith"]; P.whiteSpace; + upd <- option False (do P.lchar '!'; return True) + l <- P.natural; n <- P.name; + return (MakeWith upd (fromInteger l) n)) + <|> try (do cmd ["ps", "proofsearch"]; P.whiteSpace; + upd <- option False (do P.lchar '!'; return True) + l <- P.natural; n <- P.name; + hints <- many P.name + return (DoProofSearch upd (fromInteger l) n hints)) + <|> try (do cmd ["p", "prove"]; n <- P.name; eof; return (Prove n)) + <|> try (do cmd ["m", "metavars"]; eof; return Metavars) + <|> try (do cmd ["a", "addproof"]; do n <- option Nothing (do x <- P.name; + return (Just x)) + eof; return (AddProof n)) <|> try (do cmd ["x"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (ExecVal t)) <|> try (do cmd ["patt"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Pattelab t)) <|> do P.whiteSpace; do eof; return NOP @@ -82,18 +106,19 @@ <|> do discard (P.symbol "showimplicits"); return ShowImpl -colours :: [(String, Color)] -colours = [ ("black", Black) - , ("red", Red) - , ("green", Green) - , ("yellow", Yellow) - , ("blue", Blue) - , ("magenta", Magenta) - , ("cyan", Cyan) - , ("white", White) +colours :: [(String, Maybe Color)] +colours = [ ("black", Just Black) + , ("red", Just Red) + , ("green", Just Green) + , ("yellow", Just Yellow) + , ("blue", Just Blue) + , ("magenta", Just Magenta) + , ("cyan", Just Cyan) + , ("white", Just White) + , ("default", Nothing) ] -pColour :: P.IdrisParser Color +pColour :: P.IdrisParser (Maybe Color) pColour = doColour colours where doColour [] = fail "Unknown colour" doColour ((s, c):cs) = (try (P.symbol s) >> return c) <|> doColour cs @@ -131,7 +156,7 @@ pSetColourCmd :: P.IdrisParser Command pSetColourCmd = (do c <- pColourType - let defaultColour = IdrisColour Black True False False False + let defaultColour = IdrisColour Nothing True False False False opts <- sepBy pColourMod (P.whiteSpace) let colour = foldr ($) defaultColour $ reverse opts return $ SetColour c colour) diff --git a/src/Idris/Transforms.hs b/src/Idris/Transforms.hs --- a/src/Idris/Transforms.hs +++ b/src/Idris/Transforms.hs @@ -40,7 +40,7 @@ natTrans = [TermTrans zero, TermTrans suc, CaseTrans natcase] zname = NS (UN "Z") ["Nat","Prelude"] -sname = NS (UN "S") ["Nat","Prelude"] +sname = NS (UN "S") ["Nat","Prelude"] zero :: TT Name -> TT Name zero (P _ n _) | n == zname @@ -53,5 +53,5 @@ suc x = x natcase :: SC -> SC -natcase = undefined +natcase = undefined diff --git a/src/Idris/Unlit.hs b/src/Idris/Unlit.hs --- a/src/Idris/Unlit.hs +++ b/src/Idris/Unlit.hs @@ -10,19 +10,22 @@ data LineType = Prog | Blank | Comm +ulLine :: String -> (LineType, String) ulLine ('>':' ':xs) = (Prog, xs) ulLine ('>':xs) = (Prog, xs) ulLine xs | all isSpace xs = (Blank, "") -- make sure it's not a doc comment - | otherwise = (Comm, '-':'-':' ':'>':xs) + | otherwise = (Comm, '-':'-':' ':'>':xs) +check :: FilePath -> Int -> [(LineType, String)] -> TC () check f l (a:b:cs) = do chkAdj f l (fst a) (fst b) check f (l+1) (b:cs) check f l [x] = return () check f l [] = return () -chkAdj f l Prog Comm = tfail $ At (FC f l) ProgramLineComment -chkAdj f l Comm Prog = tfail $ At (FC f l) ProgramLineComment +chkAdj :: FilePath -> Int -> LineType -> LineType -> TC () +chkAdj f l Prog Comm = tfail $ At (FC f l 0) ProgramLineComment --TODO: Include column? +chkAdj f l Comm Prog = tfail $ At (FC f l 0) ProgramLineComment --TODO: Include column? chkAdj f l _ _ = return () diff --git a/src/Idris/UnusedArgs.hs b/src/Idris/UnusedArgs.hs --- a/src/Idris/UnusedArgs.hs +++ b/src/Idris/UnusedArgs.hs @@ -13,18 +13,18 @@ findUnusedArgs ns = mapM_ traceUnused ns traceUnused :: Name -> Idris () -traceUnused n +traceUnused n = do i <- getIState - case lookupCtxt n (idris_callgraph i) of + case lookupCtxt 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)) -> + 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 + 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 @@ -34,14 +34,14 @@ | otherwise = Just i used :: [(Name, Int)] -> Name -> Int -> Idris Bool -used path g j +used path g j | (g, j) `elem` path = return False -- cycle, never used on the way - | otherwise - = do logLvl 5 $ (show ((g, j) : path)) + | otherwise + = do logLvl 5 $ (show ((g, j) : path)) i <- getIState case lookupCtxt g (idris_callgraph i) of [CGInfo args calls scg usedns unused] -> - if (j >= length args) + if (j >= length args) then -- overapplied, assume used return True else do let directuse = args!!j `elem` usedns @@ -50,7 +50,7 @@ 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 (directuse || null recused || or recused) _ -> return True -- no definition, assume used getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))] diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -8,15 +8,12 @@ import Data.Maybe import Data.Version +import Control.Monad.Trans.Error ( ErrorT(..) ) import Control.Monad.Trans.State.Strict ( execStateT, get, put ) -import Control.Monad.Trans ( liftIO ) import Control.Monad ( when ) -import Core.CoreParser -import Core.ShellParser import Core.TT import Core.Typecheck -import Core.ProofShell import Core.Evaluate import Core.Constraints @@ -40,22 +37,28 @@ main = do xs <- getArgs let opts = parseArgs xs - execStateT (runIdris opts) idrisInit + result <- runErrorT $ execStateT (runIdris opts) idrisInit + case result of + Left err -> putStrLn $ "Uncaught error: " ++ show err + Right _ -> return () runIdris :: [Opt] -> Idris () +runIdris [Client c] = do setVerbose False + setQuiet True + runIO $ runClient c runIdris opts = do - when (Ver `elem` opts) $ liftIO showver - when (Usage `elem` opts) $ liftIO usage - when (ShowIncs `elem` opts) $ liftIO showIncs - when (ShowLibs `elem` opts) $ liftIO showLibs - when (ShowLibdir `elem` opts) $ liftIO showLibdir + when (Ver `elem` opts) $ runIO showver + when (Usage `elem` opts) $ runIO usage + when (ShowIncs `elem` opts) $ runIO showIncs + when (ShowLibs `elem` opts) $ runIO showLibs + when (ShowLibdir `elem` opts) $ runIO showLibdir case opt getPkgClean opts of [] -> return () - fs -> do liftIO $ mapM_ cleanPkg fs - liftIO $ exitWith ExitSuccess + fs -> do runIO $ mapM_ cleanPkg fs + runIO $ exitWith ExitSuccess case opt getPkg opts of [] -> idrisMain opts -- in Idris.REPL - fs -> liftIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs + fs -> runIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs usage = do putStrLn usagemsg exitWith ExitSuccess @@ -92,6 +95,7 @@ "\t--log [level] Type debugging log level\n" ++ "\t-S Do no further compilation of code generator output\n" ++ "\t-c Compile to object files rather than an executable\n" ++ + "\t--mvn Create a maven project (for Java codegen)\n" ++ "\t--exec [expr] Execute the expression expr in the interpreter,\n" ++ "\t defaulting to Main.main if none provided, and exit.\n" ++ "\t--ideslave Ideslave mode (for editors; in/ouput wrapped in \n" ++ diff --git a/src/Pkg/PParser.hs b/src/Pkg/PParser.hs --- a/src/Pkg/PParser.hs +++ b/src/Pkg/PParser.hs @@ -1,41 +1,19 @@ module Pkg.PParser where -import Core.CoreParser +import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace) + import Core.TT import Idris.REPL import Idris.AbsSyntaxTree +import Idris.ParseHelpers import Paths_idris -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Error -import Text.ParserCombinators.Parsec.Expr -import Text.ParserCombinators.Parsec.Language -import qualified Text.ParserCombinators.Parsec.Token as PTok +import Control.Monad.State.Strict +import Control.Applicative -type TokenParser a = PTok.TokenParser a -type PParser = GenParser Char PkgDesc - -lexer :: TokenParser PkgDesc -lexer = idrisLexer - -whiteSpace= PTok.whiteSpace lexer -lexeme = PTok.lexeme lexer -symbol = PTok.symbol lexer -natural = PTok.natural lexer -parens = PTok.parens lexer -semi = PTok.semi lexer -comma = PTok.comma lexer -identifier= PTok.identifier lexer -reserved = PTok.reserved lexer -operator = PTok.operator lexer -reservedOp= PTok.reservedOp lexer -integer = PTok.integer lexer -float = PTok.float lexer -strlit = PTok.stringLiteral lexer -chlit = PTok.charLiteral lexer -lchar = lexeme.char +type PParser = StateT PkgDesc IdrisInnerParser data PkgDesc = PkgDesc { pkgname :: String, libdeps :: [String], @@ -53,50 +31,50 @@ parseDesc :: FilePath -> IO PkgDesc parseDesc fp = do p <- readFile fp - case runParser pPkg defaultPkg fp p of - Left err -> fail (show err) - Right x -> return x + case runparser pPkg defaultPkg fp p of + Failure err -> fail (show err) + Success x -> return x pPkg :: PParser PkgDesc -pPkg = do reserved "package"; p <- identifier - st <- getState - setState (st { pkgname = p }) - many1 pClause - st <- getState +pPkg = do reserved "package"; p <- identifier + st <- get + put (st { pkgname = p }) + some pClause + st <- get return st pClause :: PParser () pClause = do reserved "executable"; lchar '='; exec <- iName [] - st <- getState - setState (st { execout = Just (show exec) }) + st <- get + put (st { execout = Just (show exec) }) <|> do reserved "main"; lchar '='; main <- iName [] - st <- getState - setState (st { idris_main = main }) + st <- get + put (st { idris_main = main }) <|> do reserved "sourcedir"; lchar '='; src <- identifier - st <- getState - setState (st { sourcedir = src }) + st <- get + put (st { sourcedir = src }) <|> do reserved "opts"; lchar '='; - opts <- strlit - st <- getState + opts <- stringLiteral + st <- get let args = parseArgs (words opts) - setState (st { idris_opts = args }) + put (st { idris_opts = args }) <|> do reserved "modules"; lchar '='; - ms <- sepBy1 (iName []) (lchar ',') - st <- getState - setState (st { modules = modules st ++ ms }) + ms <- sepBy1 (iName []) (lchar ',') + st <- get + put (st { modules = modules st ++ ms }) <|> do reserved "libs"; lchar '='; ls <- sepBy1 identifier (lchar ',') - st <- getState - setState (st { libdeps = libdeps st ++ ls }) + st <- get + put (st { libdeps = libdeps st ++ ls }) <|> do reserved "objs"; lchar '='; ls <- sepBy1 identifier (lchar ',') - st <- getState - setState (st { objs = libdeps st ++ ls }) + st <- get + put (st { objs = libdeps st ++ ls }) <|> do reserved "makefile"; lchar '='; mk <- iName [] - st <- getState - setState (st { makefile = Just (show mk) }) - + st <- get + put (st { makefile = Just (show mk) }) + diff --git a/src/Pkg/Package.hs b/src/Pkg/Package.hs --- a/src/Pkg/Package.hs +++ b/src/Pkg/Package.hs @@ -30,7 +30,7 @@ -- * install everything into datadir/pname, if install flag is set buildPkg :: Bool -> (Bool, FilePath) -> IO () -buildPkg warnonly (install, fp) +buildPkg warnonly (install, fp) = do pkgdesc <- parseDesc fp ok <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc) when (and ok) $ @@ -42,17 +42,17 @@ (modules pkgdesc) Just o -> do let exec = dir o buildMods - (NoREPL : Verbose : Output exec : idris_opts pkgdesc) + (NoREPL : Verbose : Output exec : idris_opts pkgdesc) [idris_main pkgdesc] setCurrentDirectory dir when install $ installPkg pkgdesc cleanPkg :: FilePath -> IO () -cleanPkg fp +cleanPkg fp = do pkgdesc <- parseDesc fp dir <- getCurrentDirectory setCurrentDirectory $ dir sourcedir pkgdesc - clean (makefile pkgdesc) + clean (makefile pkgdesc) mapM_ rmIBC (modules pkgdesc) case execout pkgdesc of Nothing -> return () @@ -70,12 +70,12 @@ buildMods :: [Opt] -> [Name] -> IO () buildMods opts ns = do let f = map (toPath . show) ns -- putStrLn $ "MODULE: " ++ show f - idris (map Filename f ++ opts) + idris (map Filename f ++ opts) return () where toPath n = foldl1' () $ splitOn "." n testLib :: Bool -> String -> String -> IO Bool -testLib warn p f +testLib warn p f = do d <- getDataDir gcc <- getCC (tmpf, tmph) <- tempfile @@ -84,15 +84,15 @@ e <- system $ gcc ++ " " ++ libtest ++ " -l" ++ f ++ " -o " ++ tmpf case e of ExitSuccess -> return True - _ -> do if warn - then do putStrLn $ "Not building " ++ p ++ + _ -> do if warn + then do putStrLn $ "Not building " ++ p ++ " due to missing library " ++ f return False else fail $ "Missing library " ++ f rmIBC :: Name -> IO () -rmIBC m = rmFile $ toIBCFile m - +rmIBC m = rmFile $ toIBCFile m + toIBCFile (UN n) = n ++ ".ibc" toIBCFile (NS n ns) = foldl1' () (reverse (toIBCFile n : ns)) diff --git a/src/Util/DynamicLinker.hs b/src/Util/DynamicLinker.hs --- a/src/Util/DynamicLinker.hs +++ b/src/Util/DynamicLinker.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ExistentialQuantification, CPP #-} module Util.DynamicLinker where +#ifdef IDRIS_FFI import Foreign.LibFFI import Foreign.Ptr (nullPtr, FunPtr, nullFunPtr,castPtrToFunPtr) import System.Directory @@ -21,6 +22,8 @@ hostDynamicLibExt = "dylib" #elif WINDOWS hostDynamicLibExt = "dll" +#elif FREEBSD +hostDynamicLibExt = "so" #else hostDynamicLibExt = error $ unwords [ "Undefined file extension for dynamic libraries" @@ -69,3 +72,19 @@ then return Nothing else return . Just $ Fun fn (castPtrToFunPtr cFn) #endif +#else +-- no libffi, just add stubbs. + +data DynamicLib = Lib { lib_name :: String + , lib_handle :: () + } + deriving Eq + +tryLoadLib :: String -> IO (Maybe DynamicLib) +tryLoadLib lib = do putStrLn $ "WARNING: Cannot load '" ++ lib ++ "' at compile time because Idris was compiled without libffi support." + return Nothing + + +#endif + + diff --git a/src/Util/LLVMStubs.hs b/src/Util/LLVMStubs.hs --- a/src/Util/LLVMStubs.hs +++ b/src/Util/LLVMStubs.hs @@ -1,6 +1,6 @@ -{-- +{-- -Things needed to build without LLVM +Things needed to build without LLVM Replaces stuff from LLVM.General.Target and IRTS.CodegenLLVM. --} diff --git a/src/Util/Net.hs b/src/Util/Net.hs new file mode 100644 --- /dev/null +++ b/src/Util/Net.hs @@ -0,0 +1,22 @@ +module Util.Net (listenOnLocalhost) where + +import Network +import Network.Socket hiding (sClose, PortNumber) +import Network.BSD (getProtocolNumber) +import Control.Exception (bracketOnError) + +-- Copied from upstream impl of listenOn +-- bound to localhost interface instead of iNADDR_ANY +listenOnLocalhost (PortNumber port) = do + proto <- getProtocolNumber "tcp" + localhost <- inet_addr "127.0.0.1" + bracketOnError + (socket AF_INET Stream proto) + (sClose) + (\sock -> do + setSocketOption sock ReuseAddr 1 + bindSocket sock (SockAddrInet port localhost) + listen sock maxListenQueue + return sock + ) + diff --git a/src/Util/System.hs b/src/Util/System.hs --- a/src/Util/System.hs +++ b/src/Util/System.hs @@ -5,6 +5,8 @@ -- System helper functions. import Control.Monad (when) +import Control.Applicative ((<$>)) +import Data.Maybe (fromMaybe) import Distribution.Text (display) import System.Directory (getTemporaryDirectory , removeFile @@ -26,39 +28,35 @@ throwIO = CE.throw - getCC :: IO String -getCC = do env <- environment "IDRIS_CC" - case env of - Nothing -> return "gcc" - Just cc -> return cc +getCC = fromMaybe "gcc" <$> environment "IDRIS_CC" -getMvn :: IO String -getMvn = do env <- environment "IDRIS_MVN" - case env of +mvnCommand :: String #ifdef mingw32_HOST_OS - Nothing -> return "mvn.bat" +mvnCommand = "mvn.bat" #else - Nothing -> return "mvn" +mvnCommand = "mvn" #endif - Just mvn -> return mvn +getMvn :: IO String +getMvn = fromMaybe mvnCommand <$> environment "IDRIS_MVN" + tempfile :: IO (FilePath, Handle) tempfile = do dir <- getTemporaryDirectory openTempFile (normalise dir) "idris" withTempdir :: String -> (FilePath -> IO a) -> IO a -withTempdir subdir callback +withTempdir subdir callback = do dir <- getTemporaryDirectory let tmpDir = (normalise dir) subdir removeLater <- catchIO (createDirectoryIfMissing True tmpDir >> return True) - (\ ioError -> if isAlreadyExistsError ioError then return False + (\ ioError -> if isAlreadyExistsError ioError then return False else throw ioError ) result <- callback tmpDir when removeLater $ removeDirectoryRecursive tmpDir return result - + environment :: String -> IO (Maybe String) environment x = catchIO (do e <- getEnv x return (Just e)) @@ -70,18 +68,35 @@ rmFile :: FilePath -> IO () rmFile f = do putStrLn $ "Removing " ++ f catchIO (removeFile f) - (\ioerr -> putStrLn $ "WARNING: Cannot remove file " + (\ioerr -> putStrLn $ "WARNING: Cannot remove file " ++ f ++ ", Error msg:" ++ show ioerr) - +#ifdef FREEBSD +extraLib = " -L/usr/local/lib" +#else +extraLib = "" +#endif + +#ifdef IDRIS_GMP +gmpLib = " -lgmp" +#else +gmpLib = "" +#endif + getLibFlags = do dir <- getDataDir - return $ "-L" ++ (dir "rts") ++ " -lidris_rts -lgmp -lpthread" - + return $ "-L" ++ (dir "rts") ++ + " -lidris_rts" ++ extraLib ++ gmpLib ++ " -lpthread" + getIdrisLibDir = do dir <- getDataDir return $ addTrailingPathSeparator dir +#ifdef FREEBSD +extraInclude = " -I/usr/local/include" +#else +extraInclude = "" +#endif getIncFlags = do dir <- getDataDir - return $ "-I" ++ dir "rts" + return $ "-I" ++ dir "rts" ++ extraInclude getExecutablePom = do dir <- getDataDir - return $ dir "executable_pom.xml" + return $ dir "java" "executable_pom.xml" diff --git a/test/Makefile b/test/Makefile --- a/test/Makefile +++ b/test/Makefile @@ -93,12 +93,13 @@ @perl ./runtest.pl test029 --codegen llvm @perl ./runtest.pl test030 --codegen llvm @perl ./runtest.pl test031 --codegen llvm + @perl ./runtest.pl test034 --codegen llvm update: - perl ./runtest.pl all -u + /usr/bin/env perl ./runtest.pl all -u diff: - perl ./runtest.pl all -d + /usr/bin/env perl ./runtest.pl all -d distclean: rm -f *~ diff --git a/test/reg001/reg001.idr b/test/reg001/reg001.idr --- a/test/reg001/reg001.idr +++ b/test/reg001/reg001.idr @@ -1,10 +1,10 @@ apply : (a -> b) -> a -> b apply f x = f x -class Functor f => VerifiedFunctor (f : Type -> Type) where - identity : (fa : f a) -> map id fa = fa +class Functor f => VerifiedFunctor (f : Type -> Type) where + identity : (fa : f a) -> map id fa = fa -data Imp : Type where +data Imp : Type where MkImp : {any : Type} -> any -> Imp testVal : Imp diff --git a/test/reg001/run b/test/reg001/run --- a/test/reg001/run +++ b/test/reg001/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris reg001.idr --check rm -rf reg001.ibc diff --git a/test/reg002/reg002.idr b/test/reg002/reg002.idr --- a/test/reg002/reg002.idr +++ b/test/reg002/reg002.idr @@ -2,7 +2,7 @@ %default total -data CoNat +data CoNat = Co Nat | Infinity @@ -11,7 +11,7 @@ S Infinity = Infinity Sn_notzero : Main.S n = Co 0 -> _|_ -Sn_notzero = believe_me +Sn_notzero = believe_me S_Co_not_Inf : Main.S (Co n) = Infinity -> _|_ S_Co_not_Inf = believe_me diff --git a/test/reg002/run b/test/reg002/run --- a/test/reg002/run +++ b/test/reg002/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris reg002.idr -o reg002 ./reg002 rm -f reg002 *.ibc diff --git a/test/reg003/expected b/test/reg003/expected --- a/test/reg003/expected +++ b/test/reg003/expected @@ -1,7 +1,7 @@ -reg003a.idr:4:When elaborating constructor ECons: +reg003a.idr:4:20:When elaborating constructor ECons: No such variable OddList -reg003a.idr:7:When elaborating constructor OCons: +reg003a.idr:7:20:When elaborating constructor OCons: No such variable EvenList -reg003a.idr:9:When elaborating type of test: +reg003a.idr:9:8:When elaborating type of test: No such variable EvenList -reg003a.idr:10:No type declaration for test +reg003a.idr:10:1:No type declaration for test diff --git a/test/reg003/reg003.idr b/test/reg003/reg003.idr --- a/test/reg003/reg003.idr +++ b/test/reg003/reg003.idr @@ -7,7 +7,7 @@ namespace Odd data OddList : Type where - (::) : Nat -> EvenList -> OddList + (::) : Nat -> EvenList -> OddList test : EvenList test = [1, 2, 3, 4, 5, 6] diff --git a/test/reg003/reg003a.idr b/test/reg003/reg003a.idr --- a/test/reg003/reg003a.idr +++ b/test/reg003/reg003a.idr @@ -4,7 +4,7 @@ ECons : Nat -> OddList -> EvenList data OddList : Type where - OCons : Nat -> EvenList -> OddList + OCons : Nat -> EvenList -> OddList test : EvenList -test = ECons 1 ENil +test = ECons 1 ENil diff --git a/test/reg003/run b/test/reg003/run --- a/test/reg003/run +++ b/test/reg003/run @@ -1,4 +1,4 @@ -#!/bin/bash -idris --check reg003.idr -idris --check reg003a.idr +#!/usr/bin/env bash +idris --check reg003.idr +idris --check reg003a.idr rm -f *.ibc diff --git a/test/reg004/run b/test/reg004/run --- a/test/reg004/run +++ b/test/reg004/run @@ -1,4 +1,4 @@ -#!/bin/bash -idris reg004.idr -o reg004 +#!/usr/bin/env bash +idris $@ reg004.idr -o reg004 ./reg004 rm -f reg004 *.ibc diff --git a/test/reg005/reg005.idr b/test/reg005/reg005.idr --- a/test/reg005/reg005.idr +++ b/test/reg005/reg005.idr @@ -7,7 +7,7 @@ data RLE : Vect n Char -> Type where REnd : RLE [] RChar : {xs : Vect k Char} -> - (n : Nat) -> (x : Char) -> RLE xs -> + (n : Nat) -> (x : Char) -> RLE xs -> RLE (rep (S n) x ++ xs) eq : (x : Char) -> (y : Char) -> Maybe (x = y) @@ -22,15 +22,15 @@ rle (x :: rep (S n) yvar ++ ys) | RChar n yvar rs with (eq x yvar) rle (x :: rep (S n) x ++ ys) | RChar n x rs | Just refl = RChar (S n) x rs - rle (x :: rep (S n) y ++ ys) | RChar n y rs | Nothing + rle (x :: rep (S n) y ++ ys) | RChar n y rs | Nothing = RChar Z x (RChar n y rs) compress : Vect n Char -> String compress xs with (rle xs) compress Nil | REnd = "" - compress (rep (S n) x ++ xs) | RChar _ _ rs + compress (rep (S n) x ++ xs) | RChar _ _ rs = let ni : Integer = cast (S n) in - show ni ++ show x ++ compress xs + show ni ++ strCons x (compress xs) compressString : String -> String compressString xs = compress (fromList (unpack xs)) diff --git a/test/reg005/run b/test/reg005/run --- a/test/reg005/run +++ b/test/reg005/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg005.idr -o reg005 ./reg005 rm -f reg005 *.ibc diff --git a/test/reg006/expected b/test/reg006/expected --- a/test/reg006/expected +++ b/test/reg006/expected @@ -1,1 +1,1 @@ -reg006.idr:17:RBTree.lookup is possibly not total due to: RBTree.case block in lookup +reg006.idr:17:1:RBTree.lookup is possibly not total due to: RBTree.case block in lookup diff --git a/test/reg006/reg006.idr b/test/reg006/reg006.idr --- a/test/reg006/reg006.idr +++ b/test/reg006/reg006.idr @@ -1,17 +1,17 @@ module RBTree - + data Colour = Red | Black data RBTree : Type -> Type -> Nat -> Colour -> Type where Leaf : RBTree k v Z Black RedBranch : k -> v -> RBTree k v n Black -> RBTree k v n Black -> RBTree k v n Red BlackBranch : k -> v -> RBTree k v n x -> RBTree k v n y -> RBTree k v (S n) Black - + toBlack : RBTree k v n c -> (m ** (RBTree k v m Black, Either (m = n) (m = (S n)))) toBlack (RedBranch k v l r) = (_ ** (BlackBranch k v l r, Right refl)) toBlack Leaf = (_ ** (Leaf, Left refl)) toBlack (BlackBranch k v l r) = (_ ** (BlackBranch k v l r, Left refl)) - + total lookup : Ord k => k -> RBTree k v n Black -> Maybe v lookup k Leaf = Nothing @@ -23,5 +23,5 @@ lookup k t GT => let (_ ** (t, _)) = toBlack r in - lookup k t + lookup k t diff --git a/test/reg006/run b/test/reg006/run --- a/test/reg006/run +++ b/test/reg006/run @@ -1,3 +1,3 @@ -#!/bin/bash -idris $@ reg006.idr -o reg006 +#!/usr/bin/env bash +idris $@ reg006.idr --check rm -f *.ibc diff --git a/test/reg007/expected b/test/reg007/expected --- a/test/reg007/expected +++ b/test/reg007/expected @@ -1,7 +1,7 @@ -reg007.lidr:8:A.n is already defined -reg007.lidr:12:When elaborating right hand side of hurrah: +reg007.lidr:8:1:A.n is already defined +reg007.lidr:12:9:When elaborating right hand side of hurrah: Can't unify - n = A.lala + n = lala with 0 = 1 diff --git a/test/reg007/run b/test/reg007/run --- a/test/reg007/run +++ b/test/reg007/run @@ -1,3 +1,3 @@ -#!/bin/bash -idris --check $@ reg007.lidr +#!/usr/bin/env bash +idris --check $@ reg007.lidr rm -f *.ibc diff --git a/test/reg008/run b/test/reg008/run --- a/test/reg008/run +++ b/test/reg008/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg008.idr --check rm -f *.ibc diff --git a/test/reg009/reg009.lidr b/test/reg009/reg009.lidr --- a/test/reg009/reg009.lidr +++ b/test/reg009/reg009.lidr @@ -2,15 +2,15 @@ > isAnyBy _ (_ ** Nil) = False > isAnyBy p (_ ** (a :: as)) = p a || isAnyBy p (_ ** as) -> filterTagP : (p : alpha -> Bool) -> -> (as : Vect n alpha) -> +> filterTagP : (p : alpha -> Bool) -> +> (as : Vect n alpha) -> > so (isAnyBy p (n ** as)) -> > (m : Nat ** (Vect m (a : alpha ** so (p a)), so (m > Z))) > filterTagP {n = S m} p (a :: as) q with (p a) > | True = (_ -> ** -> ((a ** believe_me oh) -> :: +> ** +> ((a ** believe_me oh) +> :: > (fst (getProof (filterTagP p as (believe_me oh)))), > oh > ) diff --git a/test/reg009/run b/test/reg009/run --- a/test/reg009/run +++ b/test/reg009/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg009.lidr --check rm -f reg009 *.ibc diff --git a/test/reg010/expected b/test/reg010/expected --- a/test/reg010/expected +++ b/test/reg010/expected @@ -1,4 +1,4 @@ -reg010.idr:5:When elaborating right hand side of usubst.unsafeSubst: +reg010.idr:5:15:When elaborating right hand side of usubst.unsafeSubst: Can't unify P x with diff --git a/test/reg010/run b/test/reg010/run --- a/test/reg010/run +++ b/test/reg010/run @@ -1,2 +1,2 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg010.idr --check --nocolour diff --git a/test/reg011/reg011.idr b/test/reg011/reg011.idr --- a/test/reg011/reg011.idr +++ b/test/reg011/reg011.idr @@ -1,9 +1,9 @@ -vfoldl : (P : Nat -> Type) -> +vfoldl : (P : Nat -> Type) -> ((x : Nat) -> P x -> a -> P (S x)) -> P Z -> Vect m a -> P m --- vfoldl P cons nil [] +-- vfoldl P cons nil [] -- = nil -vfoldl P cons nil (x :: xs) +vfoldl P cons nil (x :: xs) = vfoldl (\k => P (S k)) (\ n => cons (S n)) (cons Z nil x) xs --- vfoldl P cons nil (x :: xs) +-- vfoldl P cons nil (x :: xs) -- = vfoldl (\n => P (S n)) (\ n => cons _) (cons _ nil x) xs diff --git a/test/reg011/run b/test/reg011/run --- a/test/reg011/run +++ b/test/reg011/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg011.idr --check rm -f *.ibc diff --git a/test/reg012/reg012.lidr b/test/reg012/reg012.lidr --- a/test/reg012/reg012.lidr +++ b/test/reg012/reg012.lidr @@ -13,22 +13,22 @@ > soTrue : so b -> b = True > soTrue {b = False} x = soFalseElim x > soTrue {b = True} x = refl - + > class Eq alpha => ReflEqEq alpha where > reflexive_eqeq : (a : alpha) -> so (a == a) -> modifyFun : (Eq alpha) => -> (alpha -> beta) -> -> (alpha, beta) -> +> modifyFun : (Eq alpha) => +> (alpha -> beta) -> +> (alpha, beta) -> > (alpha -> beta) > modifyFun f (a, b) a' = if a' == a then b else f a' -> modifyFunLemma : (ReflEqEq alpha) => +> modifyFunLemma : (ReflEqEq alpha) => > (f : alpha -> beta) -> > (ab : (alpha, beta)) -> > modifyFun f ab (fst ab) = snd ab -> modifyFunLemma f (a,b) = +> modifyFunLemma f (a,b) = > rewrite soTrue (reflexive_eqeq a) in refl - replace {P = \ z => boolElim (a == a) b (f a) = boolElim z b (f a)} + replace {P = \ z => boolElim (a == a) b (f a) = boolElim z b (f a)} (soTrue (reflexive_eqeq a)) refl diff --git a/test/reg012/run b/test/reg012/run --- a/test/reg012/run +++ b/test/reg012/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg012.lidr --check rm -f *.ibc diff --git a/test/reg013/run b/test/reg013/run --- a/test/reg013/run +++ b/test/reg013/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg013.idr -o reg013 ./reg013 rm -f reg013 *.ibc diff --git a/test/reg014/reg014.idr b/test/reg014/reg014.idr --- a/test/reg014/reg014.idr +++ b/test/reg014/reg014.idr @@ -6,7 +6,7 @@ transpose : Matrix a (S n) (S m) -> Matrix a (S m) (S n) transpose ((x:: []) :: []) = [[x]] transpose [x :: y :: xs] = [x] :: (transpose [y :: xs]) -transpose (x :: y :: xs) - = let tx = transpose [x] in +transpose (x :: y :: xs) + = let tx = transpose [x] in let ux = transpose (y :: xs) in zipWith (++) tx ux diff --git a/test/reg014/run b/test/reg014/run --- a/test/reg014/run +++ b/test/reg014/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg014.idr --check rm -f *.ibc diff --git a/test/reg015/run b/test/reg015/run --- a/test/reg015/run +++ b/test/reg015/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg015.idr --check rm -f *.ibc diff --git a/test/reg016/expected b/test/reg016/expected --- a/test/reg016/expected +++ b/test/reg016/expected @@ -1,6 +1,1 @@ -4294967295 -4294967296 -4294967297 --1 -0 -1 +429496729500000000000000 diff --git a/test/reg016/reg016.idr b/test/reg016/reg016.idr --- a/test/reg016/reg016.idr +++ b/test/reg016/reg016.idr @@ -1,11 +1,11 @@ module Main main : IO () -main = do print $ the Integer 4294967295 - print $ the Integer 4294967296 - print $ the Integer 4294967297 - print $ the Int 4294967295 - print $ the Int 4294967296 - print $ the Int 4294967297 +main = do print $ the Integer 429496729500000000000000 +-- print $ the Integer 4294967296 +-- print $ the Integer 4294967297 +-- print $ the Int 4294967295 +-- print $ the Int 4294967296 +-- print $ the Int 4294967297 diff --git a/test/reg016/run b/test/reg016/run --- a/test/reg016/run +++ b/test/reg016/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg016.idr -o reg016 ./reg016 rm -f reg016 *.ibc diff --git a/test/reg017/run b/test/reg017/run --- a/test/reg017/run +++ b/test/reg017/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg017.idr -o reg017 ./reg017 rm -f reg017 *.ibc diff --git a/test/reg018/expected b/test/reg018/expected --- a/test/reg018/expected +++ b/test/reg018/expected @@ -1,4 +1,4 @@ -reg018a.idr:16:conat.minusCoNat is not productive -reg018b.idr:8:A.showB is possibly not total due to recursive path A.showB -reg018c.idr:19:CodataTest.inf is not productive -reg018d.idr:5:Main.pull is not total as there are missing cases +reg018a.idr:16:1:conat.minusCoNat is not productive +reg018b.idr:8:1:A.showB is possibly not total due to recursive path A.showB +reg018c.idr:19:1:CodataTest.inf is not productive +reg018d.idr:5:1:Main.pull is not total as there are missing cases diff --git a/test/reg018/reg018b.idr b/test/reg018/reg018b.idr --- a/test/reg018/reg018b.idr +++ b/test/reg018/reg018b.idr @@ -1,4 +1,4 @@ -module A +module A %default total @@ -8,7 +8,7 @@ showB (I x) = "I" ++ showB x showB (Z x) = "Z" ++ showB x -instance Show B where show = showB +instance Show B where show = showB os : B os = Z os diff --git a/test/reg018/reg018c.idr b/test/reg018/reg018c.idr --- a/test/reg018/reg018c.idr +++ b/test/reg018/reg018c.idr @@ -2,7 +2,7 @@ %default total codata InfStream a = (::) a (InfStream a) --- +-- -- natStream : InfStream Nat -- natStream = natFromStream 0 where -- natFromStream : Nat -> InfStream Nat diff --git a/test/reg018/run b/test/reg018/run --- a/test/reg018/run +++ b/test/reg018/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg018a.idr --check idris $@ reg018b.idr --check idris $@ reg018c.idr --check diff --git a/test/reg019/reg019.idr b/test/reg019/reg019.idr --- a/test/reg019/reg019.idr +++ b/test/reg019/reg019.idr @@ -1,4 +1,4 @@ -m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) -> +m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) -> Maybe (Either Bool Int) m_add x y = do x' <- x -- Extract value from x y' <- y -- Extract value from y diff --git a/test/reg019/run b/test/reg019/run --- a/test/reg019/run +++ b/test/reg019/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg019.idr --check rm -f *.ibc diff --git a/test/reg020/run b/test/reg020/run --- a/test/reg020/run +++ b/test/reg020/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg020.idr -o reg020 ./reg020 rm -f reg020 *.ibc diff --git a/test/reg021/run b/test/reg021/run --- a/test/reg021/run +++ b/test/reg021/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg021.idr --check rm -f *.ibc diff --git a/test/reg022/reg022.idr b/test/reg022/reg022.idr --- a/test/reg022/reg022.idr +++ b/test/reg022/reg022.idr @@ -9,7 +9,7 @@ ParserT : (Type -> Type) -> Type -> Type -> Type ParserT m str a = str -> m (Result str a) -ap : Monad m => ParserT m str (a -> b) -> ParserT m str a -> +ap : Monad m => ParserT m str (a -> b) -> ParserT m str a -> ParserT m str b ap f x = \s => do f' <- f s case f' of diff --git a/test/reg022/run b/test/reg022/run --- a/test/reg022/run +++ b/test/reg022/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg022.idr --check rm -f *.ibc diff --git a/test/reg023/expected b/test/reg023/expected --- a/test/reg023/expected +++ b/test/reg023/expected @@ -1,4 +1,4 @@ -reg023.idr:7:When elaborating right hand side of bad: +reg023.idr:7:5:When elaborating right hand side of bad: Can't unify Nat with diff --git a/test/reg023/run b/test/reg023/run --- a/test/reg023/run +++ b/test/reg023/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg023.idr --check rm -f *.ibc diff --git a/test/reg024/reg024.idr b/test/reg024/reg024.idr --- a/test/reg024/reg024.idr +++ b/test/reg024/reg024.idr @@ -22,10 +22,10 @@ rec End acc = acc rec (FInt rest) acc = \i: Int => rec rest (acc ++ (show i)) rec (FStr rest) acc = \s: String => rec rest (acc ++ s) - rec (FChar c rest) acc = rec rest (acc ++ (pack [c])) + rec (FChar c rest) acc = rec rest (acc ++ (strCons c "")) test : String test = printf "The %s is %d" "answer" 42 main : IO () -main = print test +main = putStrLn test diff --git a/test/reg024/run b/test/reg024/run --- a/test/reg024/run +++ b/test/reg024/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ reg024.idr -o reg024 ./reg024 rm -f reg024 *.ibc diff --git a/test/runtest.pl b/test/runtest.pl --- a/test/runtest.pl +++ b/test/runtest.pl @@ -1,4 +1,4 @@ -#!/usr/bin/perl +#!/usr/bin/env perl use strict; use Cwd; @@ -12,7 +12,7 @@ chdir($test); print "Running $test...\n"; - my $got = `sh ./run @idrOpts`; + my $got = `./run @idrOpts`; my $exp = `cat expected`; open my $out, '>', 'output'; @@ -24,7 +24,7 @@ $got =~ s/\r\n/\n/g; $exp =~ s/\r\n/\n/g; - # Normalize paths in $got and $exp, so the expected outcomes don't + # Normalize paths in $got and $exp, so the expected outcomes don't # change between platforms while($got =~ /(^|.*?\n)(.*?)\\(.*?):(\d+):(.*)/ms) { $got = "$1$2/$3:$4:$5"; @@ -35,7 +35,7 @@ if ($got eq $exp) { print "Ran $test...success\n"; - } + } else { if ($update == 0) { $exitstatus = 1; @@ -66,7 +66,7 @@ push @tests, $test; } @opts = @ARGV; -} +} else { print "Give a test name, or 'all' to run all.\n"; exit; diff --git a/test/test001/run b/test/test001/run --- a/test/test001/run +++ b/test/test001/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test001.idr -o test001 ./test001 rm -f test001 test001.ibc diff --git a/test/test001/test001.idr b/test/test001/test001.idr --- a/test/test001/test001.idr +++ b/test/test001/test001.idr @@ -27,18 +27,18 @@ Val : (x : Int) -> Expr G TyInt Lam : Expr (a :: G) t -> Expr G (TyFun a t) App : Expr G (TyFun a t) -> Expr G a -> Expr G t - Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> + Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> Expr G c If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b - + dsl expr lambda = Lam variable = Var index_first = stop index_next = pop - interp : Env G -> {static} Expr G t -> interpTy t + interp : Env G -> [static] (e : Expr G t) -> interpTy t interp env (Var i) = lookup i env interp env (Val x) = x interp env (Lam sc) = \x => interp (x :: env) sc @@ -46,7 +46,7 @@ interp env (Op op x y) = op (interp env x) (interp env y) interp env (If x t e) = if interp env x then interp env t else interp env e interp env (Bind v f) = interp env (f (interp env v)) - + eId : Expr G (TyFun TyInt TyInt) eId = expr (\x => x) @@ -55,25 +55,25 @@ eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt)) eAdd = expr (\x, y => Op (+) x y) - + -- eDouble : Expr G (TyFun TyInt TyInt) -- eDouble = Lam (App (App (Lam (Lam (Op' (+) (Var fZ) (Var (fS fZ))))) (Var fZ)) (Var fZ)) - + eDouble : Expr G (TyFun TyInt TyInt) eDouble = expr (\x => App (App eAdd x) (Var stop)) - + app : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t app = \f, a => App f a eFac : Expr G (TyFun TyInt TyInt) eFac = expr (\x => If (Op (==) x (Val 0)) - (Val 1) + (Val 1) (Op (*) (app eFac (Op (-) x (Val 1))) x)) -- Exercise elaborator: Complicated way of doing \x y => x*4 + y*2 - + eProg : Expr G (TyFun TyInt (TyFun TyInt TyInt)) - eProg = Lam (Lam + eProg = Lam (Lam (Bind (App eDouble (Var (pop stop))) (\x => Bind (App eDouble (Var stop)) (\y => Bind (App eDouble (Val x)) diff --git a/test/test002/expected b/test/test002/expected --- a/test/test002/expected +++ b/test/test002/expected @@ -0,0 +1,1 @@ +test002.idr:5:6:Universe inconsistency diff --git a/test/test002/run b/test/test002/run --- a/test/test002/run +++ b/test/test002/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test002.idr --check --noprelude rm -f *.ibc diff --git a/test/test002/test002.idr b/test/test002/test002.idr --- a/test/test002/test002.idr +++ b/test/test002/test002.idr @@ -1,9 +1,8 @@ -myid : a -> a -myid x = x +myid : (a : Type) -> a -> a +myid _ x = x --- FIXME: Raw TT quotations currently unsupported in parser ---idid : (a : Type) -> a -> a ---idid = myid ![myid] +idid : (a : Type) -> a -> a +idid = myid _ myid app : (a -> b) -> a -> b app f x = f x @@ -12,7 +11,7 @@ foo a b c d e = e doapp : a -> a -doapp x = app myid x +doapp x = app (myid _) x {- diff --git a/test/test003/Lit.lidr b/test/test003/Lit.lidr --- a/test/test003/Lit.lidr +++ b/test/test003/Lit.lidr @@ -4,14 +4,14 @@ > st : String > st = "abcdefg" - + Literate main program > main : IO () > main = do { putStrLn (show (strHead st)) > putStrLn (show (strIndex st 3)) > putStrLn (strCons 'z' st) -> putStrLn (reverse st) +> putStrLn (reverse st) > let x = unpack st > putStrLn (show (reverse x)) > putStrLn (pack x) diff --git a/test/test003/expected b/test/test003/expected --- a/test/test003/expected +++ b/test/test003/expected @@ -1,7 +1,7 @@ -./test003a.lidr:1:Program line next to comment -a -d +./test003a.lidr:1:0:Program line next to comment +'a' +'d' zabcdefg gfedcba -[g, f, e, d, c, b, a] +['g', 'f', 'e', 'd', 'c', 'b', 'a'] abcdefg diff --git a/test/test003/run b/test/test003/run --- a/test/test003/run +++ b/test/test003/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test003a.lidr --check idris $@ test003.lidr -o test003 ./test003 diff --git a/test/test004/run b/test/test004/run --- a/test/test004/run +++ b/test/test004/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test004.idr -o test004 ./test004 rm -f test004 test004.ibc testfile diff --git a/test/test004/test004.idr b/test/test004/test004.idr --- a/test/test004/test004.idr +++ b/test/test004/test004.idr @@ -20,10 +20,10 @@ main = do { h <- openFile "testfile" Write fwrite h "Hello!\nWorld!\n...\n3\n4\nLast line\n" closeFile h - putStrLn "Reading testfile" + putStrLn "Reading testfile" f <- readFile "testfile" putStrLn f - putStrLn "---" + putStrLn "---" dumpFile "testfile" putStrLn "---" } diff --git a/test/test005/expected b/test/test005/expected --- a/test/test005/expected +++ b/test/test005/expected @@ -1,6 +1,6 @@ 8 1 -(abc, 123) -(abc, 123) +("abc", "123") +("abc", "123") ([1, 2], [3, 4, 5]) ([1, 2], [3, 4, 5]) diff --git a/test/test005/run b/test/test005/run --- a/test/test005/run +++ b/test/test005/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test005.idr -o test005 ./test005 rm -f test005 test005.ibc diff --git a/test/test006/run b/test/test006/run --- a/test/test006/run +++ b/test/test006/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test006.idr -o test006 ./test006 rm -f test006 test006.ibc diff --git a/test/test007/run b/test/test007/run --- a/test/test007/run +++ b/test/test007/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test007.idr -o test007 ./test007 rm -f test007 test007.ibc diff --git a/test/test007/test007.idr b/test/test007/test007.idr --- a/test/test007/test007.idr +++ b/test/test007/test007.idr @@ -16,7 +16,7 @@ instance Functor Eval where map f (MkEval g) = MkEval (\e => map f (g e)) -instance Applicative Eval where +instance Applicative Eval where pure x = MkEval (\e => Just x) (<$>) (MkEval f) (MkEval g) = MkEval (\x => appAux (f x) (g x)) where diff --git a/test/test008/run b/test/test008/run --- a/test/test008/run +++ b/test/test008/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test008.idr -o test008 ./test008 rm -f test008 test008.ibc diff --git a/test/test008/test008.idr b/test/test008/test008.idr --- a/test/test008/test008.idr +++ b/test/test008/test008.idr @@ -14,11 +14,11 @@ ioVals : IO (String, String) -ioVals = do { return ("First", "second") } +ioVals = do { return ("First", "second") } main : IO () main = do (a, b) <- ioVals - putStr (show a ++ " and " ++ show b ++ "? ") + putStr (a ++ " and " ++ b ++ "? ") let x = "bar" putStrLn (show (getVal x 7 testlist)) let ((y, z) :: _) = testlist diff --git a/test/test009/run b/test/test009/run --- a/test/test009/run +++ b/test/test009/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test009.idr -o test009 ./test009 rm -f test009 test009.ibc diff --git a/test/test009/test009.idr b/test/test009/test009.idr --- a/test/test009/test009.idr +++ b/test/test009/test009.idr @@ -6,4 +6,4 @@ main : IO () main = putStrLn (show (pythag 50)) - + diff --git a/test/test010/expected b/test/test010/expected --- a/test/test010/expected +++ b/test/test010/expected @@ -1,3 +1,3 @@ -test010.idr:13:foo is possibly not total due to: MkBad -test010a.idr:9:main.bar is possibly not total due to: main.MkBad -test010b.idr:9:main.bar is possibly not total due to: main.MkBad +test010.idr:13:1:foo is possibly not total due to: MkBad +test010a.idr:9:1:main.bar is possibly not total due to: main.MkBad +test010b.idr:9:1:main.bar is possibly not total due to: main.MkBad diff --git a/test/test010/run b/test/test010/run --- a/test/test010/run +++ b/test/test010/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test010.idr -o test010 idris $@ test010a.idr -o test010 idris $@ test010b.idr -o test010 diff --git a/test/test011/expected b/test/test011/expected --- a/test/test011/expected +++ b/test/test011/expected @@ -1,5 +1,5 @@ -foo -Fred +"foo" +"Fred" [1, 2, 3] -[b, a] +["b", "a"] 25 diff --git a/test/test011/run b/test/test011/run --- a/test/test011/run +++ b/test/test011/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test011.idr -o test011 ./test011 rm -f test011 test011.ibc diff --git a/test/test011/test011.idr b/test/test011/test011.idr --- a/test/test011/test011.idr +++ b/test/test011/test011.idr @@ -16,7 +16,7 @@ person = MkPerson "Fred" 30 main : IO () -main = do let x = record { name = "foo", +main = do let x = record { name = "foo", more_things = reverse ["a","b"] } testFoo print $ name x print $ name person diff --git a/test/test012/expected b/test/test012/expected --- a/test/test012/expected +++ b/test/test012/expected @@ -1,1 +1,1 @@ -test012a.idr:7:x is not an accessible pattern variable +test012a.idr:7:1:x is not an accessible pattern variable diff --git a/test/test012/run b/test/test012/run --- a/test/test012/run +++ b/test/test012/run @@ -1,2 +1,2 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test012a.idr -o test012a diff --git a/test/test012/test012a.idr b/test/test012/test012a.idr --- a/test/test012/test012a.idr +++ b/test/test012/test012a.idr @@ -1,10 +1,10 @@ module Main - + f : Nat -> Nat f x = x + 1 - + foo : Nat -> Nat foo (f x) = x - + main : IO () main = putStrLn (show (foo 1)) diff --git a/test/test013/run b/test/test013/run --- a/test/test013/run +++ b/test/test013/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test013.idr -o test013 ./test013 rm -f test013 test013.ibc diff --git a/test/test013/test013.idr b/test/test013/test013.idr --- a/test/test013/test013.idr +++ b/test/test013/test013.idr @@ -9,7 +9,7 @@ main : IO () main = do putStrLn "Counting:" - for x in [1..10]: + for x in [1..10]: putStrLn $ "Number " ++ show x putStrLn "Done!" diff --git a/test/test014/Resimp.idr b/test/test014/Resimp.idr --- a/test/test014/Resimp.idr +++ b/test/test014/Resimp.idr @@ -29,7 +29,7 @@ ioc : IO a -> Creator a ioc = MkCreator - + infixr 5 :-> using (i: Fin n, gam : Vect n Ty, gam' : Vect n Ty, gam'' : Vect n Ty) @@ -63,14 +63,14 @@ update Nil stop _ impossible total - envUpdate : (p:HasType gam i a) -> (val:interpTy b) -> + envUpdate : (p:HasType gam i a) -> (val:interpTy b) -> Env gam -> Env (update gam p b) envUpdate stop val (x :: xs) = val :: xs envUpdate (pop k) val (x :: xs) = x :: envUpdate k val xs envUpdate stop _ Nil impossible total - envUpdateVal : (p:HasType gam i a) -> (val:b) -> + envUpdateVal : (p:HasType gam i a) -> (val:b) -> Env gam -> Env (update gam p (Val b)) envUpdateVal stop val (x :: xs) = val :: xs envUpdateVal (pop k) val (x :: xs) = x :: envUpdateVal k val xs @@ -81,7 +81,7 @@ data Args : Vect n Ty -> List Type -> Type where ANil : Args gam [] - ACons : HasType gam i a -> + ACons : HasType gam i a -> Args gam as -> Args gam (interpTy a :: as) funTy : List Type -> Ty -> Ty @@ -95,31 +95,31 @@ it goes out of scope, where "consumed" simply means that it has been replaced with a value of type '()'. --} - Let : Creator (interpTy a) -> - Res (a :: gam) (Val () :: gam') (R t) -> + Let : Creator (interpTy a) -> + Res (a :: gam) (Val () :: gam') (R t) -> Res gam gam' (R t) - Update : (a -> Updater b) -> (p:HasType gam i (Val a)) -> + Update : (a -> Updater b) -> (p:HasType gam i (Val a)) -> Res gam (update gam p (Val b)) (R ()) - Use : (a -> Reader b) -> HasType gam i (Val a) -> + Use : (a -> Reader b) -> HasType gam i (Val a) -> Res gam gam (R b) {-- Control structures --} Lift : |(action:IO a) -> Res gam gam (R a) - Check : (p:HasType gam i (Choice (interpTy a) (interpTy b))) -> + Check : (p:HasType gam i (Choice (interpTy a) (interpTy b))) -> (failure:Res (update gam p a) (update gam p c) t) -> (success:Res (update gam p b) (update gam p c) t) -> Res gam (update gam p c) t - While : Res gam gam (R Bool) -> + While : Res gam gam (R Bool) -> Res gam gam (R ()) -> Res gam gam (R ()) Return : a -> Res gam gam (R a) - (>>=) : Res gam gam' (R a) -> (a -> Res gam' gam'' (R t)) -> + (>>=) : Res gam gam' (R a) -> (a -> Res gam' gam'' (R t)) -> Res gam gam'' (R t) ioret : a -> IO a ioret = return - interp : Env gam -> {static} Res gam gam' t -> + interp : Env gam -> [static] (e : Res gam gam' t) -> (Env gam' -> interpTy t -> IO u) -> IO u interp env (Let val scope) k @@ -128,24 +128,24 @@ (\env', scope' => k (envTail env') scope') interp env (Update method x) k = do x' <- getUpdater (method (envLookup x env)) - k (envUpdateVal x x' env) (return ()) + k (envUpdateVal x x' env) (return ()) interp env (Use method x) k = do x' <- getReader (method (envLookup x env)) k env (return x') - interp env (Lift io) k + interp env (Lift io) k = k env io interp env (Check x left right) k = - either (envLookup x env) + either (envLookup x env) (\a => interp (envUpdate x a env) left k) (\b => interp (envUpdate x b env) right k) interp env (While test body) k = interp env test (\env', result => do r <- result - if (not r) + if (not r) then (k env' (return ())) - else (interp env' body - (\env'', body' => + else (interp env' body + (\env'', body' => do v <- body' -- make sure it's evalled interp env'' (While test body) k ))) interp env (Return v) k = k env (return v) diff --git a/test/test014/run b/test/test014/run --- a/test/test014/run +++ b/test/test014/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test014.idr -o test014 ./test014 rm -f test014 resimp.ibc test014.ibc diff --git a/test/test014/test014.idr b/test/test014/test014.idr --- a/test/test014/test014.idr +++ b/test/test014/test014.idr @@ -16,7 +16,7 @@ open : String -> (p:Purpose) -> Creator (Either () (FILE p)) open fn p = ioc (do h <- fopen fn (pstring p) - ifM validFile h + ifM validFile h then return (Right (OpenH h)) else return (Left ())) @@ -63,4 +63,5 @@ main : IO () main = run (readH "test") + diff --git a/test/test015/run b/test/test015/run --- a/test/test015/run +++ b/test/test015/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test015.idr -o test015 ./test015 rm -f test015 parity.ibc test015.ibc diff --git a/test/test015/test015.idr b/test/test015/test015.idr --- a/test/test015/test015.idr +++ b/test/test015/test015.idr @@ -24,7 +24,7 @@ show (bin # bit) = show bin ++ show bit pad : Binary w n -> Binary (S w) n -pad zero = zero # b0 +pad zero = zero # b0 pad (num # x) = pad num # x natToBin : (width : Nat) -> (n : Nat) -> @@ -47,21 +47,21 @@ pattern syntax bitpair [x] [y] = (_ ** (_ ** (x, y, _))) term syntax bitpair [x] [y] = (_ ** (_ ** (x, y, refl))) -addBit : Bit x -> Bit y -> Bit c -> +addBit : Bit x -> Bit y -> Bit c -> (bX ** (bY ** (Bit bX, Bit bY, c + x + y = bY + 2 * bX))) addBit b0 b0 b0 = bitpair b0 b0 -addBit b0 b0 b1 = bitpair b0 b1 +addBit b0 b0 b1 = bitpair b0 b1 addBit b0 b1 b0 = bitpair b0 b1 addBit b0 b1 b1 = bitpair b1 b0 -addBit b1 b0 b0 = bitpair b0 b1 -addBit b1 b0 b1 = bitpair b1 b0 -addBit b1 b1 b0 = bitpair b1 b0 -addBit b1 b1 b1 = bitpair b1 b1 +addBit b1 b0 b0 = bitpair b0 b1 +addBit b1 b0 b1 = bitpair b1 b0 +addBit b1 b1 b0 = bitpair b1 b0 +addBit b1 b1 b1 = bitpair b1 b1 -adc : Binary w x -> Binary w y -> Bit c -> Binary (S w) (c + x + y) +adc : Binary w x -> Binary w y -> Bit c -> Binary (S w) (c + x + y) adc zero zero carry ?= zero # carry adc (numx # bX) (numy # bY) carry - ?= let (bitpair carry0 lsb) = addBit bX bY carry in + ?= let (bitpair carry0 lsb) = addBit bX bY carry in adc numx numy carry0 # lsb readNum : IO Nat @@ -82,7 +82,7 @@ - + ---------- Proofs ---------- Main.ntbOdd = proof { diff --git a/test/test016/run b/test/test016/run --- a/test/test016/run +++ b/test/test016/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test016.idr -o test016 ./test016 rm -f test016 *.ibc diff --git a/test/test016/test016.idr b/test/test016/test016.idr --- a/test/test016/test016.idr +++ b/test/test016/test016.idr @@ -2,12 +2,12 @@ %default total -codata Stream a = Nil | (::) a (Stream a) +codata Stream' a = Nil | (::) a (Stream' a) -countFrom : Int -> Stream Int +countFrom : Int -> Stream' Int countFrom x = x :: countFrom (x + 1) -take : Nat -> Stream a -> List a +take : Nat -> Stream' a -> List a take Z _ = [] take (S n) (x :: xs) = x :: take n xs take n [] = [] diff --git a/test/test017/expected b/test/test017/expected --- a/test/test017/expected +++ b/test/test017/expected @@ -1,2 +1,2 @@ -test017a.idr:5:scg.vtrans is possibly not total due to recursive path scg.vtrans --> scg.vtrans -test017b.idr:4:foo.foo is possibly not total due to recursive path foo.foo +test017a.idr:5:1:scg.vtrans is possibly not total due to recursive path scg.vtrans --> scg.vtrans +test017b.idr:4:1:foo.foo is possibly not total due to recursive path foo.foo diff --git a/test/test017/run b/test/test017/run --- a/test/test017/run +++ b/test/test017/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ --check test017.idr idris $@ --check test017a.idr idris $@ --check test017b.idr diff --git a/test/test017/test017.idr b/test/test017/test017.idr --- a/test/test017/test017.idr +++ b/test/test017/test017.idr @@ -13,21 +13,23 @@ (P : Ord -> Type) -> (P Zero) -> ((x : Ord) -> P x -> P (Suc x)) -> - ((f : Nat -> Ord) -> ((n : Nat) -> P (f n)) -> + ((f : Nat -> Ord) -> ((n : Nat) -> P (f n)) -> P (Sup f)) -> P x ordElim Zero P mZ mSuc mSup = mZ ordElim (Suc o) P mZ mSuc mSup = mSuc o (ordElim o P mZ mSuc mSup) ordElim (Sup f) P mZ mSuc mSup = mSup f (\n => ordElim (f n) P mZ mSuc mSup) -myplus' : Nat -> Nat -> Nat -myplus : Nat -> Nat -> Nat - -myplus Z y = y -myplus (S k) y = S (myplus' k y) +-- For now, not going to support this -myplus' Z y = y -myplus' (S k) y = S (myplus y k) +-- myplus' : Nat -> Nat -> Nat +-- myplus : Nat -> Nat -> Nat +-- +-- myplus Z y = y +-- myplus (S k) y = S (myplus' k y) +-- +-- myplus' Z y = y +-- myplus' (S k) y = S (myplus y k) mnubBy : (a -> a -> Bool) -> List a -> List a mnubBy = nubBy' [] @@ -56,7 +58,7 @@ ack : Nat -> Nat -> Nat ack Z n = S n ack (S m) Z = ack m (S Z) -ack (S m) (S n) = ack m (ack (S m) n) +ack (S m) (S n) = ack m (ack (S m) n) data Bin = eps | c0 Bin | c1 Bin diff --git a/test/test018/run b/test/test018/run --- a/test/test018/run +++ b/test/test018/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test018.idr -o test018 idris $@ test018a.idr -o test018a ./test018 diff --git a/test/test018/test018.idr b/test/test018/test018.idr --- a/test/test018/test018.idr +++ b/test/test018/test018.idr @@ -17,10 +17,10 @@ ping thread = sendToThread thread (prim__vm, "Hello!") pingpong : IO () -pingpong +pingpong = do th <- fork pong putStrLn "Sending" - ping th + ping th reply <- getMsg putStrLn reply usleep 100000 diff --git a/test/test018/test018a.idr b/test/test018/test018a.idr --- a/test/test018/test018a.idr +++ b/test/test018/test018a.idr @@ -3,7 +3,7 @@ import System.Concurrency.Process ping : ProcID String -> ProcID String -> Process String () -ping main proc +ping main proc = do lift (usleep 1000) send proc "Hello!" lift (putStrLn "Sent ping") @@ -14,7 +14,7 @@ pong : Process String () pong = do -- lift (putStrLn "Waiting for message") (sender, m) <- recvWithSender - lift $ putStrLn ("Received " ++ m) + lift $ putStrLn ("Received " ++ m) send sender ("Hello back!") mainProc : Process String () @@ -27,7 +27,7 @@ repeatIO : Int -> IO () repeatIO 0 = return () repeatIO n = do print n - run mainProc + run mainProc repeatIO (n - 1) main : IO () diff --git a/test/test019/run b/test/test019/run --- a/test/test019/run +++ b/test/test019/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test019.lidr -o test019 ./test019 rm -f test019 *.ibc diff --git a/test/test020/expected b/test/test020/expected --- a/test/test020/expected +++ b/test/test020/expected @@ -1,5 +1,5 @@ When elaborating right hand side of foo: -test020a.idr:14:Can't unify +test020a.idr:14:18:Can't unify Vect n a with List a @@ -11,4 +11,4 @@ List a [3, 2, 1] -Number 42 +"Number 42" diff --git a/test/test020/run b/test/test020/run --- a/test/test020/run +++ b/test/test020/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test020.idr -o test020 idris $@ test020a.idr --check --nocolor ./test020 diff --git a/test/test020/test020.idr b/test/test020/test020.idr --- a/test/test020/test020.idr +++ b/test/test020/test020.idr @@ -1,10 +1,10 @@ module Main -implicit +implicit natInt : Nat -> Integer natInt x = cast x -implicit +implicit forget : Vect n a -> List a forget [] = [] forget (x :: xs) = x :: forget xs diff --git a/test/test020/test020a.idr b/test/test020/test020a.idr --- a/test/test020/test020a.idr +++ b/test/test020/test020a.idr @@ -1,6 +1,6 @@ module Main -implicit +implicit forget : Vect n a -> List a forget [] = [] forget (x :: xs) = x :: forget xs diff --git a/test/test021/expected b/test/test021/expected --- a/test/test021/expected +++ b/test/test021/expected @@ -1,6 +1,4 @@ -[HELLO!!! -, WORLD!!! -, ] +["HELLO!!!\n", "WORLD!!!\n", ""] 3 15 Answer: 99 diff --git a/test/test021/run b/test/test021/run --- a/test/test021/run +++ b/test/test021/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris -p effects $@ test021.idr -o test021 idris -p effects $@ test021a.idr -o test021a ./test021 diff --git a/test/test021/test021.idr b/test/test021/test021.idr --- a/test/test021/test021.idr +++ b/test/test021/test021.idr @@ -1,4 +1,4 @@ -module Main +module Main import Effect.File import Effect.State @@ -8,28 +8,25 @@ data FName = Count | NotCount FileIO : Type -> Type -> Type -FileIO st t +FileIO st t = Eff (IOExcept String) [FILE_IO st, STDIO, Count ::: STATE Int] t readFile : FileIO (OpenFile Read) (List String) readFile = readAcc [] where - readAcc : List String -> FileIO (OpenFile Read) (List String) + readAcc : List String -> FileIO (OpenFile Read) (List String) readAcc acc = do e <- eof - if (not e) + if (not e) then do str <- readLine - ls <- Count :- get - Count :- put (ls + 1) + Count :- put (!(Count :- get) + 1) readAcc (str :: acc) else return (reverse acc) -testFile : FileIO () () -testFile = catch (do open "testFile" Read - str <- readFile - putStrLn (show str) - ls <- Count :- get - close - putStrLn (show ls)) - (\err => putStrLn ("Handled: " ++ show err)) +testFile : FileIO () () +testFile = do open "testFile" Read + if_valid then do putStrLn (show !readFile) + close + putStrLn (show !(Count :- get)) + else putStrLn ("Error!") main : IO () main = do ioe_run (run [(), (), Count := 0] testFile) diff --git a/test/test021/test021a.idr b/test/test021/test021a.idr --- a/test/test021/test021a.idr +++ b/test/test021/test021a.idr @@ -14,7 +14,7 @@ Env = List (String, Integer) -- Evaluator : Type -> Type --- Evaluator t +-- Evaluator t -- = Eff m [EXCEPTION String, RND, STATE Env] t eval : Expr -> Eff IO [EXCEPTION String, STDIO, RND, STATE Env] Integer diff --git a/test/test022/run b/test/test022/run --- a/test/test022/run +++ b/test/test022/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash echo ":x x" | idris --quiet test022.idr rm -f test021 test021a *.ibc diff --git a/test/test023/run b/test/test023/run --- a/test/test023/run +++ b/test/test023/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris --quiet test023.idr -o test023 rm -f test023 *.ibc diff --git a/test/test023/test.idr b/test/test023/test.idr deleted file mode 100644 --- a/test/test023/test.idr +++ /dev/null @@ -1,2 +0,0 @@ -foo : PrimIO () -foo = prim__IO () diff --git a/test/test024/run b/test/test024/run --- a/test/test024/run +++ b/test/test024/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris --quiet test024.idr < input rm -f *.ibc diff --git a/test/test025/run b/test/test025/run --- a/test/test025/run +++ b/test/test025/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris -p effects $@ test025.idr -o test025 ./test025 rm -f test025 *.ibc diff --git a/test/test025/test025.idr b/test/test025/test025.idr --- a/test/test025/test025.idr +++ b/test/test025/test025.idr @@ -26,7 +26,7 @@ res <- Dst :- peek 1 (S(S(S(S Z)))) oh Dst :- free return (map (prim__zextB8_Int) res) - + main : IO () main = do ioe_run (run [Dst := (), Src := ()] testMemory) (\err => print err) (\ok => print ok) diff --git a/test/test026/run b/test/test026/run --- a/test/test026/run +++ b/test/test026/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris --quiet test026.idr < input rm -f *.ibc diff --git a/test/test027/run b/test/test027/run --- a/test/test027/run +++ b/test/test027/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test027.idr -o test027 ./test027 rm -f test027 *.ibc diff --git a/test/test028/run b/test/test028/run --- a/test/test028/run +++ b/test/test028/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test028.idr -o test028 ./test028 rm -f test028 test028.ibc diff --git a/test/test028/test028.idr b/test/test028/test028.idr --- a/test/test028/test028.idr +++ b/test/test028/test028.idr @@ -2,4 +2,4 @@ module Main -- main : IO () -main = print "hello, world!" +main = putStrLn "hello, world!" diff --git a/test/test029/run b/test/test029/run --- a/test/test029/run +++ b/test/test029/run @@ -1,3 +1,3 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test029.idr --check test029 rm -f *.ibc diff --git a/test/test029/test029.idr b/test/test029/test029.idr --- a/test/test029/test029.idr +++ b/test/test029/test029.idr @@ -1,10 +1,10 @@ -module simple +module simple plus_comm : (n : Nat) -> (m : Nat) -> (n + m = m + n) -- Base case (Z + m = m + Z) <== plus_comm = - rewrite ((m + Z = m) <== plusZeroRightNeutral) ==> + rewrite ((m + Z = m) <== plusZeroRightNeutral) ==> (Z + m = m) in refl -- Step case diff --git a/test/test030/Reflect.idr b/test/test030/Reflect.idr --- a/test/test030/Reflect.idr +++ b/test/test030/Reflect.idr @@ -41,7 +41,7 @@ expr_r (App ex ey) = let (xl ** (xr, xprf)) = expr_r ex in let (yl ** (yr, yprf)) = expr_r ey in appRExpr _ _ xr yr xprf yprf - where + where appRExpr : (xs', ys' : List a) -> RExpr G xs -> RExpr G ys -> (xs' = xs) -> (ys' = ys) -> (ws' ** (RExpr G ws', xs' ++ ys' = ws')) @@ -80,13 +80,13 @@ buildProof : {xs : List a} -> {ys : List a} -> Expr G ln -> Expr G rn -> - (xs = ln) -> (ys = rn) -> Maybe (xs = ys) + (xs = ln) -> (ys = rn) -> Maybe (xs = ys) buildProof e e' lp rp with (eqExpr e e') buildProof e e lp rp | Just refl = ?bp1 buildProof e e' lp rp | Nothing = Nothing testEq : Expr G xs -> Expr G ys -> Maybe (xs = ys) - testEq l r = let (ln ** (l', lPrf)) = reduce l in + testEq l r = let (ln ** (l', lPrf)) = reduce l in let (rn ** (r', rPrf)) = reduce r in buildProof l' r' lPrf rPrf @@ -129,7 +129,7 @@ -- reduction will work the right way. %reflection -reflectList : (G : List (List a)) -> +reflectList : (G : List (List a)) -> (xs : List a) -> (G' ** Expr (G' ++ G) xs) reflectList G [] = ([] ** ENil) @@ -140,7 +140,7 @@ reflectList G (xs ++ ys) with (reflectList G xs) | (G' ** xs') with (reflectList (G' ++ G) ys) - | (G'' ** ys') = ((G'' ++ G') ** + | (G'' ** ys') = ((G'' ++ G') ** rewrite (sym (appendAssociative G'' G' G)) in App (weaken G'' xs') ys') reflectList G t with (isElem t G) @@ -157,7 +157,7 @@ %reflection reflectEq : (a : Type) -> (G : List (List a)) -> (P : Type) -> (G' ** ListEq (G' ++ G) P) -reflectEq a G (the (List a) xs = the (List a) ys) with (reflectList G xs) +reflectEq a G (the (List a) xs = the (List a) ys) with (reflectList G xs) | (G' ** xs') with (reflectList (G' ++ G) ys) | (G'' ** ys') = ((G'' ++ G') ** rewrite (sym (appendAssociative G'' G' G)) in @@ -197,7 +197,7 @@ -- The effect is to bind x to p applied to the current goal. If 'p' is a -- reflection function (which is the most likely thing to be useful...) -- then we can feed the result to the above 'prove' function and pull out --- the proof, if it exists. +-- the proof, if it exists. -- The syntax declaration below just gives us an easy way to invoke the -- prover. diff --git a/test/test030/expected b/test/test030/expected --- a/test/test030/expected +++ b/test/test030/expected @@ -1,4 +1,4 @@ -test030a.idr:12:When elaborating right hand side of testReflect1: +test030a.idr:12:14:When elaborating right hand side of testReflect1: Can't unify IsJust (Just x) with diff --git a/test/test030/run b/test/test030/run --- a/test/test030/run +++ b/test/test030/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test030.idr --check --nocolour idris $@ test030a.idr --check --nocolour rm -f *.ibc diff --git a/test/test030/test030.idr b/test/test030/test030.idr --- a/test/test030/test030.idr +++ b/test/test030/test030.idr @@ -7,7 +7,7 @@ testReflect0 {a} xs ys = AssocProof a total -testReflect1 : (xs, ys : List a) -> +testReflect1 : (xs, ys : List a) -> ((xs ++ (x :: ys ++ xs)) = ((xs ++ [x]) ++ (ys ++ xs))) -testReflect1 {a} xs ys = AssocProof a +testReflect1 {a} xs ys = AssocProof a diff --git a/test/test030/test030a.idr b/test/test030/test030a.idr --- a/test/test030/test030a.idr +++ b/test/test030/test030a.idr @@ -7,7 +7,7 @@ testReflect0 {a} xs ys = AssocProof a total -testReflect1 : (xs, ys : List a) -> +testReflect1 : (xs, ys : List a) -> ((ys ++ (x :: ys ++ xs)) = ((xs ++ [x]) ++ (ys ++ xs))) -testReflect1 {a} xs ys = AssocProof a +testReflect1 {a} xs ys = AssocProof a diff --git a/test/test031/run b/test/test031/run --- a/test/test031/run +++ b/test/test031/run @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash idris $@ test031.idr -o test031 ./test031 rm -f test031 *.ibc diff --git a/test/test032/expected b/test/test032/expected new file mode 100644 --- /dev/null +++ b/test/test032/expected @@ -0,0 +1,11 @@ +Type checking ./test032.idr +isElem x [] = ?isElem_rhs_1 +isElem x (_ :: _) = ?isElem_rhs_3 + + localZipWith f (_ :: _) (_ :: _) = ?localZipWith_rhs_1 + +f x :: (map f xs) +isElem2 x (y :: ys) with (_) + isElem2 x (y :: ys) | with_pat = ?isElem2_rhs + isElem3 x (x :: ys) | (Yes refl) = ?isElem3_rhs_3 + diff --git a/test/test032/input b/test/test032/input new file mode 100644 --- /dev/null +++ b/test/test032/input @@ -0,0 +1,5 @@ +:cs 11 xs +:cs 17 ys +:ps 21 maprhs +:mw 25 isElem2 +:cs 30 p diff --git a/test/test032/run b/test/test032/run new file mode 100644 --- /dev/null +++ b/test/test032/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris --quiet test032.idr < input +rm -f *.ibc diff --git a/test/test032/test032.idr b/test/test032/test032.idr new file mode 100644 --- /dev/null +++ b/test/test032/test032.idr @@ -0,0 +1,32 @@ +module elem + +import Decidable.Equality + +using (xs : List a) + data Elem : a -> List a -> Type where + Here : Elem x (x :: xs) + There : Elem x xs -> Elem x (y :: xs) + +isElem : (x : Nat) -> (xs : List Nat) -> Maybe (Elem x xs) +isElem x xs = ?isElem_rhs + +vadd : Num a => Vect n a -> Vect n a -> Vect n a +vadd xs ys = localZipWith (+) xs ys where + localZipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c + localZipWith f [] [] = [] + localZipWith f (_ :: _) ys = ?localZipWith_rhs + +map : (a -> b) -> Vect n a -> Vect n b +map f [] = [] +map f (x :: xs) = ?maprhs + +isElem2 : (x : Nat) -> (xs : List Nat) -> Maybe (Elem x xs) +isElem2 x [] = Nothing +isElem2 x (y :: ys) = ?isElem_rhs_2 + +isElem3 : (x : Nat) -> (xs : List Nat) -> Maybe (Elem x xs) +isElem3 x [] = Nothing +isElem3 x (y :: ys) with (decEq x y) + isElem3 x (y :: ys) | (Yes p) = ?isElem3_rhs_1 + isElem3 x (y :: ys) | (No _) = ?isElem3_rhs_2 + diff --git a/test/test033/expected b/test/test033/expected new file mode 100644 --- /dev/null +++ b/test/test033/expected @@ -0,0 +1,1 @@ +True diff --git a/test/test033/run b/test/test033/run new file mode 100644 --- /dev/null +++ b/test/test033/run @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +idris $@ -o test033 test033.idr +./test033 +rm -f *.ibc test033 diff --git a/test/test033/test033.idr b/test/test033/test033.idr new file mode 100644 --- /dev/null +++ b/test/test033/test033.idr @@ -0,0 +1,4 @@ +module Main + +main : IO () +main = nullPtr null >>= (putStrLn . show) diff --git a/test/test034/expected b/test/test034/expected new file mode 100644 --- /dev/null +++ b/test/test034/expected @@ -0,0 +1,44 @@ +prim__floatToStr 0.0 +"0.0" +prim__strToFloat "0.0" +0.0 +prim__addFloat 1.0 1.0 +2.0 +prim__subFloat 1.0 1.0 +0.0 +prim__mulFloat 1.0 1.0 +1.0 +prim__divFloat 1.0 1.0 +1.0 +prim__slteFloat 1.0 1.0 +1 +prim__sltFloat 1.0 1.0 +0 +prim__sgteFloat 1.0 1.0 +1 +prim__sgtFloat 1.0 1.0 +0 +prim__eqFloat 1.0 1.0 +1 +prim__floatACos 1.0 +0.0 +prim__floatATan 1.0 +0.7853981633974483 +prim__floatCos 1.0 +0.5403023058681398 +prim__floatFloor 1.0 +1.0 +prim__floatSin 1.0 +0.8414709848078965 +prim__floatTan 1.0 +1.5574077246549023 +prim__floatASin 1.0 +1.5707963267948966 +prim__floatCeil 1.0 +1.0 +prim__floatExp 1.0 +2.718281828459045 +prim__floatLog 1.0 +0.0 +prim__floatSqrt 1.0 +1.0 diff --git a/test/test034/run b/test/test034/run new file mode 100644 --- /dev/null +++ b/test/test034/run @@ -0,0 +1,49 @@ +#!/usr/bin/env bash + +HEAD="module Main + +import Data.Float + +main : IO ()" + +TESTS=("prim__floatToStr 0.0" +"prim__strToFloat \"0.0\"" +"prim__addFloat 1.0 1.0" +"prim__subFloat 1.0 1.0" +"prim__mulFloat 1.0 1.0" +"prim__divFloat 1.0 1.0" +"prim__slteFloat 1.0 1.0" +"prim__sltFloat 1.0 1.0" +"prim__sgteFloat 1.0 1.0" +"prim__sgtFloat 1.0 1.0" +"prim__eqFloat 1.0 1.0" +"prim__floatACos 1.0" +"prim__floatATan 1.0" +"prim__floatCos 1.0" +"prim__floatFloor 1.0" +"prim__floatSin 1.0" +"prim__floatTan 1.0" +"prim__floatASin 1.0" +"prim__floatCeil 1.0" +"prim__floatExp 1.0" +"prim__floatLog 1.0" +"prim__floatSqrt 1.0" +) + +generate_testfile() +{ +cat < $1 +${HEAD} +main = do + putStrLn $ show $ $2 +EOF +} + +for T in "${TESTS[@]}" +do + echo ${T} + generate_testfile "tmptest.idr" "${T}" + idris $@ --quiet tmptest.idr -o tmptest || echo "missing primitive in ${CG}" + ./tmptest + rm tmptest.idr tmptest.ibc tmptest +done diff --git a/tutorial/examples/bmain.idr b/tutorial/examples/bmain.idr --- a/tutorial/examples/bmain.idr +++ b/tutorial/examples/bmain.idr @@ -3,6 +3,6 @@ import btree main : IO () -main = do let t = toTree [1,8,2,7,9,3] +main = do let t = toTree [1,8,2,7,9,3] print (btree.toList t) diff --git a/tutorial/examples/classes.idr b/tutorial/examples/classes.idr --- a/tutorial/examples/classes.idr +++ b/tutorial/examples/classes.idr @@ -1,7 +1,7 @@ m_add : Maybe Int -> Maybe Int -> Maybe Int m_add x y = do x' <- x -- Extract value from x y' <- y -- Extract value from y - return (x' + y') -- Add them + return (x' + y') -- Add them m_add' : Maybe Int -> Maybe Int -> Maybe Int m_add' x y = [ x' + y' | x' <- x, y' <- y ] diff --git a/tutorial/examples/foo.idr b/tutorial/examples/foo.idr --- a/tutorial/examples/foo.idr +++ b/tutorial/examples/foo.idr @@ -6,5 +6,5 @@ namespace y test : String -> String - test x = x ++ x + test x = x ++ x diff --git a/tutorial/examples/idiom.idr b/tutorial/examples/idiom.idr --- a/tutorial/examples/idiom.idr +++ b/tutorial/examples/idiom.idr @@ -16,7 +16,7 @@ instance Functor Eval where map f (MkEval g) = MkEval (\e => map f (g e)) -instance Applicative Eval where +instance Applicative Eval where pure x = MkEval (\e => Just x) (<$>) (MkEval f) (MkEval g) = MkEval (\x => app (f x) (g x)) where diff --git a/tutorial/examples/interp.idr b/tutorial/examples/interp.idr --- a/tutorial/examples/interp.idr +++ b/tutorial/examples/interp.idr @@ -7,7 +7,7 @@ interpTy TyBool = Bool interpTy (TyFun s t) = interpTy s -> interpTy t -using (G : Vect n Ty) +using (G : Vect n Ty) data Env : Vect n Ty -> Type where Nil : Env Nil @@ -26,17 +26,17 @@ Val : (x : Int) -> Expr G TyInt Lam : Expr (a :: G) t -> Expr G (TyFun a t) App : Expr G (TyFun a t) -> Expr G a -> Expr G t - Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> + Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b -> Expr G c If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a - + interp : Env G -> {static} Expr G t -> interpTy t interp env (Var i) = lookup i env interp env (Val x) = x interp env (Lam sc) = \x => interp (x :: env) sc interp env (App f s) = interp env f (interp env s) interp env (Op op x y) = op (interp env x) (interp env y) - interp env (If x t e) = if interp env x then interp env t + interp env (If x t e) = if interp env x then interp env t else interp env e eId : Expr G (TyFun TyInt TyInt) @@ -47,10 +47,10 @@ eEq : Expr G (TyFun TyInt (TyFun TyInt TyBool)) eEq = Lam (Lam (Op (==) (Var stop) (Var (pop stop)))) - + eDouble : Expr G (TyFun TyInt TyInt) eDouble = Lam (App (App eAdd (Var stop)) (Var stop)) - + app : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t app = \f, a => App f a @@ -67,5 +67,5 @@ main : IO () main = do putStr "Enter a number: " x <- getLine - print (interp [] fact (cast x)) + print (interp [] fact (cast x)) diff --git a/tutorial/examples/wheres.idr b/tutorial/examples/wheres.idr --- a/tutorial/examples/wheres.idr +++ b/tutorial/examples/wheres.idr @@ -1,10 +1,10 @@ module wheres -even : Nat -> Bool +even : Nat -> Bool even Z = True -even (S k) = odd k where +even (S k) = odd k where odd Z = False - odd (S k) = even k + odd (S k) = even k test : List Nat test = [c (S 1), c Z, d (S Z)]