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