refactor(users/Profpatsch/jbovlaste): factor Parse into own module r/6818

We want to use this quite generic parser type for other things as
well.

Change-Id: I890b43c58e479bdf2d179a724280ef1d8748fafa
Reviewed-on: https://cl.tvl.fyi/c/depot/+/9742
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>

3 files changed, 5 insertions, 150 deletions

diff --git a/users/Profpatsch/jbovlaste-sqlite/JbovlasteSqlite.hs b/users/Profpatsch/jbovlaste-sqlite/JbovlasteSqlite.hs
index b1256fa4affe..8dae9cd02694 100644
--- a/users/Profpatsch/jbovlaste-sqlite/JbovlasteSqlite.hs
+++ b/users/Profpatsch/jbovlaste-sqlite/JbovlasteSqlite.hs
@@ -5,34 +5,26 @@ module Main where
 
 import Conduit ((.|))
 import Conduit qualified as Cond
-import Control.Category qualified
 import Control.Category qualified as Cat
 import Control.Foldl qualified as Fold
-import Control.Selective (Selective)
 import Data.ByteString.Internal qualified as Bytes
 import Data.Error.Tree
-import Data.Functor.Compose
 import Data.Int (Int64)
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Maybe (catMaybes)
-import Data.Monoid (First (..))
-import Data.Semigroup.Traversable
-import Data.Semigroupoid qualified as Semigroupoid
 import Data.Text qualified as Text
 import Data.Text.IO qualified as Text
 import Database.SQLite.Simple qualified as Sqlite
 import Database.SQLite.Simple.FromField qualified as Sqlite
 import Database.SQLite.Simple.QQ qualified as Sqlite
-import FieldParser (FieldParser)
 import FieldParser qualified as Field
 import Label
+import Parse
 import PossehlAnalyticsPrelude
 import Text.XML (def)
 import Text.XML qualified as Xml
-import Validation (partitionValidations)
 import Prelude hiding (init, maybe)
-import Prelude qualified
 
 main :: IO ()
 main = do
@@ -131,7 +123,7 @@ insertValsi env vs = do
               ":sense" Sqlite.:= g.sense
             ]
 
-migrate :: HasField "envData" p Sqlite.Connection => p -> IO ()
+migrate :: (HasField "envData" p Sqlite.Connection) => p -> IO ()
 migrate env = do
   let x q = Sqlite.execute env.envData q ()
   x
@@ -181,7 +173,7 @@ withSqlite fileName inner = Sqlite.withConnection fileName $ \conn -> do
   Sqlite.execute conn [Sqlite.sql|PRAGMA foreign_keys = ON|] ()
   inner conn
 
-parseJbovlasteXml :: HasField "documentRoot" r Xml.Element => r -> Either ErrorTree [Valsi]
+parseJbovlasteXml :: (HasField "documentRoot" r Xml.Element) => r -> Either ErrorTree [Valsi]
 parseJbovlasteXml xml =
   xml.documentRoot
     & runParse
@@ -338,55 +330,6 @@ nodeElementMay = \case
   Xml.NodeElement el -> Just el
   _ -> Nothing
 
--- | A generic applicative “vertical” parser.
--- Similar to `FieldParser`, but made for parsing whole structures and collect all errors in an `ErrorTree`.
-newtype Parse from to = Parse ((Context, from) -> Validation (NonEmpty ErrorTree) (Context, to))
-  deriving
-    (Functor, Applicative, Selective)
-    via ( Compose
-            ( Compose
-                ((->) (Context, from))
-                (Validation (NonEmpty ErrorTree))
-            )
-            ((,) Context)
-        )
-
--- | Every parser can add to the context, like e.g. an element parser will add the name of the element it should be parsing.
--- This should be added to the error message of each parser, with `showContext`.
-newtype Context = Context (Maybe [Text])
-  deriving stock (Show)
-  deriving (Semigroup, Monoid) via (First [Text])
-
-instance Semigroupoid Parse where
-  o p2 p1 = Parse $ \from -> case runParse' p1 from of
-    Failure err -> Failure err
-    Success to1 -> runParse' p2 to1
-
-instance Category Parse where
-  (.) = Semigroupoid.o
-  id = Parse $ \t -> Success t
-
-instance Profunctor Parse where
-  lmap f (Parse p) = Parse $ lmap (second f) p
-  rmap = (<$>)
-
-runParse :: Error -> Parse from to -> from -> Either ErrorTree to
-runParse errMsg parser t =
-  (Context (Just ["$"]), t)
-    & runParse' parser
-    <&> snd
-    & first (nestedMultiError errMsg)
-    & validationToEither
-
-runParse' :: Parse from to -> (Context, from) -> Validation (NonEmpty ErrorTree) (Context, to)
-runParse' (Parse f) from = f from
-
-showContext :: Context -> Text
-showContext (Context context) = context & fromMaybe [] & List.reverse & Text.intercalate "."
-
-addContext :: Text -> Context -> Context
-addContext x (Context mxs) = Context (Just $ x : (mxs & fromMaybe []))
-
 element :: Text -> Parse Xml.Element Xml.Element
 element name = Parse $ \(ctx, el) ->
   if el.elementName.nameLocalName == name
@@ -417,96 +360,6 @@ attributeMay name = Parse $ \(ctx, el) ->
     Just a -> Success (ctx & addContext [fmt|{{attr:{name}}}|], Just a)
     Nothing -> Success (ctx, Nothing)
 
--- | Accept only exactly the given value
-exactly :: Eq from => (from -> Text) -> from -> Parse from from
-exactly errDisplay from = Parse $ \(ctx, from') ->
-  if from == from'
-    then Success (ctx, from')
-    else Failure $ singleton [fmt|Field has to be exactly {errDisplay from}, was: {errDisplay from'} at {showContext ctx}|]
-
--- | Make a parser to parse the whole list
-multiple :: Parse a1 a2 -> Parse [a1] [a2]
-multiple inner = dimap nonEmpty (Prelude.maybe [] toList) (maybe $ multipleNE inner)
-
--- | Make a parser to parse the whole non-empty list
-multipleNE :: Parse from to -> Parse (NonEmpty from) (NonEmpty to)
-multipleNE inner = Parse $ \(ctx, from) ->
-  from
-    & zipIndex
-    & traverse (\(idx, f) -> runParse' inner (ctx, f) & first (singleton . nestedMultiError [fmt|{idx}|]))
-    -- we assume that, since the same parser is used everywhere, the context will be the same as well (TODO: correct?)
-    & second (\((ctx', y) :| ys) -> (ctx', y :| (snd <$> ys)))
-
--- | Lift a parser into an optional value
-maybe :: Parse from to -> Parse (Maybe from) (Maybe to)
-maybe inner = Parse $ \(ctx, m) -> case m of
-  Nothing -> Success (ctx, Nothing)
-  Just a -> runParse' inner (ctx, a) & second (fmap Just)
-
--- | Assert that there is exactly one element in the list
-exactlyOne :: Parse [from] from
-exactlyOne = Parse $ \(ctx, xs) -> case xs of
-  [] -> Failure $ singleton [fmt|Expected exactly 1 element, but got 0, at {ctx & showContext}|]
-  [one] -> Success (ctx, one)
-  _more -> Failure $ singleton [fmt|Expected exactly 1 element, but got 2, at {ctx & showContext}|]
-
--- | Assert that there is exactly zero or one element in the list
-zeroOrOne :: Parse [from] (Maybe from)
-zeroOrOne = Parse $ \(ctx, xs) -> case xs of
-  [] -> Success (ctx, Nothing)
-  [one] -> Success (ctx, Just one)
-  _more -> Failure $ singleton [fmt|Expected exactly 1 element, but got 2, at {ctx & showContext}|]
-
--- | Find the first element on which the sub-parser succeeds; if there was no match, return all error messages.
-find :: Parse from to -> Parse [from] to
-find inner = Parse $ \(ctx, xs) -> case xs of
-  [] -> failure [fmt|Wanted to get the first sub-parser that succeeds, but there were no elements in the list, at {ctx & showContext}|]
-  (y : ys) -> runParse' (findNE' inner) (ctx, y :| ys)
-
--- | Find the first element on which the sub-parser succeeds; if there was no match, return all error messages.
-findNE' :: Parse from to -> Parse (NonEmpty from) to
-findNE' inner = Parse $ \(ctx, xs) ->
-  xs
-    <&> (\x -> runParse' inner (ctx, x))
-    & traverse1
-      ( \case
-          Success a -> Left a
-          Failure e -> Right e
-      )
-    & \case
-      Left a -> Success a
-      Right errs ->
-        errs
-          & zipIndex
-          <&> (\(idx, errs') -> nestedMultiError [fmt|{idx}|] errs')
-          & nestedMultiError [fmt|None of these sub-parsers succeeded|]
-          & singleton
-          & Failure
-
--- | Find all elements on which the sub-parser succeeds; if there was no match, return an empty list
-findAll :: Parse from to -> Parse [from] [to]
-findAll inner = Parse $ \(ctx, xs) ->
-  xs
-    <&> (\x -> runParse' inner (ctx, x))
-    & partitionValidations
-    & \case
-      (_miss, []) ->
-        -- in this case we just arbitrarily forward the original context …
-        Success (ctx, [])
-      (_miss, (hitCtx, hit) : hits) -> Success (hitCtx, hit : (hits <&> snd))
-
--- | convert a 'FieldParser' into a 'Parse'.
-fieldParser :: FieldParser from to -> Parse from to
-fieldParser fp = Parse $ \(ctx, from) -> case Field.runFieldParser fp from of
-  Right a -> Success (ctx, a)
-  Left err -> Failure $ singleton (singleError err)
-
-zipNonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
-zipNonEmpty (x :| xs) (y :| ys) = (x, y) :| zip xs ys
-
-zipIndex :: NonEmpty b -> NonEmpty (Natural, b)
-zipIndex = zipNonEmpty (1 :| [2 :: Natural ..])
-
 instance
   ( Sqlite.FromField t1,
     Sqlite.FromField t2,
diff --git a/users/Profpatsch/jbovlaste-sqlite/default.nix b/users/Profpatsch/jbovlaste-sqlite/default.nix
index f04b4ad0b3c9..ea59fdec399f 100644
--- a/users/Profpatsch/jbovlaste-sqlite/default.nix
+++ b/users/Profpatsch/jbovlaste-sqlite/default.nix
@@ -17,6 +17,7 @@ let
       pkgs.haskellPackages.pa-label
       pkgs.haskellPackages.pa-error-tree
       pkgs.haskellPackages.pa-field-parser
+      depot.users.Profpatsch.my-prelude
       pkgs.haskellPackages.foldl
       pkgs.haskellPackages.sqlite-simple
       pkgs.haskellPackages.xml-conduit
diff --git a/users/Profpatsch/jbovlaste-sqlite/jbovlaste-sqlite.cabal b/users/Profpatsch/jbovlaste-sqlite/jbovlaste-sqlite.cabal
index 40da320f08d3..f677615a1605 100644
--- a/users/Profpatsch/jbovlaste-sqlite/jbovlaste-sqlite.cabal
+++ b/users/Profpatsch/jbovlaste-sqlite/jbovlaste-sqlite.cabal
@@ -62,6 +62,7 @@ executable jbovlaste-sqlite
         pa-label,
         pa-error-tree,
         pa-field-parser,
+        my-prelude,
         containers,
         selective,
         semigroupoids,