;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.
;;;;======================================================================
;;;;  System Interface
;;;;======================================================================
;;;;  Basic routines for manipulating the operating system and file
;;;;  system.  For inspiration as to what should go in here, consider the
;;;;  Dylan 'system' library or the less complicated parts of Common
;;;;  LISP.

(use goo)
(use goo/cols/str)
(use goo/boot)     ; Need filesystem primitives.
(use goo/io/port)  ; File-copy
(use goo/%system.c)

;;;;=======================================================================
;;;;  Time Interface
;;;;=======================================================================

(dl %time)

(df time () (%ib (%time)))

(export time)

;;;;=======================================================================
;;;;  Operating System Interface
;;;;=======================================================================

(dl %os-name)
(dl %os-val)
(dl %os-val-setter)

;;; Return the name of the operating system in use.
(dm os-name (=> <str>)
  (%sb (%os-name)))


;;; Get the value of an environment variable, or the local equivalent.
(dm os-val (s|<str> => <str>)
  (%sb (%os-val (%su s))))

;;; Set the value of an environment variable, or the local equivalent.
(dm os-val-setter (v|<str> s|<str> => <str>)
  (set (%os-val (%su s)) (%su v))
  v)

(export
  os-name
  os-val
  os-val-setter)

;;;;=======================================================================
;;;;  Process Support
;;;;=======================================================================

(dl %pid)

(dm process-id ()
  (%ib (%pid)))

(export
  process-id)

;;;;=======================================================================
;;;;  Basic Filename Support
;;;;=======================================================================
;;;;  This is a really whimpy, simple cousin of Common LISP's pathnames
;;;;  and Dylan's locators.

(dv *path-separator*
  (cond
    ((= (os-name) "linux") "/")
    ((= (os-name) "win32") "\\")
    (#t                    "/")))

(dm base-path (filename|<str> => <str>)
  (rep loop ((i (- (len filename) 1)))
    (if (< i 0)
        ""
        (if (= (elt filename i) (elt *path-separator* 0))
            (sub filename 0 (+ i 1))
            (loop (- i 1))))))

;;; should be using pathname functions below
(dm fab-path (dirs|... => <str>)
  (join dirs *path-separator*))

(dl %default-goo-root)

(dv *goo-root*
  (let ((env-root (os-val "GOO_ROOT")))
    (if (nul? env-root)
        (%sb (%default-goo-root))
        env-root)))

(dv *goo-personal-root* (fab-path (os-val "HOME") ".goo"))

(dv *module-search-path*
  (lst "" ; absolute path
       (fab-path *goo-personal-root* "mods")
       (fab-path *goo-root* "local" "mods")
       (fab-path *goo-root* "mods")))

(dv *goo-build-root*
  (let ((env-root (os-val "GOO_BUILD_ROOT")))
    (if (nul? env-root)
        "."
        env-root)))

(dm add-src-path (relpath => <str>)
  (fab-path *goo-build-root* "src" relpath))

(dm add-goo-root-path (relpath => <str>)
  (fab-path *goo-root* relpath))

(dm add-goo-personal-root-path (relpath => <str>)
  (fab-path *goo-personal-root* relpath))

;; TODO: GET THIS RIGHT ON WIN32
(dm add-tmp-path (relpath => <str>)
  (fab-path "" "tmp" relpath))

(dm add-build-path (builddir relpath => <str>)
  (fab-path *goo-build-root* "c" builddir relpath))

(dv *goo-extension*  ".goo")
(dv *gooc-extension* ".gooc")
(dv *c-extension*    ".c")
(dv *obj-extension*  ".o")
(dv *exe-extension*  "")

(df goo-filename? (name|<str> => <log>)
  (suffix? name *goo-extension*))

(df goo-filename (name|<str> => <str>)
  (if (goo-filename? name) name (cat name *goo-extension*)))

(df gooc-filename? (name|<str> => <log>)
  (suffix? name *gooc-extension*))

(df gooc-filename (name|<str> => <str>)
  (if (gooc-filename? name) name (cat name *gooc-extension*)))

(df c-filename (name|<str> => <str>)
  (cat name *c-extension*))

(df obj-filename (name|<str> => <str>)
  (cat name *obj-extension*))

(df exe-filename (name|<str> => <str>)
  (cat name *exe-extension*))

(export
  *path-separator*
  *goo-root*
  *goo-personal-root*
  *module-search-path*
  *goo-build-root*
  
  add-src-path
  add-build-path
  add-tmp-path
  add-goo-root-path
  add-goo-personal-root-path
  
  *goo-extension*
  *c-extension*
  *obj-extension*
  *exe-extension*

  c-filename
  goo-filename
  gooc-filename
  exe-filename
  obj-filename
  )


;;;;=======================================================================
;;;;  Low-level Filesystem Functions
;;;;=======================================================================
;;;;  These functions all rely on C primitives in prt.c.

(dl %file-mtime)
(dl %file-type)
(dl %file-exists?)

;;; Return the last modification time of a file in seconds (relative to the
;;; Goo epoch) as a floating point number.
(dm file-mtime (filename|<str> => <flo>)
  (%fb (%file-mtime (%su filename))))

;;; Return true if and only if a file (or a directory, etc.) exists with
;;; the given name.
(df file-exists? (filename|<str> => <log>)
  (%file-exists? (%su filename)))

;;; Return 'file, 'directory or some other symbol, depending on the type
;;; of the file.
(df file-type (filename|<str> => <sym>)
  (%file-type (%su filename)))

;;; Create a directory with the given name.  The parent directory must
;;; already exist, and must contain no item with the given name.
(dl %create-directory)

(df create-directory (filename|<str>)
  (%create-directory (%su filename)))

(dm file-copy (src|<str> dst|<str>)
  (with-port (src-port (open <file-in-port> src))
  (with-port (dst-port (open <file-out-port> dst))
    (rep loop ()
      (let ((c (get src-port)))
        (unless (eof-object? c)
          (put dst-port c)
          (loop)))))))

(dl %compile)
(dl %load)

(df so-load (name)
  (%load (%su name)))  

(export
  file-mtime
  file-exists?
  file-type
  file-copy
  create-directory
  so-load
  %load
  %compile
  )


;;;;=======================================================================
;;;;  Pathname Component Functions
;;;;=======================================================================
;;;;  Slightly *less* whimpy versions of Common LISP pathnames and
;;;;  Dylan locators.  These allow you to work with hierarchical,
;;;;  structured pathnames in a reasonably portable fashion.

;;; Given a pathname, split it into a list of individual directories, etc.
;;; Three special values are returned as symbols:
;;;   root -> This path starts in the root directory
;;;   up -> Go up a directory
;;;   current -> Remain in the current directory
;;; Volume labels, drive letters, and other non-path information should
;;; be stored in a single tagged list at the head.  For example:
;;;   C:\a\c.txt -> ((drive "C:") root "a" "c.txt")
;;; 
;;; Note that the hierarchical portion of this pathname (everything but the
;;; label) must be non-nul at all times.
;;;
;;; Please port this code to other platforms as needed.
;;; TODO - Unix version should handle '//' in the middle of pathnames
;;; by reducing it to a single slash, as does the kernel.
(dc <pathname-error> (<simple-error>))

(df pathname-error (msg|<str> args|...)
  (sig (new <pathname-error> 
         condition-message msg condition-arguments (as <lst> args))))

(df pathname-to-components (pathname|<str> => <lst>)
  (when (nul? pathname)
    (pathname-error "Can't convert nul an pathname to components."))
  (when (== (last pathname) (elt *path-separator* 0))
    (set pathname (sub pathname 0 (- (len pathname) 1))))
  (map (fun (component)
         (cond
           ((= component "") 'root)
           ((= component "..") 'up)
           ((= component ".") 'current)
           (#t component)))
       (split pathname (elt *path-separator* 0))))

;;; Reassemble components created by the above function.
(df components-to-pathname (components|<lst> => <str>)
  (when (nul? components)
    (pathname-error "Can't convert nul components to a pathname."))
  (join (map (fun (component)
               (cond
                 ((== component 'root)    "")
                 ((== component 'up)      "..")
                 ((== component 'current) ".")
                 (#t                      component)))
             components)
        *path-separator*))

;;; Get any leading directory label.
(df label-components (components|<lst> => <lst>)
  (if (isa? (head components) <lst>)
      (lst (head components))
      '()))

;;; Get rid of any leading directory label, etc.
(df hierarchical-components (components|<lst> => <lst>)
  (def result (if (isa? (head components) <lst>)
                  (tail components)
                  components))
  (when (nul? result)
    (pathname-error "Hierarchical portion of %= must not be nul." components))
  result)

;;; Return the last item in a list of components.
(df components-last (components|<lst> => <any>)
  (def last (elt components (- (len components) 1)))
  (when (isa? last <lst>)
    (pathname-error "No filename in %=." components))
  last)

;;; Return all but the last item of a bunch of components.
;;; Do some magic to handle cases like 'foo.txt' => './'
;;; If you call this function enough times, you are eventually
;;; guaranteed to get components list ending in root, up or current.
;;; Requires the last item to be a string.
(df components-basename (components|<lst> => <lst>)
  (def label (label-components components))
  (def hier  (hierarchical-components components))
  (def count (len hier))
  (def last  (components-last hier))
  (unless (isa? last <str>)
    (pathname-error "Can't compute basename of %=." components))
  (if (== count 1)
      (cat label '(current))
      (cat label (sub hier 0 (- count 1)))))

;;; Calculate the parent directory of a pathname.
(df components-parent-directory (components|<lst> => <lst>)
  (def last (components-last components))
  (cond
    ((isa? last <str>) 
     (components-basename components))
    ((== last 'root)
     (pathname-error "Can't calculate parent of root directory."))
    (#t 
     (cat components '(up)))))

(export
  <pathname-error>
  pathname-to-components
  components-to-pathname
  label-components
  hierarchical-components
  components-last
  components-basename
  components-parent-directory)


;;;;=======================================================================
;;;;  High-level Functions
;;;;=======================================================================
;;;;  These operate directly on filenames.

;;; Find the parent directory of the current filename.
(df parent-directory (name|<str> => <str>)
  (def components (pathname-to-components name))
  (components-to-pathname (components-parent-directory components)))

(dc <directory-error> (<file-opening-error> <simple-error>))

(df directory-error (msg|<str> name|<str>)
  (sig (new <directory-error>
         file-opening-error-filename name
         condition-message           msg
         condition-arguments         (lst name))))

;;; Make sure that the named directory exists.
(df probe-directory (name|<str>)
  (def components (pathname-to-components name))
  (def label      (label-components components))
  (def hier       (hierarchical-components components))
  (rep ensure ((c hier))
    (def n (components-to-pathname (cat label c)))
    (cond
      ((file-exists? n)
       (unless (== (file-type n) 'directory)
         (directory-error "%s is not a directory.\n" n)))
      ((isa? (components-last c) <str>)
       (ensure (components-basename c))
       (create-directory n))
      (#t
       (directory-error "Don't know how to create the directory %s.\n" n))))
  #f)

(export
  <directory-error>
  parent-directory
  probe-directory)

(df find-goo-file-at (fname|<str> path|<str> => (t? <str>))
  (def base-file  (fab-path path fname))
  (def goo-file   (goo-filename base-file))
  (def gooc-file  (gooc-filename base-file))
  (def goo-found  (file-exists? goo-file))
  (def gooc-found (file-exists? gooc-file))
  (cond ((and (goo-filename? base-file) goo-found)
         goo-file)
        ((and (gooc-filename? base-file) gooc-found)
         gooc-file)
        ((and goo-found gooc-found)
         (if (> (file-mtime goo-file) (file-mtime gooc-file))
             goo-file
             gooc-file))
        (gooc-found gooc-file)
        (goo-found  goo-file)
        (#t         #f)))

(df find-goo-file-in-path (fname|<str> search-paths|<col> => (t? <str>))
  (esc return
    (for ((path search-paths))
      (def file (find-goo-file-at fname path))
      (when file (return file)))
    #f))

(export find-goo-file-at find-goo-file-in-path)
