mason.disk: Better handling of free disk space.

- Works if the build directory does not exist, assuming it would be created on the root disk containing the path of the first existing parent directory
- Space calculation is wrong, we should be using the available space
- MB is GB, comment was wrong
- Call find-mount-point-info to get the real disk mount point even if the dir does not exist

basis/io/files/info/info.factor

@@ -34,6 +34,20 @@ HOOK: file-readable? os ( path -- ? )
 HOOK: file-writable? os ( path -- ? )
 HOOK: file-executable? os ( path -- ? )
 
+: mount-points ( -- assoc )
+    file-systems [ [ mount-point>> ] keep ] H{ } map>assoc ;
+
+: (find-mount-point-info) ( path assoc -- mtab-entry )
+    [ resolve-symlinks ] dip
+    2dup at* [
+        2nip
+    ] [
+        drop [ parent-directory ] dip (find-mount-point-info)
+    ] if ;
+
+: find-mount-point-info ( path -- file-system-info )
+    mount-points (find-mount-point-info) ;
+
 {
     { [ os unix? ] [ "io.files.info.unix" ] }
     { [ os windows? ] [ "io.files.info.windows" ] }

basis/io/files/info/unix/linux/linux.factor

@@ -81,17 +81,6 @@ frequency pass-number ;
 M: linux file-systems
     parse-mtab [ mtab-entry>file-system-info ] map sift ;
 
-: (find-mount-point) ( path mtab-paths -- mtab-entry )
-    2dup at* [
-        2nip
-    ] [
-        drop [ parent-directory ] dip (find-mount-point)
-    ] if ;
-
-: find-mount-point ( path -- mtab-entry )
-    resolve-symlinks
-    parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
-
 M: linux file-system-info ( path -- file-system-info )
     normalize-path
     [
@@ -100,7 +89,7 @@ M: linux file-system-info ( path -- file-system-info )
         [ file-system-statvfs statvfs>file-system-info ] bi
         file-system-calculations
     ] keep
-    find-mount-point
+    find-mount-point-info
     {
         [ file-system-name>> >>device-name drop ]
         [ mount-point>> >>mount-point drop ]

extra/mason/disk/disk.factor

@@ -1,26 +1,29 @@
-! Copyright (C) 2010 Slava Pestov.
+! Copyright (C) 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.files.info io.pathnames kernel mason.config
-math math.parser namespaces sequences ;
+USING: accessors formatting io.files.info io.pathnames kernel
+mason.config math namespaces ;
 IN: mason.disk
 
-: gb ( -- n ) 30 2^ ; inline
+: Gi ( n -- gibibits ) 30 2^ * ; inline
 
 : sufficient-disk-space? ( -- ? )
-    ! We want at least 300Mb to be available before starting
-    ! a build.
-    "." file-system-info available-space>> gb > ;
+    current-directory get find-mount-point-info
+    file-system-info available-space>>
+    1 Gi > ;
 
 : check-disk-space ( -- )
     sufficient-disk-space? [
-        "Less than 1 Gb free disk space." throw
+        "Less than 1 Gi free disk space." throw
     ] unless ;
 
-: mb-str ( n -- string ) gb /i number>string ;
+: Gi-str ( n -- string ) 1 Gi /f ;
+
+: path>disk-usage ( path -- string )
+    find-mount-point-info
+    [ used-space>> ] [ available-space>> ] [ total-space>> ] tri
+    2dup /f 100 *
+    [ [ Gi-str ] tri@ ] dip
+    "%0.2fGi used, %0.2fGi avail, %0.2fGi total, %0.2f%% free" sprintf ;
 
 : disk-usage ( -- string )
-    builds-dir get file-system-info
-    [ used-space>> ] [ total-space>> ] bi
-    [ [ mb-str ] bi@ " / " glue " Gb used" append ]
-    [ [ 100 * ] dip /i number>string "(" "%)" surround ] 2bi
-    " " glue ;
+    builds-dir get path>disk-usage ;