helium-1.8: lib/LvmIO.core

----------------------------------------------------------------
-- Daan Leijen (c) 2001
--
-- $Revision: 285 $
-- $Author: uust $
-- $Date: 2004-02-14 15:46:23 +0100 (Sat, 14 Feb 2004) $
----------------------------------------------------------------
module LvmIO( Input, Output, Channel, Descriptor
            , stdin, stdout, stderr
            , flush, close
            , outputChar, outputPacked, outputString
            , inputChar
            , CreateMode(..), openInputFile, openOutputFile
            ) where

import LvmLang( primIO, packedLength, packedFromString, bindIO, unsafePerformStrictIO, False, True )

{----------------------------------------------------------
  Primitive I/O operations
----------------------------------------------------------}
extern prim_open            :: "IzII"
extern prim_close           :: "vI"
extern prim_flag_mask       :: "II"
extern prim_input_flags     :: "II"
extern prim_output_flags    :: "III"

extern prim_open_descriptor :: "aIb"
extern prim_close_channel   :: "va"
extern prim_set_binary_mode :: "vab"
extern prim_flush_partial   :: "ba"
extern prim_flush           :: "va"
extern prim_output_char     :: "vac"
extern prim_output          :: "vazll"
extern prim_input_char      :: "Ia"


{----------------------------------------------------------
  Channels
----------------------------------------------------------}
data Input
data Output
data Channel a
type Descriptor   = Int


{----------------------------------------------------------
  Private helpers
----------------------------------------------------------}
primOpenInputDescriptor :: Descriptor -> Channel Input
primOpenInputDescriptor fd
  = let! fd = fd in prim_open_descriptor fd False

primOpenOutputDescriptor :: Descriptor -> Channel Output
primOpenOutputDescriptor fd
  = let! fd = fd in prim_open_descriptor fd True


{----------------------------------------------------------
  Files
----------------------------------------------------------}
data CreateMode
  = CreateNever       -- don't create a new file, and append writes
  | CreateIfNotExists -- create one if none exists yet, append otherwise
  | CreateExclusive   -- create if none exists, but fail if a file exists
  | CreateOverwrite   -- destroy previous file, and create a new one

{----------------------------------------------------------
  Private file operations
----------------------------------------------------------}
data OpenFlag
  = OpenReadOnly
  | OpenWriteOnly
  | OpenCreate
  | OpenTruncate
  | OpenExclusive
  | OpenBinary
  | OpenText
  | OpenNonBlocking

primOpenInputFile :: FilePath -> Bool -> Channel Input
primOpenInputFile fpath asText
  = let! b     = asText
         m     = prim_input_flags b
         fname = packedFromString fpath
         fd    = prim_open fname m 0o744                         
    in primOpenInputDescriptor fd

primOpenOutputFile :: FilePath -> Bool -> CreateMode -> Channel Output
primOpenOutputFile fpath asText cmode
  = let! b     = asText
         c     = cmode
         m     = prim_output_flags b c
         fname = packedFromString fpath
         fd    = prim_open fname m 0o744
    in primOpenOutputDescriptor fd


{----------------------------------------------------------
  Channel I/O, based on the OCaml interface
----------------------------------------------------------}
stdin :: Channel Input
stdin
  = primOpenInputDescriptor 0

stdout :: Channel Output
stdout
  = primOpenOutputDescriptor 1

stderr :: Channel Output
stderr
  = primOpenOutputDescriptor 2

openInputFile :: FilePath -> Bool -> IO (Channel Input)
openInputFile fpath asText
  = let action _ = primOpenInputFile fpath asText
    in primIO action

openOutputFile :: FilePath -> Bool -> CreateMode -> IO (Channel Output)
openOutputFile fpath asText createMode
  = let action _ = primOpenOutputFile fpath asText createMode
    in primIO action

{--------------------------------------------------------------------------
  Channel operations  
--------------------------------------------------------------------------}
flush :: Channel Output -> IO ()
flush out
  = let action _ = (let! out = out in prim_flush out) 
    in primIO action

close :: Channel a -> IO ()
close chan
  = let action _ = (let! chan = chan in prim_close_channel chan) 
    in primIO action

outputChar :: Channel Output -> Char -> IO ()
outputChar out c
  = let action _ = let! out = out
                        c   = c
                   in prim_output_char out c 
    in primIO action

inputChar :: Channel Input -> IO Char
inputChar inp
  = let action _ = let! inp = inp in prim_input_char inp 
    in primIO action


outputPacked :: Channel Output -> PackedString -> IO ()
outputPacked chan s
  = let action _ = let! chan = chan
                        s    = s
                        len  = packedLength s 
                   in prim_output chan s 0 len 
    in primIO action

-- TODO: use direct I/O primitive for strings
outputString :: Channel Output -> String -> IO ()
outputString chan s
  = outputPacked chan (packedFromString s)