packages feed

idris 0.9.9.3 → 0.9.10

raw patch · 364 files changed

+17751/−11302 lines, 364 filesdep +deepseqdep +networkdep +xmldep −parsecdep ~language-javasetup-changed

Dependencies added: deepseq, network, xml

Dependencies removed: parsec

Dependency ranges changed: language-java

Files

Makefile view
@@ -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:
Setup.hs view
@@ -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"
config.mk view
@@ -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)))
− effects/Effect/Exception.idr 
@@ -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?-
− effects/Effect/File.idr 
@@ -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----
− effects/Effect/Memory.idr 
@@ -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 ()
− effects/Effect/Random.idr 
@@ -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)--
− effects/Effect/Select.idr 
@@ -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-
− effects/Effect/State.idr 
@@ -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-
− effects/Effect/StdIO.idr 
@@ -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--
− effects/Effects.idr 
@@ -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 ()
− effects/Makefile 
@@ -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:
− effects/effects.ipkg 
@@ -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-
idris.cabal view
@@ -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+
− java/executable_pom.xml 
@@ -1,66 +0,0 @@-<project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"-  xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/maven-v4_0_0.xsd">-  <modelVersion>4.0.0</modelVersion>-  <groupId>org.idris-lang</groupId>-  <artifactId>$ARTIFACT-NAME$</artifactId>-  <packaging>jar</packaging>-  <version>1.0</version>-  <name>$ARTIFACT-NAME$</name>--  <properties>-    <project.build.sourceEncoding>UTF-8</project.build.sourceEncoding>-    <skipTests>true</skipTests>-  </properties>-  <dependencies>-    <dependency>-      <groupId>org.idris-lang</groupId>-    	<artifactId>idris</artifactId>-    	<version>0.9.10-alpha-1</version>-    </dependency>-$DEPENDENCIES$-  </dependencies>---  <build>-    <finalName>$ARTIFACT-NAME$</finalName>-    <plugins>-      <plugin>-        <groupId>org.apache.maven.plugins</groupId>-        <artifactId>maven-compiler-plugin</artifactId>-        <version>3.0</version>-        <configuration>-          <source>1.7</source>-          <target>1.7</target>-        </configuration>-      </plugin>-      <plugin>-        <groupId>org.apache.maven.plugins</groupId>-          <artifactId>maven-surefire-plugin</artifactId>-          <version>2.14</version>-          <configuration>-            <skipTests>${skipTests}</skipTests>-          </configuration>-      </plugin>-      <plugin>-        <groupId>org.apache.maven.plugins</groupId>-        <artifactId>maven-shade-plugin</artifactId>-        <version>2.1</version>-        <executions>-          <execution>-            <phase>package</phase>-            <goals>-              <goal>shade</goal>-            </goals>-            <configuration>-              <transformers>-                <transformer implementation="org.apache.maven.plugins.shade.resource.ManifestResourceTransformer">-                  <mainClass>$MAIN-CLASS$</mainClass>-                </transformer>-              </transformers>-            </configuration>-          </execution>-        </executions>-      </plugin>-    </plugins>-  </build>-</project>
− java/executable_pom_template.xml 
@@ -1,66 +0,0 @@-<project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"-  xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/maven-v4_0_0.xsd">-  <modelVersion>4.0.0</modelVersion>-  <groupId>org.idris-lang</groupId>-  <artifactId>$ARTIFACT-NAME$</artifactId>-  <packaging>jar</packaging>-  <version>1.0</version>-  <name>$ARTIFACT-NAME$</name>--  <properties>-    <project.build.sourceEncoding>UTF-8</project.build.sourceEncoding>-    <skipTests>true</skipTests>-  </properties>-  <dependencies>-    <dependency>-      <groupId>org.idris-lang</groupId>-    	<artifactId>idris</artifactId>-    	<version>0.9.10-alpha-1</version>-    </dependency>-$DEPENDENCIES$-  </dependencies>---  <build>-    <finalName>$ARTIFACT-NAME$</finalName>-    <plugins>-      <plugin>-        <groupId>org.apache.maven.plugins</groupId>-        <artifactId>maven-compiler-plugin</artifactId>-        <version>3.0</version>-        <configuration>-          <source>1.7</source>-          <target>1.7</target>-        </configuration>-      </plugin>-      <plugin>-        <groupId>org.apache.maven.plugins</groupId>-          <artifactId>maven-surefire-plugin</artifactId>-          <version>2.14</version>-          <configuration>-            <skipTests>${skipTests}</skipTests>-          </configuration>-      </plugin>-      <plugin>-        <groupId>org.apache.maven.plugins</groupId>-        <artifactId>maven-shade-plugin</artifactId>-        <version>2.1</version>-        <executions>-          <execution>-            <phase>package</phase>-            <goals>-              <goal>shade</goal>-            </goals>-            <configuration>-              <transformers>-                <transformer implementation="org.apache.maven.plugins.shade.resource.ManifestResourceTransformer">-                  <mainClass>$MAIN-CLASS$</mainClass>-                </transformer>-              </transformers>-            </configuration>-          </execution>-        </executions>-      </plugin>-    </plugins>-  </build>-</project>
− javascript/JavaScript.idr 
@@ -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)
− javascript/JavaScript/JSON.idr 
@@ -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)
− javascript/Makefile 
@@ -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:
− javascript/javascript.ipkg 
@@ -1,5 +0,0 @@-package javascript--opts    = "-i ../lib"-modules = JavaScript, JavaScript.JSON-
− lib/Builtins.idr 
@@ -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--}-
− lib/Control/Arrow.idr 
@@ -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)-
− lib/Control/Catchable.idr 
@@ -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 () = []
− lib/Control/Category.idr 
@@ -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
− lib/Control/IOExcept.idr 
@@ -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-
− lib/Control/Monad/Identity.idr 
@@ -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
− lib/Control/Monad/State.idr 
@@ -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-
− lib/Data/Bits.idr 
@@ -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-
− lib/Data/BoundedList.idr 
@@ -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
− lib/Data/HVect.idr 
@@ -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-
− lib/Data/Mod2.idr 
@@ -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
− lib/Data/Morphisms.idr 
@@ -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
− lib/Data/Sign.idr 
@@ -1,6 +0,0 @@-module Data.Sign--data Sign = Plus | Minus--class Signed t where-  total sign : t -> Sign
− lib/Data/SortedMap.idr 
@@ -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)
− lib/Data/SortedSet.idr 
@@ -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)
− lib/Data/Vect.idr 
@@ -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)-
− lib/Data/Vect/Quantifiers.idr 
@@ -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')
− lib/Data/ZZ.idr 
@@ -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-
− lib/Debug/Trace.idr 
@@ -1,9 +0,0 @@-module Debug.Trace--import Prelude-import IO--trace : String -> a -> a-trace x val = unsafePerformIO (do putStrLn x; return val) --
− lib/Decidable/Decidable.idr 
@@ -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)--}
− lib/Decidable/Equality.idr 
@@ -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))
− lib/Decidable/Order.idr 
@@ -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---}-
− lib/IO.idr 
@@ -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))--
− lib/Language/Reflection.idr 
@@ -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-
− lib/Language/Reflection/Errors.idr 
@@ -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
− lib/Language/Reflection/Utils.idr 
@@ -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
− lib/Makefile 
@@ -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:
− lib/Network/Cgi.idr 
@@ -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--
− lib/Prelude.idr 
@@ -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-
− lib/Prelude/Algebra.idr 
@@ -1,257 +0,0 @@-module Prelude.Algebra--import Builtins---- XXX: change?-infixl 6 <->-infixl 6 <+>-infixl 6 <*>--%access public------------------------------------------------------------------------------------- A modest class hierarchy------------------------------------------------------------------------------------- Sets equipped with a single binary operation that is associative.  Must--- satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c-class Semigroup a where-  (<+>) : a -> a -> a--class Semigroup a => VerifiedSemigroup a where-  semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r---- Sets equipped with a single binary operation that is associative, along with--- a neutral element for that binary operation.  Must satisfy the following--- laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a-class Semigroup a => Monoid a where-  neutral : a--class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where-  monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l-  monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r---- Sets equipped with a single binary operation that is associative, along with--- a neutral element for that binary operation and inverses for all elements.--- Must satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral-class Monoid a => Group a where-  inverse : a -> a--class (VerifiedMonoid a, Group a) => VerifiedGroup a where-  groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral-  groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral--(<->) : Group a => a -> a -> a-(<->) left right = left <+> (inverse right)---- Sets equipped with a single binary operation that is associative and--- commutative, along with a neutral element for that binary operation and--- inverses for all elements. Must satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Commutativity of <+>:---     forall a b,   a <+> b         == b <+> a---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral-class Group a => AbelianGroup a where { }--class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where-  abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l---- Sets equipped with two binary operations, one associative and commutative--- supplied with a neutral element, and the other associative, with--- distributivity laws relating the two operations.  Must satisfy the following--- laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Commutativity of <+>:---     forall a b,   a <+> b         == b <+> a---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral---   Associativity of <*>:---     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c---   Distributivity of <*> and <->:---     forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)---     forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)-class AbelianGroup a => Ring a where-  (<*>) : a -> a -> a--class (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where-  ringOpIsAssociative   : (l, c, r : a) -> l <*> (c <*> r) = (l <*> c) <*> r-  ringOpIsDistributiveL : (l, c, r : a) -> l <*> (c <+> r) = (l <*> c) <+> (l <*> r)-  ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <*> r = (l <*> r) <+> (l <*> c)---- Sets equipped with two binary operations, one associative and commutative--- supplied with a neutral element, and the other associative supplied with a--- neutral element, with distributivity laws relating the two operations.  Must--- satisfy the following laws:---   Associativity of <+>:---     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c---   Commutativity of <+>:---     forall a b,   a <+> b         == b <+> a---   Neutral for <+>:---     forall a,     a <+> neutral   == a---     forall a,     neutral <+> a   == a---   Inverse for <+>:---     forall a,     a <+> inverse a == neutral---     forall a,     inverse a <+> a == neutral---   Associativity of <*>:---     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c---   Neutral for <*>:---     forall a,     a <*> unity     == a---     forall a,     unity <*> a     == a---   Distributivity of <*> and <->:---     forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)---     forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)-class Ring a => RingWithUnity a where-  unity : a--class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where-  ringWithUnityIsUnityL : (l : a) -> l <*> unity = l-  ringWithUnityIsUnityR : (r : a) -> unity <*> r = r---- Sets equipped with a binary operation that is commutative, associative and--- idempotent.  Must satisfy the following laws:---   Associativity of join:---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of join:---     forall a b,   join a b          == join b a---   Idempotency of join:---     forall a,     join a a          == a---  Join semilattices capture the notion of sets with a "least upper bound".-class JoinSemilattice a where-  join : a -> a -> a--class JoinSemilattice a => VerifiedJoinSemilattice a where-  joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r-  joinSemilatticeJoinIsCommutative : (l, r : a)    -> join l r = join r l-  joinSemilatticeJoinIsIdempotent  : (e : a)       -> join e e = e---- Sets equipped with a binary operation that is commutative, associative and--- idempotent.  Must satisfy the following laws:---   Associativity of meet:---     forall a b c, meet a (meet b c) == meet (meet a b) c---   Commutativity of meet:---     forall a b,   meet a b          == meet b a---   Idempotency of meet:---     forall a,     meet a a          == a---  Meet semilattices capture the notion of sets with a "greatest lower bound".-class MeetSemilattice a where-  meet : a -> a -> a--class MeetSemilattice a => VerifiedMeetSemilattice a where-  meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r-  meetSemilatticeMeetIsCommutative : (l, r : a)    -> meet l r = meet r l-  meetSemilatticeMeetIsIdempotent  : (e : a)       -> meet e e = e---- Sets equipped with a binary operation that is commutative, associative and--- idempotent and supplied with a neutral element.  Must satisfy the following--- laws:---   Associativity of join:---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of join:---     forall a b,   join a b          == join b a---   Idempotency of join:---     forall a,     join a a          == a---   Bottom:---     forall a,     join a bottom     == bottom---  Join semilattices capture the notion of sets with a "least upper bound"---  equipped with a "bottom" element.-class JoinSemilattice a => BoundedJoinSemilattice a where-  bottom  : a--class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where-  boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = bottom---- Sets equipped with a binary operation that is commutative, associative and--- idempotent and supplied with a neutral element.  Must satisfy the following--- laws:---   Associativity of meet:---     forall a b c, meet a (meet b c) == meet (meet a b) c---   Commutativity of meet:---     forall a b,   meet a b          == meet b a---   Idempotency of meet:---     forall a,     meet a a          == a---   Top:---     forall a,     meet a top        == top---  Meet semilattices capture the notion of sets with a "greatest lower bound"---  equipped with a "top" element.-class MeetSemilattice a => BoundedMeetSemilattice a where-  top : a--class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where-  boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = top---- Sets equipped with two binary operations that are both commutative,--- associative and idempotent, along with absorbtion laws for relating the two--- binary operations.  Must satisfy the following:---   Associativity of meet and join:---     forall a b c, meet a (meet b c) == meet (meet a b) c---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of meet and join:---     forall a b,   meet a b          == meet b a---     forall a b,   join a b          == join b a---   Idempotency of meet and join:---     forall a,     meet a a          == a---     forall a,     join a a          == a---   Absorbtion laws for meet and join:---     forall a b,   meet a (join a b) == a---     forall a b,   join a (meet a b) == a-class (JoinSemilattice a, MeetSemilattice a) => Lattice a where { }--class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where-  latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l-  latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l---- Sets equipped with two binary operations that are both commutative,--- associative and idempotent and supplied with neutral elements, along with--- absorbtion laws for relating the two binary operations.  Must satisfy the--- following:---   Associativity of meet and join:---     forall a b c, meet a (meet b c) == meet (meet a b) c---     forall a b c, join a (join b c) == join (join a b) c---   Commutativity of meet and join:---     forall a b,   meet a b          == meet b a---     forall a b,   join a b          == join b a---   Idempotency of meet and join:---     forall a,     meet a a          == a---     forall a,     join a a          == a---   Absorbtion laws for meet and join:---     forall a b,   meet a (join a b) == a---     forall a b,   join a (meet a b) == a---   Neutral for meet and join:---     forall a,     meet a top        == top---     forall a,     join a bottom     == bottom-class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }--class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }-  -  --- XXX todo:---   Fields and vector spaces.---   Structures where "abs" make sense.---   Euclidean domains, etc.---   Where to put fromInteger and fromRational?
− lib/Prelude/Applicative.idr 
@@ -1,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 ()
− lib/Prelude/Bits.idr 
@@ -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
− lib/Prelude/Cast.idr 
@@ -1,49 +0,0 @@-module Prelude.Cast--class Cast from to where-    cast : from -> to---- String casts--instance Cast String Int where-    cast = prim__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--
− lib/Prelude/Chars.idr 
@@ -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']-
− lib/Prelude/Complex.idr 
@@ -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)
− lib/Prelude/Either.idr 
@@ -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
− lib/Prelude/Fin.idr 
@@ -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-
− lib/Prelude/Foldable.idr 
@@ -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-
− lib/Prelude/Functor.idr 
@@ -1,4 +0,0 @@-module Prelude.Functor--class Functor (f : Type -> Type) where -    map : (a -> b) -> f a -> f b
− lib/Prelude/Heap.idr 
@@ -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 ()--}
− lib/Prelude/List.idr 
@@ -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;-}-
− lib/Prelude/Maybe.idr 
@@ -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--- <http://en.wikipedia.org/wiki/Monoid>: "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
− lib/Prelude/Monad.idr 
@@ -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
− lib/Prelude/Nat.idr 
@@ -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;-}
− lib/Prelude/Strings.idr 
@@ -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
− lib/Prelude/Traversable.idr 
@@ -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
− lib/Prelude/Vect.idr 
@@ -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;-}-
− lib/Providers.idr 
@@ -1,5 +0,0 @@-module Providers--public-data Provider a = Provide a | Error String-
− lib/System.idr 
@@ -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-
− lib/System/Concurrency/Process.idr 
@@ -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)-
− lib/System/Concurrency/Raw.idr 
@@ -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-
− lib/Uninhabited.idr 
@@ -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-
− lib/base.ipkg 
@@ -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
+ libs/Makefile view
@@ -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:
+ libs/base/Control/Arrow.idr view
@@ -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)+
+ libs/base/Control/Catchable.idr view
@@ -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 () = []
+ libs/base/Control/Category.idr view
@@ -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
+ libs/base/Control/IOExcept.idr view
@@ -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+
+ libs/base/Control/Monad/Identity.idr view
@@ -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
+ libs/base/Control/Monad/RWS.idr view
@@ -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
+ libs/base/Control/Monad/Reader.idr view
@@ -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
+ libs/base/Control/Monad/State.idr view
@@ -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
+ libs/base/Control/Monad/Writer.idr view
@@ -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
+ libs/base/Data/Bits.idr view
@@ -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+
+ libs/base/Data/BoundedList.idr view
@@ -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
+ libs/base/Data/Complex.idr view
@@ -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)
+ libs/base/Data/Floats.idr view
@@ -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+
+ libs/base/Data/HVect.idr view
@@ -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+
+ libs/base/Data/Heap.idr view
@@ -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 ()+-}
+ libs/base/Data/Mod2.idr view
@@ -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
+ libs/base/Data/Morphisms.idr view
@@ -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
+ libs/base/Data/Sign.idr view
@@ -0,0 +1,6 @@+module Data.Sign++data Sign = Plus | Minus++class Signed t where+  total sign : t -> Sign
+ libs/base/Data/SortedMap.idr view
@@ -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)
+ libs/base/Data/SortedSet.idr view
@@ -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)
+ libs/base/Data/Vect.idr view
@@ -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)+
+ libs/base/Data/Vect/Quantifiers.idr view
@@ -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')
+ libs/base/Data/ZZ.idr view
@@ -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+
+ libs/base/Debug/Trace.idr view
@@ -0,0 +1,6 @@+module Debug.Trace++trace : String -> a -> a+trace x val = unsafePerformIO (do putStrLn x; return val)++
+ libs/base/Decidable/Decidable.idr view
@@ -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)+-}
+ libs/base/Decidable/Order.idr view
@@ -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++-}+
+ libs/base/Language/Reflection.idr view
@@ -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+
+ libs/base/Language/Reflection/Errors.idr view
@@ -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
+ libs/base/Language/Reflection/Utils.idr view
@@ -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
+ libs/base/Makefile view
@@ -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:
+ libs/base/Network/Cgi.idr view
@@ -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++
+ libs/base/Providers.idr view
@@ -0,0 +1,5 @@+module Providers++public+data Provider a = Provide a | Error String+
+ libs/base/System.idr view
@@ -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+
+ libs/base/System/Concurrency/Process.idr view
@@ -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)+
+ libs/base/System/Concurrency/Raw.idr view
@@ -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+
+ libs/base/Uninhabited.idr view
@@ -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+
+ libs/base/base.ipkg view
@@ -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
+ libs/effects/Effect/Exception.idr view
@@ -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?+
+ libs/effects/Effect/File.idr view
@@ -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++++
+ libs/effects/Effect/Memory.idr view
@@ -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 ()
+ libs/effects/Effect/Random.idr view
@@ -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+
+ libs/effects/Effect/Select.idr view
@@ -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+
+ libs/effects/Effect/State.idr view
@@ -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+
+ libs/effects/Effect/StdIO.idr view
@@ -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++
+ libs/effects/Effects.idr view
@@ -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 ()
+ libs/effects/Makefile view
@@ -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:
+ libs/effects/effects.ipkg view
@@ -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+
+ libs/javascript/JavaScript.idr view
@@ -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)
+ libs/javascript/JavaScript/JSON.idr view
@@ -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)
+ libs/javascript/Makefile view
@@ -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:
+ libs/javascript/javascript.ipkg view
@@ -0,0 +1,5 @@+package javascript++opts    = "--nobasepkgs -i ../prelude -i ../base"+modules = JavaScript, JavaScript.JSON+
+ libs/prelude/Builtins.idr view
@@ -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+
+ libs/prelude/Decidable/Equality.idr view
@@ -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))
+ libs/prelude/IO.idr view
@@ -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))++
+ libs/prelude/Makefile view
@@ -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:
+ libs/prelude/Prelude.idr view
@@ -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+
+ libs/prelude/Prelude/Algebra.idr view
@@ -0,0 +1,257 @@+module Prelude.Algebra++import Builtins++-- XXX: change?+infixl 6 <->+infixl 6 <+>+infixl 6 <*>++%access public++--------------------------------------------------------------------------------+-- A modest class hierarchy+--------------------------------------------------------------------------------++-- Sets equipped with a single binary operation that is associative.  Must+-- satisfy the following laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+class Semigroup a where+  (<+>) : a -> a -> a++class Semigroup a => VerifiedSemigroup a where+  semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r++-- Sets equipped with a single binary operation that is associative, along with+-- a neutral element for that binary operation.  Must satisfy the following+-- laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+--   Neutral for <+>:+--     forall a,     a <+> neutral   == a+--     forall a,     neutral <+> a   == a+class Semigroup a => Monoid a where+  neutral : a++class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where+  monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l+  monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r++-- Sets equipped with a single binary operation that is associative, along with+-- a neutral element for that binary operation and inverses for all elements.+-- Must satisfy the following laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+--   Neutral for <+>:+--     forall a,     a <+> neutral   == a+--     forall a,     neutral <+> a   == a+--   Inverse for <+>:+--     forall a,     a <+> inverse a == neutral+--     forall a,     inverse a <+> a == neutral+class Monoid a => Group a where+  inverse : a -> a++class (VerifiedMonoid a, Group a) => VerifiedGroup a where+  groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral+  groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral++(<->) : Group a => a -> a -> a+(<->) left right = left <+> (inverse right)++-- Sets equipped with a single binary operation that is associative and+-- commutative, along with a neutral element for that binary operation and+-- inverses for all elements. Must satisfy the following laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+--   Commutativity of <+>:+--     forall a b,   a <+> b         == b <+> a+--   Neutral for <+>:+--     forall a,     a <+> neutral   == a+--     forall a,     neutral <+> a   == a+--   Inverse for <+>:+--     forall a,     a <+> inverse a == neutral+--     forall a,     inverse a <+> a == neutral+class Group a => AbelianGroup a where { }++class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where+  abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l++-- Sets equipped with two binary operations, one associative and commutative+-- supplied with a neutral element, and the other associative, with+-- distributivity laws relating the two operations.  Must satisfy the following+-- laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+--   Commutativity of <+>:+--     forall a b,   a <+> b         == b <+> a+--   Neutral for <+>:+--     forall a,     a <+> neutral   == a+--     forall a,     neutral <+> a   == a+--   Inverse for <+>:+--     forall a,     a <+> inverse a == neutral+--     forall a,     inverse a <+> a == neutral+--   Associativity of <*>:+--     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c+--   Distributivity of <*> and <->:+--     forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)+--     forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)+class AbelianGroup a => Ring a where+  (<*>) : a -> a -> a++class (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where+  ringOpIsAssociative   : (l, c, r : a) -> l <*> (c <*> r) = (l <*> c) <*> r+  ringOpIsDistributiveL : (l, c, r : a) -> l <*> (c <+> r) = (l <*> c) <+> (l <*> r)+  ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <*> r = (l <*> r) <+> (l <*> c)++-- Sets equipped with two binary operations, one associative and commutative+-- supplied with a neutral element, and the other associative supplied with a+-- neutral element, with distributivity laws relating the two operations.  Must+-- satisfy the following laws:+--   Associativity of <+>:+--     forall a b c, a <+> (b <+> c) == (a <+> b) <+> c+--   Commutativity of <+>:+--     forall a b,   a <+> b         == b <+> a+--   Neutral for <+>:+--     forall a,     a <+> neutral   == a+--     forall a,     neutral <+> a   == a+--   Inverse for <+>:+--     forall a,     a <+> inverse a == neutral+--     forall a,     inverse a <+> a == neutral+--   Associativity of <*>:+--     forall a b c, a <*> (b <*> c) == (a <*> b) <*> c+--   Neutral for <*>:+--     forall a,     a <*> unity     == a+--     forall a,     unity <*> a     == a+--   Distributivity of <*> and <->:+--     forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)+--     forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)+class Ring a => RingWithUnity a where+  unity : a++class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where+  ringWithUnityIsUnityL : (l : a) -> l <*> unity = l+  ringWithUnityIsUnityR : (r : a) -> unity <*> r = r++-- Sets equipped with a binary operation that is commutative, associative and+-- idempotent.  Must satisfy the following laws:+--   Associativity of join:+--     forall a b c, join a (join b c) == join (join a b) c+--   Commutativity of join:+--     forall a b,   join a b          == join b a+--   Idempotency of join:+--     forall a,     join a a          == a+--  Join semilattices capture the notion of sets with a "least upper bound".+class JoinSemilattice a where+  join : a -> a -> a++class JoinSemilattice a => VerifiedJoinSemilattice a where+  joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r+  joinSemilatticeJoinIsCommutative : (l, r : a)    -> join l r = join r l+  joinSemilatticeJoinIsIdempotent  : (e : a)       -> join e e = e++-- Sets equipped with a binary operation that is commutative, associative and+-- idempotent.  Must satisfy the following laws:+--   Associativity of meet:+--     forall a b c, meet a (meet b c) == meet (meet a b) c+--   Commutativity of meet:+--     forall a b,   meet a b          == meet b a+--   Idempotency of meet:+--     forall a,     meet a a          == a+--  Meet semilattices capture the notion of sets with a "greatest lower bound".+class MeetSemilattice a where+  meet : a -> a -> a++class MeetSemilattice a => VerifiedMeetSemilattice a where+  meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r+  meetSemilatticeMeetIsCommutative : (l, r : a)    -> meet l r = meet r l+  meetSemilatticeMeetIsIdempotent  : (e : a)       -> meet e e = e++-- Sets equipped with a binary operation that is commutative, associative and+-- idempotent and supplied with a neutral element.  Must satisfy the following+-- laws:+--   Associativity of join:+--     forall a b c, join a (join b c) == join (join a b) c+--   Commutativity of join:+--     forall a b,   join a b          == join b a+--   Idempotency of join:+--     forall a,     join a a          == a+--   Bottom:+--     forall a,     join a bottom     == bottom+--  Join semilattices capture the notion of sets with a "least upper bound"+--  equipped with a "bottom" element.+class JoinSemilattice a => BoundedJoinSemilattice a where+  bottom  : a++class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where+  boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = bottom++-- Sets equipped with a binary operation that is commutative, associative and+-- idempotent and supplied with a neutral element.  Must satisfy the following+-- laws:+--   Associativity of meet:+--     forall a b c, meet a (meet b c) == meet (meet a b) c+--   Commutativity of meet:+--     forall a b,   meet a b          == meet b a+--   Idempotency of meet:+--     forall a,     meet a a          == a+--   Top:+--     forall a,     meet a top        == top+--  Meet semilattices capture the notion of sets with a "greatest lower bound"+--  equipped with a "top" element.+class MeetSemilattice a => BoundedMeetSemilattice a where+  top : a++class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where+  boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = top++-- Sets equipped with two binary operations that are both commutative,+-- associative and idempotent, along with absorbtion laws for relating the two+-- binary operations.  Must satisfy the following:+--   Associativity of meet and join:+--     forall a b c, meet a (meet b c) == meet (meet a b) c+--     forall a b c, join a (join b c) == join (join a b) c+--   Commutativity of meet and join:+--     forall a b,   meet a b          == meet b a+--     forall a b,   join a b          == join b a+--   Idempotency of meet and join:+--     forall a,     meet a a          == a+--     forall a,     join a a          == a+--   Absorbtion laws for meet and join:+--     forall a b,   meet a (join a b) == a+--     forall a b,   join a (meet a b) == a+class (JoinSemilattice a, MeetSemilattice a) => Lattice a where { }++class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where+  latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l+  latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l++-- Sets equipped with two binary operations that are both commutative,+-- associative and idempotent and supplied with neutral elements, along with+-- absorbtion laws for relating the two binary operations.  Must satisfy the+-- following:+--   Associativity of meet and join:+--     forall a b c, meet a (meet b c) == meet (meet a b) c+--     forall a b c, join a (join b c) == join (join a b) c+--   Commutativity of meet and join:+--     forall a b,   meet a b          == meet b a+--     forall a b,   join a b          == join b a+--   Idempotency of meet and join:+--     forall a,     meet a a          == a+--     forall a,     join a a          == a+--   Absorbtion laws for meet and join:+--     forall a b,   meet a (join a b) == a+--     forall a b,   join a (meet a b) == a+--   Neutral for meet and join:+--     forall a,     meet a top        == top+--     forall a,     join a bottom     == bottom+class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }++class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }+++-- XXX todo:+--   Fields and vector spaces.+--   Structures where "abs" make sense.+--   Euclidean domains, etc.+--   Where to put fromInteger and fromRational?
+ libs/prelude/Prelude/Applicative.idr view
@@ -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 ()
+ libs/prelude/Prelude/Basics.idr view
@@ -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+
+ libs/prelude/Prelude/Bits.idr view
@@ -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
+ libs/prelude/Prelude/Bool.idr view
@@ -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+
+ libs/prelude/Prelude/Cast.idr view
@@ -0,0 +1,49 @@+module Prelude.Cast++class Cast from to where+    cast : from -> to++-- String casts++instance Cast String Int where+    cast = prim__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++
+ libs/prelude/Prelude/Chars.idr view
@@ -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 ]
+ libs/prelude/Prelude/Classes.idr view
@@ -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 ++
+ libs/prelude/Prelude/Either.idr view
@@ -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
+ libs/prelude/Prelude/Fin.idr view
@@ -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+
+ libs/prelude/Prelude/Foldable.idr view
@@ -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+
+ libs/prelude/Prelude/Functor.idr view
@@ -0,0 +1,4 @@+module Prelude.Functor++class Functor (f : Type -> Type) where+    map : (a -> b) -> f a -> f b
+ libs/prelude/Prelude/List.idr view
@@ -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;+}+
+ libs/prelude/Prelude/Maybe.idr view
@@ -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+-- <http://en.wikipedia.org/wiki/Monoid>: "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
+ libs/prelude/Prelude/Monad.idr view
@@ -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
+ libs/prelude/Prelude/Nat.idr view
@@ -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;+}
+ libs/prelude/Prelude/Stream.idr view
@@ -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)++
+ libs/prelude/Prelude/Strings.idr view
@@ -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
+ libs/prelude/Prelude/Traversable.idr view
@@ -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
+ libs/prelude/Prelude/Vect.idr view
@@ -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;+}+
+ libs/prelude/prelude.ipkg view
@@ -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+
llvm/defs.c view
@@ -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];+}
rts/Makefile view
@@ -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
rts/idris_gc.c view
@@ -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;
rts/idris_gmp.c view
@@ -1,5 +1,9 @@ #include "idris_rts.h"+#ifdef IDRIS_GMP #include <gmp.h>+#else+#include "mini-gmp.h"+#endif #include <stdlib.h> #include <string.h> @@ -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;
rts/idris_gmp.h view
@@ -1,6 +1,12 @@ #ifndef _IDRISGMP_H #define _IDRISGMP_H +#ifdef IDRIS_GMP+#include <gmp.h>+#else+#include "mini-gmp.h"+#endif+ VAL MKBIGI(int val); VAL MKBIGC(VM* vm, char* bigint); VAL MKBIGM(VM* vm, void* bigint);
rts/idris_main.c view
@@ -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
rts/idris_opts.c view
@@ -6,18 +6,17 @@ #include <string.h>  -char usage[] = -    "\n"                                                        \+#define USAGE "\n"                                              \     "Usage: <prog> [+RTS <rtsopts> -RTS] <args>\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) {
rts/idris_rts.c view
@@ -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() {
rts/idris_rts.h view
@@ -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.
+ rts/mini-gmp.c view
@@ -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 <assert.h>+#include <ctype.h>+#include <limits.h>+#include <stdio.h>+#include <stdlib.h>+#include <string.h>++#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 <n1, np[dn-1+i], np[dn-2+i], np[dn-3+i],..., np[i]>+   * by            <d1,          d0,        dp[dn-3],  ..., dp[0] >+   */++  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;+}
+ rts/mini-gmp.h view
@@ -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 <stddef.h>++#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,+   <iostream> 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__ */
src/Core/CaseTree.hs view
@@ -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
src/Core/Constraints.hs view
@@ -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
− src/Core/CoreParser.hs 
@@ -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
src/Core/Elaborate.hs view
@@ -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
src/Core/Evaluate.hs view
@@ -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
src/Core/Execute.hs view
@@ -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
− src/Core/ProofShell.hs 
@@ -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'-
src/Core/ProofState.hs view
@@ -5,7 +5,7 @@    evaluation/checking inside the proof system, etc. --}  module Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,-                  Tactic(..), Goal(..), processTactic, +                  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-
− src/Core/ShellParser.hs 
@@ -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-
src/Core/TT.hs view
@@ -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
src/Core/Typecheck.hs view
@@ -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
src/Core/Unify.hs view
@@ -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 _ = []
src/IRTS/BCImp.hs view
@@ -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
src/IRTS/Bytecode.hs view
@@ -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
src/IRTS/CodegenC.hs view
@@ -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)
src/IRTS/CodegenCommon.hs view
@@ -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
src/IRTS/CodegenJava.hs view
@@ -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 $ "<dependency>\n"-          , T.append (T.pack "  ") $ mkGroupId g-          , T.append (T.pack "  ") $ mkArtifactId a-          , T.append (T.pack "  ") $ mkVersion v-          , T.pack $ "</dependency>\n"-          ]-        _     -> []-    mkGroupId g    = T.append (T.pack $ "<groupId>")    (T.append g $ T.pack "</groupId>\n")-    mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")-    mkVersion v    = T.append (T.pack $ "<version>")    (T.append v $ T.pack "</version>\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
src/IRTS/CodegenJavaScript.hs view
@@ -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) =
src/IRTS/CodegenLLVM.hs view
@@ -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)
src/IRTS/Compiler.hs view
@@ -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'
src/IRTS/Defunctionalise.hs view
@@ -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
src/IRTS/DumpBC.hs view
@@ -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"
src/IRTS/Inliner.hs view
@@ -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
src/IRTS/Java/JTypes.hs view
@@ -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
+ src/IRTS/Java/Pom.hs view
@@ -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"+        )+      ]+    ]+  ])
− src/IRTS/LParser.hs 
@@ -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))-
src/IRTS/Lang.hs view
@@ -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)
src/IRTS/Simplified.hs view
@@ -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
src/Idris/AbsSyntax.hs view
@@ -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)
src/Idris/AbsSyntaxTree.hs view
@@ -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
+ src/Idris/CaseSplit.hs view
@@ -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
src/Idris/Chaser.hs view
@@ -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
src/Idris/Colours.hs view
@@ -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)
src/Idris/Completion.hs view
@@ -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]
src/Idris/Coverage.hs view
@@ -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
src/Idris/DSL.hs view
@@ -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))]+
src/Idris/DataOpts.hs view
@@ -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
+ src/Idris/DeepSeq.hs view
@@ -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` ()+++
src/Idris/Delaborate.hs view
@@ -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))
src/Idris/Docs.hs view
@@ -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
src/Idris/ElabDecls.hs view
@@ -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
src/Idris/ElabTerm.hs view
@@ -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]
src/Idris/Error.hs view
@@ -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
src/Idris/Help.hs view
@@ -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 @@   [ (["<expr>"], 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 <line> <name> splits the pattern variable on the line")+    , ([":casesplit!", ":cs!"], NoArg, ":cs! <line> <name> destructively splits the pattern variable on the line")+    , ([":addclause", ":ac"], NoArg, ":ac <line> <name> adds a clause for the definition of the name on the line")+    , ([":addclause!", ":ac!"], NoArg, ":ac! <line> <name> destructively adds a clause for the definition of the name on the line")+    , ([":addmissing", ":am"], NoArg, ":am <line> <name> adds all missing pattern matches for the name on the line")+    , ([":addmissing!", ":am!"], NoArg, ":am! <line> <name> destructively adds all missing pattern matches for the name on the line")+    , ([":makewith", ":mw"], NoArg, ":mw <line> <name> adds a with clause for the definition of the name on the line")+    , ([":makewith!", ":mw!"], NoArg, ":mw! <line> <name> destructively adds a with clause for the definition of the name on the line")+    , ([":proofsearch", ":ps"], NoArg, ":ps <line> <name> <names> does proof search for name on line, with names as hints")+    , ([":proofsearch!", ":ps!"], NoArg, ":ps! <line> <name> <names> destructively does proof search for name on line, with names as hints")+    , ([":addproofclause", ":apc"], NoArg, ":apc <line> <name> adds a pattern-matching proof clause to name on line")+    , ([":addproofclause!", ":apc!"], NoArg, ":apc! <line> <name> destructively adds a pattern-matching proof clause to name on line")+    ]
src/Idris/IBC.hs view
@@ -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
src/Idris/IdeSlave.hs view
@@ -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 =
src/Idris/Imports.hs view
@@ -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
src/Idris/Inliner.hs view
@@ -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)
src/Idris/ParseData.hs view
@@ -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"
src/Idris/ParseExpr.hs view
@@ -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;
src/Idris/ParseHelpers.hs view
@@ -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 [] = []
src/Idris/Parser.hs view
@@ -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
src/Idris/PartialEval.hs view
@@ -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 = []++
src/Idris/Primitives.hs view
@@ -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
+ src/Idris/ProofSearch.hs view
@@ -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)+
src/Idris/Prover.hs view
@@ -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
src/Idris/Providers.hs view
@@ -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."
src/Idris/REPL.hs view
@@ -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"
src/Idris/REPLParser.hs view
@@ -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)
src/Idris/Transforms.hs view
@@ -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
src/Idris/Unlit.hs view
@@ -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 ()
src/Idris/UnusedArgs.hs view
@@ -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))]
src/Main.hs view
@@ -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" ++
src/Pkg/PParser.hs view
@@ -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) })+
src/Pkg/Package.hs view
@@ -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))
src/Util/DynamicLinker.hs view
@@ -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++
src/Util/LLVMStubs.hs view
@@ -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.  --}
+ src/Util/Net.hs view
@@ -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+      )+
src/Util/System.hs view
@@ -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"
test/Makefile view
@@ -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 *~
test/reg001/reg001.idr view
@@ -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
test/reg001/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris reg001.idr --check rm -rf reg001.ibc
test/reg002/reg002.idr view
@@ -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
test/reg002/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris reg002.idr -o reg002 ./reg002 rm -f reg002 *.ibc
test/reg003/expected view
@@ -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
test/reg003/reg003.idr view
@@ -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]
test/reg003/reg003a.idr view
@@ -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
test/reg003/run view
@@ -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
test/reg004/run view
@@ -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
test/reg005/reg005.idr view
@@ -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))
test/reg005/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg005.idr -o reg005 ./reg005 rm -f reg005 *.ibc
test/reg006/expected view
@@ -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
test/reg006/reg006.idr view
@@ -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
test/reg006/run view
@@ -1,3 +1,3 @@-#!/bin/bash-idris $@ reg006.idr -o reg006+#!/usr/bin/env bash+idris $@ reg006.idr --check rm -f *.ibc
test/reg007/expected view
@@ -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-	[92mn[0m[94m = [0m[92mA.lala[0m+	[92mn[0m[94m = [0m[92mlala[0m with 	[91m0[0m[94m = [0m[91m1[0m
test/reg007/run view
@@ -1,3 +1,3 @@-#!/bin/bash-idris --check $@ reg007.lidr +#!/usr/bin/env bash+idris --check $@ reg007.lidr rm -f *.ibc
test/reg008/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg008.idr --check rm -f *.ibc
test/reg009/reg009.lidr view
@@ -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 >              )
test/reg009/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg009.lidr --check rm -f reg009 *.ibc
test/reg010/expected view
@@ -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
test/reg010/run view
@@ -1,2 +1,2 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg010.idr --check --nocolour
test/reg011/reg011.idr view
@@ -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
test/reg011/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg011.idr --check rm -f *.ibc
test/reg012/reg012.lidr view
@@ -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
test/reg012/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg012.lidr --check rm -f *.ibc
test/reg013/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg013.idr -o reg013 ./reg013 rm -f reg013 *.ibc
test/reg014/reg014.idr view
@@ -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
test/reg014/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg014.idr --check rm -f *.ibc
test/reg015/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg015.idr --check rm -f *.ibc
test/reg016/expected view
@@ -1,6 +1,1 @@-4294967295-4294967296-4294967297--1-0-1+429496729500000000000000
test/reg016/reg016.idr view
@@ -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
test/reg016/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg016.idr -o reg016 ./reg016 rm -f reg016 *.ibc
test/reg017/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg017.idr -o reg017 ./reg017 rm -f reg017 *.ibc
test/reg018/expected view
@@ -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
test/reg018/reg018b.idr view
@@ -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
test/reg018/reg018c.idr view
@@ -2,7 +2,7 @@ %default total  codata InfStream a = (::) a (InfStream a)--- +-- -- natStream : InfStream Nat -- natStream = natFromStream 0 where --   natFromStream : Nat -> InfStream Nat
test/reg018/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg018a.idr --check idris $@ reg018b.idr --check idris $@ reg018c.idr --check
test/reg019/reg019.idr view
@@ -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
test/reg019/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg019.idr --check rm -f *.ibc
test/reg020/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg020.idr -o reg020 ./reg020 rm -f reg020 *.ibc
test/reg021/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg021.idr --check rm -f *.ibc
test/reg022/reg022.idr view
@@ -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
test/reg022/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg022.idr --check rm -f *.ibc
test/reg023/expected view
@@ -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 	[94mNat[0m with
test/reg023/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg023.idr --check rm -f *.ibc
test/reg024/reg024.idr view
@@ -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
test/reg024/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ reg024.idr -o reg024 ./reg024 rm -f reg024 *.ibc
test/runtest.pl view
@@ -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;
test/test001/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test001.idr -o test001 ./test001 rm -f test001 test001.ibc
test/test001/test001.idr view
@@ -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))
test/test002/expected view
@@ -0,0 +1,1 @@+test002.idr:5:6:Universe inconsistency
test/test002/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test002.idr --check --noprelude rm -f *.ibc
test/test002/test002.idr view
@@ -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  {-
test/test003/Lit.lidr view
@@ -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)
test/test003/expected view
@@ -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
test/test003/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test003a.lidr --check idris $@ test003.lidr -o test003 ./test003
test/test004/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test004.idr -o test004 ./test004 rm -f test004 test004.ibc testfile
test/test004/test004.idr view
@@ -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 "---"           }
test/test005/expected view
@@ -1,6 +1,6 @@ 8 1-(abc, 123)-(abc, 123)+("abc", "123")+("abc", "123") ([1, 2], [3, 4, 5]) ([1, 2], [3, 4, 5])
test/test005/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test005.idr -o test005 ./test005 rm -f test005 test005.ibc
test/test006/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test006.idr -o test006 ./test006 rm -f test006 test006.ibc
test/test007/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test007.idr -o test007 ./test007 rm -f test007 test007.ibc
test/test007/test007.idr view
@@ -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
test/test008/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test008.idr -o test008 ./test008 rm -f test008 test008.ibc
test/test008/test008.idr view
@@ -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
test/test009/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test009.idr -o test009 ./test009 rm -f test009 test009.ibc
test/test009/test009.idr view
@@ -6,4 +6,4 @@  main : IO () main = putStrLn (show (pythag 50))-      +
test/test010/expected view
@@ -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
test/test010/run view
@@ -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
test/test011/expected view
@@ -1,5 +1,5 @@-foo-Fred+"foo"+"Fred" [1, 2, 3]-[b, a]+["b", "a"] 25
test/test011/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test011.idr -o test011 ./test011 rm -f test011 test011.ibc
test/test011/test011.idr view
@@ -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
test/test012/expected view
@@ -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
test/test012/run view
@@ -1,2 +1,2 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test012a.idr -o test012a
test/test012/test012a.idr view
@@ -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))
test/test013/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test013.idr -o test013 ./test013 rm -f test013 test013.ibc
test/test013/test013.idr view
@@ -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!"
test/test014/Resimp.idr view
@@ -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)
test/test014/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test014.idr -o test014 ./test014 rm -f test014 resimp.ibc test014.ibc
test/test014/test014.idr view
@@ -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")+
test/test015/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test015.idr -o test015 ./test015 rm -f test015 parity.ibc test015.ibc
test/test015/test015.idr view
@@ -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 {
test/test016/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test016.idr -o test016 ./test016 rm -f test016 *.ibc
test/test016/test016.idr view
@@ -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 [] = []
test/test017/expected view
@@ -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
test/test017/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ --check test017.idr idris $@ --check test017a.idr idris $@ --check test017b.idr
test/test017/test017.idr view
@@ -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
test/test018/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test018.idr -o test018 idris $@ test018a.idr -o test018a ./test018
test/test018/test018.idr view
@@ -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
test/test018/test018a.idr view
@@ -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 ()
test/test019/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test019.lidr -o test019 ./test019 rm -f test019 *.ibc
test/test020/expected view
@@ -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"
test/test020/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test020.idr -o test020 idris $@ test020a.idr --check --nocolor ./test020
test/test020/test020.idr view
@@ -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
test/test020/test020a.idr view
@@ -1,6 +1,6 @@ module Main -implicit +implicit forget : Vect n a -> List a forget [] = [] forget (x :: xs) = x :: forget xs
test/test021/expected view
@@ -1,6 +1,4 @@-[HELLO!!!-, WORLD!!!-, ]+["HELLO!!!\n", "WORLD!!!\n", ""] 3 15 Answer: 99
test/test021/run view
@@ -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
test/test021/test021.idr view
@@ -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)
test/test021/test021a.idr view
@@ -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
test/test022/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash echo ":x x" | idris --quiet  test022.idr rm -f test021 test021a *.ibc
test/test023/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris --quiet test023.idr -o test023 rm -f test023 *.ibc
− test/test023/test.idr 
@@ -1,2 +0,0 @@-foo : PrimIO ()-foo = prim__IO ()
test/test024/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris --quiet  test024.idr < input rm -f *.ibc
test/test025/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris -p effects $@ test025.idr -o test025 ./test025 rm -f test025 *.ibc
test/test025/test025.idr view
@@ -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)
test/test026/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris --quiet test026.idr < input rm -f *.ibc
test/test027/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test027.idr -o test027 ./test027 rm -f test027 *.ibc
test/test028/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test028.idr -o test028 ./test028 rm -f test028 test028.ibc
test/test028/test028.idr view
@@ -2,4 +2,4 @@ module Main -- main : IO ()-main = print "hello, world!"+main = putStrLn "hello, world!"
test/test029/run view
@@ -1,3 +1,3 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test029.idr --check test029 rm -f *.ibc
test/test029/test029.idr view
@@ -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
test/test030/Reflect.idr view
@@ -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.
test/test030/expected view
@@ -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
test/test030/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test030.idr --check --nocolour idris $@ test030a.idr --check --nocolour rm -f *.ibc
test/test030/test030.idr view
@@ -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
test/test030/test030a.idr view
@@ -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
test/test031/run view
@@ -1,4 +1,4 @@-#!/bin/bash+#!/usr/bin/env bash idris $@ test031.idr -o test031 ./test031 rm -f test031 *.ibc
+ test/test032/expected view
@@ -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+
+ test/test032/input view
@@ -0,0 +1,5 @@+:cs 11 xs+:cs 17 ys+:ps 21 maprhs+:mw 25 isElem2+:cs 30 p
+ test/test032/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --quiet test032.idr < input+rm -f *.ibc
+ test/test032/test032.idr view
@@ -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+
+ test/test033/expected view
@@ -0,0 +1,1 @@+True
+ test/test033/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ -o test033 test033.idr+./test033+rm -f *.ibc test033
+ test/test033/test033.idr view
@@ -0,0 +1,4 @@+module Main++main : IO ()+main = nullPtr null >>= (putStrLn . show)
+ test/test034/expected view
@@ -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
+ test/test034/run view
@@ -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 <<EOF > $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
tutorial/examples/bmain.idr view
@@ -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)
tutorial/examples/classes.idr view
@@ -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 ]
tutorial/examples/foo.idr view
@@ -6,5 +6,5 @@  namespace y   test : String -> String-  test x = x ++ x +  test x = x ++ x
tutorial/examples/idiom.idr view
@@ -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
tutorial/examples/interp.idr view
@@ -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))
tutorial/examples/wheres.idr view
@@ -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)]