From b83325c4b5c324a42acfe366cf58b455f8aa941f Mon Sep 17 00:00:00 2001
From: Matthew Hall <hallmatthew314@gmail.com>
Date: Thu, 16 Feb 2023 23:05:24 +1300
Subject: Big file-structure refactor

---
 DSL/BaseParsers.hs | 139 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 139 insertions(+)
 create mode 100644 DSL/BaseParsers.hs

(limited to 'DSL/BaseParsers.hs')

diff --git a/DSL/BaseParsers.hs b/DSL/BaseParsers.hs
new file mode 100644
index 0000000..403ca42
--- /dev/null
+++ b/DSL/BaseParsers.hs
@@ -0,0 +1,139 @@
+module DSL.BaseParsers where
+
+-- Parsec is for casuals
+
+import Control.Applicative (Alternative(..), liftA2)
+import Control.Monad (MonadPlus(..), guard)
+import Data.Maybe (catMaybes)
+
+newtype Parser t a =
+  Parser { parse :: [t] -> Maybe ([t], a) }
+
+instance Semigroup a => Semigroup (Parser t a) where
+  (<>) = liftA2 (<>)
+
+instance Monoid a => Monoid (Parser t a) where
+  mempty = pure mempty
+
+instance Functor (Parser t) where
+  fmap f (Parser p) = Parser $ fmap (fmap f) . p
+
+instance Applicative (Parser t) where
+  pure = result
+
+  p <*> q = Parser $ \ inp -> do
+    (inp', f) <- parse p inp
+    parse (f <$> q) inp'
+
+instance Monad (Parser t) where
+  return = pure
+
+  p >>= f = Parser $ \ inp -> do
+    (inp', x) <- parse p inp
+    parse (f x) inp'
+
+instance Alternative (Parser t) where
+  empty = flunk
+
+  (<|>) = alt
+
+instance MonadPlus (Parser t)
+
+instance MonadFail (Parser t) where
+  fail _ = mzero
+
+-----------------------------------------------------------------------------
+
+flunk :: Parser t a
+flunk = Parser $ \ _ -> Nothing
+
+result :: a -> Parser t a
+result x = Parser $ \ inp -> Just (inp, x)
+
+peek :: Parser t a -> Parser t a
+peek p = Parser $ \ inp -> do
+  (_, x) <- parse p inp
+  return (inp, x)
+
+anyToken :: Parser t t
+anyToken = Parser $ \ inp -> case inp of
+  t:ts -> Just (ts, t)
+  _    -> Nothing
+
+eof :: Parser t ()
+eof = Parser $ \ inp -> case inp of
+  [] -> Just ([], ())
+  _  -> Nothing
+
+infixl 3 `alt`
+alt :: Parser t a -> Parser t a -> Parser t a
+alt (Parser p) (Parser q) = Parser $ \ inp -> p inp <|> q inp
+
+-----------------------------------------------------------------------------
+
+phrase :: Parser t a -> Parser t a
+phrase = (<* eof)
+
+recover :: a -> Parser t a -> Parser t a
+recover x p = p <|> pure x
+
+optional :: Parser t a -> Parser t (Maybe a)
+optional = recover Nothing . fmap Just
+
+assert :: (a -> Bool) -> Parser t a -> Parser t a
+assert f p = do
+  x <- p
+  guard $ f x
+  return x
+
+satisfy :: (t -> Bool) -> Parser t t
+satisfy f = assert f anyToken
+
+token :: Eq t => t -> Parser t t
+token t = satisfy (==t)
+
+list :: Eq t => [t] -> Parser t [t]
+list = traverse token
+
+mult :: Parser t a -> Parser t [a]
+mult = many
+
+mult1 :: Parser t a -> Parser t [a]
+mult1 = some
+
+exactly :: Int -> Parser t a -> Parser t [a]
+exactly i = sequence . replicate i
+
+atLeast :: Int -> Parser t a -> Parser t [a]
+atLeast i p = exactly i p <> mult p
+
+atMost :: Int -> Parser t a -> Parser t [a]
+atMost i = fmap catMaybes . exactly i . optional
+
+between :: Int -> Int -> Parser t a -> Parser t [a]
+between x y p = exactly (min x y) p <> atMost (abs $ x - y) p
+
+stopAt :: Parser t a -> Parser t [t]
+stopAt p = go
+  where
+    p' = ([] <$ peek p)
+    go = p' <|> liftA2 (:) anyToken go
+
+stopAfter :: Parser t a -> Parser t ([t], a)
+stopAfter p = (,) <$> stopAt p <*> p
+
+stopIf :: Parser t a -> Parser t [t]
+stopIf p = stopAt $ () <$ p <|> eof
+
+firstOf :: [Parser t a] -> Parser t a
+firstOf = foldr1 (<|>)
+
+sepBy1 :: Parser t a -> Parser t b -> Parser t [a]
+sepBy1 a b = do
+  x  <- a
+  xs <- mult $ b >> a
+  return $ x:xs
+
+sepBy :: Parser t a -> Parser t b -> Parser t [a]
+sepBy a b = sepBy1 a b <|> pure []
+
-- 
cgit v1.2.1