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

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>

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,

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

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,

users/Profpatsch/my-prelude/default.nix

@@ -10,6 +10,7 @@ pkgs.haskellPackages.mkDerivation {
     ./src/AtLeast.hs
     ./src/MyPrelude.hs
     ./src/Test.hs
+    ./src/Parse.hs
     ./src/Seconds.hs
     ./src/Tool.hs
     ./src/ValidationParseT.hs

users/Profpatsch/my-prelude/my-prelude.cabal

@@ -62,6 +62,7 @@ library
       Postgres.Decoder
       Postgres.MonadPostgres
       ValidationParseT
+      Parse
       Seconds
       Tool
 

users/Profpatsch/my-prelude/src/MyPrelude.hs

@@ -213,7 +213,7 @@ import Validation
   )
 
 -- | Forward-applying 'contramap', like '&'/'$' and '<&>'/'<$>' but for '>$<'.
-(>&<) :: Contravariant f => f b -> (a -> b) -> f a
+(>&<) :: (Contravariant f) => f b -> (a -> b) -> f a
 (>&<) = flip contramap
 
 infixl 5 >&<
@@ -226,7 +226,7 @@ infixl 5 >&<
 -- for functions : (a -> b) -> (b -> c) -> (a -> c)
 -- for Folds: Fold a b -> Fold b c -> Fold a c
 -- @@
-(&>>) :: Semigroupoid s => s a b -> s b c -> s a c
+(&>>) :: (Semigroupoid s) => s a b -> s b c -> s a c
 (&>>) = flip Data.Semigroupoid.o
 
 -- like >>>
@@ -334,7 +334,7 @@ annotate err = \case
   Just a -> Right a
 
 -- | Map the same function over both sides of a Bifunctor (e.g. a tuple).
-both :: Bifunctor bi => (a -> b) -> bi a a -> bi b b
+both :: (Bifunctor bi) => (a -> b) -> bi a a -> bi b b
 both f = bimap f f
 
 -- | Find the first element for which pred returns `Just a`, and return the `a`.
@@ -348,7 +348,7 @@ both f = bimap f f
 -- Nothing
 -- >>> findMaybe (Text.Read.readMaybe @Int) ["foo", "34.40", "34", "abc"]
 -- Just 34
-findMaybe :: Foldable t => (a -> Maybe b) -> t a -> Maybe b
+findMaybe :: (Foldable t) => (a -> Maybe b) -> t a -> Maybe b
 findMaybe mPred list =
   let pred' x = Maybe.isJust $ mPred x
    in case Foldable.find pred' list of
@@ -455,13 +455,13 @@ traverseFold1 f xs = fold1 <$> traverse f xs
 --
 -- Uses the same trick as https://hackage.haskell.org/package/protolude-0.3.0/docs/src/Protolude.Error.html#error
 {-# WARNING todo "'todo' (undefined code) remains in code" #-}
-todo :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => a
+todo :: forall (r :: RuntimeRep). forall (a :: TYPE r). (HasCallStack) => a
 todo = raise# (errorCallWithCallStackException "This code was not yet implemented: TODO" ?callStack)
 
 -- | Convert an integer to a 'Natural' if possible
 --
 -- Named the same as the function from "GHC.Natural", but does not crash.
-intToNatural :: Integral a => a -> Maybe Natural
+intToNatural :: (Integral a) => a -> Maybe Natural
 intToNatural i =
   if i < 0
     then Nothing
@@ -560,7 +560,7 @@ inverseMap f =
 
 -- Sum {getSum = 6}
 
-ifTrue :: Monoid m => Bool -> m -> m
+ifTrue :: (Monoid m) => Bool -> m -> m
 ifTrue pred' m = if pred' then m else mempty
 
 -- | If the given @Maybe@ is @Just@, return the @m@, else return mempty.
@@ -570,18 +570,12 @@ ifTrue pred' m = if pred' then m else mempty
 -- >>> import Data.Monoid (Sum(..))
 --
 -- >>> :{ mconcat [
---   ifExists (Just [1]),
+-- unknown command '{'
---   [2, 3, 4],
---   ifExists Nothing,
--- ]
--- :}
--- [1,2,3,4]
 --
 -- Or any other Monoid:
 --
--- >>> mconcat [ Sum 1, ifExists (Just (Sum 2)), Sum 3 ]
+-- >>> mconcat [ Sum 1, ifExists Sum (Just 2), Sum 3 ]
-
 -- Sum {getSum = 6}
 
-ifExists :: Monoid m => Maybe m -> m
+ifExists :: (Monoid m) => (a -> m) -> Maybe a -> m
-ifExists = fold
+ifExists = foldMap

users/Profpatsch/my-prelude/src/Parse.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Parse where
+
+import Control.Category qualified
+import Control.Selective (Selective)
+import Data.Error.Tree
+import Data.Functor.Compose
+import Data.List qualified as List
+import Data.Monoid (First (..))
+import Data.Semigroup.Traversable
+import Data.Semigroupoid qualified as Semigroupoid
+import Data.Text qualified as Text
+import FieldParser (FieldParser)
+import FieldParser qualified as Field
+import PossehlAnalyticsPrelude
+import Validation (partitionValidations)
+import Prelude hiding (init, maybe)
+import Prelude qualified
+
+-- | 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 []))
+
+-- | 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 ..])