diff options
Diffstat (limited to 'users/Profpatsch/my-prelude')
| -rw-r--r-- | users/Profpatsch/my-prelude/default.nix | 1 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/my-prelude.cabal | 1 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/MyPrelude.hs | 28 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Parse.hs | 158 |
4 files changed, 171 insertions, 17 deletions
diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 5ed68026db50..7af3a899f30a 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/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 diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index 658c42728993..f9b0e11831cf 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -62,6 +62,7 @@ library Postgres.Decoder Postgres.MonadPostgres ValidationParseT + Parse Seconds Tool diff --git a/users/Profpatsch/my-prelude/src/MyPrelude.hs b/users/Profpatsch/my-prelude/src/MyPrelude.hs index 1be248d091a9..7857ace61fdb 100644 --- a/users/Profpatsch/my-prelude/src/MyPrelude.hs +++ b/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]), --- [2, 3, 4], --- ifExists Nothing, --- ] --- :} --- [1,2,3,4] +-- unknown command '{' -- -- 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 = fold +ifExists :: (Monoid m) => (a -> m) -> Maybe a -> m +ifExists = foldMap 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 ..]) |