From 82278597609146bd4e70a5a88095793391ee8c10 Mon Sep 17 00:00:00 2001
From: Edwin Brady <ecb10@st-andrews.ac.uk>
Date: Sat, 1 Feb 2020 18:43:28 +0000
Subject: [PATCH] Add System.Directory

Currently supports creating and changing directories. Support for
reading contents of directories still missing.
---
 libs/base/System/Directory.idr | 58 +++++++++++++---------------------
 libs/base/base.ipkg            |  1 +
 support/chez/support.ss        | 15 ++++++++-
 support/racket/support.rkt     | 13 ++++++++
 4 files changed, 50 insertions(+), 37 deletions(-)

diff --git a/libs/base/System/Directory.idr b/libs/base/System/Directory.idr
index b0e71a4..4589b45 100644
--- a/libs/base/System/Directory.idr
+++ b/libs/base/System/Directory.idr
@@ -2,52 +2,38 @@ module System.Directory
 
 import public System.File
 
-public export
-data Directory : Type where
-  DHandle : (p : AnyPtr) -> Directory
+toFileError : Int -> FileError
+toFileError 1 = FileReadError
+toFileError 2 = FileWriteError
+toFileError 3 = FileNotFound
+toFileError 4 = PermissionDenied
+toFileError x = GenericFileError (x - 256)
 
-export
-dirOpen : (d : String) -> IO (Either FileError Directory)
--- dirOpen d
---     = do dptr <- foreign FFI_C "idris_dirOpen" (String -> IO Ptr) d
---          if !(nullPtr dptr)
---             then Left <$> getFileError
---             else pure (Right (DHandle dptr))
+fpure : Either Int a -> IO (Either FileError a)
+fpure (Left err) = pure (Left (toFileError err))
+fpure (Right x) = pure (Right x)
 
-export
-dirClose : Directory -> IO ()
--- dirClose (DHandle d) = foreign FFI_C "idris_dirClose" (Ptr -> IO ()) d
+%foreign "scheme:blodwen-current-directory"
+prim_currentDir : PrimIO String
 
-export
-dirError : Directory -> IO Bool
--- dirError (DHandle d)
---     = do err <- foreign FFI_C "idris_dirError" (Ptr -> IO Int) d
---          pure (err /= 0)
+%foreign "scheme:blodwen-change-directory"
+prim_changeDir : String -> PrimIO Int
 
-export
-dirEntry : Directory -> IO (Either FileError String)
--- dirEntry (DHandle d)
---     = do fn <- foreign FFI_C "idris_nextDirEntry" (Ptr -> IO String) d
---          if !(dirError (DHandle d))
---             then pure (Left FileReadError)
---             else pure (Right fn)
+%foreign "scheme:blodwen-create-directory"
+prim_createDir : String -> PrimIO (Either Int ())
 
 export
 createDir : String -> IO (Either FileError ())
--- createDir d
---     = do ok <- foreign FFI_C "idris_mkdir" (String -> IO Int) d
---          if (ok == 0)
---             then pure (Right ())
---             else Left <$> getFileError
+createDir dir
+    = do ok <- primIO (prim_createDir dir)
+         fpure ok
 
 export
 changeDir : String -> IO Bool
--- changeDir dir 
---     = do ok <- foreign FFI_C "idris_chdir" (String -> IO Int) dir
---          pure (ok == 0)
+changeDir dir
+    = do ok <- primIO (prim_changeDir dir)
+         pure (ok /= 0)
 
 export
 currentDir : IO String
--- currentDir = do
---   MkRaw s <- foreign FFI_C "idris_currentDir" (IO (Raw String))
---   pure s
+currentDir = primIO prim_currentDir
diff --git a/libs/base/base.ipkg b/libs/base/base.ipkg
index 2fc7313..b578f4d 100644
--- a/libs/base/base.ipkg
+++ b/libs/base/base.ipkg
@@ -33,6 +33,7 @@ modules = Control.Monad.Identity,
 
           System,
           System.Concurrency.Raw,
+          System.Directory,
           System.File,
           System.Info,
           System.REPL
diff --git a/support/chez/support.ss b/support/chez/support.ss
index 5384220..2040317 100644
--- a/support/chez/support.ss
+++ b/support/chez/support.ss
@@ -117,7 +117,7 @@
         ((i/o-write-error? x) 2)
         ((i/o-file-does-not-exist-error? x) 3)
         ((i/o-file-protection-error? x) 4)
-        (else (+ x 256))))
+        (else 255)))
 
 ;; If the file operation raises an error, catch it and return an appropriate
 ;; error code
@@ -164,6 +164,19 @@
         1
         0))
 
+;; Directories
+
+(define (blodwen-current-directory)
+  (current-directory))
+
+(define (blodwen-change-directory dir)
+  (if (file-directory? dir)
+      (begin (current-directory dir) 1)
+      0))
+
+(define (blodwen-create-directory dir)
+  (blodwen-file-op (lambda () (mkdir dir) 0)))
+
 ;; Threads
 
 (define blodwen-thread-data (make-thread-parameter #f))
diff --git a/support/racket/support.rkt b/support/racket/support.rkt
index fb36e3e..c77cbb0 100644
--- a/support/racket/support.rkt
+++ b/support/racket/support.rkt
@@ -169,6 +169,19 @@
       1
       0))
 
+;; Directories
+
+(define (blodwen-current-directory)
+  (path->string (current-directory)))
+
+(define (blodwen-change-directory dir)
+  (if (directory-exists? dir)
+      (begin (current-directory dir) 1)
+      0))
+
+(define (blodwen-create-directory dir)
+  (blodwen-file-op (lambda () (make-directory dir))))
+
 ;; Threads
 
 (define blodwen-thread-data (make-thread-cell #f))