more correct lexer

src/Control/Monad/Errorful.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TupleSections, PatternSynonyms #-}
+module Control.Monad.Errorful
+    ( ErrorfulT
+    , runErrorfulT
+    , Errorful
+    , runErrorful
+    , MonadErrorful(..)
+    )
+    where
+----------------------------------------------------------------------------------
+import Control.Monad.Trans
+import Control.Monad.Except
+import Data.Functor.Identity
+import Data.Coerce
+import Lens.Micro
+----------------------------------------------------------------------------------
+
+newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Either e (a, [e])) }
+
+type Errorful e = ErrorfulT e Identity
+
+pattern Errorful :: (Either e (a, [e])) -> Errorful e a
+pattern Errorful a = ErrorfulT (Identity a)
+
+runErrorful :: Errorful e a -> Either e (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
+
+instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where
+    addWound e = ErrorfulT $ pure . Right $ ((), [e])
+    addFatal e = ErrorfulT $ pure . Left  $ e
+
+instance MonadTrans (ErrorfulT e) where
+    lift m = ErrorfulT (Right . (,[]) <$> m)
+
+instance (Functor m) => Functor (ErrorfulT e m) where
+    fmap f (ErrorfulT m) = ErrorfulT $ fmap (_1 %~ f) <$> m
+
+instance (Applicative m) => Applicative (ErrorfulT e m) where
+    pure a = ErrorfulT (pure . Right $ (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)) 
+
+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)
+