implementation module StdIOMonad

import StdBool
import StdEnum
import StdFile
import StdList
import StdMaybe
import StdMisc
import StdMonad
import StdOverloaded
import StdString
import StdTuple

:: IO a = IO (*W -> *(a, *W))
:: *W :== *(*World, *[*(Filehandle, *File)])
:: Filemode = Lees | Schrijf
:: Filenaam :== String
:: Filehandle :== String

// Conversion from our filemodes to StdFile filemodes
instance toInt Filemode where
	toInt Lees = FReadText
	toInt Schrijf = FWriteText

// Apply the monadic program on the world
doIO:: (IO a) *World -> *(a, *W)
doIO (IO f) w = f (w, [])

// Lift the value out of the monadic domain
unIO:: (IO a) -> *W -> *(a, *W)
unIO (IO f) = f 

instance return IO where
	return x = IO (\w -> (x, w))
instance >>=    IO where
	(>>=) (IO f) g = IO (\w = let (a, w1) = f w in unIO (g a) w1)

// Read one line from the console
read:: IO String
read = IO read`
	where
		read`:: *W -> *(String, *W)
		read` (world, s)
		# (io, world) = stdio world
		# (line, io) = freadline io
		# (_, world) = fclose io world
		= (line, (world, s))

// Write a line from the console
write		:: String -> IO Void
write s = IO (write` s)
	where
		write`:: String *W -> *(Void, *W)
		write` line (world, s)
		# (io, world) = stdio world
		# io = io <<< line
		# (_, world) = fclose io world
		= (Void, (world, s))

// Open a file
open:: Filenaam Filemode -> IO (Maybe Filehandle)
open s m = IO (open` s m)
	where
		open`:: String Filemode *W -> *(Maybe Filehandle, *W)
		open` fp m (world, fs)
		| any (\l = fp == fst l) fs = (Nothing, (world, fs))
		# (ok, file, world) = fopen fp (toInt m) world
		= (Just fp, (world, [(fp, file):fs]))

// Close a file. If the file can't be closed by the system the program will
// abort
close:: Filehandle -> IO Bool
close fh = IO (close` fh)
	where
		close`:: Filehandle *W -> *(Bool, *W)
		close` fp (world, fs)
		# (currentfiletuple, fs) = getFH fp fs
		| isNothing currentfiletuple = (False, (world, fs))
		# (currentfh, currentfile) = fromJust currentfiletuple
		# (ok, world) = fclose currentfile world
		| not ok = abort "File can't be closed"
		| otherwise = (True, (world, fs))
		

// Determine if the file is at the end. This will abort when the file is not
// open or error if the file is not opened for reading.
eof			:: Filehandle -> IO Bool
eof fh = IO (eof` fh)
	where 
		eof`:: Filehandle *W -> *(Bool, *W)
		eof` fp (world, fs)
		# (currentfiletuple, fs) = getFH fp fs
		| isNothing currentfiletuple = abort "Can't do eof on non-existing file"
		# (currentfh, currentfile) = fromJust currentfiletuple
		# (ok, file) = fend currentfile
		= (ok, (world, [(currentfh, file):fs]))

// Read one line from a file (including newline). This will abort when the file
// is not open or error if the file is not opened for reading.
readline	:: Filehandle -> IO (Maybe String)
readline fh = IO (readline` fh)
	where
		readline` :: Filehandle *W -> *(Maybe String, *W)
		readline` fh (world, fs)
		# (currentfiletuple, fs) = getFH fh fs
		| isNothing currentfiletuple = abort "File not open"
		# (currentfh, currentfile) = fromJust currentfiletuple
		# (s, currentfile) = freadline currentfile
		= (Just s, (world, [(currentfh, currentfile):fs]))

// Write one line from a file (will not append newline). This will abort when
// the file is not open or error if the file is not opened for writing.
writeline	:: String Filehandle -> IO Bool
writeline s fh = IO (writeline` s fh)
	where
		writeline` :: String Filehandle *W -> *(Bool, *W)
		writeline` s fh (world, fs)
		# (currentfiletuple, fs) = getFH fh fs
		| isNothing currentfiletuple = abort "File not open"
		# (currentfh, currentfile) = fromJust currentfiletuple
		# currentfile = fwrites s currentfile
		= (True, (world, [(currentfh, currentfile):fs]))

// Gets the file associated with the filehandle given, this is done in a very
// ugly way to retain uniqueness...
getFH:: Filehandle *[*(Filehandle, *File)] ->
	(Maybe *(Filehandle, *File), *[*(Filehandle, *File)]) 
getFH fh fs
# (fhs, fis) = unzip fs
# fhsC = zip2 [0..length fhs] fhs
# index = [(i, h) \\ (i, h) <- fhsC | h == fh]
| length index == 0 = (Nothing, zip2 fhs fis)
# index = fst (hd index)
# (fis1, fis2) = splitAt index fis
# (fhs1, fhs2) = splitAt index fhs
# (thefile, fis2) = splitAt 1 fis2
# (thehandle, fhs2) = splitAt 1 fhs2
= (Just (hd thehandle, hd thefile), zip2 (fhs1 ++ fhs2) (fis1 ++ fis2))