From 57bab040edbad11689740487eb68de865862361b Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sun, 16 Jul 2023 22:10:48 +0200 Subject: chore(users/Profpatsch): move utils to my-prelude I want to use these in multiple projects. Change-Id: I5dfdad8614bc5835e59df06f724de78acae78d42 Reviewed-on: https://cl.tvl.fyi/c/depot/+/8971 Reviewed-by: Profpatsch Tested-by: BuildkiteCI --- users/Profpatsch/my-prelude/Aeson.hs | 188 ------- users/Profpatsch/my-prelude/MyPrelude.hs | 587 --------------------- users/Profpatsch/my-prelude/Pretty.hs | 91 ---- users/Profpatsch/my-prelude/RunCommand.hs | 162 ------ users/Profpatsch/my-prelude/Test.hs | 115 ---- users/Profpatsch/my-prelude/default.nix | 37 +- users/Profpatsch/my-prelude/my-prelude.cabal | 82 ++- users/Profpatsch/my-prelude/src/Aeson.hs | 176 ++++++ users/Profpatsch/my-prelude/src/MyPrelude.hs | 587 +++++++++++++++++++++ .../Profpatsch/my-prelude/src/Postgres/Decoder.hs | 58 ++ .../my-prelude/src/Postgres/MonadPostgres.hs | 379 +++++++++++++ users/Profpatsch/my-prelude/src/Pretty.hs | 91 ++++ users/Profpatsch/my-prelude/src/RunCommand.hs | 162 ++++++ users/Profpatsch/my-prelude/src/Test.hs | 115 ++++ users/Profpatsch/my-prelude/src/Tool.hs | 75 +++ .../Profpatsch/my-prelude/src/ValidationParseT.hs | 16 + .../whatcd-resolver/src/Postgres/Decoder.hs | 58 -- .../whatcd-resolver/src/Postgres/MonadPostgres.hs | 379 ------------- users/Profpatsch/whatcd-resolver/src/Tool.hs | 75 --- .../whatcd-resolver/src/ValidationParseT.hs | 16 - .../whatcd-resolver/whatcd-resolver.cabal | 37 +- 21 files changed, 1768 insertions(+), 1718 deletions(-) delete mode 100644 users/Profpatsch/my-prelude/Aeson.hs delete mode 100644 users/Profpatsch/my-prelude/MyPrelude.hs delete mode 100644 users/Profpatsch/my-prelude/Pretty.hs delete mode 100644 users/Profpatsch/my-prelude/RunCommand.hs delete mode 100644 users/Profpatsch/my-prelude/Test.hs create mode 100644 users/Profpatsch/my-prelude/src/Aeson.hs create mode 100644 users/Profpatsch/my-prelude/src/MyPrelude.hs create mode 100644 users/Profpatsch/my-prelude/src/Postgres/Decoder.hs create mode 100644 users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs create mode 100644 users/Profpatsch/my-prelude/src/Pretty.hs create mode 100644 users/Profpatsch/my-prelude/src/RunCommand.hs create mode 100644 users/Profpatsch/my-prelude/src/Test.hs create mode 100644 users/Profpatsch/my-prelude/src/Tool.hs create mode 100644 users/Profpatsch/my-prelude/src/ValidationParseT.hs delete mode 100644 users/Profpatsch/whatcd-resolver/src/Postgres/Decoder.hs delete mode 100644 users/Profpatsch/whatcd-resolver/src/Postgres/MonadPostgres.hs delete mode 100644 users/Profpatsch/whatcd-resolver/src/Tool.hs delete mode 100644 users/Profpatsch/whatcd-resolver/src/ValidationParseT.hs diff --git a/users/Profpatsch/my-prelude/Aeson.hs b/users/Profpatsch/my-prelude/Aeson.hs deleted file mode 100644 index ad095e1b43..0000000000 --- a/users/Profpatsch/my-prelude/Aeson.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GHC2021 #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} - -module Aeson where - -import Data.Aeson (Encoding, FromJSON (parseJSON), GFromJSON, GToEncoding, GToJSON, Options (fieldLabelModifier), ToJSON (toEncoding, toJSON), Value (..), Zero, defaultOptions, genericParseJSON, genericToEncoding, genericToJSON, withObject) -import Data.Aeson.BetterErrors qualified as Json -import Data.Aeson.Encoding qualified as Enc -import Data.Aeson.Key qualified as Key -import Data.Aeson.KeyMap qualified as KeyMap -import Data.Char qualified -import Data.Error.Tree -import Data.Foldable qualified as Foldable -import Data.Int (Int64) -import Data.List (isPrefixOf) -import Data.List qualified as List -import Data.Map.Strict qualified as Map -import Data.Maybe (catMaybes) -import Data.String (IsString (fromString)) -import Data.Text.Lazy qualified as Lazy -import Data.Vector qualified as Vector -import GHC.Generics (Generic (Rep)) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -import Label -import MyPrelude -import Test.Hspec (describe, it, shouldBe) -import Test.Hspec qualified as Hspec - --- | Convert a 'Json.ParseError' to a corresponding 'ErrorTree' -parseErrorTree :: Error -> Json.ParseError Error -> ErrorTree -parseErrorTree contextMsg errs = - errs - & Json.displayError prettyError - <&> newError - & nonEmpty - & \case - Nothing -> singleError contextMsg - Just errs' -> errorTree contextMsg errs' - --- | Parse a key from the object, à la 'Json.key', return a labelled value. --- --- We don’t provide a version that infers the json object key, --- since that conflates internal naming with the external API, which is dangerous. --- --- @@ --- do --- txt <- keyLabel @"myLabel" "jsonKeyName" Json.asText --- pure (txt :: Label "myLabel" Text) --- @@ -keyLabel :: - forall label err m a. - Monad m => - Text -> - Json.ParseT err m a -> - Json.ParseT err m (Label label a) -keyLabel = do - keyLabel' (Proxy @label) - --- | Parse a key from the object, à la 'Json.key', return a labelled value. --- Version of 'keyLabel' that requires a proxy. --- --- @@ --- do --- txt <- keyLabel' (Proxy @"myLabel") "jsonKeyName" Json.asText --- pure (txt :: Label "myLabel" Text) --- @@ -keyLabel' :: - forall label err m a. - Monad m => - Proxy label -> - Text -> - Json.ParseT err m a -> - Json.ParseT err m (Label label a) -keyLabel' Proxy key parser = label @label <$> Json.key key parser - --- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value. --- --- We don’t provide a version that infers the json object key, --- since that conflates internal naming with the external API, which is dangerous. --- --- @@ --- do --- txt <- keyLabelMay @"myLabel" "jsonKeyName" Json.asText --- pure (txt :: Label "myLabel" (Maybe Text)) --- @@ -keyLabelMay :: - forall label err m a. - Monad m => - Text -> - Json.ParseT err m a -> - Json.ParseT err m (Label label (Maybe a)) -keyLabelMay = do - keyLabelMay' (Proxy @label) - --- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value. --- Version of 'keyLabelMay' that requires a proxy. --- --- @@ --- do --- txt <- keyLabelMay' (Proxy @"myLabel") "jsonKeyName" Json.asText --- pure (txt :: Label "myLabel" (Maybe Text)) --- @@ -keyLabelMay' :: - forall label err m a. - Monad m => - Proxy label -> - Text -> - Json.ParseT err m a -> - Json.ParseT err m (Label label (Maybe a)) -keyLabelMay' Proxy key parser = label @label <$> Json.keyMay key parser - --- | Like 'Json.key', but allows a list of keys that are tried in order. --- --- This is intended for renaming keys in an object. --- The first key is the most up-to-date version of a key, the others are for backward-compatibility. --- --- If a key (new or old) exists, the inner parser will always be executed for that key. -keyRenamed :: Monad m => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m a -keyRenamed (newKey :| oldKeys) inner = - keyRenamedTryOldKeys oldKeys inner >>= \case - Nothing -> Json.key newKey inner - Just parse -> parse - --- | Like 'Json.keyMay', but allows a list of keys that are tried in order. --- --- This is intended for renaming keys in an object. --- The first key is the most up-to-date version of a key, the others are for backward-compatibility. --- --- If a key (new or old) exists, the inner parser will always be executed for that key. -keyRenamedMay :: Monad m => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m (Maybe a) -keyRenamedMay (newKey :| oldKeys) inner = - keyRenamedTryOldKeys oldKeys inner >>= \case - Nothing -> Json.keyMay newKey inner - Just parse -> Just <$> parse - --- | Helper function for 'keyRenamed' and 'keyRenamedMay' that returns the parser for the first old key that exists, if any. -keyRenamedTryOldKeys :: Monad m => [Text] -> Json.ParseT err m a -> Json.ParseT err m (Maybe (Json.ParseT err m a)) -keyRenamedTryOldKeys oldKeys inner = do - oldKeys & traverse tryOld <&> catMaybes <&> nonEmpty <&> \case - Nothing -> Nothing - Just (old :| _moreOld) -> Just old - where - tryOld key = - Json.keyMay key (pure ()) <&> \case - Just () -> Just $ Json.key key inner - Nothing -> Nothing - -test_keyRenamed :: Hspec.Spec -test_keyRenamed = do - describe "keyRenamed" $ do - let parser = keyRenamed ("new" :| ["old"]) Json.asText - let p = Json.parseValue @() parser - it "accepts the new key and the old key" $ do - p (Object (KeyMap.singleton "new" (String "text"))) - `shouldBe` (Right "text") - p (Object (KeyMap.singleton "old" (String "text"))) - `shouldBe` (Right "text") - it "fails with the old key in the error if the inner parser is wrong" $ do - p (Object (KeyMap.singleton "old" Null)) - `shouldBe` (Left (Json.BadSchema [Json.ObjectKey "old"] (Json.WrongType Json.TyString Null))) - it "fails with the new key in the error if the inner parser is wrong" $ do - p (Object (KeyMap.singleton "new" Null)) - `shouldBe` (Left (Json.BadSchema [Json.ObjectKey "new"] (Json.WrongType Json.TyString Null))) - it "fails if the key is missing" $ do - p (Object KeyMap.empty) - `shouldBe` (Left (Json.BadSchema [] (Json.KeyMissing "new"))) - describe "keyRenamedMay" $ do - let parser = keyRenamedMay ("new" :| ["old"]) Json.asText - let p = Json.parseValue @() parser - it "accepts the new key and the old key" $ do - p (Object (KeyMap.singleton "new" (String "text"))) - `shouldBe` (Right (Just "text")) - p (Object (KeyMap.singleton "old" (String "text"))) - `shouldBe` (Right (Just "text")) - it "allows the old and new key to be missing" $ do - p (Object KeyMap.empty) - `shouldBe` (Right Nothing) - --- | Create a json array from a list of json values. -jsonArray :: [Value] -> Value -jsonArray xs = xs & Vector.fromList & Array diff --git a/users/Profpatsch/my-prelude/MyPrelude.hs b/users/Profpatsch/my-prelude/MyPrelude.hs deleted file mode 100644 index 1be248d091..0000000000 --- a/users/Profpatsch/my-prelude/MyPrelude.hs +++ /dev/null @@ -1,587 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fexpose-all-unfoldings #-} - -module MyPrelude - ( -- * Text conversions - Text, - ByteString, - Word8, - fmt, - textToString, - stringToText, - showToText, - textToBytesUtf8, - textToBytesUtf8Lazy, - bytesToTextUtf8, - bytesToTextUtf8Lazy, - bytesToTextUtf8Lenient, - bytesToTextUtf8LenientLazy, - bytesToTextUtf8Unsafe, - bytesToTextUtf8UnsafeLazy, - toStrict, - toLazy, - toStrictBytes, - toLazyBytes, - charToWordUnsafe, - - -- * IO - putStrLn, - putStderrLn, - exitWithMessage, - - -- * WIP code - todo, - - -- * Records - HasField, - - -- * Control flow - (&), - (<&>), - (<|>), - foldMap1, - foldMap', - join, - when, - unless, - guard, - ExceptT (..), - runExceptT, - MonadThrow, - throwM, - MonadIO, - liftIO, - MonadReader, - asks, - Bifunctor, - first, - second, - bimap, - both, - foldMap, - fold, - foldl', - fromMaybe, - mapMaybe, - findMaybe, - Traversable, - for, - for_, - traverse, - traverse_, - traverseFold, - traverseFold1, - traverseFoldDefault, - MonadTrans, - lift, - - -- * Data types - Coercible, - coerce, - Proxy (Proxy), - Map, - annotate, - Validation (Success, Failure), - failure, - successes, - failures, - eitherToValidation, - eitherToListValidation, - validationToEither, - These (This, That, These), - eitherToThese, - eitherToListThese, - validationToThese, - thenThese, - thenValidate, - NonEmpty ((:|)), - singleton, - nonEmpty, - nonEmptyDef, - toList, - toNonEmptyDefault, - maximum1, - minimum1, - Generic, - Semigroup, - sconcat, - Monoid, - mconcat, - ifTrue, - ifExists, - Void, - absurd, - Identity (Identity, runIdentity), - Natural, - intToNatural, - Contravariant, - contramap, - (>$<), - (>&<), - Profunctor, - dimap, - lmap, - rmap, - Semigroupoid, - Category, - (>>>), - (&>>), - - -- * Enum definition - inverseFunction, - inverseMap, - - -- * Error handling - HasCallStack, - module Data.Error, - ) -where - -import Control.Applicative ((<|>)) -import Control.Category (Category, (>>>)) -import Control.Monad (guard, join, unless, when) -import Control.Monad.Catch (MonadThrow (throwM)) -import Control.Monad.Except - ( ExceptT (..), - runExceptT, - ) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Identity (Identity (Identity)) -import Control.Monad.Reader (MonadReader, asks) -import Control.Monad.Trans (MonadTrans (lift)) -import Data.Bifunctor (Bifunctor, bimap, first, second) -import Data.ByteString - ( ByteString, - ) -import Data.ByteString.Lazy qualified -import Data.Char qualified -import Data.Coerce (Coercible, coerce) -import Data.Data (Proxy (Proxy)) -import Data.Error -import Data.Foldable (Foldable (foldMap', toList), fold, foldl', for_, traverse_) -import Data.Foldable qualified as Foldable -import Data.Function ((&)) -import Data.Functor ((<&>)) -import Data.Functor.Contravariant (Contravariant (contramap), (>$<)) -import Data.Functor.Identity (Identity (runIdentity)) -import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) -import Data.Map.Strict - ( Map, - ) -import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Maybe qualified as Maybe -import Data.Profunctor (Profunctor, dimap, lmap, rmap) -import Data.Semigroup (Max (Max, getMax), Min (Min, getMin), sconcat) -import Data.Semigroup.Foldable (Foldable1 (fold1), foldMap1) -import Data.Semigroup.Traversable (Traversable1) -import Data.Semigroupoid (Semigroupoid (o)) -import Data.Text - ( Text, - ) -import Data.Text qualified -import Data.Text.Encoding qualified -import Data.Text.Encoding.Error qualified -import Data.Text.Lazy qualified -import Data.Text.Lazy.Encoding qualified -import Data.These (These (That, These, This)) -import Data.Traversable (for) -import Data.Void (Void, absurd) -import Data.Word (Word8) -import GHC.Exception (errorCallWithCallStackException) -import GHC.Exts (RuntimeRep, TYPE, raise#) -import GHC.Generics (Generic) -import GHC.Natural (Natural) -import GHC.Records (HasField) -import GHC.Stack (HasCallStack) -import PyF (fmt) -import System.Exit qualified -import System.IO qualified -import Validation - ( Validation (Failure, Success), - eitherToValidation, - failure, - failures, - successes, - validationToEither, - ) - --- | Forward-applying 'contramap', like '&'/'$' and '<&>'/'<$>' but for '>$<'. -(>&<) :: Contravariant f => f b -> (a -> b) -> f a -(>&<) = flip contramap - -infixl 5 >&< - --- | Forward semigroupoid application. The same as '(>>>)', but 'Semigroupoid' is not a superclass of 'Category' (yet). --- --- Specialized examples: --- --- @@ --- 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 -(&>>) = flip Data.Semigroupoid.o - --- like >>> -infixr 1 &>> - --- | encode a Text to a UTF-8 encoded Bytestring -textToBytesUtf8 :: Text -> ByteString -textToBytesUtf8 = Data.Text.Encoding.encodeUtf8 - --- | encode a lazy Text to a UTF-8 encoded lazy Bytestring -textToBytesUtf8Lazy :: Data.Text.Lazy.Text -> Data.ByteString.Lazy.ByteString -textToBytesUtf8Lazy = Data.Text.Lazy.Encoding.encodeUtf8 - -bytesToTextUtf8 :: ByteString -> Either Error Text -bytesToTextUtf8 = first exceptionToError . Data.Text.Encoding.decodeUtf8' - -bytesToTextUtf8Lazy :: Data.ByteString.Lazy.ByteString -> Either Error Data.Text.Lazy.Text -bytesToTextUtf8Lazy = first exceptionToError . Data.Text.Lazy.Encoding.decodeUtf8' - --- | decode a Text from a ByteString that is assumed to be UTF-8 (crash if that is not the case) -bytesToTextUtf8Unsafe :: ByteString -> Text -bytesToTextUtf8Unsafe = Data.Text.Encoding.decodeUtf8 - --- | decode a Text from a ByteString that is assumed to be UTF-8 (crash if that is not the case) -bytesToTextUtf8UnsafeLazy :: Data.ByteString.Lazy.ByteString -> Data.Text.Lazy.Text -bytesToTextUtf8UnsafeLazy = Data.Text.Lazy.Encoding.decodeUtf8 - --- | decode a Text from a ByteString that is assumed to be UTF-8, --- replace non-UTF-8 characters with the replacment char U+FFFD. -bytesToTextUtf8Lenient :: Data.ByteString.ByteString -> Data.Text.Text -bytesToTextUtf8Lenient = - Data.Text.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode - --- | decode a lazy Text from a lazy ByteString that is assumed to be UTF-8, --- replace non-UTF-8 characters with the replacment char U+FFFD. -bytesToTextUtf8LenientLazy :: Data.ByteString.Lazy.ByteString -> Data.Text.Lazy.Text -bytesToTextUtf8LenientLazy = - Data.Text.Lazy.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode - --- | Make a lazy text strict -toStrict :: Data.Text.Lazy.Text -> Text -toStrict = Data.Text.Lazy.toStrict - --- | Make a strict text lazy -toLazy :: Text -> Data.Text.Lazy.Text -toLazy = Data.Text.Lazy.fromStrict - -toStrictBytes :: Data.ByteString.Lazy.ByteString -> ByteString -toStrictBytes = Data.ByteString.Lazy.toStrict - -toLazyBytes :: ByteString -> Data.ByteString.Lazy.ByteString -toLazyBytes = Data.ByteString.Lazy.fromStrict - -textToString :: Text -> String -textToString = Data.Text.unpack - -stringToText :: String -> Text -stringToText = Data.Text.pack - -showToText :: (Show a) => a -> Text -showToText = stringToText . show - --- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and --- silently truncates to 8 bits Chars > '\255'. It is provided as --- convenience for ByteString construction. --- --- Use if you want to get the 'Word8' representation of a character literal. --- Don’t use on arbitrary characters! --- --- >>> charToWordUnsafe ',' --- 44 -charToWordUnsafe :: Char -> Word8 -charToWordUnsafe = fromIntegral . Data.Char.ord -{-# INLINE charToWordUnsafe #-} - --- | Single element in a (non-empty) list. -singleton :: a -> NonEmpty a -singleton a = a :| [] - --- | If the given list is empty, use the given default element and return a non-empty list. -nonEmptyDef :: a -> [a] -> NonEmpty a -nonEmptyDef def xs = - xs & nonEmpty & \case - Nothing -> def :| [] - Just ne -> ne - --- | Construct a non-empty list, given a default value if the ist list was empty. -toNonEmptyDefault :: a -> [a] -> NonEmpty a -toNonEmptyDefault def xs = case xs of - [] -> def :| [] - (x : xs') -> x :| xs' - --- | @O(n)@. Get the maximum element from a non-empty structure. -maximum1 :: (Foldable1 f, Ord a) => f a -> a -maximum1 xs = xs & foldMap1 Max & getMax - --- | @O(n)@. Get the minimum element from a non-empty structure. -minimum1 :: (Foldable1 f, Ord a) => f a -> a -minimum1 xs = xs & foldMap1 Min & getMin - --- | Annotate a 'Maybe' with an error message and turn it into an 'Either'. -annotate :: err -> Maybe a -> Either err a -annotate err = \case - Nothing -> Left err - 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 f = bimap f f - --- | Find the first element for which pred returns `Just a`, and return the `a`. --- --- Example: --- @ --- >>> :set -XTypeApplications --- >>> import qualified Text.Read --- --- >>> findMaybe (Text.Read.readMaybe @Int) ["foo"] --- Nothing --- >>> findMaybe (Text.Read.readMaybe @Int) ["foo", "34.40", "34", "abc"] --- Just 34 -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 - Just a -> mPred a - Nothing -> Nothing - --- | Like 'eitherToValidation', but puts the Error side into a NonEmpty list --- to make it combine with other validations. -eitherToListValidation :: Either a c -> Validation (NonEmpty a) c -eitherToListValidation = first singleton . eitherToValidation - --- | Convert an 'Either' to a 'These'. -eitherToThese :: Either err a -> These err a -eitherToThese (Left err) = This err -eitherToThese (Right a) = That a - --- | Like 'eitherToThese', but puts the Error side into a NonEmpty list --- to make it combine with other theses. -eitherToListThese :: Either err a -> These (NonEmpty err) a -eitherToListThese (Left e) = This (singleton e) -eitherToListThese (Right a) = That a - --- | Convert a 'Validation' to a 'These'. -validationToThese :: Validation err a -> These err a -validationToThese (Failure err) = This err -validationToThese (Success a) = That a - --- | Nested '>>=' of a These inside some other @m@. --- --- Use if you want to collect errors and successes, and want to chain multiple function returning 'These'. -thenThese :: - (Monad m, Semigroup err) => - (a -> m (These err b)) -> - m (These err a) -> - m (These err b) -thenThese f x = do - th <- x - join <$> traverse f th - --- | Nested validating bind-like combinator inside some other @m@. --- --- Use if you want to collect errors, and want to chain multiple functions returning 'Validation'. -thenValidate :: - (Monad m) => - (a -> m (Validation err b)) -> - m (Validation err a) -> - m (Validation err b) -thenValidate f x = - eitherToValidation <$> do - x' <- validationToEither <$> x - case x' of - Left err -> pure $ Left err - Right a -> validationToEither <$> f a - --- | Put the text to @stderr@. -putStderrLn :: Text -> IO () -putStderrLn msg = - System.IO.hPutStrLn System.IO.stderr $ textToString msg - -exitWithMessage :: Text -> IO a -exitWithMessage msg = do - putStderrLn msg - System.Exit.exitWith $ System.Exit.ExitFailure (-1) - --- | Run some function producing applicative over a traversable data structure, --- then collect the results in a Monoid. --- --- Very helpful with side-effecting functions returning @(Validation err a)@: --- --- @ --- let --- f :: Text -> IO (Validation (NonEmpty Error) Text) --- f t = pure $ if t == "foo" then Success t else Failure (singleton ("not foo: " <> t)) --- --- in traverseFold f [ "foo", "bar", "baz" ] --- == Failure ("not foo bar" :| ["not foo baz"]) --- @ --- --- … since @(Semigroup err => Validation err a)@ is a @Semigroup@/@Monoid@ itself. -traverseFold :: (Applicative ap, Traversable t, Monoid m) => (a -> ap m) -> t a -> ap m -traverseFold f xs = - -- note: could be weakened to (Foldable t) via `getAp . foldMap (Ap . f)` - fold <$> traverse f xs -{-# INLINE traverseFold #-} - --- | Like 'traverseFold', but fold over a semigroup instead of a Monoid, by providing a starting element. -traverseFoldDefault :: (Applicative ap, Traversable t, Semigroup m) => m -> (a -> ap m) -> t a -> ap m -traverseFoldDefault def f xs = foldDef def <$> traverse f xs - where - foldDef = foldr (<>) -{-# INLINE traverseFoldDefault #-} - --- | Same as 'traverseFold', but with a 'Semigroup' and 'Traversable1' restriction. -traverseFold1 :: (Applicative ap, Traversable1 t, Semigroup s) => (a -> ap s) -> t a -> ap s --- note: cannot be weakened to (Foldable1 t) because there is no `Ap` for Semigroup (No `Apply` typeclass) -traverseFold1 f xs = fold1 <$> traverse f xs -{-# INLINE traverseFold1 #-} - --- | Use this in places where the code is still to be implemented. --- --- It always type-checks and will show a warning at compile time if it was forgotten in the code. --- --- Use instead of 'error' and 'undefined' for code that hasn’t been written. --- --- 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 = 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 i = - if i < 0 - then Nothing - else Just $ fromIntegral i - --- | @inverseFunction f@ creates a function that is the inverse of a given function --- @f@. It does so by constructing 'M.Map' internally for each value @f a@. The --- implementation makes sure that the 'M.Map' is constructed only once and then --- shared for every call. --- --- __Memory usage note:__ don't inverse functions that have types like 'Int' --- as their result. In this case the created 'M.Map' will have huge size. --- --- The complexity of reversed mapping is \(\mathcal{O}(\log n)\). --- --- __Performance note:__ make sure to specialize monomorphic type of your functions --- that use 'inverseFunction' to avoid 'M.Map' reconstruction. --- --- One of the common 'inverseFunction' use-case is inverting the 'show' or a 'show'-like --- function. --- --- >>> data Color = Red | Green | Blue deriving (Show, Enum, Bounded) --- >>> parse = inverseFunction show :: String -> Maybe Color --- >>> parse "Red" --- Just Red --- >>> parse "Black" --- Nothing --- --- __Correctness note:__ 'inverseFunction' expects /injective function/ as its argument, --- i.e. the function must map distinct arguments to distinct values. --- --- Typical usage of this function looks like this: --- --- @ --- __data__ GhcVer --- = Ghc802 --- | Ghc822 --- | Ghc844 --- | Ghc865 --- | Ghc881 --- __deriving__ ('Eq', 'Ord', 'Show', 'Enum', 'Bounded') --- --- showGhcVer :: GhcVer -> 'Text' --- showGhcVer = \\__case__ --- Ghc802 -> "8.0.2" --- Ghc822 -> "8.2.2" --- Ghc844 -> "8.4.4" --- Ghc865 -> "8.6.5" --- Ghc881 -> "8.8.1" --- --- parseGhcVer :: 'Text' -> 'Maybe' GhcVer --- parseGhcVer = 'inverseFunction' showGhcVer --- --- Taken from relude’s @Relude.Extra.Enum@. -inverseFunction :: - forall a k. - (Bounded a, Enum a, Ord k) => - (a -> k) -> - (k -> Maybe a) -inverseFunction f k = Map.lookup k $ inverseMap f - --- | Like `inverseFunction`, but instead of returning the function --- it returns a mapping from all possible outputs to their possible inputs. --- --- This has the same restrictions of 'inverseFunction'. -inverseMap :: - forall a k. - (Bounded a, Enum a, Ord k) => - (a -> k) -> - Map k a -inverseMap f = - universe - <&> (\a -> (f a, a)) - & Map.fromList - where - universe :: [a] - universe = [minBound .. maxBound] - --- | If the predicate is true, return the @m@, else 'mempty'. --- --- This can be used (together with `ifExists`) to e.g. create lists with optional elements: --- --- >>> import Data.Monoid (Sum(..)) --- --- >>> :{ mconcat [ --- ifTrue (1 == 1) [1], --- [2, 3, 4], --- ifTrue False [5], --- ] --- :} --- [1,2,3,4] --- --- Or any other Monoid: --- --- >>> mconcat [ Sum 1, ifTrue (1 == 1) (Sum 2), Sum 3 ] - --- Sum {getSum = 6} - -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. - --- This can be used (together with `ifTrue`) to e.g. create lists with optional elements: --- --- >>> import Data.Monoid (Sum(..)) --- --- >>> :{ mconcat [ --- ifExists (Just [1]), --- [2, 3, 4], --- ifExists Nothing, --- ] --- :} --- [1,2,3,4] --- --- Or any other Monoid: --- --- >>> mconcat [ Sum 1, ifExists (Just (Sum 2)), Sum 3 ] - --- Sum {getSum = 6} - -ifExists :: Monoid m => Maybe m -> m -ifExists = fold diff --git a/users/Profpatsch/my-prelude/Pretty.hs b/users/Profpatsch/my-prelude/Pretty.hs deleted file mode 100644 index 8046c83e45..0000000000 --- a/users/Profpatsch/my-prelude/Pretty.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE LambdaCase #-} - -module Pretty - ( -- * Pretty printing for error messages - Err, - printPretty, - showPretty, - -- constructors hidden - prettyErrs, - message, - messageString, - pretty, - prettyString, - hscolour', - ) -where - -import Data.List qualified as List -import Data.Text qualified as Text -import Language.Haskell.HsColour - ( Output (TTYg), - hscolour, - ) -import Language.Haskell.HsColour.ANSI (TerminalType (..)) -import Language.Haskell.HsColour.Colourise - ( defaultColourPrefs, - ) -import MyPrelude -import System.Console.ANSI (setSGRCode) -import System.Console.ANSI.Types - ( Color (Red), - ColorIntensity (Dull), - ConsoleLayer (Foreground), - SGR (Reset, SetColor), - ) -import Text.Nicify (nicify) - --- | Print any 'Show'able type to stderr, formatted nicely and in color. Very helpful for debugging. -printPretty :: Show a => a -> IO () -printPretty a = - a & pretty & (: []) & prettyErrs & stringToText & putStderrLn - -showPretty :: Show a => a -> Text -showPretty a = a & pretty & (: []) & prettyErrs & stringToText - --- | Display a list of 'Err's as a colored error message --- and abort the test. -prettyErrs :: [Err] -> String -prettyErrs errs = res - where - res = List.intercalate "\n" $ map one errs - one = \case - ErrMsg s -> color Red s - ErrPrettyString s -> prettyShowString s - -- Pretty print a String that was produced by 'show' - prettyShowString :: String -> String - prettyShowString = hscolour' . nicify - --- | Small DSL for pretty-printing errors -data Err - = -- | Message to display in the error - ErrMsg String - | -- | Pretty print a String that was produced by 'show' - ErrPrettyString String - --- | Plain message to display, as 'Text' -message :: Text -> Err -message = ErrMsg . Text.unpack - --- | Plain message to display, as 'String' -messageString :: String -> Err -messageString = ErrMsg - --- | Any 'Show'able to pretty print -pretty :: Show a => a -> Err -pretty x = ErrPrettyString $ show x - --- | Pretty print a String that was produced by 'show' -prettyString :: String -> Err -prettyString s = ErrPrettyString s - --- Prettifying Helpers, mostly stolen from --- https://hackage.haskell.org/package/hspec-expectations-pretty-diff-0.7.2.5/docs/src/Test.Hspec.Expectations.Pretty.html#prettyColor - -hscolour' :: String -> String -hscolour' = - hscolour (TTYg Ansi16Colour) defaultColourPrefs False False "" False - -color :: Color -> String -> String -color c s = setSGRCode [SetColor Foreground Dull c] ++ s ++ setSGRCode [Reset] diff --git a/users/Profpatsch/my-prelude/RunCommand.hs b/users/Profpatsch/my-prelude/RunCommand.hs deleted file mode 100644 index 5c80eb3aac..0000000000 --- a/users/Profpatsch/my-prelude/RunCommand.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -module RunCommand where - -import Data.ByteString qualified as ByteString -import Data.ByteString.Lazy qualified as Bytes.Lazy -import Data.Char qualified as Char -import Data.List qualified as List -import Data.Text qualified as Text -import MyPrelude -import System.Exit qualified as Exit -import System.IO (Handle) -import System.Process.Typed qualified as Process -import Prelude hiding (log) - --- | Given a a command, the executable and arguments, --- spawn the tool as subprocess and collect its stdout (stderr will go to our stderr). - --- Will strip the stdout of trailing newlines. --- --- If the executable is not a path, it will be resolved via the @PATH@ environment variable. -runCommand :: MonadIO m => FilePath -> [Text] -> m (Exit.ExitCode, ByteString) -runCommand executable args = do - let bashArgs = prettyArgsForBash ((executable & stringToText) : args) - log [fmt|Running: $ {bashArgs}|] - Process.proc - executable - (args <&> textToString) - & Process.readProcessStdout - <&> second toStrictBytes - <&> second stripWhitespaceFromEnd - --- | Given a a command, the executable and arguments, --- spawn the tool as subprocess and run it to conclusion. --- --- If the executable is not a path, it will be resolved via the @PATH@ environment variable. -runCommandNoStdout :: MonadIO m => FilePath -> [Text] -> m Exit.ExitCode -runCommandNoStdout executable args = do - let bashArgs = prettyArgsForBash ((executable & stringToText) : args) - log [fmt|Running: $ {bashArgs}|] - Process.proc - executable - (args <&> textToString) - & Process.runProcess - --- TODO: This is reversing the whole string *twice*. Can we strip from end without doing that? -stripWhitespaceFromEnd :: ByteString -> ByteString -stripWhitespaceFromEnd = ByteString.reverse . ByteString.dropWhile (\w -> w == charToWordUnsafe '\n') . ByteString.reverse - --- | Like `runCommand`, but takes a Bytestring that provides the command with streamed input on stdin. -runCommandWithStdin :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m (Exit.ExitCode, ByteString) -runCommandWithStdin executable args stdin = do - let bashArgs = prettyArgsForBash ((executable & stringToText) : args) - log [fmt|Running: $ {bashArgs}|] - Process.proc - executable - (args <&> textToString) - & Process.setStdin (Process.byteStringInput stdin) - & Process.readProcessStdout - <&> second toStrictBytes - <&> second stripWhitespaceFromEnd - --- | Like `runCommand`, but takes a Bytestring that provides the command with streamed input on stdin. -runCommandWithStdinNoStdout :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m Exit.ExitCode -runCommandWithStdinNoStdout executable args stdin = do - let bashArgs = prettyArgsForBash ((executable & stringToText) : args) - log [fmt|Running: $ {bashArgs}|] - Process.proc - executable - (args <&> textToString) - & Process.setStdin (Process.byteStringInput stdin) - & Process.runProcess - --- | Like 'runCommandWithStdin' but exit if the command returns a non-0 status. -runCommandWithStdinExpect0 :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m ByteString -runCommandWithStdinExpect0 executable args stdin = - runCommandWithStdin executable args stdin >>= \case - (ex, stdout) -> do - checkStatus0 executable ex - pure stdout - --- | Like 'runCommandWithStdinNoStdout' but exit if the command returns a non-0 status. -runCommandWithStdinNoStdoutExpect0 :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m () -runCommandWithStdinNoStdoutExpect0 executable args stdin = - runCommandWithStdinNoStdout executable args stdin - >>= checkStatus0 executable - --- | Like 'runCommandExpect0', but don’t capture stdout, --- connect stdin and stdout to the command until it returns. --- --- This is for interactive subcommands. -runCommandInteractiveExpect0 :: MonadIO m => FilePath -> [Text] -> m () -runCommandInteractiveExpect0 executable args = do - let bashArgs = prettyArgsForBash ((executable & stringToText) : args) - log [fmt|Running interactively: $ {bashArgs}|] - ( liftIO $ - Process.runProcess $ - Process.proc - executable - (args <&> textToString) - ) - >>= checkStatus0 executable - --- | Given a name of a command, the executable and arguments, --- spawn the tool as subprocess and pipe its stdout to the given 'Handle'. --- --- If the executable is not a path, it will be resolved via the @PATH@ environment variable. -runCommandPipeToHandle :: MonadIO m => FilePath -> [Text] -> Handle -> m Exit.ExitCode -runCommandPipeToHandle executable args handle = do - -- TODO log the output file? - let bashArgs = prettyArgsForBash ((executable & stringToText) : args) - log [fmt|Running: $ {bashArgs}|] - liftIO $ - Process.runProcess - ( Process.proc - executable - (args <&> textToString) - & Process.setStdout (Process.useHandleClose handle) - ) - --- | Check whether a command exited 0 or crash. -checkStatus0 :: MonadIO m => FilePath -> Exit.ExitCode -> m () -checkStatus0 executable = \case - Exit.ExitSuccess -> pure () - Exit.ExitFailure status -> do - logCritical [fmt|Command `{executable}` did not exit with status 0 (success), but status {status}|] - -log :: MonadIO m => Text -> m () -log = liftIO . putStderrLn - --- | Log the message on the normal logging level & exit the program -logCritical :: MonadIO m => Text -> m b -logCritical msg = do - liftIO $ putStderrLn msg - liftIO $ Exit.exitWith (Exit.ExitFailure 1) - --- | Pretty print a command line in a way that can be copied to bash. -prettyArgsForBash :: [Text] -> Text -prettyArgsForBash = Text.intercalate " " . map simpleBashEscape - --- | Simple escaping for bash words. If they contain anything that’s not ascii chars --- and a bunch of often-used special characters, put the word in single quotes. -simpleBashEscape :: Text -> Text -simpleBashEscape t = do - case Text.find (not . isSimple) t of - Just _ -> escapeSingleQuote t - Nothing -> t - where - -- any word that is just ascii characters is simple (no spaces or control characters) - -- or contains a few often-used characters like - or . - isSimple c = - Char.isAsciiLower c - || Char.isAsciiUpper c - || Char.isDigit c - -- These are benign, bash will not interpret them as special characters. - || List.elem c ['-', '.', ':', '/'] - -- Put the word in single quotes - -- If there is a single quote in the word, - -- close the single quoted word, add a single quote, open the word again - escapeSingleQuote t' = "'" <> Text.replace "'" "'\\''" t' <> "'" diff --git a/users/Profpatsch/my-prelude/Test.hs b/users/Profpatsch/my-prelude/Test.hs deleted file mode 100644 index 862ee16c25..0000000000 --- a/users/Profpatsch/my-prelude/Test.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -{- Generate Test suites. - -Restricted version of hspec, introduction: http://hspec.github.io/getting-started.html --} -module Test - ( Spec, - runTest, - testMain, - - -- * Structure - describe, - it, - - -- * Expectations - Expectation, - testOk, - testErr, - shouldBe, - shouldNotBe, - shouldSatisfy, - shouldNotSatisfy, - - -- * Setup & Teardown (hooks http://hspec.github.io/writing-specs.html#using-hooks) - before, - before_, - beforeWith, - beforeAll, - beforeAll_, - beforeAllWith, - after, - after_, - afterAll, - afterAll_, - around, - around_, - aroundWith, - aroundAll, - aroundAllWith, - - -- * Common helpful predicates (use with 'shouldSatisfy') - isRight, - isLeft, - - -- * Pretty printing of errors - errColored, - module Pretty, - ) -where - --- export more expectations if needed - -import Data.Either - ( isLeft, - isRight, - ) -import Pretty -import Test.Hspec - ( Expectation, - HasCallStack, - Spec, - after, - afterAll, - afterAll_, - after_, - around, - aroundAll, - aroundAllWith, - aroundWith, - around_, - before, - beforeAll, - beforeAllWith, - beforeAll_, - beforeWith, - before_, - describe, - hspec, - it, - ) -import Test.Hspec.Expectations.Pretty - ( expectationFailure, - shouldBe, - shouldNotBe, - shouldNotSatisfy, - shouldSatisfy, - ) - --- | Run a test directly (e.g. from the repl) -runTest :: Spec -> IO () -runTest = hspec - --- | Run a testsuite -testMain :: - -- | Name of the test suite - String -> - -- | The tests in this test module - Spec -> - IO () -testMain testSuiteName tests = hspec $ describe testSuiteName tests - --- | test successful -testOk :: Expectation -testOk = pure () - --- | Abort the test with an error message. --- If you want to display a Haskell type, use `errColored`. -testErr :: HasCallStack => String -> Expectation -testErr = expectationFailure - --- | Display a list of 'Err's as a colored error message --- and abort the test. -errColored :: [Pretty.Err] -> Expectation -errColored = testErr . Pretty.prettyErrs diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 0c582c9585..c046c213bd 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/users/Profpatsch/my-prelude/default.nix @@ -6,34 +6,43 @@ pkgs.haskellPackages.mkDerivation { src = depot.users.Profpatsch.exactSource ./. [ ./my-prelude.cabal - ./MyPrelude.hs - ./Pretty.hs - ./Aeson.hs - ./RunCommand.hs - ./Test.hs + ./src/Aeson.hs + ./src/MyPrelude.hs + ./src/Pretty.hs + ./src/RunCommand.hs + ./src/Test.hs + ./src/Tool.hs + ./src/ValidationParseT.hs + ./src/Postgres/Decoder.hs + ./src/Postgres/MonadPostgres.hs ]; isLibrary = true; libraryHaskellDepends = [ + pkgs.haskellPackages.pa-prelude pkgs.haskellPackages.pa-label pkgs.haskellPackages.pa-error-tree - pkgs.haskellPackages.aeson + pkgs.haskellPackages.pa-json pkgs.haskellPackages.aeson-better-errors - pkgs.haskellPackages.PyF - pkgs.haskellPackages.errors - pkgs.haskellPackages.profunctors - pkgs.haskellPackages.semigroupoids - pkgs.haskellPackages.these - pkgs.haskellPackages.validation-selective + pkgs.haskellPackages.ansi-terminal pkgs.haskellPackages.error + pkgs.haskellPackages.hscolour pkgs.haskellPackages.hspec pkgs.haskellPackages.hspec-expectations-pretty-diff - pkgs.haskellPackages.hscolour + pkgs.haskellPackages.monad-logger pkgs.haskellPackages.nicify-lib + pkgs.haskellPackages.postgresql-simple + pkgs.haskellPackages.profunctors + pkgs.haskellPackages.PyF + pkgs.haskellPackages.semigroupoids + pkgs.haskellPackages.these pkgs.haskellPackages.typed-process - pkgs.haskellPackages.ansi-terminal + pkgs.haskellPackages.unliftio + pkgs.haskellPackages.validation-selective pkgs.haskellPackages.vector + + ]; license = lib.licenses.mit; diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index fad13300a2..3a4a06d165 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -4,13 +4,66 @@ version: 0.0.1.0 author: Profpatsch maintainer: mail@profpatsch.de +common common-options + ghc-options: + -Wall + -Wno-type-defaults + -Wunused-packages + -Wredundant-constraints + -fwarn-missing-deriving-strategies + + -- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html + -- for a description of all these extensions + default-extensions: + -- Infer Applicative instead of Monad where possible + ApplicativeDo + + -- Allow literal strings to be Text + OverloadedStrings + + -- Syntactic sugar improvements + LambdaCase + MultiWayIf + + -- Makes the (deprecated) usage of * instead of Data.Kind.Type an error + NoStarIsType + + -- Convenient and crucial to deal with ambiguous field names, commonly + -- known as RecordDotSyntax + OverloadedRecordDot + + -- does not export record fields as functions, use OverloadedRecordDot to access instead + NoFieldSelectors + + -- Record punning + RecordWildCards + + -- Improved Deriving + DerivingStrategies + DerivingVia + + -- Type-level strings + DataKinds + + -- to enable the `type` keyword in import lists (ormolu uses this automatically) + ExplicitNamespaces + + default-language: GHC2021 + + library + import: common-options + hs-source-dirs: src exposed-modules: MyPrelude Pretty Aeson RunCommand Test + Postgres.Decoder + Postgres.MonadPostgres + ValidationParseT + Tool -- Modules included in this executable, other than Main. -- other-modules: @@ -19,26 +72,33 @@ library -- other-extensions: build-depends: base >=4.15 && <5 + , pa-prelude , pa-label , pa-error-tree + , pa-json , aeson , aeson-better-errors - , PyF - , validation-selective - , these - , text - , semigroupoids - , profunctors + , ansi-terminal + , bytestring , containers , error , exceptions - , bytestring - , mtl + , filepath + , hscolour , hspec , hspec-expectations-pretty-diff - , hscolour + , monad-logger + , mtl , nicify-lib + , postgresql-simple + , profunctors + , PyF + , semigroupoids + , selective + , text + , these , typed-process - , ansi-terminal + , unix + , unliftio + , validation-selective , vector - default-language: GHC2021 diff --git a/users/Profpatsch/my-prelude/src/Aeson.hs b/users/Profpatsch/my-prelude/src/Aeson.hs new file mode 100644 index 0000000000..73d6116082 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Aeson.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module Aeson where + +import Data.Aeson (Value (..)) +import Data.Aeson.BetterErrors qualified as Json +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Error.Tree +import Data.Maybe (catMaybes) +import Data.Vector qualified as Vector +import Label +import PossehlAnalyticsPrelude +import Test.Hspec (describe, it, shouldBe) +import Test.Hspec qualified as Hspec + +-- | Convert a 'Json.ParseError' to a corresponding 'ErrorTree' +parseErrorTree :: Error -> Json.ParseError Error -> ErrorTree +parseErrorTree contextMsg errs = + errs + & Json.displayError prettyError + <&> newError + & nonEmpty + & \case + Nothing -> singleError contextMsg + Just errs' -> errorTree contextMsg errs' + +-- | Parse a key from the object, à la 'Json.key', return a labelled value. +-- +-- We don’t provide a version that infers the json object key, +-- since that conflates internal naming with the external API, which is dangerous. +-- +-- @@ +-- do +-- txt <- keyLabel @"myLabel" "jsonKeyName" Json.asText +-- pure (txt :: Label "myLabel" Text) +-- @@ +keyLabel :: + forall label err m a. + Monad m => + Text -> + Json.ParseT err m a -> + Json.ParseT err m (Label label a) +keyLabel = do + keyLabel' (Proxy @label) + +-- | Parse a key from the object, à la 'Json.key', return a labelled value. +-- Version of 'keyLabel' that requires a proxy. +-- +-- @@ +-- do +-- txt <- keyLabel' (Proxy @"myLabel") "jsonKeyName" Json.asText +-- pure (txt :: Label "myLabel" Text) +-- @@ +keyLabel' :: + forall label err m a. + Monad m => + Proxy label -> + Text -> + Json.ParseT err m a -> + Json.ParseT err m (Label label a) +keyLabel' Proxy key parser = label @label <$> Json.key key parser + +-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value. +-- +-- We don’t provide a version that infers the json object key, +-- since that conflates internal naming with the external API, which is dangerous. +-- +-- @@ +-- do +-- txt <- keyLabelMay @"myLabel" "jsonKeyName" Json.asText +-- pure (txt :: Label "myLabel" (Maybe Text)) +-- @@ +keyLabelMay :: + forall label err m a. + Monad m => + Text -> + Json.ParseT err m a -> + Json.ParseT err m (Label label (Maybe a)) +keyLabelMay = do + keyLabelMay' (Proxy @label) + +-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value. +-- Version of 'keyLabelMay' that requires a proxy. +-- +-- @@ +-- do +-- txt <- keyLabelMay' (Proxy @"myLabel") "jsonKeyName" Json.asText +-- pure (txt :: Label "myLabel" (Maybe Text)) +-- @@ +keyLabelMay' :: + forall label err m a. + Monad m => + Proxy label -> + Text -> + Json.ParseT err m a -> + Json.ParseT err m (Label label (Maybe a)) +keyLabelMay' Proxy key parser = label @label <$> Json.keyMay key parser + +-- | Like 'Json.key', but allows a list of keys that are tried in order. +-- +-- This is intended for renaming keys in an object. +-- The first key is the most up-to-date version of a key, the others are for backward-compatibility. +-- +-- If a key (new or old) exists, the inner parser will always be executed for that key. +keyRenamed :: Monad m => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m a +keyRenamed (newKey :| oldKeys) inner = + keyRenamedTryOldKeys oldKeys inner >>= \case + Nothing -> Json.key newKey inner + Just parse -> parse + +-- | Like 'Json.keyMay', but allows a list of keys that are tried in order. +-- +-- This is intended for renaming keys in an object. +-- The first key is the most up-to-date version of a key, the others are for backward-compatibility. +-- +-- If a key (new or old) exists, the inner parser will always be executed for that key. +keyRenamedMay :: Monad m => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m (Maybe a) +keyRenamedMay (newKey :| oldKeys) inner = + keyRenamedTryOldKeys oldKeys inner >>= \case + Nothing -> Json.keyMay newKey inner + Just parse -> Just <$> parse + +-- | Helper function for 'keyRenamed' and 'keyRenamedMay' that returns the parser for the first old key that exists, if any. +keyRenamedTryOldKeys :: Monad m => [Text] -> Json.ParseT err m a -> Json.ParseT err m (Maybe (Json.ParseT err m a)) +keyRenamedTryOldKeys oldKeys inner = do + oldKeys & traverse tryOld <&> catMaybes <&> nonEmpty <&> \case + Nothing -> Nothing + Just (old :| _moreOld) -> Just old + where + tryOld key = + Json.keyMay key (pure ()) <&> \case + Just () -> Just $ Json.key key inner + Nothing -> Nothing + +test_keyRenamed :: Hspec.Spec +test_keyRenamed = do + describe "keyRenamed" $ do + let parser = keyRenamed ("new" :| ["old"]) Json.asText + let p = Json.parseValue @() parser + it "accepts the new key and the old key" $ do + p (Object (KeyMap.singleton "new" (String "text"))) + `shouldBe` (Right "text") + p (Object (KeyMap.singleton "old" (String "text"))) + `shouldBe` (Right "text") + it "fails with the old key in the error if the inner parser is wrong" $ do + p (Object (KeyMap.singleton "old" Null)) + `shouldBe` (Left (Json.BadSchema [Json.ObjectKey "old"] (Json.WrongType Json.TyString Null))) + it "fails with the new key in the error if the inner parser is wrong" $ do + p (Object (KeyMap.singleton "new" Null)) + `shouldBe` (Left (Json.BadSchema [Json.ObjectKey "new"] (Json.WrongType Json.TyString Null))) + it "fails if the key is missing" $ do + p (Object KeyMap.empty) + `shouldBe` (Left (Json.BadSchema [] (Json.KeyMissing "new"))) + describe "keyRenamedMay" $ do + let parser = keyRenamedMay ("new" :| ["old"]) Json.asText + let p = Json.parseValue @() parser + it "accepts the new key and the old key" $ do + p (Object (KeyMap.singleton "new" (String "text"))) + `shouldBe` (Right (Just "text")) + p (Object (KeyMap.singleton "old" (String "text"))) + `shouldBe` (Right (Just "text")) + it "allows the old and new key to be missing" $ do + p (Object KeyMap.empty) + `shouldBe` (Right Nothing) + +-- | Create a json array from a list of json values. +jsonArray :: [Value] -> Value +jsonArray xs = xs & Vector.fromList & Array diff --git a/users/Profpatsch/my-prelude/src/MyPrelude.hs b/users/Profpatsch/my-prelude/src/MyPrelude.hs new file mode 100644 index 0000000000..1be248d091 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/MyPrelude.hs @@ -0,0 +1,587 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} + +module MyPrelude + ( -- * Text conversions + Text, + ByteString, + Word8, + fmt, + textToString, + stringToText, + showToText, + textToBytesUtf8, + textToBytesUtf8Lazy, + bytesToTextUtf8, + bytesToTextUtf8Lazy, + bytesToTextUtf8Lenient, + bytesToTextUtf8LenientLazy, + bytesToTextUtf8Unsafe, + bytesToTextUtf8UnsafeLazy, + toStrict, + toLazy, + toStrictBytes, + toLazyBytes, + charToWordUnsafe, + + -- * IO + putStrLn, + putStderrLn, + exitWithMessage, + + -- * WIP code + todo, + + -- * Records + HasField, + + -- * Control flow + (&), + (<&>), + (<|>), + foldMap1, + foldMap', + join, + when, + unless, + guard, + ExceptT (..), + runExceptT, + MonadThrow, + throwM, + MonadIO, + liftIO, + MonadReader, + asks, + Bifunctor, + first, + second, + bimap, + both, + foldMap, + fold, + foldl', + fromMaybe, + mapMaybe, + findMaybe, + Traversable, + for, + for_, + traverse, + traverse_, + traverseFold, + traverseFold1, + traverseFoldDefault, + MonadTrans, + lift, + + -- * Data types + Coercible, + coerce, + Proxy (Proxy), + Map, + annotate, + Validation (Success, Failure), + failure, + successes, + failures, + eitherToValidation, + eitherToListValidation, + validationToEither, + These (This, That, These), + eitherToThese, + eitherToListThese, + validationToThese, + thenThese, + thenValidate, + NonEmpty ((:|)), + singleton, + nonEmpty, + nonEmptyDef, + toList, + toNonEmptyDefault, + maximum1, + minimum1, + Generic, + Semigroup, + sconcat, + Monoid, + mconcat, + ifTrue, + ifExists, + Void, + absurd, + Identity (Identity, runIdentity), + Natural, + intToNatural, + Contravariant, + contramap, + (>$<), + (>&<), + Profunctor, + dimap, + lmap, + rmap, + Semigroupoid, + Category, + (>>>), + (&>>), + + -- * Enum definition + inverseFunction, + inverseMap, + + -- * Error handling + HasCallStack, + module Data.Error, + ) +where + +import Control.Applicative ((<|>)) +import Control.Category (Category, (>>>)) +import Control.Monad (guard, join, unless, when) +import Control.Monad.Catch (MonadThrow (throwM)) +import Control.Monad.Except + ( ExceptT (..), + runExceptT, + ) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Identity (Identity (Identity)) +import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Trans (MonadTrans (lift)) +import Data.Bifunctor (Bifunctor, bimap, first, second) +import Data.ByteString + ( ByteString, + ) +import Data.ByteString.Lazy qualified +import Data.Char qualified +import Data.Coerce (Coercible, coerce) +import Data.Data (Proxy (Proxy)) +import Data.Error +import Data.Foldable (Foldable (foldMap', toList), fold, foldl', for_, traverse_) +import Data.Foldable qualified as Foldable +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Functor.Contravariant (Contravariant (contramap), (>$<)) +import Data.Functor.Identity (Identity (runIdentity)) +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import Data.Map.Strict + ( Map, + ) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe qualified as Maybe +import Data.Profunctor (Profunctor, dimap, lmap, rmap) +import Data.Semigroup (Max (Max, getMax), Min (Min, getMin), sconcat) +import Data.Semigroup.Foldable (Foldable1 (fold1), foldMap1) +import Data.Semigroup.Traversable (Traversable1) +import Data.Semigroupoid (Semigroupoid (o)) +import Data.Text + ( Text, + ) +import Data.Text qualified +import Data.Text.Encoding qualified +import Data.Text.Encoding.Error qualified +import Data.Text.Lazy qualified +import Data.Text.Lazy.Encoding qualified +import Data.These (These (That, These, This)) +import Data.Traversable (for) +import Data.Void (Void, absurd) +import Data.Word (Word8) +import GHC.Exception (errorCallWithCallStackException) +import GHC.Exts (RuntimeRep, TYPE, raise#) +import GHC.Generics (Generic) +import GHC.Natural (Natural) +import GHC.Records (HasField) +import GHC.Stack (HasCallStack) +import PyF (fmt) +import System.Exit qualified +import System.IO qualified +import Validation + ( Validation (Failure, Success), + eitherToValidation, + failure, + failures, + successes, + validationToEither, + ) + +-- | Forward-applying 'contramap', like '&'/'$' and '<&>'/'<$>' but for '>$<'. +(>&<) :: Contravariant f => f b -> (a -> b) -> f a +(>&<) = flip contramap + +infixl 5 >&< + +-- | Forward semigroupoid application. The same as '(>>>)', but 'Semigroupoid' is not a superclass of 'Category' (yet). +-- +-- Specialized examples: +-- +-- @@ +-- 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 +(&>>) = flip Data.Semigroupoid.o + +-- like >>> +infixr 1 &>> + +-- | encode a Text to a UTF-8 encoded Bytestring +textToBytesUtf8 :: Text -> ByteString +textToBytesUtf8 = Data.Text.Encoding.encodeUtf8 + +-- | encode a lazy Text to a UTF-8 encoded lazy Bytestring +textToBytesUtf8Lazy :: Data.Text.Lazy.Text -> Data.ByteString.Lazy.ByteString +textToBytesUtf8Lazy = Data.Text.Lazy.Encoding.encodeUtf8 + +bytesToTextUtf8 :: ByteString -> Either Error Text +bytesToTextUtf8 = first exceptionToError . Data.Text.Encoding.decodeUtf8' + +bytesToTextUtf8Lazy :: Data.ByteString.Lazy.ByteString -> Either Error Data.Text.Lazy.Text +bytesToTextUtf8Lazy = first exceptionToError . Data.Text.Lazy.Encoding.decodeUtf8' + +-- | decode a Text from a ByteString that is assumed to be UTF-8 (crash if that is not the case) +bytesToTextUtf8Unsafe :: ByteString -> Text +bytesToTextUtf8Unsafe = Data.Text.Encoding.decodeUtf8 + +-- | decode a Text from a ByteString that is assumed to be UTF-8 (crash if that is not the case) +bytesToTextUtf8UnsafeLazy :: Data.ByteString.Lazy.ByteString -> Data.Text.Lazy.Text +bytesToTextUtf8UnsafeLazy = Data.Text.Lazy.Encoding.decodeUtf8 + +-- | decode a Text from a ByteString that is assumed to be UTF-8, +-- replace non-UTF-8 characters with the replacment char U+FFFD. +bytesToTextUtf8Lenient :: Data.ByteString.ByteString -> Data.Text.Text +bytesToTextUtf8Lenient = + Data.Text.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode + +-- | decode a lazy Text from a lazy ByteString that is assumed to be UTF-8, +-- replace non-UTF-8 characters with the replacment char U+FFFD. +bytesToTextUtf8LenientLazy :: Data.ByteString.Lazy.ByteString -> Data.Text.Lazy.Text +bytesToTextUtf8LenientLazy = + Data.Text.Lazy.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode + +-- | Make a lazy text strict +toStrict :: Data.Text.Lazy.Text -> Text +toStrict = Data.Text.Lazy.toStrict + +-- | Make a strict text lazy +toLazy :: Text -> Data.Text.Lazy.Text +toLazy = Data.Text.Lazy.fromStrict + +toStrictBytes :: Data.ByteString.Lazy.ByteString -> ByteString +toStrictBytes = Data.ByteString.Lazy.toStrict + +toLazyBytes :: ByteString -> Data.ByteString.Lazy.ByteString +toLazyBytes = Data.ByteString.Lazy.fromStrict + +textToString :: Text -> String +textToString = Data.Text.unpack + +stringToText :: String -> Text +stringToText = Data.Text.pack + +showToText :: (Show a) => a -> Text +showToText = stringToText . show + +-- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and +-- silently truncates to 8 bits Chars > '\255'. It is provided as +-- convenience for ByteString construction. +-- +-- Use if you want to get the 'Word8' representation of a character literal. +-- Don’t use on arbitrary characters! +-- +-- >>> charToWordUnsafe ',' +-- 44 +charToWordUnsafe :: Char -> Word8 +charToWordUnsafe = fromIntegral . Data.Char.ord +{-# INLINE charToWordUnsafe #-} + +-- | Single element in a (non-empty) list. +singleton :: a -> NonEmpty a +singleton a = a :| [] + +-- | If the given list is empty, use the given default element and return a non-empty list. +nonEmptyDef :: a -> [a] -> NonEmpty a +nonEmptyDef def xs = + xs & nonEmpty & \case + Nothing -> def :| [] + Just ne -> ne + +-- | Construct a non-empty list, given a default value if the ist list was empty. +toNonEmptyDefault :: a -> [a] -> NonEmpty a +toNonEmptyDefault def xs = case xs of + [] -> def :| [] + (x : xs') -> x :| xs' + +-- | @O(n)@. Get the maximum element from a non-empty structure. +maximum1 :: (Foldable1 f, Ord a) => f a -> a +maximum1 xs = xs & foldMap1 Max & getMax + +-- | @O(n)@. Get the minimum element from a non-empty structure. +minimum1 :: (Foldable1 f, Ord a) => f a -> a +minimum1 xs = xs & foldMap1 Min & getMin + +-- | Annotate a 'Maybe' with an error message and turn it into an 'Either'. +annotate :: err -> Maybe a -> Either err a +annotate err = \case + Nothing -> Left err + 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 f = bimap f f + +-- | Find the first element for which pred returns `Just a`, and return the `a`. +-- +-- Example: +-- @ +-- >>> :set -XTypeApplications +-- >>> import qualified Text.Read +-- +-- >>> findMaybe (Text.Read.readMaybe @Int) ["foo"] +-- Nothing +-- >>> findMaybe (Text.Read.readMaybe @Int) ["foo", "34.40", "34", "abc"] +-- Just 34 +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 + Just a -> mPred a + Nothing -> Nothing + +-- | Like 'eitherToValidation', but puts the Error side into a NonEmpty list +-- to make it combine with other validations. +eitherToListValidation :: Either a c -> Validation (NonEmpty a) c +eitherToListValidation = first singleton . eitherToValidation + +-- | Convert an 'Either' to a 'These'. +eitherToThese :: Either err a -> These err a +eitherToThese (Left err) = This err +eitherToThese (Right a) = That a + +-- | Like 'eitherToThese', but puts the Error side into a NonEmpty list +-- to make it combine with other theses. +eitherToListThese :: Either err a -> These (NonEmpty err) a +eitherToListThese (Left e) = This (singleton e) +eitherToListThese (Right a) = That a + +-- | Convert a 'Validation' to a 'These'. +validationToThese :: Validation err a -> These err a +validationToThese (Failure err) = This err +validationToThese (Success a) = That a + +-- | Nested '>>=' of a These inside some other @m@. +-- +-- Use if you want to collect errors and successes, and want to chain multiple function returning 'These'. +thenThese :: + (Monad m, Semigroup err) => + (a -> m (These err b)) -> + m (These err a) -> + m (These err b) +thenThese f x = do + th <- x + join <$> traverse f th + +-- | Nested validating bind-like combinator inside some other @m@. +-- +-- Use if you want to collect errors, and want to chain multiple functions returning 'Validation'. +thenValidate :: + (Monad m) => + (a -> m (Validation err b)) -> + m (Validation err a) -> + m (Validation err b) +thenValidate f x = + eitherToValidation <$> do + x' <- validationToEither <$> x + case x' of + Left err -> pure $ Left err + Right a -> validationToEither <$> f a + +-- | Put the text to @stderr@. +putStderrLn :: Text -> IO () +putStderrLn msg = + System.IO.hPutStrLn System.IO.stderr $ textToString msg + +exitWithMessage :: Text -> IO a +exitWithMessage msg = do + putStderrLn msg + System.Exit.exitWith $ System.Exit.ExitFailure (-1) + +-- | Run some function producing applicative over a traversable data structure, +-- then collect the results in a Monoid. +-- +-- Very helpful with side-effecting functions returning @(Validation err a)@: +-- +-- @ +-- let +-- f :: Text -> IO (Validation (NonEmpty Error) Text) +-- f t = pure $ if t == "foo" then Success t else Failure (singleton ("not foo: " <> t)) +-- +-- in traverseFold f [ "foo", "bar", "baz" ] +-- == Failure ("not foo bar" :| ["not foo baz"]) +-- @ +-- +-- … since @(Semigroup err => Validation err a)@ is a @Semigroup@/@Monoid@ itself. +traverseFold :: (Applicative ap, Traversable t, Monoid m) => (a -> ap m) -> t a -> ap m +traverseFold f xs = + -- note: could be weakened to (Foldable t) via `getAp . foldMap (Ap . f)` + fold <$> traverse f xs +{-# INLINE traverseFold #-} + +-- | Like 'traverseFold', but fold over a semigroup instead of a Monoid, by providing a starting element. +traverseFoldDefault :: (Applicative ap, Traversable t, Semigroup m) => m -> (a -> ap m) -> t a -> ap m +traverseFoldDefault def f xs = foldDef def <$> traverse f xs + where + foldDef = foldr (<>) +{-# INLINE traverseFoldDefault #-} + +-- | Same as 'traverseFold', but with a 'Semigroup' and 'Traversable1' restriction. +traverseFold1 :: (Applicative ap, Traversable1 t, Semigroup s) => (a -> ap s) -> t a -> ap s +-- note: cannot be weakened to (Foldable1 t) because there is no `Ap` for Semigroup (No `Apply` typeclass) +traverseFold1 f xs = fold1 <$> traverse f xs +{-# INLINE traverseFold1 #-} + +-- | Use this in places where the code is still to be implemented. +-- +-- It always type-checks and will show a warning at compile time if it was forgotten in the code. +-- +-- Use instead of 'error' and 'undefined' for code that hasn’t been written. +-- +-- 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 = 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 i = + if i < 0 + then Nothing + else Just $ fromIntegral i + +-- | @inverseFunction f@ creates a function that is the inverse of a given function +-- @f@. It does so by constructing 'M.Map' internally for each value @f a@. The +-- implementation makes sure that the 'M.Map' is constructed only once and then +-- shared for every call. +-- +-- __Memory usage note:__ don't inverse functions that have types like 'Int' +-- as their result. In this case the created 'M.Map' will have huge size. +-- +-- The complexity of reversed mapping is \(\mathcal{O}(\log n)\). +-- +-- __Performance note:__ make sure to specialize monomorphic type of your functions +-- that use 'inverseFunction' to avoid 'M.Map' reconstruction. +-- +-- One of the common 'inverseFunction' use-case is inverting the 'show' or a 'show'-like +-- function. +-- +-- >>> data Color = Red | Green | Blue deriving (Show, Enum, Bounded) +-- >>> parse = inverseFunction show :: String -> Maybe Color +-- >>> parse "Red" +-- Just Red +-- >>> parse "Black" +-- Nothing +-- +-- __Correctness note:__ 'inverseFunction' expects /injective function/ as its argument, +-- i.e. the function must map distinct arguments to distinct values. +-- +-- Typical usage of this function looks like this: +-- +-- @ +-- __data__ GhcVer +-- = Ghc802 +-- | Ghc822 +-- | Ghc844 +-- | Ghc865 +-- | Ghc881 +-- __deriving__ ('Eq', 'Ord', 'Show', 'Enum', 'Bounded') +-- +-- showGhcVer :: GhcVer -> 'Text' +-- showGhcVer = \\__case__ +-- Ghc802 -> "8.0.2" +-- Ghc822 -> "8.2.2" +-- Ghc844 -> "8.4.4" +-- Ghc865 -> "8.6.5" +-- Ghc881 -> "8.8.1" +-- +-- parseGhcVer :: 'Text' -> 'Maybe' GhcVer +-- parseGhcVer = 'inverseFunction' showGhcVer +-- +-- Taken from relude’s @Relude.Extra.Enum@. +inverseFunction :: + forall a k. + (Bounded a, Enum a, Ord k) => + (a -> k) -> + (k -> Maybe a) +inverseFunction f k = Map.lookup k $ inverseMap f + +-- | Like `inverseFunction`, but instead of returning the function +-- it returns a mapping from all possible outputs to their possible inputs. +-- +-- This has the same restrictions of 'inverseFunction'. +inverseMap :: + forall a k. + (Bounded a, Enum a, Ord k) => + (a -> k) -> + Map k a +inverseMap f = + universe + <&> (\a -> (f a, a)) + & Map.fromList + where + universe :: [a] + universe = [minBound .. maxBound] + +-- | If the predicate is true, return the @m@, else 'mempty'. +-- +-- This can be used (together with `ifExists`) to e.g. create lists with optional elements: +-- +-- >>> import Data.Monoid (Sum(..)) +-- +-- >>> :{ mconcat [ +-- ifTrue (1 == 1) [1], +-- [2, 3, 4], +-- ifTrue False [5], +-- ] +-- :} +-- [1,2,3,4] +-- +-- Or any other Monoid: +-- +-- >>> mconcat [ Sum 1, ifTrue (1 == 1) (Sum 2), Sum 3 ] + +-- Sum {getSum = 6} + +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. + +-- This can be used (together with `ifTrue`) to e.g. create lists with optional elements: +-- +-- >>> import Data.Monoid (Sum(..)) +-- +-- >>> :{ mconcat [ +-- ifExists (Just [1]), +-- [2, 3, 4], +-- ifExists Nothing, +-- ] +-- :} +-- [1,2,3,4] +-- +-- Or any other Monoid: +-- +-- >>> mconcat [ Sum 1, ifExists (Just (Sum 2)), Sum 3 ] + +-- Sum {getSum = 6} + +ifExists :: Monoid m => Maybe m -> m +ifExists = fold diff --git a/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs b/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs new file mode 100644 index 0000000000..2e7fcb8779 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs @@ -0,0 +1,58 @@ +module Postgres.Decoder where + +import Control.Applicative (Alternative) +import Data.Aeson qualified as Json +import Data.Aeson.BetterErrors qualified as Json +import Data.Error.Tree +import Data.Typeable (Typeable) +import Database.PostgreSQL.Simple.FromField qualified as PG +import Database.PostgreSQL.Simple.FromRow qualified as PG +import Json qualified +import Label +import PossehlAnalyticsPrelude + +-- | A Decoder of postgres values. Allows embedding more complex parsers (like a 'Json.ParseT'). +newtype Decoder a = Decoder (PG.RowParser a) + deriving newtype (Functor, Applicative, Alternative, Monad) + +-- | Turn any type that implements 'PG.fromField' into a 'Decoder'. Use type applications to prevent accidental conversions: +-- +-- @ +-- fromField @Text :: Decoder Text +-- @ +fromField :: PG.FromField a => Decoder a +fromField = Decoder $ PG.fieldWith PG.fromField + +-- | Turn any type that implements 'PG.fromField' into a 'Decoder' and wrap the result into the given 'Label'. Use type applications to prevent accidental conversions: +-- +-- @ +-- fromField @"myField" @Text :: Decoder (Label "myField" Text) +-- @ +fromFieldLabel :: forall lbl a. PG.FromField a => Decoder (Label lbl a) +fromFieldLabel = label @lbl <$> fromField + +-- | Parse fields out of a json value returned from the database. +-- +-- ATTN: The whole json record has to be transferred before it is parsed, +-- so if you only need a tiny bit of it, use `->` and `->>` in your SQL statement +-- and return only the fields you need from the query. +-- +-- In that case pay attention to NULL though: +-- +-- @ +-- SELECT '{"foo": {}}'::jsonb->>'foo' IS NULL +-- → TRUE +-- @ +-- +-- Also note: `->>` will coerce the json value to @text@, regardless of the content. +-- So the JSON object @{"foo": {}}"@ would be returned as the text: @"{\"foo\": {}}"@. +json :: Typeable a => Json.ParseT ErrorTree Identity a -> Decoder a +json parser = Decoder $ PG.fieldWith $ \field bytes -> do + val <- PG.fromField @Json.Value field bytes + case Json.parseValue parser val of + Left err -> + PG.returnError + PG.ConversionFailed + field + (err & Json.parseErrorTree "Cannot decode jsonb column" & prettyErrorTree & textToString) + Right a -> pure a diff --git a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs new file mode 100644 index 0000000000..e602ee287f --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Postgres.MonadPostgres where + +import Control.Exception +import Control.Monad.Except +import Control.Monad.Logger.CallStack +import Control.Monad.Reader (MonadReader (ask), ReaderT (..)) +import Data.Error.Tree +import Data.Int (Int64) +import Data.Kind (Type) +import Data.List qualified as List +import Data.Typeable (Typeable) +import Database.PostgreSQL.Simple (Connection, FormatError, FromRow, Query, QueryError, ResultError, SqlError, ToRow) +import Database.PostgreSQL.Simple qualified as PG +import Database.PostgreSQL.Simple.FromRow qualified as PG +import Database.PostgreSQL.Simple.ToField (ToField) +import Database.PostgreSQL.Simple.ToRow (ToRow (toRow)) +import Database.PostgreSQL.Simple.Types (fromQuery) +import GHC.Records (HasField (..)) +import Label +import PossehlAnalyticsPrelude +import Postgres.Decoder +import Pretty (showPretty) +import System.Exit (ExitCode (..)) +import Tool +import UnliftIO (MonadUnliftIO (withRunInIO)) +import UnliftIO.Process qualified as Process + +-- | Postgres queries/commands that can be executed within a running transaction. +-- +-- These are implemented with the @postgresql-simple@ primitives of the same name +-- and will behave the same unless othewise documented. +class Monad m => MonadPostgres (m :: Type -> Type) where + -- | Execute an INSERT, UPDATE, or other SQL query that is not expected to return results. + -- + -- Returns the number of rows affected. + execute :: (ToRow params, Typeable params) => Query -> params -> Transaction m (Label "numberOfRowsAffected" Natural) + + -- | Execute an INSERT, UPDATE, or other SQL query that is not expected to return results. Does not perform parameter substitution. + -- + -- Returns the number of rows affected. + execute_ :: Query -> Transaction m (Label "numberOfRowsAffected" Natural) + + -- | Execute a multi-row INSERT, UPDATE, or other SQL query that is not expected to return results. + -- + -- Returns the number of rows affected. If the list of parameters is empty, this function will simply return 0 without issuing the query to the backend. If this is not desired, consider using the 'PG.Values' constructor instead. + executeMany :: (ToRow params, Typeable params) => Query -> [params] -> Transaction m (Label "numberOfRowsAffected" Natural) + + -- | Execute INSERT ... RETURNING, UPDATE ... RETURNING, or other SQL query that accepts multi-row input and is expected to return results. Note that it is possible to write query conn "INSERT ... RETURNING ..." ... in cases where you are only inserting a single row, and do not need functionality analogous to 'executeMany'. + -- + -- If the list of parameters is empty, this function will simply return [] without issuing the query to the backend. If this is not desired, consider using the 'PG.Values' constructor instead. + executeManyReturningWith :: (ToRow q) => Query -> [q] -> Decoder r -> Transaction m [r] + + -- | Run a query, passing parameters and result row parser. + queryWith :: (PG.ToRow params, Typeable params, Typeable r) => PG.Query -> params -> Decoder r -> Transaction m [r] + + -- | Run a query without any parameters and result row parser. + queryWith_ :: (Typeable r) => PG.Query -> Decoder r -> Transaction m [r] + + -- | Run a query, passing parameters, and fold over the resulting rows. + -- + -- This doesn’t have to realize the full list of results in memory, + -- rather results are streamed incrementally from the database. + -- + -- When dealing with small results, it may be simpler (and perhaps faster) to use query instead. + -- + -- This fold is _not_ strict. The stream consumer is responsible for forcing the evaluation of its result to avoid space leaks. + -- + -- If you can, prefer aggregating in the database itself. + foldRows :: + (FromRow row, ToRow params, Typeable row, Typeable params) => + Query -> + params -> + a -> + (a -> row -> Transaction m a) -> + Transaction m a + + -- | Run a given transaction in a transaction block, rolling back the transaction + -- if any exception (postgres or Haskell Exception) is thrown during execution. + -- + -- Re-throws the exception. + -- + -- Don’t do any long-running things on the Haskell side during a transaction, + -- because it will block a database connection and potentially also lock + -- database tables from being written or read by other clients. + -- + -- Nonetheless, try to push transactions as far out to the handlers as possible, + -- don’t do something like @runTransaction $ query …@, because it will lead people + -- to accidentally start nested transactions (the inner transaction is run on a new connections, + -- thus can’t see any changes done by the outer transaction). + -- Only handlers should run transactions. + runTransaction :: Transaction m a -> m a + +-- | Run a query, passing parameters. +query :: forall m params r. (PG.ToRow params, PG.FromRow r, Typeable params, Typeable r, MonadPostgres m) => PG.Query -> params -> Transaction m [r] +query qry params = queryWith qry params (Decoder PG.fromRow) + +-- | Run a query without any parameters. +query_ :: forall m r. (Typeable r, PG.FromRow r, MonadPostgres m) => PG.Query -> Transaction m [r] +query_ qry = queryWith_ qry (Decoder PG.fromRow) + +-- TODO: implement via fold, so that the result doesn’t have to be realized in memory +querySingleRow :: + ( MonadPostgres m, + ToRow qParams, + Typeable qParams, + FromRow a, + Typeable a, + MonadThrow m + ) => + Query -> + qParams -> + Transaction m a +querySingleRow qry params = do + query qry params >>= ensureSingleRow + +-- TODO: implement via fold, so that the result doesn’t have to be realized in memory +querySingleRowMaybe :: + ( MonadPostgres m, + ToRow qParams, + Typeable qParams, + FromRow a, + Typeable a, + MonadThrow m + ) => + Query -> + qParams -> + Transaction m (Maybe a) +querySingleRowMaybe qry params = do + rows <- query qry params + case rows of + [] -> pure Nothing + [one] -> pure (Just one) + -- TODO: Should we MonadThrow this here? It’s really an implementation detail of MonadPostgres + -- that a database function can error out, should probably handled by the instances. + more -> throwM $ SingleRowError {numberOfRowsReturned = (List.length more)} + +ensureSingleRow :: MonadThrow m => [a] -> m a +ensureSingleRow = \case + -- TODO: Should we MonadThrow this here? It’s really an implementation detail of MonadPostgres + -- that a database function can error out, should probably handled by the instances. + [] -> throwM (SingleRowError {numberOfRowsReturned = 0}) + [one] -> pure one + more -> + throwM $ + SingleRowError + { numberOfRowsReturned = + -- TODO: this is VERY bad, because it requires to parse the full database output, even if there’s 10000000000 elements + List.length more + } + +newtype Transaction m a = Transaction {unTransaction :: (ReaderT Connection m a)} + deriving newtype + ( Functor, + Applicative, + Monad, + MonadThrow, + MonadLogger, + MonadIO, + MonadUnliftIO, + MonadTrans + ) + +runTransaction' :: Connection -> Transaction m a -> m a +runTransaction' conn transaction = runReaderT transaction.unTransaction conn + +-- | Catch any Postgres exception that gets thrown, +-- print the query that was run and the query parameters, +-- then rethrow inside an 'Error'. +handlePGException :: + forall a params m. + (ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => + Text -> + Query -> + -- | Depending on whether we used `format` or `formatMany`. + Either params [params] -> + IO a -> + Transaction m a +handlePGException queryType query' params io = do + withRunInIO $ \unliftIO -> + io + `catches` [ Handler $ unliftIO . logQueryException @SqlError, + Handler $ unliftIO . logQueryException @QueryError, + Handler $ unliftIO . logQueryException @ResultError, + Handler $ unliftIO . logFormatException + ] + where + -- TODO: use throwInternalError here (after pulling it into the MonadPostgres class) + throwAsError = unwrapIOError . Left . newError + throwErr err = liftIO $ throwAsError $ prettyErrorTree $ nestedMultiError "A Postgres query failed" err + logQueryException :: Exception e => e -> Transaction m a + logQueryException exc = do + formattedQuery <- case params of + Left one -> pgFormatQuery' query' one + Right many -> pgFormatQueryMany' query' many + throwErr + ( singleError [fmt|Query Type: {queryType}|] + :| [ nestedError "Exception" (exc & showPretty & newError & singleError), + nestedError "Query" (formattedQuery & newError & singleError) + ] + ) + logFormatException :: FormatError -> Transaction m a + logFormatException fe = throwErr (fe & showPretty & newError & singleError & singleton) + +pgExecute :: (ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> params -> Transaction m (Label "numberOfRowsAffected" Natural) +pgExecute qry params = do + conn <- Transaction ask + PG.execute conn qry params + & handlePGException "execute" qry (Left params) + >>= toNumberOfRowsAffected "pgExecute" + +pgExecute_ :: (MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> Transaction m (Label "numberOfRowsAffected" Natural) +pgExecute_ qry = do + conn <- Transaction ask + PG.execute_ conn qry + & handlePGException "execute_" qry (Left ()) + >>= toNumberOfRowsAffected "pgExecute_" + +pgExecuteMany :: (ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> [params] -> Transaction m (Label "numberOfRowsAffected" Natural) +pgExecuteMany qry params = + do + conn <- Transaction ask + PG.executeMany conn qry params + & handlePGException "executeMany" qry (Right params) + >>= toNumberOfRowsAffected "pgExecuteMany" + +toNumberOfRowsAffected :: MonadIO m => Text -> Int64 -> m (Label "numberOfRowsAffected" Natural) +toNumberOfRowsAffected functionName i64 = + i64 + & intToNatural + & annotate [fmt|{functionName}: postgres returned a negative number of rows affected: {i64}|] + -- we throw this directly in IO here, because we don’t want to e.g. have to propagate MonadThrow through user code (it’s an assertion) + & unwrapIOError + & liftIO + <&> label @"numberOfRowsAffected" + +pgExecuteManyReturningWith :: (ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> [params] -> Decoder r -> Transaction m [r] +pgExecuteManyReturningWith qry params (Decoder fromRow) = + do + conn <- Transaction ask + PG.returningWith fromRow conn qry params + & handlePGException "executeManyReturning" qry (Right params) + +pgFold :: + (FromRow row, ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => + Query -> + params -> + a -> + (a -> row -> Transaction m a) -> + Transaction m a +pgFold qry params accumulator f = do + conn <- Transaction ask + + withRunInIO + ( \runInIO -> + do + PG.fold + conn + qry + params + accumulator + (\acc row -> runInIO $ f acc row) + & handlePGException "fold" qry (Left params) + & runInIO + ) + +pgFormatQuery :: (ToRow params, MonadIO m) => Query -> params -> Transaction m ByteString +pgFormatQuery qry params = Transaction $ do + conn <- ask + liftIO $ PG.formatQuery conn qry params + +pgFormatQueryMany :: (MonadIO m, ToRow params) => Query -> [params] -> Transaction m ByteString +pgFormatQueryMany qry params = Transaction $ do + conn <- ask + liftIO $ PG.formatMany conn qry params + +pgQueryWith :: (ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> params -> Decoder r -> Transaction m [r] +pgQueryWith qry params (Decoder fromRow) = do + conn <- Transaction ask + PG.queryWith fromRow conn qry params + & handlePGException "query" qry (Left params) + +pgQueryWith_ :: (MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> Decoder r -> Transaction m [r] +pgQueryWith_ qry (Decoder fromRow) = do + conn <- Transaction ask + liftIO (PG.queryWith_ fromRow conn qry) + & handlePGException "query" qry (Left ()) + +pgQuery :: (ToRow params, FromRow r, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> params -> Transaction m [r] +pgQuery qry params = do + conn <- Transaction ask + PG.query conn qry params + & handlePGException "query" qry (Left params) + +pgQuery_ :: (FromRow r, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> Transaction m [r] +pgQuery_ qry = do + conn <- Transaction ask + PG.query_ conn qry + & handlePGException "query_" qry (Left ()) + +data SingleRowError = SingleRowError + { -- | How many columns were actually returned by the query + numberOfRowsReturned :: Int + } + deriving stock (Show) + +instance Exception SingleRowError where + displayException (SingleRowError {..}) = [fmt|Single row expected from SQL query result, {numberOfRowsReturned} rows were returned instead."|] + +pgFormatQueryNoParams' :: (MonadIO m, MonadLogger m, MonadTools m) => Query -> Transaction m Text +pgFormatQueryNoParams' q = + lift $ pgFormatQueryByteString q.fromQuery + +pgFormatQuery' :: (MonadIO m, ToRow params, MonadLogger m, MonadTools m) => Query -> params -> Transaction m Text +pgFormatQuery' q p = + pgFormatQuery q p + >>= lift . pgFormatQueryByteString + +pgFormatQueryMany' :: (MonadIO m, ToRow params, MonadLogger m, MonadTools m) => Query -> [params] -> Transaction m Text +pgFormatQueryMany' q p = + pgFormatQueryMany q p + >>= lift . pgFormatQueryByteString + +-- | Tools required at runtime +data Tools = Tools + { pgFormat :: Tool + } + deriving stock (Show) + +class Monad m => MonadTools m where + getTools :: m Tools + +initMonadTools :: Label "envvar" Text -> IO Tools +initMonadTools var = + Tool.readTools (label @"toolsEnvVar" var.envvar) toolParser + where + toolParser = do + pgFormat <- readTool "pg_format" + pure $ Tools {..} + +pgFormatQueryByteString :: (MonadIO m, MonadLogger m, MonadTools m) => ByteString -> m Text +pgFormatQueryByteString queryBytes = do + do + tools <- getTools + (exitCode, stdout, stderr) <- + Process.readProcessWithExitCode + tools.pgFormat.toolPath + ["-"] + (queryBytes & bytesToTextUtf8Lenient & textToString) + case exitCode of + ExitSuccess -> pure (stdout & stringToText) + ExitFailure status -> do + logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|] + logDebug + ( prettyErrorTree + ( nestedMultiError + "pg_format output" + ( nestedError "stdout" (singleError (stdout & stringToText & newError)) + :| [(nestedError "stderr" (singleError (stderr & stringToText & newError)))] + ) + ) + ) + logDebug [fmt|pg_format stdout: stderr|] + pure (queryBytes & bytesToTextUtf8Lenient) + +instance (ToField t1) => ToRow (Label l1 t1) where + toRow t2 = toRow $ PG.Only $ getField @l1 t2 + +instance (ToField t1, ToField t2) => ToRow (T2 l1 t1 l2 t2) where + toRow t2 = toRow (getField @l1 t2, getField @l2 t2) + +instance (ToField t1, ToField t2, ToField t3) => ToRow (T3 l1 t1 l2 t2 l3 t3) where + toRow t3 = toRow (getField @l1 t3, getField @l2 t3, getField @l3 t3) diff --git a/users/Profpatsch/my-prelude/src/Pretty.hs b/users/Profpatsch/my-prelude/src/Pretty.hs new file mode 100644 index 0000000000..8046c83e45 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Pretty.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} + +module Pretty + ( -- * Pretty printing for error messages + Err, + printPretty, + showPretty, + -- constructors hidden + prettyErrs, + message, + messageString, + pretty, + prettyString, + hscolour', + ) +where + +import Data.List qualified as List +import Data.Text qualified as Text +import Language.Haskell.HsColour + ( Output (TTYg), + hscolour, + ) +import Language.Haskell.HsColour.ANSI (TerminalType (..)) +import Language.Haskell.HsColour.Colourise + ( defaultColourPrefs, + ) +import MyPrelude +import System.Console.ANSI (setSGRCode) +import System.Console.ANSI.Types + ( Color (Red), + ColorIntensity (Dull), + ConsoleLayer (Foreground), + SGR (Reset, SetColor), + ) +import Text.Nicify (nicify) + +-- | Print any 'Show'able type to stderr, formatted nicely and in color. Very helpful for debugging. +printPretty :: Show a => a -> IO () +printPretty a = + a & pretty & (: []) & prettyErrs & stringToText & putStderrLn + +showPretty :: Show a => a -> Text +showPretty a = a & pretty & (: []) & prettyErrs & stringToText + +-- | Display a list of 'Err's as a colored error message +-- and abort the test. +prettyErrs :: [Err] -> String +prettyErrs errs = res + where + res = List.intercalate "\n" $ map one errs + one = \case + ErrMsg s -> color Red s + ErrPrettyString s -> prettyShowString s + -- Pretty print a String that was produced by 'show' + prettyShowString :: String -> String + prettyShowString = hscolour' . nicify + +-- | Small DSL for pretty-printing errors +data Err + = -- | Message to display in the error + ErrMsg String + | -- | Pretty print a String that was produced by 'show' + ErrPrettyString String + +-- | Plain message to display, as 'Text' +message :: Text -> Err +message = ErrMsg . Text.unpack + +-- | Plain message to display, as 'String' +messageString :: String -> Err +messageString = ErrMsg + +-- | Any 'Show'able to pretty print +pretty :: Show a => a -> Err +pretty x = ErrPrettyString $ show x + +-- | Pretty print a String that was produced by 'show' +prettyString :: String -> Err +prettyString s = ErrPrettyString s + +-- Prettifying Helpers, mostly stolen from +-- https://hackage.haskell.org/package/hspec-expectations-pretty-diff-0.7.2.5/docs/src/Test.Hspec.Expectations.Pretty.html#prettyColor + +hscolour' :: String -> String +hscolour' = + hscolour (TTYg Ansi16Colour) defaultColourPrefs False False "" False + +color :: Color -> String -> String +color c s = setSGRCode [SetColor Foreground Dull c] ++ s ++ setSGRCode [Reset] diff --git a/users/Profpatsch/my-prelude/src/RunCommand.hs b/users/Profpatsch/my-prelude/src/RunCommand.hs new file mode 100644 index 0000000000..5c80eb3aac --- /dev/null +++ b/users/Profpatsch/my-prelude/src/RunCommand.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module RunCommand where + +import Data.ByteString qualified as ByteString +import Data.ByteString.Lazy qualified as Bytes.Lazy +import Data.Char qualified as Char +import Data.List qualified as List +import Data.Text qualified as Text +import MyPrelude +import System.Exit qualified as Exit +import System.IO (Handle) +import System.Process.Typed qualified as Process +import Prelude hiding (log) + +-- | Given a a command, the executable and arguments, +-- spawn the tool as subprocess and collect its stdout (stderr will go to our stderr). + +-- Will strip the stdout of trailing newlines. +-- +-- If the executable is not a path, it will be resolved via the @PATH@ environment variable. +runCommand :: MonadIO m => FilePath -> [Text] -> m (Exit.ExitCode, ByteString) +runCommand executable args = do + let bashArgs = prettyArgsForBash ((executable & stringToText) : args) + log [fmt|Running: $ {bashArgs}|] + Process.proc + executable + (args <&> textToString) + & Process.readProcessStdout + <&> second toStrictBytes + <&> second stripWhitespaceFromEnd + +-- | Given a a command, the executable and arguments, +-- spawn the tool as subprocess and run it to conclusion. +-- +-- If the executable is not a path, it will be resolved via the @PATH@ environment variable. +runCommandNoStdout :: MonadIO m => FilePath -> [Text] -> m Exit.ExitCode +runCommandNoStdout executable args = do + let bashArgs = prettyArgsForBash ((executable & stringToText) : args) + log [fmt|Running: $ {bashArgs}|] + Process.proc + executable + (args <&> textToString) + & Process.runProcess + +-- TODO: This is reversing the whole string *twice*. Can we strip from end without doing that? +stripWhitespaceFromEnd :: ByteString -> ByteString +stripWhitespaceFromEnd = ByteString.reverse . ByteString.dropWhile (\w -> w == charToWordUnsafe '\n') . ByteString.reverse + +-- | Like `runCommand`, but takes a Bytestring that provides the command with streamed input on stdin. +runCommandWithStdin :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m (Exit.ExitCode, ByteString) +runCommandWithStdin executable args stdin = do + let bashArgs = prettyArgsForBash ((executable & stringToText) : args) + log [fmt|Running: $ {bashArgs}|] + Process.proc + executable + (args <&> textToString) + & Process.setStdin (Process.byteStringInput stdin) + & Process.readProcessStdout + <&> second toStrictBytes + <&> second stripWhitespaceFromEnd + +-- | Like `runCommand`, but takes a Bytestring that provides the command with streamed input on stdin. +runCommandWithStdinNoStdout :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m Exit.ExitCode +runCommandWithStdinNoStdout executable args stdin = do + let bashArgs = prettyArgsForBash ((executable & stringToText) : args) + log [fmt|Running: $ {bashArgs}|] + Process.proc + executable + (args <&> textToString) + & Process.setStdin (Process.byteStringInput stdin) + & Process.runProcess + +-- | Like 'runCommandWithStdin' but exit if the command returns a non-0 status. +runCommandWithStdinExpect0 :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m ByteString +runCommandWithStdinExpect0 executable args stdin = + runCommandWithStdin executable args stdin >>= \case + (ex, stdout) -> do + checkStatus0 executable ex + pure stdout + +-- | Like 'runCommandWithStdinNoStdout' but exit if the command returns a non-0 status. +runCommandWithStdinNoStdoutExpect0 :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m () +runCommandWithStdinNoStdoutExpect0 executable args stdin = + runCommandWithStdinNoStdout executable args stdin + >>= checkStatus0 executable + +-- | Like 'runCommandExpect0', but don’t capture stdout, +-- connect stdin and stdout to the command until it returns. +-- +-- This is for interactive subcommands. +runCommandInteractiveExpect0 :: MonadIO m => FilePath -> [Text] -> m () +runCommandInteractiveExpect0 executable args = do + let bashArgs = prettyArgsForBash ((executable & stringToText) : args) + log [fmt|Running interactively: $ {bashArgs}|] + ( liftIO $ + Process.runProcess $ + Process.proc + executable + (args <&> textToString) + ) + >>= checkStatus0 executable + +-- | Given a name of a command, the executable and arguments, +-- spawn the tool as subprocess and pipe its stdout to the given 'Handle'. +-- +-- If the executable is not a path, it will be resolved via the @PATH@ environment variable. +runCommandPipeToHandle :: MonadIO m => FilePath -> [Text] -> Handle -> m Exit.ExitCode +runCommandPipeToHandle executable args handle = do + -- TODO log the output file? + let bashArgs = prettyArgsForBash ((executable & stringToText) : args) + log [fmt|Running: $ {bashArgs}|] + liftIO $ + Process.runProcess + ( Process.proc + executable + (args <&> textToString) + & Process.setStdout (Process.useHandleClose handle) + ) + +-- | Check whether a command exited 0 or crash. +checkStatus0 :: MonadIO m => FilePath -> Exit.ExitCode -> m () +checkStatus0 executable = \case + Exit.ExitSuccess -> pure () + Exit.ExitFailure status -> do + logCritical [fmt|Command `{executable}` did not exit with status 0 (success), but status {status}|] + +log :: MonadIO m => Text -> m () +log = liftIO . putStderrLn + +-- | Log the message on the normal logging level & exit the program +logCritical :: MonadIO m => Text -> m b +logCritical msg = do + liftIO $ putStderrLn msg + liftIO $ Exit.exitWith (Exit.ExitFailure 1) + +-- | Pretty print a command line in a way that can be copied to bash. +prettyArgsForBash :: [Text] -> Text +prettyArgsForBash = Text.intercalate " " . map simpleBashEscape + +-- | Simple escaping for bash words. If they contain anything that’s not ascii chars +-- and a bunch of often-used special characters, put the word in single quotes. +simpleBashEscape :: Text -> Text +simpleBashEscape t = do + case Text.find (not . isSimple) t of + Just _ -> escapeSingleQuote t + Nothing -> t + where + -- any word that is just ascii characters is simple (no spaces or control characters) + -- or contains a few often-used characters like - or . + isSimple c = + Char.isAsciiLower c + || Char.isAsciiUpper c + || Char.isDigit c + -- These are benign, bash will not interpret them as special characters. + || List.elem c ['-', '.', ':', '/'] + -- Put the word in single quotes + -- If there is a single quote in the word, + -- close the single quoted word, add a single quote, open the word again + escapeSingleQuote t' = "'" <> Text.replace "'" "'\\''" t' <> "'" diff --git a/users/Profpatsch/my-prelude/src/Test.hs b/users/Profpatsch/my-prelude/src/Test.hs new file mode 100644 index 0000000000..862ee16c25 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Test.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE LambdaCase #-} + +{- Generate Test suites. + +Restricted version of hspec, introduction: http://hspec.github.io/getting-started.html +-} +module Test + ( Spec, + runTest, + testMain, + + -- * Structure + describe, + it, + + -- * Expectations + Expectation, + testOk, + testErr, + shouldBe, + shouldNotBe, + shouldSatisfy, + shouldNotSatisfy, + + -- * Setup & Teardown (hooks http://hspec.github.io/writing-specs.html#using-hooks) + before, + before_, + beforeWith, + beforeAll, + beforeAll_, + beforeAllWith, + after, + after_, + afterAll, + afterAll_, + around, + around_, + aroundWith, + aroundAll, + aroundAllWith, + + -- * Common helpful predicates (use with 'shouldSatisfy') + isRight, + isLeft, + + -- * Pretty printing of errors + errColored, + module Pretty, + ) +where + +-- export more expectations if needed + +import Data.Either + ( isLeft, + isRight, + ) +import Pretty +import Test.Hspec + ( Expectation, + HasCallStack, + Spec, + after, + afterAll, + afterAll_, + after_, + around, + aroundAll, + aroundAllWith, + aroundWith, + around_, + before, + beforeAll, + beforeAllWith, + beforeAll_, + beforeWith, + before_, + describe, + hspec, + it, + ) +import Test.Hspec.Expectations.Pretty + ( expectationFailure, + shouldBe, + shouldNotBe, + shouldNotSatisfy, + shouldSatisfy, + ) + +-- | Run a test directly (e.g. from the repl) +runTest :: Spec -> IO () +runTest = hspec + +-- | Run a testsuite +testMain :: + -- | Name of the test suite + String -> + -- | The tests in this test module + Spec -> + IO () +testMain testSuiteName tests = hspec $ describe testSuiteName tests + +-- | test successful +testOk :: Expectation +testOk = pure () + +-- | Abort the test with an error message. +-- If you want to display a Haskell type, use `errColored`. +testErr :: HasCallStack => String -> Expectation +testErr = expectationFailure + +-- | Display a list of 'Err's as a colored error message +-- and abort the test. +errColored :: [Pretty.Err] -> Expectation +errColored = testErr . Pretty.prettyErrs diff --git a/users/Profpatsch/my-prelude/src/Tool.hs b/users/Profpatsch/my-prelude/src/Tool.hs new file mode 100644 index 0000000000..066f68bbe0 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Tool.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Tool where + +import Data.Error.Tree +import Label +import PossehlAnalyticsPrelude +import System.Environment qualified as Env +import System.Exit qualified as Exit +import System.FilePath (()) +import System.Posix qualified as Posix +import ValidationParseT + +data Tool = Tool + { -- | absolute path to the executable + toolPath :: FilePath + } + deriving stock (Show) + +-- | Reads all tools from the @toolsEnvVar@ variable or aborts. +readTools :: + Label "toolsEnvVar" Text -> + -- | Parser for Tools we bring with us at build time. + -- + -- These are executables that we need available, and that we have to ship with the distribution of @pa-cli@. + ToolParserT IO tools -> + IO tools +readTools env toolParser = + Env.lookupEnv (env.toolsEnvVar & textToString) >>= \case + Nothing -> do + Exit.die [fmt|Please set {env.toolsEnvVar} to a directory with all tools we need (see `Tools` in the code).|] + Just toolsDir -> + (Posix.fileExist toolsDir & ifTrueOrErr () [fmt|{env.toolsEnvVar} directory does not exist: {toolsDir}|]) + & thenValidate + ( \() -> + (Posix.getFileStatus toolsDir <&> Posix.isDirectory) + & ifTrueOrErr () [fmt|{env.toolsEnvVar} does not point to a directory: {toolsDir}|] + ) + & thenValidate + (\() -> toolParser.unToolParser toolsDir) + <&> first (errorTree [fmt|Could not find all tools in {env.toolsEnvVar}|]) + >>= \case + Failure err -> Exit.die (err & prettyErrorTree & textToString) + Success t -> pure t + +newtype ToolParserT m a = ToolParserT + { unToolParser :: + FilePath -> + m (Validation (NonEmpty Error) a) + } + deriving + (Functor, Applicative) + via (ValidationParseT FilePath m) + +-- | Given a file path and the name of the tool executable, see whether it is an executable and return its full path. +readTool :: Text -> ToolParserT IO Tool +readTool exeName = ToolParserT $ \toolDir -> do + let toolPath :: FilePath = toolDir (exeName & textToString) + let read' = True + let write = False + let exec = True + Posix.fileExist toolPath + & ifTrueOrErr () [fmt|Tool does not exist: {toolPath}|] + & thenValidate + ( \() -> + Posix.fileAccess toolPath read' write exec + & ifTrueOrErr (Tool {..}) [fmt|Tool is not readable/executable: {toolPath}|] + ) + +-- | helper +ifTrueOrErr :: Functor f => a -> Text -> f Bool -> f (Validation (NonEmpty Error) a) +ifTrueOrErr true err io = + io <&> \case + True -> Success true + False -> Failure $ singleton $ newError err diff --git a/users/Profpatsch/my-prelude/src/ValidationParseT.hs b/users/Profpatsch/my-prelude/src/ValidationParseT.hs new file mode 100644 index 0000000000..593b7ebf39 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/ValidationParseT.hs @@ -0,0 +1,16 @@ +module ValidationParseT where + +import Control.Selective (Selective) +import Data.Functor.Compose (Compose (..)) +import PossehlAnalyticsPrelude + +-- | A simple way to create an Applicative parser that parses from some environment. +-- +-- Use with DerivingVia. Grep codebase for examples. +newtype ValidationParseT env m a = ValidationParseT {unValidationParseT :: env -> m (Validation (NonEmpty Error) a)} + deriving + (Functor, Applicative, Selective) + via ( Compose + ((->) env) + (Compose m (Validation (NonEmpty Error))) + ) diff --git a/users/Profpatsch/whatcd-resolver/src/Postgres/Decoder.hs b/users/Profpatsch/whatcd-resolver/src/Postgres/Decoder.hs deleted file mode 100644 index 2e7fcb8779..0000000000 --- a/users/Profpatsch/whatcd-resolver/src/Postgres/Decoder.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Postgres.Decoder where - -import Control.Applicative (Alternative) -import Data.Aeson qualified as Json -import Data.Aeson.BetterErrors qualified as Json -import Data.Error.Tree -import Data.Typeable (Typeable) -import Database.PostgreSQL.Simple.FromField qualified as PG -import Database.PostgreSQL.Simple.FromRow qualified as PG -import Json qualified -import Label -import PossehlAnalyticsPrelude - --- | A Decoder of postgres values. Allows embedding more complex parsers (like a 'Json.ParseT'). -newtype Decoder a = Decoder (PG.RowParser a) - deriving newtype (Functor, Applicative, Alternative, Monad) - --- | Turn any type that implements 'PG.fromField' into a 'Decoder'. Use type applications to prevent accidental conversions: --- --- @ --- fromField @Text :: Decoder Text --- @ -fromField :: PG.FromField a => Decoder a -fromField = Decoder $ PG.fieldWith PG.fromField - --- | Turn any type that implements 'PG.fromField' into a 'Decoder' and wrap the result into the given 'Label'. Use type applications to prevent accidental conversions: --- --- @ --- fromField @"myField" @Text :: Decoder (Label "myField" Text) --- @ -fromFieldLabel :: forall lbl a. PG.FromField a => Decoder (Label lbl a) -fromFieldLabel = label @lbl <$> fromField - --- | Parse fields out of a json value returned from the database. --- --- ATTN: The whole json record has to be transferred before it is parsed, --- so if you only need a tiny bit of it, use `->` and `->>` in your SQL statement --- and return only the fields you need from the query. --- --- In that case pay attention to NULL though: --- --- @ --- SELECT '{"foo": {}}'::jsonb->>'foo' IS NULL --- → TRUE --- @ --- --- Also note: `->>` will coerce the json value to @text@, regardless of the content. --- So the JSON object @{"foo": {}}"@ would be returned as the text: @"{\"foo\": {}}"@. -json :: Typeable a => Json.ParseT ErrorTree Identity a -> Decoder a -json parser = Decoder $ PG.fieldWith $ \field bytes -> do - val <- PG.fromField @Json.Value field bytes - case Json.parseValue parser val of - Left err -> - PG.returnError - PG.ConversionFailed - field - (err & Json.parseErrorTree "Cannot decode jsonb column" & prettyErrorTree & textToString) - Right a -> pure a diff --git a/users/Profpatsch/whatcd-resolver/src/Postgres/MonadPostgres.hs b/users/Profpatsch/whatcd-resolver/src/Postgres/MonadPostgres.hs deleted file mode 100644 index e602ee287f..0000000000 --- a/users/Profpatsch/whatcd-resolver/src/Postgres/MonadPostgres.hs +++ /dev/null @@ -1,379 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Postgres.MonadPostgres where - -import Control.Exception -import Control.Monad.Except -import Control.Monad.Logger.CallStack -import Control.Monad.Reader (MonadReader (ask), ReaderT (..)) -import Data.Error.Tree -import Data.Int (Int64) -import Data.Kind (Type) -import Data.List qualified as List -import Data.Typeable (Typeable) -import Database.PostgreSQL.Simple (Connection, FormatError, FromRow, Query, QueryError, ResultError, SqlError, ToRow) -import Database.PostgreSQL.Simple qualified as PG -import Database.PostgreSQL.Simple.FromRow qualified as PG -import Database.PostgreSQL.Simple.ToField (ToField) -import Database.PostgreSQL.Simple.ToRow (ToRow (toRow)) -import Database.PostgreSQL.Simple.Types (fromQuery) -import GHC.Records (HasField (..)) -import Label -import PossehlAnalyticsPrelude -import Postgres.Decoder -import Pretty (showPretty) -import System.Exit (ExitCode (..)) -import Tool -import UnliftIO (MonadUnliftIO (withRunInIO)) -import UnliftIO.Process qualified as Process - --- | Postgres queries/commands that can be executed within a running transaction. --- --- These are implemented with the @postgresql-simple@ primitives of the same name --- and will behave the same unless othewise documented. -class Monad m => MonadPostgres (m :: Type -> Type) where - -- | Execute an INSERT, UPDATE, or other SQL query that is not expected to return results. - -- - -- Returns the number of rows affected. - execute :: (ToRow params, Typeable params) => Query -> params -> Transaction m (Label "numberOfRowsAffected" Natural) - - -- | Execute an INSERT, UPDATE, or other SQL query that is not expected to return results. Does not perform parameter substitution. - -- - -- Returns the number of rows affected. - execute_ :: Query -> Transaction m (Label "numberOfRowsAffected" Natural) - - -- | Execute a multi-row INSERT, UPDATE, or other SQL query that is not expected to return results. - -- - -- Returns the number of rows affected. If the list of parameters is empty, this function will simply return 0 without issuing the query to the backend. If this is not desired, consider using the 'PG.Values' constructor instead. - executeMany :: (ToRow params, Typeable params) => Query -> [params] -> Transaction m (Label "numberOfRowsAffected" Natural) - - -- | Execute INSERT ... RETURNING, UPDATE ... RETURNING, or other SQL query that accepts multi-row input and is expected to return results. Note that it is possible to write query conn "INSERT ... RETURNING ..." ... in cases where you are only inserting a single row, and do not need functionality analogous to 'executeMany'. - -- - -- If the list of parameters is empty, this function will simply return [] without issuing the query to the backend. If this is not desired, consider using the 'PG.Values' constructor instead. - executeManyReturningWith :: (ToRow q) => Query -> [q] -> Decoder r -> Transaction m [r] - - -- | Run a query, passing parameters and result row parser. - queryWith :: (PG.ToRow params, Typeable params, Typeable r) => PG.Query -> params -> Decoder r -> Transaction m [r] - - -- | Run a query without any parameters and result row parser. - queryWith_ :: (Typeable r) => PG.Query -> Decoder r -> Transaction m [r] - - -- | Run a query, passing parameters, and fold over the resulting rows. - -- - -- This doesn’t have to realize the full list of results in memory, - -- rather results are streamed incrementally from the database. - -- - -- When dealing with small results, it may be simpler (and perhaps faster) to use query instead. - -- - -- This fold is _not_ strict. The stream consumer is responsible for forcing the evaluation of its result to avoid space leaks. - -- - -- If you can, prefer aggregating in the database itself. - foldRows :: - (FromRow row, ToRow params, Typeable row, Typeable params) => - Query -> - params -> - a -> - (a -> row -> Transaction m a) -> - Transaction m a - - -- | Run a given transaction in a transaction block, rolling back the transaction - -- if any exception (postgres or Haskell Exception) is thrown during execution. - -- - -- Re-throws the exception. - -- - -- Don’t do any long-running things on the Haskell side during a transaction, - -- because it will block a database connection and potentially also lock - -- database tables from being written or read by other clients. - -- - -- Nonetheless, try to push transactions as far out to the handlers as possible, - -- don’t do something like @runTransaction $ query …@, because it will lead people - -- to accidentally start nested transactions (the inner transaction is run on a new connections, - -- thus can’t see any changes done by the outer transaction). - -- Only handlers should run transactions. - runTransaction :: Transaction m a -> m a - --- | Run a query, passing parameters. -query :: forall m params r. (PG.ToRow params, PG.FromRow r, Typeable params, Typeable r, MonadPostgres m) => PG.Query -> params -> Transaction m [r] -query qry params = queryWith qry params (Decoder PG.fromRow) - --- | Run a query without any parameters. -query_ :: forall m r. (Typeable r, PG.FromRow r, MonadPostgres m) => PG.Query -> Transaction m [r] -query_ qry = queryWith_ qry (Decoder PG.fromRow) - --- TODO: implement via fold, so that the result doesn’t have to be realized in memory -querySingleRow :: - ( MonadPostgres m, - ToRow qParams, - Typeable qParams, - FromRow a, - Typeable a, - MonadThrow m - ) => - Query -> - qParams -> - Transaction m a -querySingleRow qry params = do - query qry params >>= ensureSingleRow - --- TODO: implement via fold, so that the result doesn’t have to be realized in memory -querySingleRowMaybe :: - ( MonadPostgres m, - ToRow qParams, - Typeable qParams, - FromRow a, - Typeable a, - MonadThrow m - ) => - Query -> - qParams -> - Transaction m (Maybe a) -querySingleRowMaybe qry params = do - rows <- query qry params - case rows of - [] -> pure Nothing - [one] -> pure (Just one) - -- TODO: Should we MonadThrow this here? It’s really an implementation detail of MonadPostgres - -- that a database function can error out, should probably handled by the instances. - more -> throwM $ SingleRowError {numberOfRowsReturned = (List.length more)} - -ensureSingleRow :: MonadThrow m => [a] -> m a -ensureSingleRow = \case - -- TODO: Should we MonadThrow this here? It’s really an implementation detail of MonadPostgres - -- that a database function can error out, should probably handled by the instances. - [] -> throwM (SingleRowError {numberOfRowsReturned = 0}) - [one] -> pure one - more -> - throwM $ - SingleRowError - { numberOfRowsReturned = - -- TODO: this is VERY bad, because it requires to parse the full database output, even if there’s 10000000000 elements - List.length more - } - -newtype Transaction m a = Transaction {unTransaction :: (ReaderT Connection m a)} - deriving newtype - ( Functor, - Applicative, - Monad, - MonadThrow, - MonadLogger, - MonadIO, - MonadUnliftIO, - MonadTrans - ) - -runTransaction' :: Connection -> Transaction m a -> m a -runTransaction' conn transaction = runReaderT transaction.unTransaction conn - --- | Catch any Postgres exception that gets thrown, --- print the query that was run and the query parameters, --- then rethrow inside an 'Error'. -handlePGException :: - forall a params m. - (ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => - Text -> - Query -> - -- | Depending on whether we used `format` or `formatMany`. - Either params [params] -> - IO a -> - Transaction m a -handlePGException queryType query' params io = do - withRunInIO $ \unliftIO -> - io - `catches` [ Handler $ unliftIO . logQueryException @SqlError, - Handler $ unliftIO . logQueryException @QueryError, - Handler $ unliftIO . logQueryException @ResultError, - Handler $ unliftIO . logFormatException - ] - where - -- TODO: use throwInternalError here (after pulling it into the MonadPostgres class) - throwAsError = unwrapIOError . Left . newError - throwErr err = liftIO $ throwAsError $ prettyErrorTree $ nestedMultiError "A Postgres query failed" err - logQueryException :: Exception e => e -> Transaction m a - logQueryException exc = do - formattedQuery <- case params of - Left one -> pgFormatQuery' query' one - Right many -> pgFormatQueryMany' query' many - throwErr - ( singleError [fmt|Query Type: {queryType}|] - :| [ nestedError "Exception" (exc & showPretty & newError & singleError), - nestedError "Query" (formattedQuery & newError & singleError) - ] - ) - logFormatException :: FormatError -> Transaction m a - logFormatException fe = throwErr (fe & showPretty & newError & singleError & singleton) - -pgExecute :: (ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> params -> Transaction m (Label "numberOfRowsAffected" Natural) -pgExecute qry params = do - conn <- Transaction ask - PG.execute conn qry params - & handlePGException "execute" qry (Left params) - >>= toNumberOfRowsAffected "pgExecute" - -pgExecute_ :: (MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> Transaction m (Label "numberOfRowsAffected" Natural) -pgExecute_ qry = do - conn <- Transaction ask - PG.execute_ conn qry - & handlePGException "execute_" qry (Left ()) - >>= toNumberOfRowsAffected "pgExecute_" - -pgExecuteMany :: (ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> [params] -> Transaction m (Label "numberOfRowsAffected" Natural) -pgExecuteMany qry params = - do - conn <- Transaction ask - PG.executeMany conn qry params - & handlePGException "executeMany" qry (Right params) - >>= toNumberOfRowsAffected "pgExecuteMany" - -toNumberOfRowsAffected :: MonadIO m => Text -> Int64 -> m (Label "numberOfRowsAffected" Natural) -toNumberOfRowsAffected functionName i64 = - i64 - & intToNatural - & annotate [fmt|{functionName}: postgres returned a negative number of rows affected: {i64}|] - -- we throw this directly in IO here, because we don’t want to e.g. have to propagate MonadThrow through user code (it’s an assertion) - & unwrapIOError - & liftIO - <&> label @"numberOfRowsAffected" - -pgExecuteManyReturningWith :: (ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> [params] -> Decoder r -> Transaction m [r] -pgExecuteManyReturningWith qry params (Decoder fromRow) = - do - conn <- Transaction ask - PG.returningWith fromRow conn qry params - & handlePGException "executeManyReturning" qry (Right params) - -pgFold :: - (FromRow row, ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => - Query -> - params -> - a -> - (a -> row -> Transaction m a) -> - Transaction m a -pgFold qry params accumulator f = do - conn <- Transaction ask - - withRunInIO - ( \runInIO -> - do - PG.fold - conn - qry - params - accumulator - (\acc row -> runInIO $ f acc row) - & handlePGException "fold" qry (Left params) - & runInIO - ) - -pgFormatQuery :: (ToRow params, MonadIO m) => Query -> params -> Transaction m ByteString -pgFormatQuery qry params = Transaction $ do - conn <- ask - liftIO $ PG.formatQuery conn qry params - -pgFormatQueryMany :: (MonadIO m, ToRow params) => Query -> [params] -> Transaction m ByteString -pgFormatQueryMany qry params = Transaction $ do - conn <- ask - liftIO $ PG.formatMany conn qry params - -pgQueryWith :: (ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> params -> Decoder r -> Transaction m [r] -pgQueryWith qry params (Decoder fromRow) = do - conn <- Transaction ask - PG.queryWith fromRow conn qry params - & handlePGException "query" qry (Left params) - -pgQueryWith_ :: (MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> Decoder r -> Transaction m [r] -pgQueryWith_ qry (Decoder fromRow) = do - conn <- Transaction ask - liftIO (PG.queryWith_ fromRow conn qry) - & handlePGException "query" qry (Left ()) - -pgQuery :: (ToRow params, FromRow r, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> params -> Transaction m [r] -pgQuery qry params = do - conn <- Transaction ask - PG.query conn qry params - & handlePGException "query" qry (Left params) - -pgQuery_ :: (FromRow r, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> Transaction m [r] -pgQuery_ qry = do - conn <- Transaction ask - PG.query_ conn qry - & handlePGException "query_" qry (Left ()) - -data SingleRowError = SingleRowError - { -- | How many columns were actually returned by the query - numberOfRowsReturned :: Int - } - deriving stock (Show) - -instance Exception SingleRowError where - displayException (SingleRowError {..}) = [fmt|Single row expected from SQL query result, {numberOfRowsReturned} rows were returned instead."|] - -pgFormatQueryNoParams' :: (MonadIO m, MonadLogger m, MonadTools m) => Query -> Transaction m Text -pgFormatQueryNoParams' q = - lift $ pgFormatQueryByteString q.fromQuery - -pgFormatQuery' :: (MonadIO m, ToRow params, MonadLogger m, MonadTools m) => Query -> params -> Transaction m Text -pgFormatQuery' q p = - pgFormatQuery q p - >>= lift . pgFormatQueryByteString - -pgFormatQueryMany' :: (MonadIO m, ToRow params, MonadLogger m, MonadTools m) => Query -> [params] -> Transaction m Text -pgFormatQueryMany' q p = - pgFormatQueryMany q p - >>= lift . pgFormatQueryByteString - --- | Tools required at runtime -data Tools = Tools - { pgFormat :: Tool - } - deriving stock (Show) - -class Monad m => MonadTools m where - getTools :: m Tools - -initMonadTools :: Label "envvar" Text -> IO Tools -initMonadTools var = - Tool.readTools (label @"toolsEnvVar" var.envvar) toolParser - where - toolParser = do - pgFormat <- readTool "pg_format" - pure $ Tools {..} - -pgFormatQueryByteString :: (MonadIO m, MonadLogger m, MonadTools m) => ByteString -> m Text -pgFormatQueryByteString queryBytes = do - do - tools <- getTools - (exitCode, stdout, stderr) <- - Process.readProcessWithExitCode - tools.pgFormat.toolPath - ["-"] - (queryBytes & bytesToTextUtf8Lenient & textToString) - case exitCode of - ExitSuccess -> pure (stdout & stringToText) - ExitFailure status -> do - logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|] - logDebug - ( prettyErrorTree - ( nestedMultiError - "pg_format output" - ( nestedError "stdout" (singleError (stdout & stringToText & newError)) - :| [(nestedError "stderr" (singleError (stderr & stringToText & newError)))] - ) - ) - ) - logDebug [fmt|pg_format stdout: stderr|] - pure (queryBytes & bytesToTextUtf8Lenient) - -instance (ToField t1) => ToRow (Label l1 t1) where - toRow t2 = toRow $ PG.Only $ getField @l1 t2 - -instance (ToField t1, ToField t2) => ToRow (T2 l1 t1 l2 t2) where - toRow t2 = toRow (getField @l1 t2, getField @l2 t2) - -instance (ToField t1, ToField t2, ToField t3) => ToRow (T3 l1 t1 l2 t2 l3 t3) where - toRow t3 = toRow (getField @l1 t3, getField @l2 t3, getField @l3 t3) diff --git a/users/Profpatsch/whatcd-resolver/src/Tool.hs b/users/Profpatsch/whatcd-resolver/src/Tool.hs deleted file mode 100644 index 066f68bbe0..0000000000 --- a/users/Profpatsch/whatcd-resolver/src/Tool.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Tool where - -import Data.Error.Tree -import Label -import PossehlAnalyticsPrelude -import System.Environment qualified as Env -import System.Exit qualified as Exit -import System.FilePath (()) -import System.Posix qualified as Posix -import ValidationParseT - -data Tool = Tool - { -- | absolute path to the executable - toolPath :: FilePath - } - deriving stock (Show) - --- | Reads all tools from the @toolsEnvVar@ variable or aborts. -readTools :: - Label "toolsEnvVar" Text -> - -- | Parser for Tools we bring with us at build time. - -- - -- These are executables that we need available, and that we have to ship with the distribution of @pa-cli@. - ToolParserT IO tools -> - IO tools -readTools env toolParser = - Env.lookupEnv (env.toolsEnvVar & textToString) >>= \case - Nothing -> do - Exit.die [fmt|Please set {env.toolsEnvVar} to a directory with all tools we need (see `Tools` in the code).|] - Just toolsDir -> - (Posix.fileExist toolsDir & ifTrueOrErr () [fmt|{env.toolsEnvVar} directory does not exist: {toolsDir}|]) - & thenValidate - ( \() -> - (Posix.getFileStatus toolsDir <&> Posix.isDirectory) - & ifTrueOrErr () [fmt|{env.toolsEnvVar} does not point to a directory: {toolsDir}|] - ) - & thenValidate - (\() -> toolParser.unToolParser toolsDir) - <&> first (errorTree [fmt|Could not find all tools in {env.toolsEnvVar}|]) - >>= \case - Failure err -> Exit.die (err & prettyErrorTree & textToString) - Success t -> pure t - -newtype ToolParserT m a = ToolParserT - { unToolParser :: - FilePath -> - m (Validation (NonEmpty Error) a) - } - deriving - (Functor, Applicative) - via (ValidationParseT FilePath m) - --- | Given a file path and the name of the tool executable, see whether it is an executable and return its full path. -readTool :: Text -> ToolParserT IO Tool -readTool exeName = ToolParserT $ \toolDir -> do - let toolPath :: FilePath = toolDir (exeName & textToString) - let read' = True - let write = False - let exec = True - Posix.fileExist toolPath - & ifTrueOrErr () [fmt|Tool does not exist: {toolPath}|] - & thenValidate - ( \() -> - Posix.fileAccess toolPath read' write exec - & ifTrueOrErr (Tool {..}) [fmt|Tool is not readable/executable: {toolPath}|] - ) - --- | helper -ifTrueOrErr :: Functor f => a -> Text -> f Bool -> f (Validation (NonEmpty Error) a) -ifTrueOrErr true err io = - io <&> \case - True -> Success true - False -> Failure $ singleton $ newError err diff --git a/users/Profpatsch/whatcd-resolver/src/ValidationParseT.hs b/users/Profpatsch/whatcd-resolver/src/ValidationParseT.hs deleted file mode 100644 index 593b7ebf39..0000000000 --- a/users/Profpatsch/whatcd-resolver/src/ValidationParseT.hs +++ /dev/null @@ -1,16 +0,0 @@ -module ValidationParseT where - -import Control.Selective (Selective) -import Data.Functor.Compose (Compose (..)) -import PossehlAnalyticsPrelude - --- | A simple way to create an Applicative parser that parses from some environment. --- --- Use with DerivingVia. Grep codebase for examples. -newtype ValidationParseT env m a = ValidationParseT {unValidationParseT :: env -> m (Validation (NonEmpty Error) a)} - deriving - (Functor, Applicative, Selective) - via ( Compose - ((->) env) - (Compose m (Validation (NonEmpty Error))) - ) diff --git a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal index a4a7f6e449..86a19a7ced 100644 --- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal +++ b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal @@ -58,44 +58,37 @@ library exposed-modules: WhatcdResolver - Postgres.Decoder - Postgres.MonadPostgres - Tool - ValidationParseT Multipart2 build-depends: base >=4.15 && <5, text, + my-prelude, pa-prelude, pa-error-tree, pa-label, pa-json, pa-field-parser, - pa-run-command, + aeson-better-errors, + aeson, + blaze-html, + bytestring, containers, - pa-pretty, - tmp-postgres, directory, + dlist, filepath, - aeson, - aeson-better-errors, - postgresql-simple, - resource-pool, http-conduit, http-types, + ihp-hsx, + monad-logger, mtl, - transformers, + resource-pool, + postgresql-simple, + scientific, + selective, + tmp-postgres, unliftio, - monad-logger, - unix, - warp, - wai, wai-extra, - ihp-hsx, - blaze-html, - bytestring, - dlist, - scientific, - selective + wai, + warp, -- cgit 1.4.1