1 files changed, 107 insertions, 0 deletions
diff --git a/ch18/18_b_1.hs b/ch18/18_b_1.hs
new file mode 100644
index 0000000..905e730
--- /dev/null
+++ b/ch18/18_b_1.hs
@@ -0,0 +1,107 @@
+-- Our Parse monad is not a perfect replacement for its earlier
+-- counterpart. Because we are using Maybe instead of Either to represent a
+-- result, we can't report any useful information if a parse fails.
+--
+-- Create an EitherT sometype monad transformer, and use it to implement a more
+-- capable Parse monad that can report an error message if parsing fails.
+--
+-- Tip: If you like to explore the Haskell libraries for fun, you may have run
+-- across an existing Monad instance for the Either type in the
+-- Control.Monad.Error module. We suggest that you do not use that as a
+-- guide. Its design is too restrictive: it turns Either String into a monad,
+-- when you could use a type parameter instead of String.
+--
+-- Hint: if you follow this suggestion, you'll probably need to use the
+-- FlexibleInstances language extension in your definition.
+
+
+{-# LANGUAGE UndecidableInstances #-}
+
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.State
+import Data.Int (Int64)
+import qualified Data.ByteString.Lazy as L
+
+
+{-- From examples/examples/ch18/MaybeTParse.hs and modified --}
+data ParseState = ParseState {
+      string :: L.ByteString
+    , offset :: Int64
+    } deriving (Show)
+
+newtype Parse a = P {
+      runP :: EitherT (State ParseState) a
+      -- Added Functor and Applicative to deriving
+    } deriving (Functor, Applicative, Monad, MonadState ParseState)
+
+evalParse :: Parse a -> L.ByteString -> Either String a
+evalParse m s = evalState (runEitherT (runP m)) (ParseState s 0)
+{-- End of code from examples --}
+
+
+{-- From examples/examples/ch18/MaybeT.hs and modified --}
+newtype EitherT m a = EitherT {
+      runEitherT :: m (Either String a)
+    }
+
+bindET :: (Monad m) => EitherT m a -> (a -> EitherT m b) -> EitherT m b
+x `bindET` f = EitherT $ do
+                 unwrapped <- runEitherT x
+                 case unwrapped of
+                   Left err -> return $ Left err
+                   Right y -> runEitherT (f y)
+
+failET :: (Monad m) => String -> EitherT m a
+failET err = EitherT $ return $ Left err
+
+instance (Monad m) => Monad (EitherT m) where
+  -- Use 'pure' as suggested by the GHC instead of noncanonical 'return'
+  -- definition (like the 'returnMT')
+  return = pure
+  (>>=) = bindET
+
+instance (Monad m) => MonadFail (EitherT m) where
+  fail s = failET s
+
+instance MonadTrans EitherT where
+    lift m = EitherT (Right `liftM` m)
+
+instance (Functor m) => Functor (EitherT m) where
+  fmap f x = EitherT $ fmap (fmap f) . runEitherT $ x
+
+instance (Applicative m) => Applicative (EitherT m) where
+  pure :: a -> EitherT m a
+  pure x = EitherT $ pure $ Right x
+
+  (<*>) :: EitherT m (a -> b) -> EitherT m a -> EitherT m b
+  ff <*> fa = EitherT $ (fmap x (runEitherT ff)) <*> (runEitherT fa)
+    where
+      x :: Either String (a -> b) -> Either String a -> Either String b
+      x f a = f <*> a
+
+instance (MonadState s m) => MonadState s (EitherT m) where
+  get = lift get
+  put k = lift (put k)
+{-- End of code from examples --}
+
+
+identityParse :: a -> Parse a
+identityParse x = P $ pure x
+
+failParse :: a -> Parse a
+failParse _ = P $ fail "Test error in fail"
+
+
+-- ghci> :l 18_b_1.hs
+-- [1 of 2] Compiling Main             ( 18_b_1.hs, interpreted )
+-- Ok, one module loaded.
+
+-- ghci> evalParse (identityParse 123) L.empty
+-- Right 123
+
+-- ghci> evalParse (identityParse "Test value") L.empty
+-- Right "Test value"
+
+-- ghci> evalParse (failParse "Test value") L.empty
+-- Left "Test error in fail"