Errors.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}

module Errors2 where


import Prelude
import Control.Monad.Identity


data Error = Error String

data Value = Value Int


data Step m a = Step [Error] (Maybe Value) (m a)


alt (Just x) Nothing = Just x
alt (Just x) (Just x') = Just x'
alt Nothing r = r


instance Functor f => Functor (Step f) where
  fmap f (Step errors x val) =
    Step errors x (f <$> val)
    

instance Applicative f => Applicative (Step f) where 
   pure x = Step [] Nothing (pure x)
   a <*> b = merge' a b
    

instance Monad (Step Maybe) where
  step@(Step errors x m) >>= k = 
    case m of 
      Just v ->
        step `merge` k v
      Nothing -> 
         Step 
              errors
              x
              Nothing
              

instance Monad (Step (Either Error)) where
  step@(Step errors x m) >>= k = 
    case m of 
      Right v ->
         step `merge` k v           
      Left err -> 
         Step 
              (errors <> [ err ])
              x
              (Left err)


merge :: Step m a -> Step m b -> Step m b
merge (Step errors x m) (Step errors' x' m') =
    Step
        (errors <> errors')
        (x `alt` x')
        m'
        

merge' :: Applicative m => Step m (a -> b) -> Step m a -> Step m b
merge' (Step errors x f) (Step errors' x' v) =
    Step
        (errors <> errors')
        (x `alt` x')
        (f <*> v)



instance Show Error where
  show (Error err) = show err
               

instance Show a => Show (Step Maybe a) where
   show (Step errors (Just (Value num)) val)
      = 
          "Step " 
              ++ show errors 
              ++ " / has value " 
              ++ show num 
              ++ " / " 
              ++ show val
   show (Step errors Nothing val)
            = "Step " 
               ++ show errors 
               ++ " / has no value " 
               ++ " / " 
               ++ show val
               

instance Show a => Show (Step (Either Error) a) where
   show (Step errors (Just (Value num)) val)
      = 
          "Step " 
              ++ show errors 
              ++ " / has value " 
              ++ show num 
              ++ " / " 
              ++ show val
   show (Step errors Nothing val)
            = "Step " 
               ++ show errors 
               ++ " / has no value " 
               ++ " / " 
               ++ show val
               

cover :: Value -> m a -> Step m a
cover x m =
  Step [] (Just x) m
  

cover' :: m a -> Step m a
cover' m =
    Step [] Nothing m
    

coverError :: Error -> Value -> m a -> Step m a
coverError error x m =
  Step [error] (Just x) m 


coverError' :: Error -> m a -> Step m a
coverError' error m =
  Step [error] Nothing m 
 


(|>) = flip ($)


test :: Step Maybe ()
test = do
    _ <- Just "a" |> cover (Value 0)
    _ <- Just "b" |> cover (Value 1)
    _ <- Just "c" |> coverError (Error "foo") (Value 2)
    _ <- Just "d" |> coverError (Error "bar") (Value 3)
    _ <- Just "e" |> cover (Value 4)
    _ <- Just "f" |> cover'
    _ <- Just "g" |> cover'
    _ <- Just "h" |> cover'
    _ <- Just "i" |> cover (Value 5)
    _ <- Just "j" |> cover'
    _ <- Just "k" |> cover'
    _ <- Just "l" |> cover'
    _ <- Just "m" |> coverError' (Error "buz")                           
    return ()
    

test2 :: Step Maybe ()
test2 = do
    _ <- Just "a" |> cover (Value 0)
    _ <- Just "b" |> cover'
    _ <- Just "c" |> coverError' (Error "foo")
    _ <- Just "d" |> coverError' (Error "bar")
    _ <- Just "e" |> cover'
    _ <- Just "f" |> cover'
    _ <- Just "g" |> cover'
    _ <- Just "h" |> cover'
    _ <- Just "i" |> cover'
    _ <- Just "j" |> cover'
    _ <- Just "k" |> cover'
    _ <- Just "l" |> cover'   
    _ <- Just "m" |> coverError' (Error "buz")
    return ()
    

test3 :: Step Maybe ()
test3 = do
    _ <- Just "a" |> cover'  
    _ <- Just "b" |> cover'  
    _ <- Just "c" |> coverError' (Error "foo")
    _ <- Just "d" |> coverError' (Error "bar")
    _ <- Just "e" |> cover'
    _ <- Just "f" |> cover'
    _ <- Just "g" |> cover'
    _ <- Just "h" |> cover'
    _ <- Just "i" |> cover'
    _ <- Just "j" |> cover'
    _ <- Just "k" |> cover'
    _ <- Just "l" |> cover' 
    _ <- Just "m" |> coverError' (Error "buz")                          
    return ()
    

push :: Monad m => Value -> Step m ()
push x = 
    Step [] (Just x) (return ())


note :: Either Error x -> Step (Either Error) x
note either = Step [] Nothing either


test4 :: Step (Either Error) ()
test4 = do
    _ <- push $ Value 1
    _ <- Right "b" |> cover'
    _ <- Right "c" |> coverError (Error "foo") (Value 2)
    _ <- push $ Value 3
    _ <- note $ Left $ Error "x"
    _ <- note $ Left $ Error "y"
    _ <- Right "d" |> coverError' (Error "bar")
    _ <- Right "e" |> cover'
    _ <- Right "f" |> cover'
    _ <- Right "g" |> cover'
    _ <- Right "h" |> cover'
    _ <- Right "i" |> cover'
    _ <- Right "j" |> cover'
    _ <- Right "k" |> cover'
    _ <- Right "l" |> cover'
    _ <- Right "m" |> coverError' (Error "buz")
    return ()