fp2/week2/mart/StdIOMonad.icl

   1 implementation module StdIOMonad
   2
   3 import StdBool
   4 import StdEnum
   5 import StdFile
   6 import StdList
   7 import StdMaybe
   8 import StdMisc
   9 import StdMonad
  10 import StdOverloaded
  11 import StdString
  12 import StdTuple
  13
  14 :: IO a = IO (*W -> *(a, *W))
  15 :: *W :== *(*World, *[*(Filehandle, *File)])
  16 :: Filemode = Lees | Schrijf
  17 :: Filenaam :== String
  18 :: Filehandle :== String
  19
  20 // Conversion from our filemodes to StdFile filemodes
  21 instance toInt Filemode where
  22         toInt Lees = FReadText
  23         toInt Schrijf = FWriteText
  24
  25 // Apply the monadic program on the world
  26 doIO:: (IO a) *World -> *(a, *W)
  27 doIO (IO f) w = f (w, [])
  28
  29 // Lift the value out of the monadic domain
  30 unIO:: (IO a) -> *W -> *(a, *W)
  31 unIO (IO f) = f
  32
  33 instance return IO where
  34         return x = IO (\w -> (x, w))
  35 instance >>=    IO where
  36         (>>=) (IO f) g = IO (\w = let (a, w1) = f w in unIO (g a) w1)
  37
  38 // Read one line from the console
  39 read:: IO String
  40 read = IO read`
  41         where
  42                 read`:: *W -> *(String, *W)
  43                 read` (world, s)
  44                 # (io, world) = stdio world
  45                 # (line, io) = freadline io
  46                 # (_, world) = fclose io world
  47                 = (line, (world, s))
  48
  49 // Write a line from the console
  50 write           :: String -> IO Void
  51 write s = IO (write` s)
  52         where
  53                 write`:: String *W -> *(Void, *W)
  54                 write` line (world, s)
  55                 # (io, world) = stdio world
  56                 # io = io <<< line
  57                 # (_, world) = fclose io world
  58                 = (Void, (world, s))
  59
  60 // Open a file
  61 open:: Filenaam Filemode -> IO (Maybe Filehandle)
  62 open s m = IO (open` s m)
  63         where
  64                 open`:: String Filemode *W -> *(Maybe Filehandle, *W)
  65                 open` fp m (world, fs)
  66                 | any (\l = fp == fst l) fs = (Nothing, (world, fs))
  67                 # (ok, file, world) = fopen fp (toInt m) world
  68                 = (Just fp, (world, [(fp, file):fs]))
  69
  70 // Close a file. If the file can't be closed by the system the program will
  71 // abort
  72 close:: Filehandle -> IO Bool
  73 close fh = IO (close` fh)
  74         where
  75                 close`:: Filehandle *W -> *(Bool, *W)
  76                 close` fp (world, fs)
  77                 # (currentfiletuple, fs) = getFH fp fs
  78                 | isNothing currentfiletuple = (False, (world, fs))
  79                 # (currentfh, currentfile) = fromJust currentfiletuple
  80                 # (ok, world) = fclose currentfile world
  81                 | not ok = abort "File can't be closed"
  82                 | otherwise = (True, (world, fs))
  83
  84
  85 // Determine if the file is at the end. This will abort when the file is not
  86 // open or error if the file is not opened for reading.
  87 eof                     :: Filehandle -> IO Bool
  88 eof fh = IO (eof` fh)
  89         where
  90                 eof`:: Filehandle *W -> *(Bool, *W)
  91                 eof` fp (world, fs)
  92                 # (currentfiletuple, fs) = getFH fp fs
  93                 | isNothing currentfiletuple = abort "Can't do eof on non-existing file"
  94                 # (currentfh, currentfile) = fromJust currentfiletuple
  95                 # (ok, file) = fend currentfile
  96                 = (ok, (world, [(currentfh, file):fs]))
  97
  98 // Read one line from a file (including newline). This will abort when the file
  99 // is not open or error if the file is not opened for reading.
 100 readline        :: Filehandle -> IO (Maybe String)
 101 readline fh = IO (readline` fh)
 102         where
 103                 readline` :: Filehandle *W -> *(Maybe String, *W)
 104                 readline` fh (world, fs)
 105                 # (currentfiletuple, fs) = getFH fh fs
 106                 | isNothing currentfiletuple = abort "File not open"
 107                 # (currentfh, currentfile) = fromJust currentfiletuple
 108                 # (s, currentfile) = freadline currentfile
 109                 = (Just s, (world, [(currentfh, currentfile):fs]))
 110
 111 // Write one line from a file (will not append newline). This will abort when
 112 // the file is not open or error if the file is not opened for writing.
 113 writeline       :: String Filehandle -> IO Bool
 114 writeline s fh = IO (writeline` s fh)
 115         where
 116                 writeline` :: String Filehandle *W -> *(Bool, *W)
 117                 writeline` s fh (world, fs)
 118                 # (currentfiletuple, fs) = getFH fh fs
 119                 | isNothing currentfiletuple = abort "File not open"
 120                 # (currentfh, currentfile) = fromJust currentfiletuple
 121                 # currentfile = fwrites s currentfile
 122                 = (True, (world, [(currentfh, currentfile):fs]))
 123
 124 // Gets the file associated with the filehandle given, this is done in a very
 125 // ugly way to retain uniqueness...
 126 getFH:: Filehandle *[*(Filehandle, *File)] ->
 127         (Maybe *(Filehandle, *File), *[*(Filehandle, *File)])
 128 getFH fh fs
 129 # (fhs, fis) = unzip fs
 130 # fhsC = zip2 [0..length fhs] fhs
 131 # index = [(i, h) \\ (i, h) <- fhsC | h == fh]
 132 | length index == 0 = (Nothing, zip2 fhs fis)
 133 # index = fst (hd index)
 134 # (fis1, fis2) = splitAt index fis
 135 # (fhs1, fhs2) = splitAt index fhs
 136 # (thefile, fis2) = splitAt 1 fis2
 137 # (thehandle, fhs2) = splitAt 1 fhs2
 138 = (Just (hd thehandle, hd thefile), zip2 (fhs1 ++ fhs2) (fis1 ++ fis2))