From df43454dc5cea21d173df7385c3576318cb71211 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sun, 15 Oct 2023 23:03:43 +0200 Subject: 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 Tested-by: BuildkiteCI Reviewed-by: Profpatsch --- users/Profpatsch/my-prelude/src/Parse.hs | 158 +++++++++++++++++++++++++++++++ 1 file changed, 158 insertions(+) create mode 100644 users/Profpatsch/my-prelude/src/Parse.hs (limited to 'users/Profpatsch/my-prelude/src/Parse.hs') diff --git a/users/Profpatsch/my-prelude/src/Parse.hs b/users/Profpatsch/my-prelude/src/Parse.hs new file mode 100644 index 000000000000..5b6cca0fd26f --- /dev/null +++ b/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 ..]) -- cgit 1.4.1