mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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>
This commit is contained in:
Profpatsch 2023-10-15 23:03:43 +02:00 committed by clbot
parent c79c2f3557
commit df43454dc5
7 changed files with 176 additions and 167 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

153
users/Profpatsch/jbovlaste-sqlite/JbovlasteSqlite.hs
View file

@ -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,

1
users/Profpatsch/jbovlaste-sqlite/default.nix
View file

@ -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

1
users/Profpatsch/jbovlaste-sqlite/jbovlaste-sqlite.cabal
View file

@ -62,6 +62,7 @@ executable jbovlaste-sqlite
pa-label,
pa-error-tree,
pa-field-parser,
my-prelude,
containers,
selective,
semigroupoids,

1
users/Profpatsch/my-prelude/default.nix
View file

@ -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

1
users/Profpatsch/my-prelude/my-prelude.cabal
View file

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

28
users/Profpatsch/my-prelude/src/MyPrelude.hs
View file

@ -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

158
users/Profpatsch/my-prelude/src/Parse.hs Normal file
View file

@ -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 ..])