From 2d1d7be949d7e4239c8c922b398b25ff263c5582 Mon Sep 17 00:00:00 2001 From: Edwin Brady Date: Wed, 13 May 2020 00:08:48 +0100 Subject: [PATCH] Move directory code to C ...and remove the scheme support for it on the way --- libs/base/System/Directory.idr | 73 +++++++++++++++++++++------------- support/c/Makefile | 4 +- support/c/idris_directory.c | 63 +++++++++++++++++++++++++++++ support/c/idris_directory.h | 11 +++++ support/chez/support.ss | 40 ------------------- support/gambit/support.scm | 23 ----------- support/racket/support.rkt | 27 ------------- 7 files changed, 123 insertions(+), 118 deletions(-) create mode 100644 support/c/idris_directory.c create mode 100644 support/c/idris_directory.h diff --git a/libs/base/System/Directory.idr b/libs/base/System/Directory.idr index 67aa4b4..8981659 100644 --- a/libs/base/System/Directory.idr +++ b/libs/base/System/Directory.idr @@ -3,37 +3,46 @@ module System.Directory import public System.File public export -data DirPtr : Type where +DirPtr : Type +DirPtr = AnyPtr -toFileError : Int -> FileError -toFileError 1 = FileReadError -toFileError 2 = FileWriteError -toFileError 3 = FileNotFound -toFileError 4 = PermissionDenied -toFileError 5 = FileExists -toFileError x = GenericFileError (x - 256) +support : String -> String +support fn = "C:" ++ fn ++ ", libidris2_support" -fpure : Either Int a -> IO (Either FileError a) -fpure (Left err) = pure (Left (toFileError err)) -fpure (Right x) = pure (Right x) +%foreign support "idris2_fileErrno" +prim_fileErrno : PrimIO Int -%foreign "scheme:blodwen-current-directory" -prim_currentDir : PrimIO String +returnError : IO (Either FileError a) +returnError + = do err <- primIO prim_fileErrno + case err of + 0 => pure $ Left FileReadError + 1 => pure $ Left FileWriteError + 2 => pure $ Left FileNotFound + 3 => pure $ Left PermissionDenied + 4 => pure $ Left FileExists + _ => pure $ Left (GenericFileError (err-5)) -%foreign "scheme:blodwen-change-directory" +ok : a -> IO (Either FileError a) +ok x = pure (Right x) + +%foreign support "idris2_currentDirectory" +prim_currentDir : PrimIO (Ptr String) + +%foreign support "idris2_changeDir" prim_changeDir : String -> PrimIO Int -%foreign "scheme:blodwen-create-directory" -prim_createDir : String -> PrimIO (Either Int ()) +%foreign support "idris2_createDir" +prim_createDir : String -> PrimIO Int -%foreign "scheme:blodwen-open-directory" -prim_openDir : String -> PrimIO (Either Int DirPtr) +%foreign support "idris2_dirOpen" +prim_openDir : String -> PrimIO DirPtr -%foreign "scheme:blodwen-close-directory" +%foreign support "idris2_dirClose" prim_closeDir : DirPtr -> PrimIO () -%foreign "scheme:blodwen-next-dir-entry" -prim_dirEntry : DirPtr -> PrimIO (Either Int String) +%foreign support "idris2_nextDirEntry" +prim_dirEntry : DirPtr -> PrimIO (Ptr String) export data Directory : Type where @@ -42,8 +51,10 @@ data Directory : Type where export createDir : String -> IO (Either FileError ()) createDir dir - = do ok <- primIO (prim_createDir dir) - fpure ok + = do res <- primIO (prim_createDir dir) + if res == 0 + then ok () + else returnError export changeDir : String -> IO Bool @@ -52,14 +63,20 @@ changeDir dir pure (ok /= 0) export -currentDir : IO String -currentDir = primIO prim_currentDir +currentDir : IO (Maybe String) +currentDir + = do res <- primIO prim_currentDir + if prim__nullPtr res /= 0 + then pure Nothing + else pure (Just (prim__getString res)) export dirOpen : String -> IO (Either FileError Directory) dirOpen d = do res <- primIO (prim_openDir d) - fpure (map MkDir res) + if prim__nullAnyPtr res /= 0 + then returnError + else ok (MkDir res) export dirClose : Directory -> IO () @@ -69,4 +86,6 @@ export dirEntry : Directory -> IO (Either FileError String) dirEntry (MkDir d) = do res <- primIO (prim_dirEntry d) - fpure res + if prim__nullPtr res /= 0 + then returnError + else ok (prim__getString res) diff --git a/support/c/Makefile b/support/c/Makefile index 3aa17d0..e67630b 100644 --- a/support/c/Makefile +++ b/support/c/Makefile @@ -3,7 +3,9 @@ DYLIBTARGET = libidris2_support.so .PHONY: build clean install -OBJS = getline.o idris_buffer.o idris_file.o idris_support.o +OBJS = getline.o idris_buffer.o idris_directory.o idris_file.o \ + idris_support.o + CFLAGS := -fPIC -O2 ${CFLAGS} build : $(LIBTARGET) $(DYLIBTARGET) diff --git a/support/c/idris_directory.c b/support/c/idris_directory.c new file mode 100644 index 0000000..3ed25d9 --- /dev/null +++ b/support/c/idris_directory.c @@ -0,0 +1,63 @@ +#include "idris_directory.h" + +#include +#include +#include +#include +#include + +char* idris2_currentDirectory() { + char cwd[1024]; // probably ought to deal with the unlikely event of this being too small + return getcwd(cwd, sizeof(cwd)); // freed by RTS +} + +int idris2_changeDir(char* dir) { + return chdir(dir); +} + +int idris2_createDir(char* dir) { +#ifdef _WIN32 + return mkdir(dir); +#else + return mkdir(dir, S_IRWXU | S_IRGRP | S_IROTH); +#endif +} + +typedef struct { + DIR* dirptr; + int error; +} DirInfo; + +void* idris2_dirOpen(char* dir) { + DIR *d = opendir(dir); + if (d == NULL) { + return NULL; + } else { + DirInfo* di = malloc(sizeof(DirInfo)); + di->dirptr = d; + di->error = 0; + + return (void*)di; + } +} + +void idris2_dirClose(void* d) { + DirInfo* di = (DirInfo*)d; + + closedir(di->dirptr); + free(di); +} + +char* idris2_nextDirEntry(void* d) { + DirInfo* di = (DirInfo*)d; + struct dirent* de = readdir(di->dirptr); + + if (de == NULL) { + di->error = -1; + return NULL; + } else { + return de->d_name; + } +} + + diff --git a/support/c/idris_directory.h b/support/c/idris_directory.h new file mode 100644 index 0000000..2c707b2 --- /dev/null +++ b/support/c/idris_directory.h @@ -0,0 +1,11 @@ +#ifndef __IDRIS_DIRECTORY_H +#define __IDRIS_DIRECTORY_H + +char* idris2_currentDirectory(); +int idris2_changeDir(char* dir); +int idris2_createDir(char* dir); +void* idris2_dirOpen(char* dir); +void idris2_dirClose(void* d); +char* idris2_nextDirEntry(void* d); + +#endif diff --git a/support/chez/support.ss b/support/chez/support.ss index de28a12..244be62 100644 --- a/support/chez/support.ss +++ b/support/chez/support.ss @@ -73,46 +73,6 @@ chr)) void)) -;; Directories - -(define (blodwen-error-code x) - (cond - ((i/o-read-error? x) 1) - ((i/o-write-error? x) 2) - ((i/o-file-does-not-exist-error? x) 3) - ((i/o-file-protection-error? x) 4) - (else 255))) - -(define (blodwen-file-op op) - (guard - (x ((i/o-error? x) (either-left (blodwen-error-code x)))) - (either-right (op)))) - -(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))) - -; Scheme only gives a primitive for reading all the files in a directory, -; so this is faking the C interface! -(define (blodwen-open-directory dir) - (blodwen-file-op (lambda () (box (directory-list dir))))) - -(define (blodwen-close-directory dir) '()) ; no-op, it's not really open - -(define (blodwen-next-dir-entry dir) - (let [(dlist (unbox dir))] - (if (null? dlist) - (either-left 255) - (begin (set-box! dir (cdr dlist)) - (either-right (car dlist)))))) - ;; Threads (define blodwen-thread-data (make-thread-parameter #f)) diff --git a/support/gambit/support.scm b/support/gambit/support.scm index a088233..2f28148 100644 --- a/support/gambit/support.scm +++ b/support/gambit/support.scm @@ -81,29 +81,6 @@ (if (eof-object? chr) #\null chr)) #\null)) -;; Directories - -(define blodwen-current-directory current-directory) - -(define (blodwen-change-directory dir) - (with-exception-catcher - (lambda (e) 0) - (lambda () (current-directory dir) 1))) - -(define (blodwen-create-directory dir) - (blodwen-file-op (lambda () (create-directory dir) 0))) - -(define (blodwen-open-directory dir) - (blodwen-file-op (lambda () (open-directory dir)))) - -(define blodwen-close-directory close-input-port) - -(define (blodwen-next-dir-entry dir) - (let ((e (read dir))) - (if (eof-object? e) - (either-left 255) - (either-right e)))) - ;; Threads (define (blodwen-thread p) diff --git a/support/racket/support.rkt b/support/racket/support.rkt index 2175741..d7f7a99 100644 --- a/support/racket/support.rkt +++ b/support/racket/support.rkt @@ -70,33 +70,6 @@ chr)) void)) -;; 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)))) - -; Scheme only gives a primitive for reading all the files in a directory, -; so this is faking the C interface! -(define (blodwen-open-directory dir) - (blodwen-file-op (lambda () (box (directory-list dir))))) - -(define (blodwen-close-directory dir) '()) ; no-op, it's not really open - -(define (blodwen-next-dir-entry dir) - (let [(dlist (unbox dir))] - (if (null? dlist) - (either-left 255) - (begin (set-box! dir (cdr dlist)) - (either-right (path->string (car dlist))))))) - ;; Threads (define blodwen-thread-data (make-thread-cell #f))