From b801218e7627f98556ab7d1acbefbbf8daafd851 Mon Sep 17 00:00:00 2001
From: Jan Sucan <jan@jansucan.com>
Date: Wed, 30 Jul 2025 10:29:40 +0200
Subject: 15_a_1 and 15_a_2: Add solutions

---
 ch15/15_a_1.hs      | 84 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 ch15/MonadHandle.hs | 16 ++++++++++
 ch15/SafeHello.hs   | 12 ++++++++
 3 files changed, 112 insertions(+)
 create mode 100644 ch15/15_a_1.hs
 create mode 100644 ch15/MonadHandle.hs
 create mode 100644 ch15/SafeHello.hs

(limited to 'ch15')

diff --git a/ch15/15_a_1.hs b/ch15/15_a_1.hs
new file mode 100644
index 0000000..66d13d9
--- /dev/null
+++ b/ch15/15_a_1.hs
@@ -0,0 +1,84 @@
+-- 1. Using QuickCheck, write a test for an action in the MonadHandle monad, to
+--    see if it tries to write to a file handle that is not open. Try it out on
+--    safeHello.
+--
+-- 2. Write an action that tries to write to a file handle that it has
+--    closed. Does your test catch this bug?
+
+
+{-- From examples/examples/ch15/WriterIO.hs and modified --}
+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses,
+  TypeSynonymInstances #-}
+
+import Control.Monad.Writer
+import MonadHandle
+import System.IO (IOMode(..))
+import SafeHello
+
+import Test.QuickCheck
+
+data Event = Close
+           | Open
+           | Write
+           deriving (Show)
+
+-- Added missing Functor and Applicative instance derivation
+newtype WriterIO a = W { runW :: Writer [Event] a }
+    deriving (Functor, Applicative, Monad, MonadWriter [Event])
+
+runWriterIO :: WriterIO a -> (a, [Event])
+runWriterIO = runWriter . runW
+
+instance MonadHandle FilePath WriterIO where
+    openFile path mode = tell [Open] >> return path
+    hPutStr h str = tell [Write]
+    hClose h = tell [Close]
+    hGetContents h = return ""
+{-- End of code from examples --}
+
+
+{-- From examples/examples/ch15/SafeHello.hs and modified --}
+writeAfterCloseHello :: MonadHandle h m => FilePath -> m ()
+writeAfterCloseHello path = do
+  h <- openFile path WriteMode
+  hClose h
+  hPutStrLn h "hello world"
+  hClose h
+{-- End of code from examples --}
+
+
+data State = Closed
+           | Opened
+           | None
+
+-- Analyze the logged events for containing write of a closed file handle
+hasWriteAfterClose :: [Event] -> Bool
+hasWriteAfterClose es = hasWriteAfterClose' es None
+  where
+    hasWriteAfterClose' (Write:_) Closed = True
+    hasWriteAfterClose' [] _ = False
+    hasWriteAfterClose' (Close:es) state = hasWriteAfterClose' es Closed
+    hasWriteAfterClose' (Open:es) state = hasWriteAfterClose' es Opened
+    hasWriteAfterClose' (_:es) state = hasWriteAfterClose' es state
+
+
+
+runSafeHello filePath = runWriterIO (safeHello filePath)
+runWriteAfterCloseHello filePath = runWriterIO (writeAfterCloseHello filePath)
+
+prop_noWriteAfterClose :: (FilePath -> ((), [Event])) -> FilePath -> Bool
+prop_noWriteAfterClose action filePath = hasWriteAfterClose (snd (action filePath)) == False
+
+
+-- ghci> :l 15_a_1.hs
+-- [1 of 4] Compiling MonadHandle      ( MonadHandle.hs, interpreted )
+-- [2 of 4] Compiling SafeHello        ( SafeHello.hs, interpreted )
+-- [3 of 4] Compiling Main             ( 15_a_1.hs, interpreted )
+-- Ok, three modules loaded.
+
+-- ghci> quickCheck(prop_noWriteAfterClose runSafeHello)
+-- +++ OK, passed 100 tests.
+
+-- ghci> quickCheck(prop_noWriteAfterClose runWriteAfterCloseHello)
+-- *** Failed! Falsified (after 1 test):
+-- ""
diff --git a/ch15/MonadHandle.hs b/ch15/MonadHandle.hs
new file mode 100644
index 0000000..209728d
--- /dev/null
+++ b/ch15/MonadHandle.hs
@@ -0,0 +1,16 @@
+{-- snippet MonadHandle --}
+{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-}
+
+module MonadHandle (MonadHandle(..)) where
+
+import System.IO (IOMode(..))
+
+class Monad m => MonadHandle h m | m -> h where
+    openFile :: FilePath -> IOMode -> m h
+    hPutStr :: h -> String -> m ()
+    hClose :: h -> m ()
+    hGetContents :: h -> m String
+
+    hPutStrLn :: h -> String -> m ()
+    hPutStrLn h s = hPutStr h s >> hPutStr h "\n"
+{-- /snippet MonadHandle --}
diff --git a/ch15/SafeHello.hs b/ch15/SafeHello.hs
new file mode 100644
index 0000000..91a7ff1
--- /dev/null
+++ b/ch15/SafeHello.hs
@@ -0,0 +1,12 @@
+module SafeHello where
+
+import MonadHandle
+import System.IO (IOMode(..))
+
+{-- snippet safeHello --}
+safeHello :: MonadHandle h m => FilePath -> m ()
+safeHello path = do
+  h <- openFile path WriteMode
+  hPutStrLn h "hello world"
+  hClose h
+{-- /snippet safeHello --}
-- 
cgit v1.2.3