diff options
Diffstat (limited to 'users/Profpatsch')
| -rw-r--r-- | users/Profpatsch/jbovlaste-sqlite/JbovlasteSqlite.hs | 153 | ||||
| -rw-r--r-- | users/Profpatsch/jbovlaste-sqlite/default.nix | 1 | ||||
| -rw-r--r-- | users/Profpatsch/jbovlaste-sqlite/jbovlaste-sqlite.cabal | 1 | ||||
| -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 |
7 files changed, 176 insertions, 167 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, 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 ..]) |