Allow waiting on data on a file descriptor

Makefile

@@ -209,7 +209,7 @@ runtestgsan: bin/mhsevalsane bin/gmhs
 
 # Run test examples going via JavaScript
 runtestemscripten: bin/mhseval bin/mhs bin/cpphs
-	cd tests; $(MAKE) MHS=../bin/mhs cache; MHSDIR=.. $(MAKE) MHSTARGET="-temscripten" MHS="../bin/mhs -CR -oout.js" EVAL="$(NODE) $(NODEFLAGS) out.js" info test errtest
+	cd tests; $(MAKE) MHS=../bin/mhs cache; MHSDIR=.. $(MAKE) MHSTARGET="-temscripten" MHS="../bin/mhs -CR -oout.js" EVAL="$(NODE) $(NODEFLAGS) out.js" info test errtest testpipenonblockioem
 
 runtestinstemscripten:
 	cd tests; $(MAKE) MHSTARGET="-temscripten" MHS="mhs.js -oout.js" EVAL="$(NODE) $(NODEFLAGS) out.js" test

README.md

@@ -252,63 +252,18 @@ separated list of directories.
 ## Setting the _packageDbPath_
 The default _packageDbPath_ is take from the `mhs.conf` file
 in the section `[mhs]` and key `packageDbPath`.
-
-In case this does not exists the path defaults to `~/.mcabal/mhs-VERSION`,
-where `~` will be replaced by the home directory and `VERSION` is the
-compiler version (as displayed by `mhs --numeric-version`).
+The path can contain environment variables that are expanded.
+In addition $MHSPKG expand to the package directory relative to the executing binary.
+Furthermore $VERSION expands to the mhs version number.
 
 The path can be cleared by using the `-a` command line flag.
 To append to the path use `-aPATH`, where `PATH` is a colon (':')
 separated list if directories.
 
 ## Installing packages
-The default _packageDb_ for installing packages is given by the
-key `packageDbDefaultInstall`.
-If absent, it defaults to `~/.mcabal/mhs-VERSION`.
 
-The _packageDb_ directory can also be given directly with the `-Q`
+The _packageDb_ directory can be given directly with the `-Q`
 flag used to install.
 
 The `mcabal` command can install to a particular package db by using
 `--install=PATH`.
-
-## Examples
-### Status Quo
-All packages go to the same place.
-
-Compile a module with `mhs Foo`.
-
-
-mhs.config:
-```
-[mhs]
-packageDbPath=~/.mcabal/mhs-0.15.5.0
-packageDbDefaultInstall=~/.mcabal/mhs-0.15.5.0
-...
-```
-
-### GhcUp
-Separate system and user package dbs.
-
-Compile a module with `mhs Foo`.
-
-mhs.config:
-```
-[mhs]
-packageDbPath=~/.mcabal/system:~/.mcabal-user
-packageDbDefaultInstall=~/.mcabal-user
-...
-```
-
-### Nix
-A system package db and then a separate db for each package.
-
-Compile a module with `mhs -a%transformers:%mtl Foo`.
-
-```
-[mhs]
-packageDbPath=~/.mcabal/system
-packageDbDefaultInstall=NO_INSTALL_GIVEN
-packageDbPrefix=~/.mcabal-user-dbs
-...
-```

Tools/Install.hs

@@ -11,13 +11,15 @@ import System.Directory
 import System.Environment
 import System.FilePath
 import System.Process
+import System.IO.TimeMilli
 import MicroHs.Config
 
 type CConf = [(Key, Value)]
 
 
 main :: IO ()
 main = do
+  start <- getTimeMilli
   args <- getArgs
   let flags = decodeArgs defaultFlags args
   confText <- macroExpand flags <$> readFile (confFile flags)
@@ -33,6 +35,11 @@ main = do
 
   install flags'
 
+  end <- getTimeMilli
+  let delta = (end - start) `quot` 100
+      (sec, tenths) = delta `quotRem` 10
+  putStrLn $ "Install time: " ++ show sec ++ "." ++ show tenths ++ "s"
+
 install :: Flags -> IO ()
 install flags = do
   instBin flags

lib/Control/Concurrent.hs

@@ -119,11 +119,12 @@ threadStatus thr = do
   st <- primThreadStatus thr
   return $
     case st of
-      0 -> ThreadRunning                 -- ts_runnable
-      1 -> ThreadBlocked BlockedOnMVar   -- ts_wait_mvar
-      2 -> ThreadBlocked BlockedOnOther  -- ts_wait_time
-      3 -> ThreadFinished                -- ts_finished
-      4 -> ThreadDied                    -- ts_died
+      0 -> ThreadRunning                      -- ts_runnable
+      1 -> ThreadBlocked BlockedOnMVar        -- ts_wait_mvar
+      2 -> ThreadBlocked BlockedOnOther       -- ts_wait_time
+      3 -> ThreadFinished                     -- ts_finished
+      4 -> ThreadDied                         -- ts_died
+      5 -> ThreadBlocked BlockedOnForeignCall -- ts_wait_io
 
 -------------------------------------------------------
 -- Just for GHC compatibility.

lib/Foreign/C/Error.hs

@@ -99,6 +99,9 @@ instance Eq Errno where
     | isValidErrno errno1 = no1 == no2
     | otherwise           = False
 
+instance Show Errno where
+  showsPrec p (Errno e) = showsPrec p e
+
 eOK :: Errno
 eOK = Errno 0
 

lib/Primitives.hs

@@ -389,6 +389,12 @@ primTryPutMVar = _primitive "IO.tryputmvar"
 primTryReadMVar :: MVar a -> IO b {-(Maybe a)-}
 primTryReadMVar = _primitive "IO.tryreadmvar"
 
+primWaitWriteFD :: Int -> IO Int
+primWaitWriteFD = _primitive "IO.waitwrfd"
+
+primWaitReadFD :: Int -> IO Int
+primWaitReadFD = _primitive "IO.waitrdfd"
+
 primThreadDelay :: Int -> IO ()
 primThreadDelay = _primitive "IO.threaddelay"
 

lib/System/Directory.hs

@@ -1,27 +1,74 @@
 module System.Directory(
-  removeFile,
-  doesFileExist,
-  doesDirectoryExist,
-  getDirectoryContents,
-  listDirectory,
-  setCurrentDirectory,
-  getCurrentDirectory,
-  withCurrentDirectory,
-  createDirectory,
-  createDirectoryIfMissing,
-  copyFile,
-  getHomeDirectory,
-  getTemporaryDirectory,
-  --
-  Permissions(..),
-  emptyPermissions,
-  setOwnerReadable,
-  setOwnerWritable,
-  setOwnerExecutable,
-  setOwnerSearchable,
-  getPermissions,
-  setPermissions,
-  copyPermissions,
+    createDirectory
+  , createDirectoryIfMissing
+--  , removeDirectory
+--  , removeDirectoryRecursive
+--  , removePathForcibly
+--  , renameDirectory
+  , listDirectory
+  , getDirectoryContents
+  , getCurrentDirectory
+  , setCurrentDirectory
+  , withCurrentDirectory
+
+  , getHomeDirectory
+--  , XdgDirectory(..)
+--  , getXdgDirectory
+--  , XdgDirectoryList(..)
+--  , getXdgDirectoryList
+--  , getAppUserDataDirectory
+--  , getUserDocumentsDirectory
+  , getTemporaryDirectory
+
+--  , getExecSearchPath
+
+  , removeFile
+--  , renameFile
+--  , renamePath
+  , copyFile
+--  , copyFileWithMetadata
+--  , getFileSize
+
+--  , canonicalizePath
+--  , makeAbsolute
+--  , makeRelativeToCurrentDirectory
+
+--  , doesPathExist
+  , doesFileExist
+  , doesDirectoryExist
+
+--  , findExecutable
+--  , findExecutables
+--  , findExecutablesInDirectories
+--  , findFile
+--  , findFiles
+--  , findFileWith
+--  , findFilesWith
+--  , exeExtension
+
+--  , createFileLink
+--  , createDirectoryLink
+--  , removeDirectoryLink
+--  , pathIsSymbolicLink
+--  , getSymbolicLinkTarget
+
+  , Permissions(..)
+  , emptyPermissions
+  , setOwnerReadable
+  , setOwnerWritable
+  , setOwnerExecutable
+  , setOwnerSearchable
+
+  , getPermissions
+  , setPermissions
+  , copyPermissions
+
+--  , getAccessTime
+--  , getModificationTime
+--  , setAccessTime
+--  , setModificationTime
+
+--  , isSymbolicLink
   ) where
 import qualified Prelude(); import MiniPrelude
 import Control.Exception(bracket)
@@ -166,7 +213,6 @@ data Permissions
   , searchable :: Bool
   } deriving (Eq, Ord, Show)
 
-emptyPermissions :: Permissions
 emptyPermissions :: Permissions
 emptyPermissions = Permissions {
                        readable   = False,

lib/System/IO/FD.hs

@@ -0,0 +1,9 @@
+module System.IO.FD (waitForReadFD, waitForWriteFD) where
+
+import Primitives
+
+waitForReadFD :: Int -> IO Int
+waitForReadFD = primWaitReadFD
+
+waitForWriteFD :: Int -> IO Int
+waitForWriteFD = primWaitWriteFD

lib/base.cabal

@@ -190,6 +190,7 @@ library base
         System.Environment
         System.Exit
         System.IO
+        System.IO.FD
         System.IO.Error
         System.IO.MD5
         System.IO.PrintOrRun

src/MicroHs/Translate.hs

@@ -272,6 +272,8 @@ primTable = [
   ("bs2fp", _primitive "bs2fp"),
   ("IO.fork", _primitive "IO.fork"),
   ("IO.thid", _primitive "IO.thid"),
+  ("IO.waitrdfd", _primitive "IO.waitrdfd"),
+  ("IO.waitwrfd", _primitive "IO.waitwrfd"),
   ("thnum", _primitive "thnum"),
   ("IO.throwto", _primitive "IO.throwto"),
   ("IO.yield", _primitive "IO.yield"),