compiles (kill me)

man

src/Control/Monad/Errorful.hs

@@ -14,60 +14,52 @@ module Control.Monad.Errorful
 import Control.Monad.Trans
 import Data.Functor.Identity
 import Data.Coerce
+import Data.HashSet             (HashSet)
+import Data.HashSet             qualified as H
 import Lens.Micro
 ----------------------------------------------------------------------------------
 
-newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Either e (a, [e])) }
+newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }
 
 type Errorful e = ErrorfulT e Identity
 
-pattern Errorful :: (Either e (a, [e])) -> Errorful e a
+pattern Errorful :: (Maybe a, [e]) -> Errorful e a
 pattern Errorful a = ErrorfulT (Identity a)
 
-runErrorful :: Errorful e a -> Either e (a, [e])
+runErrorful :: Errorful e a -> (Maybe a, [e])
 runErrorful m = coerce (runErrorfulT m)
 
 class (Applicative m) => MonadErrorful e m | m -> e where
-    addWound   :: e -> m ()
-    addFatal   :: e -> m a
-
-    -- not sure if i want to add this yet...
-    -- catchWound :: m a -> (e -> m a) -> m a
+    addWound :: e -> m ()
+    addFatal :: e -> m a
 
 instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where
-    addWound e = ErrorfulT $ pure . Right $ ((), [e])
-    addFatal e = ErrorfulT $ pure . Left  $ e
+    addWound e = ErrorfulT $ pure (Just (), [e])
+    addFatal e = ErrorfulT $ pure (Nothing, [e])
 
 instance MonadTrans (ErrorfulT e) where
-    lift m = ErrorfulT (Right . (,[]) <$> m)
+    lift m = ErrorfulT ((\x -> (Just x,[])) <$> m)
 
 instance (MonadIO m) => MonadIO (ErrorfulT e m) where
     liftIO = lift . liftIO
 
 instance (Functor m) => Functor (ErrorfulT e m) where
-    fmap f (ErrorfulT m) = ErrorfulT $ fmap (_1 %~ f) <$> m
+    fmap f (ErrorfulT m) = ErrorfulT (m & mapped . _1 . _Just %~ f)
 
 instance (Applicative m) => Applicative (ErrorfulT e m) where
-    pure a = ErrorfulT (pure . Right $ (a, []))
+    pure a = ErrorfulT . pure $ (Just a, [])
 
-    m <*> a = ErrorfulT (m' `apply` a')
-        where
-            m' = runErrorfulT m
-            a' = runErrorfulT a
-            -- TODO: strict concatenation
-            apply = liftA2 $ liftA2 (\ (f,e1) (x,e2) -> (f x, e1 ++ e2)) 
+    ErrorfulT m <*> ErrorfulT n = ErrorfulT $ m `apply` n where
+        apply :: m (Maybe (a -> b), [e]) -> m (Maybe a, [e]) -> m (Maybe b, [e])
+        apply = liftA2 $ \ (mf,e1) (ma,e2) -> (mf <*> ma, e1 <> e2)
 
 instance (Monad m) => Monad (ErrorfulT e m) where
     ErrorfulT m >>= k = ErrorfulT $ do
-        m' <- m
-        case m' of
-            Right (a,es) -> runErrorfulT (k a)
-            Left e       -> pure (Left e)
+        (a,es) <- m
+        case a of
+            Just x      -> runErrorfulT (k x)
+            Nothing     -> pure (Nothing, es)
 
 mapErrors :: (Monad m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
-mapErrors f m = ErrorfulT $ do
-    x <- runErrorfulT m
-    case x of
-        Left  e      -> pure . Left  $ f e
-        Right (a,es) -> pure . Right $ (a, f <$> es)
+mapErrors f m = undefined