{-# OPTIONS -fglasgow-exts #-}
-- ghc ThrowCatch.hs -o ThrowCatch && ./ThrowCatch
module Main where
	{
	import qualified Control.Monad.Error;
	import qualified Control.Exception;
	import qualified System.IO.Error;
	import Data.IORef;
	import Prelude;

	safeCatch :: IO () -> IO ();
	safeCatch f = Control.Exception.catch f (\_ -> return ());

	type Thrower = IO Bool;

	type Catcher = IO Bool -> IO () -> IO ();

	checkCatch :: Catcher -> Thrower -> IO Bool;
	checkCatch catcher thrower = do
		{
		ref <- newIORef False;
		safeCatch (catcher thrower (writeIORef ref True));
		readIORef ref;
		};

	data Named a = MkNamed String a;

	checkNamedCatch :: Named Catcher -> Named Thrower -> IO ();
	checkNamedCatch (MkNamed cname catcher) (MkNamed tname thrower) = do
		{
		didCatch <- checkCatch catcher thrower;
		putStrLn (cname ++ (if didCatch then " CAUGHT " else " MISSED ") ++ tname);
		};

	checkNamedCatches :: [Named Catcher] -> [Named Thrower] -> IO ();
	checkNamedCatches [] _ = return ();
	checkNamedCatches _ [] = return ();
	checkNamedCatches [c] (t:tr) = do
		{
		checkNamedCatch c t;
		checkNamedCatches [c] tr;
		};
	checkNamedCatches (c:cr) ts = do
		{
		checkNamedCatches [c] ts;
		checkNamedCatches cr ts
		};

	getBottom :: a -> IO (Maybe Control.Exception.Exception);
	getBottom a = Control.Exception.catch (seq a (return Nothing)) (\ex -> return (Just ex));	

	class IOShow a where
		{
		ioShowGood :: a -> IO String;
		};

	ioShow :: (IOShow a) => a -> IO String;
	ioShow a = do
		{
		mex <- getBottom a;
		case mex of
			{
			Just ex -> do
				{
				text <- ioShow ex;
				return ("BOTTOM: " ++ text);
				};
			_ -> ioShowGood a;
			};
		};

	ioDeepShow :: (IOShow a) => a -> IO String;
	ioDeepShow a = do
		{
		mex <- getBottom a;
		case mex of
			{
			Just ex -> do
				{
				text <- ioShow ex;
				return ("unshowable: " ++ text);
				};
			_ -> ioShowGood a;
			};
		};
	
	instance IOShow String where
		{
		ioShowGood a = return a;
		};
	
	instance IOShow Bool where
		{
		ioShowGood a = ioDeepShow (show a);
		};
	
	instance IOShow Control.Exception.Exception where
		{
		ioShowGood a = ioDeepShow (show a);
		};
	
	instance (IOShow a) => IOShow (IO a) where
		{
		ioShowGood ioa = Control.Exception.catch (do
			{
			a <- ioa;
			text <- ioShow a;
			return ("return " ++ text);
			}) (\ex -> do
			{
			text <- ioShow ex;
			return ("throw "++ text);
			});
		};

	showBottoms :: [Named Thrower] -> IO ();
	showBottoms [] = return ();
	showBottoms (MkNamed name val:rest) = do
		{
		text <- ioShow val;
		putStrLn (name ++ " is " ++ text);
		showBottoms rest;
		};
		
	type ResultCatcher a = IO Bool -> (a -> IO()) -> IO ();

	checkResultCatch :: ResultCatcher a -> Thrower -> IO (Maybe a);
	checkResultCatch catcher thrower = do
		{
		ref <- newIORef Nothing;
		safeCatch (catcher thrower (\a -> writeIORef ref (Just a)));
		readIORef ref;
		};
{-
	checkNamedResultCatch :: (Show a) => Named (ResultCatcher a) -> Named Thrower -> IO ();
	checkNamedResultCatch (MkNamed cname catcher) (MkNamed tname thrower) = do
		{
		didCatch <- checkCatch catcher thrower;
		putStrLn (cname ++ (if didCatch then " CAUGHT " else " MISSED ") ++ tname);
		};
-}

	-- throwers

	returnThrower :: Named Thrower;
	returnThrower = MkNamed "return" (return True);

	returnUndefinedThrower :: Named Thrower;
	returnUndefinedThrower = MkNamed "return undefined" (return undefined);

	evaluateUndefinedThrower :: Named Thrower;
	evaluateUndefinedThrower = MkNamed "evaluate undefined" (Control.Exception.evaluate undefined);

	returnErrorThrower :: Named Thrower;
	returnErrorThrower = MkNamed "return error" (return (error "some error"));

	undefinedThrower :: Named Thrower;
	undefinedThrower = MkNamed "undefined" undefined;

	failThrower :: Named Thrower;
	failThrower = MkNamed "fail" (fail "some failure");

	errorThrower :: Named Thrower;
	errorThrower = MkNamed "error" (error "some error");

	throwThrower :: Named Thrower;
	throwThrower = MkNamed "Control.Exception.throw"
	 (Control.Exception.throw (Control.Exception.ErrorCall "throw error"));

	cmeThrowErrorThrower :: Named Thrower;
	cmeThrowErrorThrower = MkNamed "Control.Monad.Error.throwError userError"
	 (Control.Monad.Error.throwError (userError "some error"));

	ioErrorUserErrorThrower :: Named Thrower;
	ioErrorUserErrorThrower = MkNamed "ioError userError"
	 (ioError (userError "some error"));

	ioErrorUndefinedThrower :: Named Thrower;
	ioErrorUndefinedThrower = MkNamed "ioError undefined"
	 (ioError undefined);

	returnThrowThrower :: Named Thrower;
	returnThrowThrower = MkNamed "return Control.Exception.throw"
	 (return (Control.Exception.throw (Control.Exception.ErrorCall "throw error")));

	throwers :: [Named Thrower];
	throwers = [returnThrower,returnUndefinedThrower,returnThrowThrower,returnErrorThrower,evaluateUndefinedThrower,failThrower,
		cmeThrowErrorThrower,ioErrorUserErrorThrower,ioErrorUndefinedThrower,errorThrower,throwThrower,undefinedThrower];


	-- catchers

	seqCatcher :: Named Catcher;
	seqCatcher = MkNamed "seq" seq;

	bindCatcher :: Named Catcher;
	bindCatcher = MkNamed ">>" (>>);

	preludeCatchCatcher :: Named Catcher;
	preludeCatchCatcher = MkNamed "Prelude.catch"
	 (\f cc -> Prelude.catch (f >> (return ())) (const cc));

	ceCatchCatcher :: Named Catcher;
	ceCatchCatcher = MkNamed "Control.Exception.catch"
	 (\f cc -> Control.Exception.catch (f >> (return ())) (const cc));

	cmeCatchCatcher :: Named Catcher;
	cmeCatchCatcher = MkNamed "Control.Monad.Error.catchError"
	 (\f cc -> Control.Monad.Error.catchError (f >> (return ())) (const cc));

	sieCatchCatcher :: Named Catcher;
	sieCatchCatcher = MkNamed "System.IO.Error.catch"
	 (\f cc -> System.IO.Error.catch (f >> (return ())) (const cc));

	finallyCatcher :: Named Catcher;
	finallyCatcher = MkNamed "Control.Exception.finally"
	 (\f cc -> Control.Exception.finally (f >> (return ())) cc);

	ceCatchOrBindCatcher :: Named Catcher;
	ceCatchOrBindCatcher = MkNamed "Control.Exception.catch or >>"
	 (\f cc -> Control.Exception.catch (f >> cc) (const cc));

	catchers :: [Named Catcher];
	catchers = [seqCatcher,bindCatcher,preludeCatchCatcher,sieCatchCatcher,ceCatchCatcher,cmeCatchCatcher,finallyCatcher,ceCatchOrBindCatcher];

	main :: IO ();
	main = do
		{
		showBottoms throwers;
		checkNamedCatches catchers throwers;
		};

	}