module PureIO
(
runIO
,IO
,Input(..)
,Output(..)
,Interrupt(..)
,IOException(..)
,putStrLn
,putStr
,getLine
,readLn
,print
,readIO
,throw
,PureIO.catch
,readFile
,writeFile
,appendFile
,doesFileExist
,removeFile
,getDirectoryContents
)
where
import Control.Applicative
import Control.Arrow
import Control.Monad.Error
import Control.Monad.State
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Prelude hiding (IO,putStr,putStrLn,getLine,readLn,print,readIO,readFile,writeFile,appendFile)
import Data.List
import Safe
data IOException = UserError String
| FileNotFound FilePath
| DirectoryNotFound FilePath
deriving (Show,Read)
data Input = Input
{ inputStdin :: ![String]
, inputFiles :: !(Map String String)
} deriving (Show)
data Output = Output
{ outputStdout :: ![String]
, outputFiles :: !(Map String String)
} deriving (Show,Read)
instance Monoid Output where
mempty = Output mempty mempty
(Output a x) `mappend` (Output b y) = Output (a <> b) (x <> y)
data Interrupt
= InterruptStdin
| InterruptException !IOException
deriving (Show,Read)
instance Error Interrupt
newtype IO a = IO
{ unIO :: ErrorT Interrupt (State (Input,Output)) a
}
deriving (Monad,Functor,Applicative)
runIO :: Input -> IO a -> (Either Interrupt a,Output)
runIO input m =
second snd
(runState (runErrorT (unIO m))
(input { inputFiles = mempty }
,mempty { outputFiles = inputFiles input }))
interrupt :: Interrupt -> IO a
interrupt = IO . throwError
modifyFile :: FilePath -> (String -> String) -> IO ()
modifyFile fp f =
modifyFiles (M.alter (\contents -> Just (f (fromMaybe "" contents))) fp)
modifyFiles :: (Map FilePath String -> Map FilePath String) -> IO ()
modifyFiles f = IO (modify (\(i,o) -> (i,updateFile o)))
where updateFile (Output stdout files) =
(Output stdout (f files))
putStrLn :: String -> IO ()
putStrLn = putStr . (++ "\n")
putStr :: String -> IO ()
putStr new = IO (modify (\(i,o) -> (i,o <> Output [new] mempty)))
getLine :: IO String
getLine = do
(Input is fs,_) <- IO get
case is of
[] -> interrupt InterruptStdin
(i:is') -> do IO (modify (first (const (Input is' fs))))
return i
readIO :: Read a => String -> IO a
readIO s =
case readMay s of
Nothing -> throw (UserError "readIO: no parse")
Just r -> return r
readLn :: Read a => IO a
readLn = getLine >>= readIO
print :: Show a => a -> IO ()
print = putStrLn . show
throw :: IOException -> IO a
throw = interrupt . InterruptException
catch :: IO a -> (IOException -> IO a) -> IO a
catch (IO m) f = IO (catchError m handler)
where handler i =
case i of
InterruptException e ->
let (IO m') = f e
in m'
_ -> throwError i
readFile :: FilePath -> IO String
readFile fp =
do mbytes <- IO (gets (M.lookup fp . outputFiles . snd))
case mbytes of
Nothing -> throw (FileNotFound fp)
Just bytes -> return bytes
writeFile :: FilePath -> String -> IO ()
writeFile fp = modifyFile fp . const
appendFile :: FilePath -> String -> IO ()
appendFile fp more = modifyFile fp (\contents -> contents ++ more)
doesFileExist :: FilePath -> IO Bool
doesFileExist fp =
fmap (isJust)
(IO (gets (M.lookup fp . outputFiles . snd)))
removeFile :: FilePath -> IO ()
removeFile fp = do
exists <- doesFileExist fp
if exists
then modifyFiles (M.delete fp)
else throw (FileNotFound fp)
getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents fp =
do entries <- IO (gets (M.keys . outputFiles . snd))
case filter (isPrefixOf fp') entries of
[] -> throw (DirectoryNotFound fp)
fs -> return fs
where fp' | isSuffixOf "/" fp = fp
| otherwise = fp ++ "/"