From f25099d6f359d051ca5def25c347611a43609b3c Mon Sep 17 00:00:00 2001
From: Joscha <joscha@plugh.de>
Date: Thu, 2 Apr 2020 14:23:28 +0000
Subject: [PATCH] Add back Weed monad

Make weed monad compatible with all sorts of parsers instead of requiring a
Parsec T.Text Void.
---
 src/Mima/Asm/Weed.hs | 75 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 75 insertions(+)
 create mode 100644 src/Mima/Asm/Weed.hs

diff --git a/src/Mima/Asm/Weed.hs b/src/Mima/Asm/Weed.hs
new file mode 100644
index 0000000..659201b
--- /dev/null
+++ b/src/Mima/Asm/Weed.hs
@@ -0,0 +1,75 @@
+module Mima.Asm.Weed
+  ( Weed
+  , runWeed
+  , critical
+  , harmless
+  -- * Megaparsec compatibility
+  , defaultPosState
+  , errorAt
+  , errorsAt
+  , runWeedBundle
+  ) where
+
+import qualified Data.List.NonEmpty as NE
+import           Data.Monoid
+import qualified Data.Set           as Set
+import           Text.Megaparsec
+
+-- The star of the show
+data Weed e a = Weed (Endo [e]) (Either e a)
+
+instance Functor (Weed e) where
+  fmap f (Weed e a) = Weed e $ fmap f a
+
+instance Applicative (Weed e) where
+  pure = Weed mempty . pure
+  (Weed es1 (Left e1)) <*> (Weed es2 (Left e2)) = Weed (es1 <> Endo (e1:) <> es2) (Left e2)
+  (Weed es1 f)         <*> (Weed es2 a)         = Weed (es1 <> es2) (f <*> a)
+
+instance Monad (Weed e) where
+  (Weed es1 v) >>= f =
+    case f <$> v of
+      Left e             -> Weed es1 (Left e)
+      Right (Weed es2 a) -> Weed (es1 <> es2) a
+
+runWeed :: Weed e a -> Either (NE.NonEmpty e) a
+-- Since the Endos never remove an element and we add an extra
+-- element, this list is never empty.
+--
+-- I've tried to figure out nicer types for this, but if I want to
+-- keep the Endo trick, the tradeoff isn't worth it. The problem here
+-- is that I can't easily check if 'es' is 'mempty' with these
+-- endofunctors.
+runWeed (Weed es (Left e))  = Left $ NE.fromList $ appEndo es [e]
+runWeed (Weed es (Right a)) =
+  case appEndo es [] of
+    (x:xs) -> Left $ x NE.:| xs
+    []     -> Right a
+
+critical :: e -> Weed e a
+critical e = Weed mempty (Left e)
+
+harmless :: e -> Weed e ()
+harmless e = Weed (Endo (e:)) (Right ())
+
+{- Megaparsec compatibility -}
+
+defaultPosState :: FilePath -> s -> PosState s
+defaultPosState filename input = PosState
+  { pstateInput      = input
+  , pstateOffset     = 0
+  , pstateSourcePos  = initialPos filename
+  , pstateTabWidth   = defaultTabWidth
+  , pstateLinePrefix = ""
+  }
+
+errorAt :: (Ord e) => Int -> String -> ParseError s e
+errorAt o errorMsg = errorsAt o [errorMsg]
+
+errorsAt :: (Ord e) => Int -> [String] -> ParseError s e
+errorsAt o = FancyError o . Set.fromList . map ErrorFail
+
+runWeedBundle :: FilePath -> s -> Weed (ParseError s e) a -> Either (ParseErrorBundle s e) a
+runWeedBundle filename input w = case runWeed w of
+  Left errors -> Left $ ParseErrorBundle errors $ defaultPosState filename input
+  Right a     -> Right a