diff options
Diffstat (limited to 'users/Profpatsch/my-prelude')
| -rw-r--r-- | users/Profpatsch/my-prelude/README.md | 42 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/default.nix | 35 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/my-prelude.cabal | 116 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Aeson.hs | 176 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Arg.hs | 34 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/AtLeast.hs | 51 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/MyPrelude.hs (renamed from users/Profpatsch/my-prelude/MyPrelude.hs) | 418 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Parse.hs | 174 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Postgres/Decoder.hs | 94 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs | 930 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Pretty.hs | 108 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Seconds.hs | 55 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Test.hs | 115 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Tool.hs | 75 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/ValidationParseT.hs | 16 |
15 files changed, 2332 insertions, 107 deletions
diff --git a/users/Profpatsch/my-prelude/README.md b/users/Profpatsch/my-prelude/README.md new file mode 100644 index 0000000000..2cc068579a --- /dev/null +++ b/users/Profpatsch/my-prelude/README.md @@ -0,0 +1,42 @@ +# My Haskell Prelude + +Contains various modules I’ve found useful when writing Haskell. + +## Contents + +A short overview: + +### `MyPrelude.hs` + +A collection of re-exports and extra functions. This does *not* replace the `Prelude` module from `base`, but rather should be imported *in addition* to `Prelude`. + +Stuff like bad functions from prelude (partial stuff, or plain horrible stuff) are handled by a custom `.hlint` file, which you can find in [../.hlint.yaml](). + +The common style of haskell they try to enable is what I call “left-to-right Haskell”, +where one mostly prefers forward-chaining operators like `&`/`<&>`/`>>=` to backwards operators like `$`/`<$>`/`<=<`. In addition, all transformation function should follow the scheme of `aToB` instead of `B.fromA`, e.g. `Text.unpack`/`Text.pack` -> `textToString`/`stringToText`. Includes a bunch of text conversion functions one needs all the time, in the same style. + +These have been battle-tested in a production codebase of ~30k lines of Haskell. + +### `Label.hs` + +A very useful collection of anonymous labbeled tuples and enums of size 2 and 3. Assumes GHC >9.2 for `RecordDotSyntax` support. + +### `Pretty.hs` + +Colorful multiline pretty-printing of Haskell values. + +### `Test.hs` + +A wrapper around `hspec` which produces colorful test diffs. + +### `Aeson.hs` + +Helpers around Json parsing. + +### `Data.Error.Tree` + +Collect errors (from [`Data.Error`](https://hackage.haskell.org/package/error-1.0.0.0/docs/Data-Error.html)) into a tree, then display them in a nested fashion. Super useful for e.g. collecting and displaying nested parsing errors. + +### `RunCommand.hs` + +A module wrapping the process API with some helpful defaults for executing commands and printing what is executed to stderr. diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 88e67f7a50..4bca8ea49f 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/users/Profpatsch/my-prelude/default.nix @@ -6,20 +6,45 @@ pkgs.haskellPackages.mkDerivation { src = depot.users.Profpatsch.exactSource ./. [ ./my-prelude.cabal - ./MyPrelude.hs + ./src/Aeson.hs + ./src/Arg.hs + ./src/AtLeast.hs + ./src/MyPrelude.hs + ./src/Test.hs + ./src/Parse.hs + ./src/Pretty.hs + ./src/Seconds.hs + ./src/Tool.hs + ./src/ValidationParseT.hs + ./src/Postgres/Decoder.hs + ./src/Postgres/MonadPostgres.hs ]; isLibrary = true; libraryHaskellDepends = [ - pkgs.haskellPackages.PyF - pkgs.haskellPackages.errors + pkgs.haskellPackages.pa-prelude + pkgs.haskellPackages.pa-label + pkgs.haskellPackages.pa-error-tree + pkgs.haskellPackages.pa-json + pkgs.haskellPackages.pa-pretty + pkgs.haskellPackages.pa-field-parser + pkgs.haskellPackages.aeson-better-errors + pkgs.haskellPackages.foldl + pkgs.haskellPackages.resource-pool + pkgs.haskellPackages.error + pkgs.haskellPackages.hs-opentelemetry-api + pkgs.haskellPackages.hspec + pkgs.haskellPackages.hspec-expectations-pretty-diff + pkgs.haskellPackages.monad-logger + pkgs.haskellPackages.postgresql-simple pkgs.haskellPackages.profunctors + pkgs.haskellPackages.PyF pkgs.haskellPackages.semigroupoids pkgs.haskellPackages.these + pkgs.haskellPackages.unliftio pkgs.haskellPackages.validation-selective - pkgs.haskellPackages.error - + 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 7de057e9e1..2f7882a526 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -1,11 +1,74 @@ -cabal-version: 2.4 +cabal-version: 3.0 name: my-prelude 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 + + -- allows defining pattern synonyms, but also the `import Foo (pattern FooPattern)` import syntax + PatternSynonyms + default-language: GHC2021 + + library - exposed-modules: MyPrelude + import: common-options + hs-source-dirs: src + exposed-modules: + MyPrelude + Aeson + Arg + AtLeast + Test + Postgres.Decoder + Postgres.MonadPostgres + ValidationParseT + Parse + Pretty + Seconds + Tool -- Modules included in this executable, other than Main. -- other-modules: @@ -13,15 +76,46 @@ library -- LANGUAGE extensions used by modules in this package. -- other-extensions: build-depends: - base ^>=4.15.1.0 - , PyF - , validation-selective - , these - , text - , semigroupoids - , profunctors + base >=4.15 && <5 + , pa-prelude + , pa-label + , pa-error-tree + , pa-json + , pa-pretty + , pa-field-parser + , aeson + , aeson-better-errors + , bytestring , containers + , foldl + , unordered-containers + , resource-pool + , resourcet + , scientific + , time , error - , bytestring + , exceptions + , filepath + , hspec + , hspec-expectations-pretty-diff + , hs-opentelemetry-api + , monad-logger , mtl - default-language: Haskell2010 + , postgresql-simple + , profunctors + , PyF + , semigroupoids + , selective + , template-haskell + , text + , these + , unix + , unliftio + , validation-selective + , vector + , ghc-boot + -- for Pretty + , aeson-pretty + , hscolour + , ansi-terminal + , nicify-lib 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/Arg.hs b/users/Profpatsch/my-prelude/src/Arg.hs new file mode 100644 index 0000000000..a6ffa90924 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Arg.hs @@ -0,0 +1,34 @@ +module Arg where + +import Data.String (IsString) +import GHC.Exts (IsList) +import GHC.TypeLits (Symbol) + +-- | Wrap a function argument into this helper to give it a better description for the caller without disturbing the callsite too much. +-- +-- This has instances for IsString and Num, meaning if the caller is usually a string or number literal, it should Just Work. +-- +-- e.g. +-- +-- @ +-- myFoo :: Arg "used as the name in error message" Text -> IO () +-- myFoo (Arg name) = … +-- @ +-- +-- Will display the description in the inferred type of the callsite. +-- +-- Due to IsString you can call @myFoo@ like +-- +-- @myFoo "name in error"@ +-- +-- This is mostly intended for literals, if you want to wrap arbitrary data, use @Label@. +newtype Arg (description :: Symbol) a = Arg {unArg :: a} + deriving newtype + ( Show, + Eq, + IsString, + IsList, + Num, + Monoid, + Semigroup + ) diff --git a/users/Profpatsch/my-prelude/src/AtLeast.hs b/users/Profpatsch/my-prelude/src/AtLeast.hs new file mode 100644 index 0000000000..3857c3a7cf --- /dev/null +++ b/users/Profpatsch/my-prelude/src/AtLeast.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE QuasiQuotes #-} + +module AtLeast where + +import Data.Aeson (FromJSON (parseJSON)) +import Data.Aeson.BetterErrors qualified as Json +import FieldParser (FieldParser) +import FieldParser qualified as Field +import GHC.Records (HasField (..)) +import GHC.TypeLits (KnownNat, natVal) +import PossehlAnalyticsPrelude + ( Natural, + Proxy (Proxy), + fmt, + prettyError, + (&), + ) + +-- | A natural number that must be at least as big as the type literal. +newtype AtLeast (min :: Natural) num = AtLeast num + -- Just use the instances of the wrapped number type + deriving newtype (Eq, Show) + +-- | This is the “destructor” for `AtLeast`, because of the phantom type (@min@) it cannot be inferred automatically. +instance HasField "unAtLeast" (AtLeast min num) num where + getField (AtLeast num) = num + +parseAtLeast :: + forall min num. + (KnownNat min, Integral num, Show num) => + FieldParser num (AtLeast min num) +parseAtLeast = + let minInt = natVal (Proxy @min) + in Field.FieldParser $ \from -> + if from >= (minInt & fromIntegral) + then Right (AtLeast from) + else Left [fmt|Must be at least {minInt & show} but was {from & show}|] + +instance + (KnownNat min, FromJSON num, Integral num, Bounded num, Show num) => + FromJSON (AtLeast min num) + where + parseJSON = + Json.toAesonParser + prettyError + ( do + num <- Json.fromAesonParser @_ @num + case Field.runFieldParser (parseAtLeast @min @num) num of + Left err -> Json.throwCustomError err + Right a -> pure a + ) diff --git a/users/Profpatsch/my-prelude/MyPrelude.hs b/users/Profpatsch/my-prelude/src/MyPrelude.hs index a2c99bc9ea..880983c47e 100644 --- a/users/Profpatsch/my-prelude/MyPrelude.hs +++ b/users/Profpatsch/my-prelude/src/MyPrelude.hs @@ -1,10 +1,7 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} module MyPrelude ( -- * Text conversions @@ -14,6 +11,7 @@ module MyPrelude fmt, textToString, stringToText, + stringToBytesUtf8, showToText, textToBytesUtf8, textToBytesUtf8Lazy, @@ -37,7 +35,11 @@ module MyPrelude -- * WIP code todo, + -- * Records + HasField, + -- * Control flow + doAs, (&), (<&>), (<|>), @@ -47,10 +49,10 @@ module MyPrelude when, unless, guard, - ExceptT, + ExceptT (..), runExceptT, - MonadError, - throwError, + MonadThrow, + throwM, MonadIO, liftIO, MonadReader, @@ -59,9 +61,11 @@ module MyPrelude first, second, bimap, + both, foldMap, fold, foldl', + fromMaybe, mapMaybe, findMaybe, Traversable, @@ -72,6 +76,8 @@ module MyPrelude traverseFold, traverseFold1, traverseFoldDefault, + MonadTrans, + lift, -- * Data types Coercible, @@ -83,6 +89,9 @@ module MyPrelude failure, successes, failures, + traverseValidate, + traverseValidateM, + traverseValidateM_, eitherToValidation, eitherToListValidation, validationToEither, @@ -92,24 +101,40 @@ module MyPrelude validationToThese, thenThese, thenValidate, + thenValidateM, NonEmpty ((:|)), + pattern IsEmpty, + pattern IsNonEmpty, singleton, nonEmpty, nonEmptyDef, + overNonEmpty, + zipNonEmpty, + zipWithNonEmpty, + zip3NonEmpty, + zipWith3NonEmpty, + zip4NonEmpty, toList, - toNonEmptyDefault, + lengthNatural, maximum1, minimum1, + maximumBy1, + minimumBy1, + Vector, Generic, + Lift, Semigroup, sconcat, Monoid, mconcat, + ifTrue, + ifExists, Void, absurd, Identity (Identity, runIdentity), Natural, intToNatural, + Scientific, Contravariant, contramap, (>$<), @@ -120,79 +145,92 @@ module MyPrelude rmap, Semigroupoid, Category, - (<<<), (>>>), + (&>>), + Any, -- * Enum definition inverseFunction, inverseMap, + enumerateAll, + + -- * Map helpers + mapFromListOn, + mapFromListOnMerge, -- * Error handling HasCallStack, module Data.Error, - smushErrors, ) where import Control.Applicative ((<|>)) -import Control.Category (Category, (<<<), (>>>)) +import Control.Category (Category, (>>>)) +import Control.Foldl.NonEmpty qualified as Foldl1 import Control.Monad (guard, join, unless, when) +import Control.Monad.Catch (MonadThrow (throwM)) import Control.Monad.Except - ( ExceptT, - MonadError, + ( ExceptT (..), runExceptT, - throwError, ) 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 qualified Data.ByteString.Lazy -import qualified Data.Char +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 qualified Data.Foldable as Foldable +import Data.Foldable (Foldable (foldMap', toList), fold, foldl', for_, sequenceA_, 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 (zip4) import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict ( Map, ) -import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) -import qualified Data.Maybe as Maybe +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.Scientific (Scientific) +import Data.Semigroup (sconcat) import Data.Semigroup.Foldable (Foldable1 (fold1), foldMap1) import Data.Semigroup.Traversable (Traversable1) -import Data.Semigroupoid (Semigroupoid) +import Data.Semigroupoid (Semigroupoid (o)) import Data.Text ( Text, ) -import qualified Data.Text -import qualified Data.Text.Encoding -import qualified Data.Text.Encoding.Error -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Encoding +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.Vector (Vector) import Data.Void (Void, absurd) import Data.Word (Word8) import GHC.Exception (errorCallWithCallStackException) -import GHC.Exts (RuntimeRep, TYPE, raise#) +import GHC.Exts (Any, RuntimeRep, TYPE, raise#) import GHC.Generics (Generic) import GHC.Natural (Natural) +import GHC.Records (HasField) import GHC.Stack (HasCallStack) +import GHC.Utils.Encoding qualified as GHC +import Language.Haskell.TH.Syntax (Lift) import PyF (fmt) -import qualified System.Exit -import qualified System.IO +import System.Exit qualified +import System.IO qualified import Validation ( Validation (Failure, Success), eitherToValidation, @@ -202,12 +240,41 @@ import Validation validationToEither, ) +-- | Mark a `do`-block with the type of the Monad/Applicativ it uses. +-- Only intended for reading ease and making code easier to understand, +-- especially do-blocks that use unconventional monads (like Maybe or List). +-- +-- Example: +-- +-- @ +-- doAs @Maybe $ do +-- a <- Just 'a' +-- b <- Just 'b' +-- pure (a, b) +-- @ +doAs :: forall m a. m a -> m a +doAs = id + -- | Forward-applying 'contramap', like '&'/'$' and '<&>'/'<$>' but for '>$<'. -(>&<) :: Contravariant f => f b -> (a -> b) -> f a +(>&<) :: (Contravariant f) => f b -> (a -> b) -> f a (>&<) = flip contramap infixl 5 >&< +-- | 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 @@ -242,26 +309,52 @@ bytesToTextUtf8LenientLazy :: Data.ByteString.Lazy.ByteString -> Data.Text.Lazy. bytesToTextUtf8LenientLazy = Data.Text.Lazy.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode --- | Make a lazy text strict +-- | Make a lazy 'Text' strict. toStrict :: Data.Text.Lazy.Text -> Text toStrict = Data.Text.Lazy.toStrict --- | Make a strict text lazy +-- | Make a strict 'Text' lazy. toLazy :: Text -> Data.Text.Lazy.Text toLazy = Data.Text.Lazy.fromStrict +-- | Make a lazy 'ByteString' strict. toStrictBytes :: Data.ByteString.Lazy.ByteString -> ByteString toStrictBytes = Data.ByteString.Lazy.toStrict +-- | Make a strict 'ByteString' lazy. toLazyBytes :: ByteString -> Data.ByteString.Lazy.ByteString toLazyBytes = Data.ByteString.Lazy.fromStrict +-- | Convert a (performant) 'Text' into an (imperformant) list-of-char 'String'. +-- +-- Some libraries (like @time@ or @network-uri@) still use the `String` as their interface. We only want to convert to string at the edges, otherwise use 'Text'. +-- +-- ATTN: Don’t use `String` in code if you can avoid it, prefer `Text` instead. textToString :: Text -> String textToString = Data.Text.unpack +-- | Convert an (imperformant) list-of-char 'String' into a (performant) 'Text' . +-- +-- Some libraries (like @time@ or @network-uri@) still use the `String` as their interface. We want to convert 'String' to 'Text' as soon as possible and only use 'Text' in our code. +-- +-- ATTN: Don’t use `String` in code if you can avoid it, prefer `Text` instead. stringToText :: String -> Text stringToText = Data.Text.pack +-- | Encode a String to an UTF-8 encoded Bytestring +-- +-- ATTN: Don’t use `String` in code if you can avoid it, prefer `Text` instead. +stringToBytesUtf8 :: String -> ByteString +-- TODO(Profpatsch): use a stable interface +stringToBytesUtf8 = GHC.utf8EncodeByteString + +-- | Like `show`, but generate a 'Text' +-- +-- ATTN: This goes via `String` and thus is fairly inefficient. +-- We should add a good display library at one point. +-- +-- ATTN: unlike `show`, this forces the whole @'a +-- so only use if you want to display the whole thing. showToText :: (Show a) => a -> Text showToText = stringToText . show @@ -275,8 +368,20 @@ showToText = stringToText . show -- >>> charToWordUnsafe ',' -- 44 charToWordUnsafe :: Char -> Word8 -charToWordUnsafe = fromIntegral . Data.Char.ord {-# INLINE charToWordUnsafe #-} +charToWordUnsafe = fromIntegral . Data.Char.ord + +pattern IsEmpty :: [a] +pattern IsEmpty <- (null -> True) + where + IsEmpty = [] + +pattern IsNonEmpty :: NonEmpty a -> [a] +pattern IsNonEmpty n <- (nonEmpty -> Just n) + where + IsNonEmpty n = toList n + +{-# COMPLETE IsEmpty, IsNonEmpty #-} -- | Single element in a (non-empty) list. singleton :: a -> NonEmpty a @@ -289,19 +394,69 @@ nonEmptyDef def xs = 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' +-- | If the list is not empty, run the given function with a NonEmpty list, otherwise just return [] +overNonEmpty :: (Applicative f) => (NonEmpty a -> f [b]) -> [a] -> f [b] +overNonEmpty f xs = case xs of + IsEmpty -> pure [] + IsNonEmpty xs' -> f xs' + +-- | Zip two non-empty lists. +zipNonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty (a, b) +{-# INLINE zipNonEmpty #-} +zipNonEmpty ~(a :| as) ~(b :| bs) = (a, b) :| zip as bs + +-- | Zip two non-empty lists, combining them with the given function +zipWithNonEmpty :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c +{-# INLINE zipWithNonEmpty #-} +zipWithNonEmpty = NonEmpty.zipWith + +-- | Zip three non-empty lists. +zip3NonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c) +{-# INLINE zip3NonEmpty #-} +zip3NonEmpty ~(a :| as) ~(b :| bs) ~(c :| cs) = (a, b, c) :| zip3 as bs cs + +-- | Zip three non-empty lists, combining them with the given function +zipWith3NonEmpty :: (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d +{-# INLINE zipWith3NonEmpty #-} +zipWith3NonEmpty f ~(x :| xs) ~(y :| ys) ~(z :| zs) = f x y z :| zipWith3 f xs ys zs + +-- | Zip four non-empty lists +zip4NonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty (a, b, c, d) +{-# INLINE zip4NonEmpty #-} +zip4NonEmpty ~(a :| as) ~(b :| bs) ~(c :| cs) ~(d :| ds) = (a, b, c, d) :| zip4 as bs cs ds + +-- | We don’t want to use Foldable’s `length`, because it is too polymorphic and can lead to bugs. +-- Only list-y things should have a length. +class (Foldable f) => Lengthy f + +instance Lengthy [] --- | @O(n)@. Get the maximum element from a non-empty structure. +instance Lengthy NonEmpty + +instance Lengthy Vector + +lengthNatural :: (Lengthy f) => f a -> Natural +lengthNatural xs = + xs + & Foldable.length + -- length can never be negative or something went really, really wrong + & fromIntegral @Int @Natural + +-- | @O(n)@. Get the maximum element from a non-empty structure (strict). maximum1 :: (Foldable1 f, Ord a) => f a -> a -maximum1 xs = xs & foldMap1 Max & getMax +maximum1 = Foldl1.fold1 Foldl1.maximum --- | @O(n)@. Get the minimum element from a non-empty structure. +-- | @O(n)@. Get the maximum element from a non-empty structure, using the given comparator (strict). +maximumBy1 :: (Foldable1 f) => (a -> a -> Ordering) -> f a -> a +maximumBy1 f = Foldl1.fold1 (Foldl1.maximumBy f) + +-- | @O(n)@. Get the minimum element from a non-empty structure (strict). minimum1 :: (Foldable1 f, Ord a) => f a -> a -minimum1 xs = xs & foldMap1 Min & getMin +minimum1 = Foldl1.fold1 Foldl1.minimum + +-- | @O(n)@. Get the minimum element from a non-empty structure, using the given comparator (strict). +minimumBy1 :: (Foldable1 f) => (a -> a -> Ordering) -> f a -> a +minimumBy1 f = Foldl1.fold1 (Foldl1.minimumBy f) -- | Annotate a 'Maybe' with an error message and turn it into an 'Either'. annotate :: err -> Maybe a -> Either err a @@ -309,6 +464,10 @@ 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: @@ -320,15 +479,55 @@ annotate err = \case -- Nothing -- >>> findMaybe (Text.Read.readMaybe @Int) ["foo", "34.40", "34", "abc"] -- Just 34 -findMaybe :: Foldable t => (a -> Maybe b) -> t a -> Maybe b +findMaybe :: (Foldable t) => (a -> Maybe b) -> t a -> Maybe b findMaybe mPred list = let pred' x = Maybe.isJust $ mPred x in case Foldable.find pred' list of Just a -> mPred a Nothing -> Nothing +-- | 'traverse' with a function returning 'Either' and collect all errors that happen, if they happen. +-- +-- Does not shortcut on error, so will always traverse the whole list/'Traversable' structure. +-- +-- This is a useful error handling function in many circumstances, +-- because it won’t only return the first error that happens, but rather all of them. +traverseValidate :: forall t a err b. (Traversable t) => (a -> Either err b) -> t a -> Either (NonEmpty err) (t b) +traverseValidate f as = + as + & traverse @t @(Validation _) (eitherToListValidation . f) + & validationToEither + +-- | 'traverse' with a function returning 'm Either' and collect all errors that happen, if they happen. +-- +-- Does not shortcut on error, so will always traverse the whole list/'Traversable' structure. +-- +-- This is a useful error handling function in many circumstances, +-- because it won’t only return the first error that happens, but rather all of them. +traverseValidateM :: forall t m a err b. (Traversable t, Applicative m) => (a -> m (Either err b)) -> t a -> m (Either (NonEmpty err) (t b)) +traverseValidateM f as = + as + & traverse @t @m (\a -> a & f <&> eitherToListValidation) + <&> sequenceA @t @(Validation _) + <&> validationToEither + +-- | 'traverse_' with a function returning 'm Either' and collect all errors that happen, if they happen. +-- +-- Does not shortcut on error, so will always traverse the whole list/'Traversable' structure. +-- +-- This is a useful error handling function in many circumstances, +-- because it won’t only return the first error that happens, but rather all of them. +traverseValidateM_ :: forall t m a err. (Traversable t, Applicative m) => (a -> m (Either err ())) -> t a -> m (Either (NonEmpty err) ()) +traverseValidateM_ f as = + as + & traverse @t @m (\a -> a & f <&> eitherToListValidation) + <&> sequenceA_ @t @(Validation _) + <&> validationToEither + -- | Like 'eitherToValidation', but puts the Error side into a NonEmpty list -- to make it combine with other validations. +-- +-- See also 'validateEithers', if you have a list of Either and want to collect all errors. eitherToListValidation :: Either a c -> Validation (NonEmpty a) c eitherToListValidation = first singleton . eitherToValidation @@ -360,15 +559,26 @@ thenThese f x = do th <- x join <$> traverse f th --- | Nested validating bind-like combinator inside some other @m@. +-- | Nested validating bind-like combinator. -- -- Use if you want to collect errors, and want to chain multiple functions returning 'Validation'. thenValidate :: + (a -> Validation err b) -> + Validation err a -> + Validation err b +thenValidate f = \case + Success a -> f a + Failure err -> Failure err + +-- | Nested validating bind-like combinator inside some other @m@. +-- +-- Use if you want to collect errors, and want to chain multiple functions returning 'Validation'. +thenValidateM :: (Monad m) => (a -> m (Validation err b)) -> m (Validation err a) -> m (Validation err b) -thenValidate f x = +thenValidateM f x = eitherToValidation <$> do x' <- validationToEither <$> x case x' of @@ -401,23 +611,23 @@ exitWithMessage msg = do -- -- … 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 +{-# INLINE traverseFold #-} 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 +{-# INLINE traverseFoldDefault #-} 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 +{-# INLINE traverseFold1 #-} -- 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. -- @@ -427,40 +637,13 @@ traverseFold1 f xs = fold1 <$> traverse f xs -- -- Uses the same trick as https://hackage.haskell.org/package/protolude-0.3.0/docs/src/Protolude.Error.html#error {-# WARNING todo "'todo' (undefined code) remains in code" #-} -todo :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => a +todo :: forall (r :: RuntimeRep). forall (a :: TYPE r). (HasCallStack) => a todo = raise# (errorCallWithCallStackException "This code was not yet implemented: TODO" ?callStack) --- TODO: use a Text.Builder? - --- | Pretty print a bunch of errors, on multiple lines, prefixed by the given message, --- then turn the result back into an 'Error'. --- --- Example: --- --- smushErrors "There was a problem with the frobl" --- [ (anyhow "frobz") --- , (errorContext "oh no" (anyhow "barz")) --- ] --- --- ==> --- "There was a problem with the frobl\n\ --- - frobz\n\ --- - oh no: barz\n" --- @ --- --- TODO how do we make this compatible with/integrate it into the Error library? -smushErrors :: Foldable t => Text -> t Error -> Error -smushErrors msg errs = - errs - -- hrm, pretty printing and then creating a new error is kinda shady - & foldMap (\err -> "\n- " <> prettyError err) - & newError - & errorContext msg - -- | Convert an integer to a 'Natural' if possible -- -- Named the same as the function from "GHC.Natural", but does not crash. -intToNatural :: Integral a => a -> Maybe Natural +intToNatural :: (Integral a) => a -> Maybe Natural intToNatural i = if i < 0 then Nothing @@ -526,15 +709,68 @@ inverseFunction f k = Map.lookup k $ inverseMap f -- 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 :: (Bounded a, Enum a) => [a] - universe = [minBound .. maxBound] +inverseMap :: forall a k. (Bounded a, Enum a, Ord k) => (a -> k) -> Map k a +inverseMap f = enumerateAll <&> (\a -> (f a, a)) & Map.fromList + +-- | All possible values in this enum. +enumerateAll :: (Enum a, Bounded a) => [a] +enumerateAll = [minBound .. maxBound] + +-- | Create a 'Map' from a list of values, extracting the map key from each value. Like 'Map.fromList'. +-- +-- Attention: if the key is not unique, the earliest value with the key will be in the map. +mapFromListOn :: (Ord key) => (a -> key) -> [a] -> Map key a +mapFromListOn f xs = xs <&> (\x -> (f x, x)) & Map.fromList + +-- | Create a 'Map' from a list of values, merging multiple values at the same key with '<>' (left-to-right) +-- +-- `f` has to extract the key and value. Value must be mergable. +-- +-- Attention: if the key is not unique, the earliest value with the key will be in the map. +mapFromListOnMerge :: (Ord key, Semigroup s) => (a -> (key, s)) -> [a] -> Map key s +mapFromListOnMerge f xs = + xs + <&> (\x -> f x) + & Map.fromListWith + -- we have to flip (`<>`) because `Map.fromListWith` merges its values “the other way around” + (flip (<>)) + +-- | 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 result of `f` wrapped in `pure`, else return `mempty`. + +-- This can be used (together with `ifTrue`) to e.g. create lists with optional elements: +-- +-- >>> import Data.Monoid (Sum(..)) +-- +-- >>> :{ mconcat [ +-- unknown command '{' +-- +-- Or any other Monoid: +-- +-- >>> mconcat [ Sum 1, ifExists id (Just 2), Sum 3 ] +-- Sum {getSum = 6} + +ifExists :: (Monoid (f b), Applicative f) => (a -> b) -> Maybe a -> f b +ifExists f m = m & foldMap @Maybe (pure . f) diff --git a/users/Profpatsch/my-prelude/src/Parse.hs b/users/Profpatsch/my-prelude/src/Parse.hs new file mode 100644 index 0000000000..65a0b0d39e --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Parse.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Parse where + +import Control.Category qualified +import Control.Selective (Selective) +import Data.Error.Tree +import Data.Functor.Compose +import Data.List qualified as List +import Data.Monoid (First (..)) +import Data.Semigroup.Traversable +import Data.Semigroupoid qualified as Semigroupoid +import Data.Text qualified as Text +import FieldParser (FieldParser) +import FieldParser qualified as Field +import PossehlAnalyticsPrelude +import Validation (partitionValidations) +import Prelude hiding (init, maybe) +import Prelude qualified + +-- | A generic applicative “vertical” parser. +-- Similar to `FieldParser`, but made for parsing whole structures and collect all errors in an `ErrorTree`. +newtype Parse from to = Parse ((Context, from) -> Validation (NonEmpty ErrorTree) (Context, to)) + deriving + (Functor, Applicative, Selective) + via ( Compose + ( Compose + ((->) (Context, from)) + (Validation (NonEmpty ErrorTree)) + ) + ((,) Context) + ) + +-- | Every parser can add to the context, like e.g. an element parser will add the name of the element it should be parsing. +-- This should be added to the error message of each parser, with `showContext`. +newtype Context = Context (Maybe [Text]) + deriving stock (Show) + deriving (Semigroup, Monoid) via (First [Text]) + +instance Semigroupoid Parse where + o p2 p1 = Parse $ \from -> case runParse' p1 from of + Failure err -> Failure err + Success to1 -> runParse' p2 to1 + +instance Category Parse where + (.) = Semigroupoid.o + id = Parse $ \t -> Success t + +instance Profunctor Parse where + lmap f (Parse p) = Parse $ lmap (second f) p + rmap = (<$>) + +runParse :: Error -> Parse from to -> from -> Either ErrorTree to +runParse errMsg parser t = + (Context (Just ["$"]), t) + & runParse' parser + <&> snd + & first (nestedMultiError errMsg) + & validationToEither + +runParse' :: Parse from to -> (Context, from) -> Validation (NonEmpty ErrorTree) (Context, to) +runParse' (Parse f) from = f from + +showContext :: Context -> Text +showContext (Context context) = context & fromMaybe [] & List.reverse & Text.intercalate "." + +addContext :: Text -> Context -> Context +addContext x (Context mxs) = Context (Just $ x : (mxs & fromMaybe [])) + +mkParsePushContext :: Text -> ((Context, from) -> Either ErrorTree to) -> Parse from to +mkParsePushContext toPush f = Parse $ \(ctx, from) -> case f (ctx, from) of + Right to -> Success (addContext toPush ctx, to) + Left err -> Failure $ singleton err + +mkParseNoContext :: (from -> Either ErrorTree to) -> Parse from to +mkParseNoContext f = Parse $ \(ctx, from) -> case f from of + Right to -> Success (ctx, to) + Left err -> Failure $ singleton err + +-- | Accept only exactly the given value +exactly :: (Eq from) => (from -> Text) -> from -> Parse from from +exactly errDisplay from = Parse $ \(ctx, from') -> + if from == from' + then Success (ctx, from') + else Failure $ singleton [fmt|Field has to be exactly {errDisplay from}, was: {errDisplay from'} at {showContext ctx}|] + +-- | Make a parser to parse the whole list +multiple :: Parse a1 a2 -> Parse [a1] [a2] +multiple inner = dimap nonEmpty (Prelude.maybe [] toList) (maybe $ multipleNE inner) + +-- | Make a parser to parse the whole non-empty list +multipleNE :: Parse from to -> Parse (NonEmpty from) (NonEmpty to) +multipleNE inner = Parse $ \(ctx, from) -> + from + & zipIndex + & traverse (\(idx, f) -> runParse' inner (ctx, f) & first (singleton . nestedMultiError [fmt|{idx}|])) + -- we assume that, since the same parser is used everywhere, the context will be the same as well (TODO: correct?) + & second (\((ctx', y) :| ys) -> (ctx', y :| (snd <$> ys))) + +-- | Like '(>>>)', but returns the intermediate result alongside the final parse result. +andParse :: Parse to to2 -> Parse from to -> Parse from (to, to2) +andParse outer inner = Parse $ \from -> case runParse' inner from of + Failure err -> Failure err + Success (ctx, to) -> runParse' outer (ctx, to) <&> (second (to,)) + +-- | Lift a parser into an optional value +maybe :: Parse from to -> Parse (Maybe from) (Maybe to) +maybe inner = Parse $ \(ctx, m) -> case m of + Nothing -> Success (ctx, Nothing) + Just a -> runParse' inner (ctx, a) & second (fmap Just) + +-- | Assert that there is exactly one element in the list +exactlyOne :: Parse [from] from +exactlyOne = Parse $ \(ctx, xs) -> case xs of + [] -> Failure $ singleton [fmt|Expected exactly 1 element, but got 0, at {ctx & showContext}|] + [one] -> Success (ctx, one) + _more -> Failure $ singleton [fmt|Expected exactly 1 element, but got 2, at {ctx & showContext}|] + +-- | Assert that there is exactly zero or one element in the list +zeroOrOne :: Parse [from] (Maybe from) +zeroOrOne = Parse $ \(ctx, xs) -> case xs of + [] -> Success (ctx, Nothing) + [one] -> Success (ctx, Just one) + _more -> Failure $ singleton [fmt|Expected exactly 1 element, but got 2, at {ctx & showContext}|] + +-- | Find the first element on which the sub-parser succeeds; if there was no match, return all error messages. +find :: Parse from to -> Parse [from] to +find inner = Parse $ \(ctx, xs) -> case xs of + [] -> failure [fmt|Wanted to get the first sub-parser that succeeds, but there were no elements in the list, at {ctx & showContext}|] + (y : ys) -> runParse' (findNE' inner) (ctx, y :| ys) + +-- | Find the first element on which the sub-parser succeeds; if there was no match, return all error messages. +findNE' :: Parse from to -> Parse (NonEmpty from) to +findNE' inner = Parse $ \(ctx, xs) -> + xs + <&> (\x -> runParse' inner (ctx, x)) + & traverse1 + ( \case + Success a -> Left a + Failure e -> Right e + ) + & \case + Left a -> Success a + Right errs -> + errs + & zipIndex + <&> (\(idx, errs') -> nestedMultiError [fmt|{idx}|] errs') + & nestedMultiError [fmt|None of these sub-parsers succeeded|] + & singleton + & Failure + +-- | Find all elements on which the sub-parser succeeds; if there was no match, return an empty list +findAll :: Parse from to -> Parse [from] [to] +findAll inner = Parse $ \(ctx, xs) -> + xs + <&> (\x -> runParse' inner (ctx, x)) + & partitionValidations + & \case + (_miss, []) -> + -- in this case we just arbitrarily forward the original context … + Success (ctx, []) + (_miss, (hitCtx, hit) : hits) -> Success (hitCtx, hit : (hits <&> snd)) + +-- | convert a 'FieldParser' into a 'Parse'. +fieldParser :: FieldParser from to -> Parse from to +fieldParser fp = Parse $ \(ctx, from) -> case Field.runFieldParser fp from of + Right a -> Success (ctx, a) + Left err -> Failure $ singleton (singleError err) + +zipNonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty (a, b) +zipNonEmpty (x :| xs) (y :| ys) = (x, y) :| zip xs ys + +zipIndex :: NonEmpty b -> NonEmpty (Natural, b) +zipIndex = zipNonEmpty (1 :| [2 :: Natural ..]) 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..008b89b4ba --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs @@ -0,0 +1,94 @@ +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 (Binary (fromBinary)) +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) + +-- | Parse a `bytea` field, equivalent to @Binary ByteString@ but avoids the pitfall of having to use 'Binary'. +bytea :: Decoder ByteString +bytea = fromField @(Binary ByteString) <&> (.fromBinary) + +-- | Parse a nullable `bytea` field, equivalent to @Binary ByteString@ but avoids the pitfall of having to use 'Binary'. +byteaMay :: Decoder (Maybe ByteString) +byteaMay = fromField @(Maybe (Binary ByteString)) <&> fmap (.fromBinary) + +-- | 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 + +-- | Parse fields out of a nullable 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\": {}}"@. +jsonMay :: Typeable a => Json.ParseT ErrorTree Identity a -> Decoder (Maybe a) +jsonMay parser = Decoder $ PG.fieldWith $ \field bytes -> do + val <- PG.fromField @(Maybe Json.Value) field bytes + case Json.parseValue parser <$> val of + Nothing -> pure Nothing + Just (Left err) -> + PG.returnError + PG.ConversionFailed + field + (err & Json.parseErrorTree "Cannot decode jsonb column" & prettyErrorTree & textToString) + Just (Right a) -> pure (Just 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..2c9a48d134 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs @@ -0,0 +1,930 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Postgres.MonadPostgres where + +import Arg +import AtLeast (AtLeast) +import Control.Exception + ( Exception (displayException), + Handler (Handler), + catches, + try, + ) +import Control.Foldl qualified as Fold +import Control.Monad.Logger.CallStack (MonadLogger, logDebug, logWarn) +import Control.Monad.Reader (MonadReader (ask), ReaderT (..)) +import Control.Monad.Trans.Resource +import Data.Aeson (FromJSON) +import Data.ByteString qualified as ByteString +import Data.Error.Tree +import Data.HashMap.Strict qualified as HashMap +import Data.Int (Int64) +import Data.Kind (Type) +import Data.List qualified as List +import Data.Pool (Pool) +import Data.Pool qualified as Pool +import Data.Text qualified as Text +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 qualified as Postgres +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 (Query (..)) +import GHC.IO.Handle (Handle) +import GHC.Records (getField) +import Label +import OpenTelemetry.Trace.Core (NewEvent (newEventName)) +import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan') +import OpenTelemetry.Trace.Monad qualified as Otel +import PossehlAnalyticsPrelude +import Postgres.Decoder +import Postgres.Decoder qualified as Dec +import Pretty (showPretty) +import Seconds +import System.Exit (ExitCode (..)) +import Tool +import UnliftIO (MonadUnliftIO (withRunInIO), bracket, hClose, mask_) +import UnliftIO.Concurrent (forkIO) +import UnliftIO.Process (ProcessHandle) +import UnliftIO.Process qualified as Process +import UnliftIO.Resource qualified as Resource +import Prelude hiding (init, span) + +-- | 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 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 -> + NonEmpty 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 -> NonEmpty 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. + foldRowsWithAcc :: + (ToRow params, Typeable row, Typeable params) => + Query -> + params -> + Decoder row -> + 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. Prefer 'queryWith' if possible. +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. Prefer 'queryWith' if possible. +-- +-- TODO: I think(?) this can always be replaced by passing @()@ to 'query', remove? +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 +querySingleRowWith :: + ( MonadPostgres m, + ToRow qParams, + Typeable qParams, + Typeable a, + MonadThrow m + ) => + Query -> + qParams -> + Decoder a -> + Transaction m a +querySingleRowWith qry params decoder = do + queryWith qry params decoder >>= 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 + } + +ensureNoneOrSingleRow :: + (MonadThrow m) => + [a] -> + m (Maybe a) +ensureNoneOrSingleRow = \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. + [] -> pure Nothing + [one] -> pure $ Just 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 + } + +-- | 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. +-- +-- The results are folded strictly by the 'Fold.Fold' that is passed. +-- +-- If you can, prefer aggregating in the database itself. +foldRowsWith :: + forall row params m b. + ( MonadPostgres m, + PG.ToRow params, + Typeable row, + Typeable params + ) => + PG.Query -> + params -> + Decoder row -> + Fold.Fold row b -> + Transaction m b +foldRowsWith qry params decoder = Fold.purely f + where + f :: forall x. (x -> row -> x) -> x -> (x -> b) -> Transaction m b + f acc init extract = do + x <- foldRowsWithAcc qry params decoder init (\a r -> pure $ acc a r) + pure $ extract x + +newtype Transaction m a = Transaction {unTransaction :: (ReaderT Connection m a)} + deriving newtype + ( Functor, + Applicative, + Monad, + MonadThrow, + MonadLogger, + MonadIO, + MonadUnliftIO, + MonadTrans, + Otel.MonadTracer + ) + +-- | [Resource Pool](http://hackage.haskell.org/package/resource-pool-0.2.3.2/docs/Data-Pool.html) configuration. +data PoolingInfo = PoolingInfo + { -- | Minimal amount of resources that are + -- always available. + numberOfStripes :: AtLeast 1 Int, + -- | Time after which extra resources + -- (above minimum) can stay in the pool + -- without being used. + unusedResourceOpenTime :: Seconds, + -- | Max number of resources that can be + -- in the Pool at any time + maxOpenResourcesAcrossAllStripes :: AtLeast 1 Int + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON) + +initMonadPostgres :: + (Text -> IO ()) -> + -- | Info describing the connection to the Postgres DB + Postgres.ConnectInfo -> + -- | Configuration info for pooling attributes + PoolingInfo -> + -- | Created Postgres connection pool + ResourceT IO (Pool Postgres.Connection) +initMonadPostgres logInfoFn connectInfo poolingInfo = do + (_releaseKey, connPool) <- + Resource.allocate + (logInfoFn "Creating Postgres Connection Pool" >> createPGConnPool) + (\pool -> logInfoFn "Destroying Postgres Connection Pool" >> destroyPGConnPool pool) + pure connPool + where + -- \| Create a Postgres connection pool + createPGConnPool :: + IO (Pool Postgres.Connection) + createPGConnPool = + Pool.newPool $ + Pool.defaultPoolConfig + {- resource init action -} poolCreateResource + {- resource destruction -} poolfreeResource + ( poolingInfo.unusedResourceOpenTime.unSeconds + & fromIntegral @Natural @Double + ) + (poolingInfo.maxOpenResourcesAcrossAllStripes.unAtLeast) + where + poolCreateResource = Postgres.connect connectInfo + poolfreeResource = Postgres.close + + -- \| Destroy a Postgres connection pool + destroyPGConnPool :: + -- \| Pool to be destroyed + (Pool Postgres.Connection) -> + IO () + destroyPGConnPool p = Pool.destroyAllResources p + +-- | Improve a possible error message, by adding some context to it. +-- +-- The given Exception type is caught, 'show'n and pretty-printed. +-- +-- In case we get an `IOError`, we display it in a reasonable fashion. +addErrorInformation :: + forall exc a. + (Exception exc) => + Text.Text -> + IO a -> + IO a +addErrorInformation msg io = + io + & try @exc + <&> first (showPretty >>> newError >>> errorContext msg) + & try @IOError + <&> first (showToError >>> errorContext "IOError" >>> errorContext msg) + <&> join @(Either Error) + >>= unwrapIOError + +-- | 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 tools m. + ( ToRow params, + MonadUnliftIO m, + MonadLogger m, + HasField "pgFormat" tools PgFormatPool + ) => + tools -> + Text -> + Query -> + -- | Depending on whether we used `format` or `formatMany`. + Either params (NonEmpty params) -> + IO a -> + Transaction m a +handlePGException tools 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' tools query' one + Right many -> pgFormatQueryMany' tools 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) + +-- | Perform a Postgres action within a transaction +withPGTransaction :: + -- | Postgres connection pool to be used for the action + (Pool Postgres.Connection) -> + -- | DB-action to be performed + (Postgres.Connection -> IO a) -> + -- | Result of the DB-action + IO a +withPGTransaction connPool f = + Pool.withResource + connPool + (\conn -> Postgres.withTransaction conn (f conn)) + +-- | `pg_formatter` is a perl script that does not support any kind of streaming. +-- Thus we initialize a pool with a bunch of these scripts running, waiting for input. This way we can have somewhat fast SQL formatting. +-- +-- Call `initPgFormatPool` to initialize, then use `runPgFormat` to format some sql. +data PgFormatPool = PgFormatPool + { pool :: Pool PgFormatProcess, + pgFormat :: Tool + } + +data PgFormatProcess = PgFormatProcess + { stdinHdl :: Handle, + stdoutHdl :: Handle, + stderrHdl :: Handle, + procHdl :: ProcessHandle, + startedAt :: Otel.Timestamp + } + +initPgFormatPool :: (HasField "pgFormat" tools Tool) => tools -> IO PgFormatPool +initPgFormatPool tools = do + pool <- + Pool.newPool + ( Pool.defaultPoolConfig + (pgFormatStartCommandWaitForInput tools) + ( \pgFmt -> do + Process.terminateProcess pgFmt.procHdl + -- make sure we don’t leave any zombies + _ <- forkIO $ do + _ <- Process.waitForProcess pgFmt.procHdl + pure () + pure () + ) + -- unused resource time + 100 + -- number of resources + 10 + ) + + -- fill the pool with resources + let go = + Pool.tryWithResource pool (\_ -> go) >>= \case + Nothing -> pure () + Just () -> pure () + _ <- go + pure (PgFormatPool {pool, pgFormat = tools.pgFormat}) + +destroyPgFormatPool :: PgFormatPool -> IO () +destroyPgFormatPool pool = Pool.destroyAllResources pool.pool + +-- | Get the oldest resource from the pool, or stop if you find a resource that’s older than `cutoffPointMs`. +takeOldestResource :: PgFormatPool -> Arg "cutoffPointMs" Integer -> IO (PgFormatProcess, Pool.LocalPool PgFormatProcess) +takeOldestResource pool cutoffPointMs = do + now <- Otel.getTimestamp + mask_ $ do + a <- Pool.takeResource pool.pool + (putBack, res) <- go now [] a + -- make sure we don’t leak any resources we didn’t use in the end + for_ putBack $ \(x, xLocal) -> Pool.putResource xLocal x + pure res + where + mkMs ts = (ts & Otel.timestampNanoseconds & toInteger) `div` 1000_000 + go now putBack a@(a', _) = + if abs (mkMs now - mkMs a'.startedAt) > cutoffPointMs.unArg + then pure (putBack, a) + else + Pool.tryTakeResource pool.pool >>= \case + Nothing -> pure (putBack, a) + Just b@(b', _) -> do + if a'.startedAt < b'.startedAt + then go now (b : putBack) a + else go now (a : putBack) b + +-- | Format the given SQL with pg_formatter. Will use the pool of already running formatters to speed up execution. +runPgFormat :: PgFormatPool -> ByteString -> IO (T3 "exitCode" ExitCode "formatted" ByteString "stderr" ByteString) +runPgFormat pool sqlStatement = do + bracket + (takeOldestResource pool 200) + ( \(a, localPool) -> do + -- we always destroy the resource, because the process exited + Pool.destroyResource pool.pool localPool a + -- create a new process to keep the pool “warm” + new <- pgFormatStartCommandWaitForInput pool + Pool.putResource localPool new + ) + ( \(pgFmt, _localPool) -> do + ByteString.hPut pgFmt.stdinHdl sqlStatement + -- close stdin to make pg_formatter format (it exits …) + -- issue: https://github.com/darold/pgFormatter/issues/333 + hClose pgFmt.stdinHdl + formatted <- ByteString.hGetContents pgFmt.stdoutHdl + errs <- ByteString.hGetContents pgFmt.stderrHdl + exitCode <- Process.waitForProcess pgFmt.procHdl + pure $ + T3 + (label @"exitCode" exitCode) + (label @"formatted" formatted) + (label @"stderr" errs) + ) + +runPGTransactionImpl :: + (MonadUnliftIO m) => + m (Pool Postgres.Connection) -> + Transaction m a -> + m a +{-# INLINE runPGTransactionImpl #-} +runPGTransactionImpl zoom (Transaction transaction) = do + pool <- zoom + withRunInIO $ \unliftIO -> + withPGTransaction pool $ \conn -> do + unliftIO $ runReaderT transaction conn + +executeImpl :: + (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => + m tools -> + m DebugLogDatabaseQueries -> + Query -> + params -> + Transaction m (Label "numberOfRowsAffected" Natural) +{-# INLINE executeImpl #-} +executeImpl zoomTools zoomDebugLogDatabaseQueries qry params = + Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do + tools <- lift @Transaction zoomTools + logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries + traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params) + conn <- Transaction ask + PG.execute conn qry params + & handlePGException tools "execute" qry (Left params) + >>= toNumberOfRowsAffected "executeImpl" + +executeImpl_ :: + (MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => + m tools -> + m DebugLogDatabaseQueries -> + Query -> + Transaction m (Label "numberOfRowsAffected" Natural) +{-# INLINE executeImpl_ #-} +executeImpl_ zoomTools zoomDebugLogDatabaseQueries qry = + Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do + tools <- lift @Transaction zoomTools + logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries + traceQueryIfEnabled @() tools span logDatabaseQueries qry HasNoParams + conn <- Transaction ask + PG.execute_ conn qry + & handlePGException tools "execute_" qry (Left ()) + >>= toNumberOfRowsAffected "executeImpl_" + +executeManyImpl :: + (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => + m tools -> + m DebugLogDatabaseQueries -> + Query -> + NonEmpty params -> + Transaction m (Label "numberOfRowsAffected" Natural) +executeManyImpl zoomTools zoomDebugLogDatabaseQueries qry params = + Otel.inSpan' "Postgres Query (executeMany)" Otel.defaultSpanArguments $ \span -> do + tools <- lift @Transaction zoomTools + logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries + traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params) + conn <- Transaction ask + PG.executeMany conn qry (params & toList) + & handlePGException tools "executeMany" qry (Right params) + >>= toNumberOfRowsAffected "executeManyImpl" + +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" + +executeManyReturningWithImpl :: + (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => + m tools -> + m DebugLogDatabaseQueries -> + Query -> + NonEmpty params -> + Decoder r -> + Transaction m [r] +{-# INLINE executeManyReturningWithImpl #-} +executeManyReturningWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow) = do + Otel.inSpan' "Postgres Query (executeManyReturning)" Otel.defaultSpanArguments $ \span -> do + tools <- lift @Transaction zoomTools + logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries + traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params) + conn <- Transaction ask + PG.returningWith fromRow conn qry (params & toList) + & handlePGException tools "executeManyReturning" qry (Right params) + +foldRowsWithAccImpl :: + ( ToRow params, + MonadUnliftIO m, + MonadLogger m, + HasField "pgFormat" tools PgFormatPool, + Otel.MonadTracer m + ) => + m tools -> + m DebugLogDatabaseQueries -> + Query -> + params -> + Decoder row -> + a -> + (a -> row -> Transaction m a) -> + Transaction m a +{-# INLINE foldRowsWithAccImpl #-} +foldRowsWithAccImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder rowParser) accumulator f = do + Otel.inSpan' "Postgres Query (foldRowsWithAcc)" Otel.defaultSpanArguments $ \span -> do + tools <- lift @Transaction zoomTools + logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries + traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params) + conn <- Transaction ask + withRunInIO + ( \runInIO -> + do + PG.foldWithOptionsAndParser + PG.defaultFoldOptions + rowParser + conn + qry + params + accumulator + (\acc row -> runInIO $ f acc row) + & handlePGException tools "fold" qry (Left params) + & runInIO + ) + +pgFormatQueryNoParams' :: + (MonadIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool) => + tools -> + Query -> + Transaction m Text +pgFormatQueryNoParams' tools q = + lift $ pgFormatQueryByteString tools q.fromQuery + +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 -> + NonEmpty params -> + Transaction m ByteString +pgFormatQueryMany qry params = Transaction $ do + conn <- ask + liftIO $ + PG.formatMany + conn + qry + ( params + -- upstream is partial on empty list, see https://github.com/haskellari/postgresql-simple/issues/129 + & toList + ) + +queryWithImpl :: + ( ToRow params, + MonadUnliftIO m, + MonadLogger m, + HasField "pgFormat" tools PgFormatPool, + Otel.MonadTracer m + ) => + m tools -> + m DebugLogDatabaseQueries -> + Query -> + params -> + Decoder r -> + Transaction m [r] +{-# INLINE queryWithImpl #-} +queryWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow) = do + Otel.inSpan' "Postgres Query (queryWith)" Otel.defaultSpanArguments $ \span -> do + tools <- lift @Transaction zoomTools + logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries + traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params) + conn <- Transaction ask + PG.queryWith fromRow conn qry params + & handlePGException tools "query" qry (Left params) + +queryWithImpl_ :: + ( MonadUnliftIO m, + MonadLogger m, + HasField "pgFormat" tools PgFormatPool + ) => + m tools -> + Query -> + Decoder r -> + Transaction m [r] +{-# INLINE queryWithImpl_ #-} +queryWithImpl_ zoomTools qry (Decoder fromRow) = do + tools <- lift @Transaction zoomTools + conn <- Transaction ask + liftIO (PG.queryWith_ fromRow conn qry) + & handlePGException tools "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."|] + +pgFormatQuery' :: + ( MonadIO m, + ToRow params, + MonadLogger m, + HasField "pgFormat" tools PgFormatPool + ) => + tools -> + Query -> + params -> + Transaction m Text +pgFormatQuery' tools q p = + pgFormatQuery q p + >>= lift . pgFormatQueryByteString tools + +pgFormatQueryMany' :: + ( MonadIO m, + ToRow params, + MonadLogger m, + HasField "pgFormat" tools PgFormatPool + ) => + tools -> + Query -> + NonEmpty params -> + Transaction m Text +pgFormatQueryMany' tools q p = + pgFormatQueryMany q p + >>= lift . pgFormatQueryByteString tools + +-- | Read the executable name "pg_format" +postgresToolsParser :: ToolParserT IO (Label "pgFormat" Tool) +postgresToolsParser = label @"pgFormat" <$> readTool "pg_format" + +pgFormatQueryByteString :: + ( MonadIO m, + MonadLogger m, + HasField "pgFormat" tools PgFormatPool + ) => + tools -> + ByteString -> + m Text +pgFormatQueryByteString tools queryBytes = do + res <- + liftIO $ + runPgFormat + tools.pgFormat + (queryBytes) + case res.exitCode of + ExitSuccess -> pure (res.formatted & bytesToTextUtf8Lenient) + 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 (res.formatted & bytesToTextUtf8Lenient & newError)) + :| [(nestedError "stderr" (singleError (res.stderr & bytesToTextUtf8Lenient & newError)))] + ) + ) + ) + logDebug [fmt|pg_format stdout: stderr|] + pure (queryBytes & bytesToTextUtf8Lenient) + +pgFormatStartCommandWaitForInput :: + ( MonadIO m, + HasField "pgFormat" tools Tool, + MonadFail m + ) => + tools -> + m PgFormatProcess +pgFormatStartCommandWaitForInput tools = do + do + startedAt <- Otel.getTimestamp + (Just stdinHdl, Just stdoutHdl, Just stderrHdl, procHdl) <- + Process.createProcess + ( ( Process.proc + tools.pgFormat.toolPath + [ "--no-rcfile", + "-" + ] + ) + { Process.std_in = Process.CreatePipe, + Process.std_out = Process.CreatePipe, + Process.std_err = Process.CreatePipe + } + ) + + pure PgFormatProcess {..} + +data DebugLogDatabaseQueries + = -- | Do not log the database queries + DontLogDatabaseQueries + | -- | Log the database queries as debug output; + LogDatabaseQueries + | -- | Log the database queries as debug output and additionally the EXPLAIN output (from the query analyzer, not the actual values after execution cause that’s a bit harder to do) + LogDatabaseQueriesAndExplain + deriving stock (Show, Enum, Bounded) + +data HasQueryParams param + = HasNoParams + | HasSingleParam param + | HasMultiParams (NonEmpty param) + +-- | Log the postgres query depending on the given setting +traceQueryIfEnabled :: + ( ToRow params, + MonadUnliftIO m, + MonadLogger m, + HasField "pgFormat" tools PgFormatPool, + Otel.MonadTracer m + ) => + tools -> + Otel.Span -> + DebugLogDatabaseQueries -> + Query -> + HasQueryParams params -> + Transaction m () +traceQueryIfEnabled tools span logDatabaseQueries qry params = do + -- In case we have query logging enabled, we want to do that + let formattedQuery = do + withEvent + span + "Query Format start" + "Query Format end" + $ case params of + HasNoParams -> pgFormatQueryNoParams' tools qry + HasSingleParam p -> pgFormatQuery' tools qry p + HasMultiParams ps -> pgFormatQueryMany' tools qry ps + + let doLog errs = + Otel.addAttributes + span + $ HashMap.fromList + $ ( ("_.postgres.query", Otel.toAttribute @Text errs.query) + : ( errs.explain + & \case + Nothing -> [] + Just ex -> [("_.postgres.explain", Otel.toAttribute @Text ex)] + ) + ) + let doExplain = do + q <- formattedQuery + Otel.inSpan "Postgres EXPLAIN Query" Otel.defaultSpanArguments $ do + queryWithImpl_ + (pure tools) + ( "EXPLAIN " + <> ( + -- TODO: this is not nice, but the only way to get the `executeMany` form to work with this + -- because we need the query with all elements already interpolated. + Query (q & textToBytesUtf8) + ) + ) + (Dec.fromField @Text) + <&> Text.intercalate "\n" + case logDatabaseQueries of + DontLogDatabaseQueries -> pure () + LogDatabaseQueries -> do + q <- formattedQuery + doLog (T2 (label @"query" q) (label @"explain" Nothing)) + LogDatabaseQueriesAndExplain -> do + q <- formattedQuery + -- XXX: stuff like `CREATE SCHEMA` cannot be EXPLAINed, so we should catch exceptions here + -- and just ignore anything that errors (if it errors because of a problem with the query, it would have been caught by the query itself. + ex <- doExplain + doLog (T2 (label @"query" q) (label @"explain" (Just ex))) + +-- | Add a start and end event to the span, and figure out how long the difference was. +-- +-- This is more lightweight than starting an extra span for timing things. +withEvent :: (MonadIO f) => Otel.Span -> Text -> Text -> f b -> f b +withEvent span start end act = do + let mkMs ts = (ts & Otel.timestampNanoseconds & toInteger) `div` 1000_000 + s <- Otel.getTimestamp + Otel.addEvent + span + ( Otel.NewEvent + { newEventName = start, + newEventAttributes = mempty, + newEventTimestamp = Just s + } + ) + res <- act + e <- Otel.getTimestamp + let tookMs = + (mkMs e - mkMs s) + -- should be small enough + & fromInteger @Int + Otel.addEvent + span + ( Otel.NewEvent + { newEventName = end, + newEventAttributes = HashMap.fromList [("took ms", Otel.toAttribute tookMs)], + newEventTimestamp = Just e + } + ) + pure res + +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..d9d4ce132b --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Pretty.hs @@ -0,0 +1,108 @@ +module Pretty + ( -- * Pretty printing for error messages + Err, + showPretty, + showPrettyJson, + showedStringPretty, + printPretty, + printShowedStringPretty, + -- constructors hidden + prettyErrs, + message, + messageString, + pretty, + prettyString, + hscolour', + ) +where + +import Data.Aeson qualified as Json +import Data.Aeson.Encode.Pretty qualified as Aeson.Pretty +import Data.List qualified as List +import Data.Text.Lazy.Builder qualified as Text.Builder +import Language.Haskell.HsColour + ( Output (TTYg), + hscolour, + ) +import Language.Haskell.HsColour.ANSI (TerminalType (..)) +import Language.Haskell.HsColour.Colourise + ( defaultColourPrefs, + ) +import PossehlAnalyticsPrelude +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 & showPretty & putStderrLn + +showPretty :: (Show a) => a -> Text +showPretty a = a & pretty & (: []) & prettyErrs & stringToText + +-- | Pretty-print a string that was produced by `show` to stderr, formatted nicely and in color. +printShowedStringPretty :: String -> IO () +printShowedStringPretty s = s & showedStringPretty & putStderrLn + +-- | Pretty-print a string that was produced by `show` +showedStringPretty :: String -> Text +showedStringPretty s = s & ErrPrettyString & (: []) & prettyErrs & stringToText + +showPrettyJson :: Json.Value -> Text +showPrettyJson val = + val + & Aeson.Pretty.encodePrettyToTextBuilder + & Text.Builder.toLazyText + & toStrict + +-- | 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 . textToString + +-- | 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/Seconds.hs b/users/Profpatsch/my-prelude/src/Seconds.hs new file mode 100644 index 0000000000..8d05f30be8 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Seconds.hs @@ -0,0 +1,55 @@ +module Seconds where + +import Data.Aeson (FromJSON) +import Data.Aeson qualified as Json +import Data.Aeson.Types (FromJSON (parseJSON)) +import Data.Scientific +import Data.Time (NominalDiffTime) +import FieldParser +import FieldParser qualified as Field +import GHC.Natural (naturalToInteger) +import PossehlAnalyticsPrelude + +-- | A natural number of seconds. +newtype Seconds = Seconds {unSeconds :: Natural} + deriving stock (Eq, Show) + +-- | Parse a decimal number as a number of seconds +textToSeconds :: FieldParser Text Seconds +textToSeconds = Seconds <$> Field.decimalNatural + +scientificToSeconds :: FieldParser Scientific Seconds +scientificToSeconds = + ( Field.boundedScientificIntegral @Int "Number of seconds" + >>> Field.integralToNatural + ) + & rmap Seconds + +-- Microseconds, represented internally with a 64 bit Int +newtype MicrosecondsInt = MicrosecondsInt {unMicrosecondsInt :: Int} + deriving stock (Eq, Show) + +-- | Try to fit a number of seconds into a MicrosecondsInt +secondsToMicrosecondsInt :: FieldParser Seconds MicrosecondsInt +secondsToMicrosecondsInt = + lmap + (\sec -> naturalToInteger sec.unSeconds * 1_000_000) + (Field.bounded "Could not fit into an Int after multiplying with 1_000_000 (seconds to microseconds)") + & rmap MicrosecondsInt + +secondsToNominalDiffTime :: Seconds -> NominalDiffTime +secondsToNominalDiffTime sec = + sec.unSeconds + & naturalToInteger + & fromInteger @NominalDiffTime + +instance FromJSON Seconds where + parseJSON = Field.toParseJSON jsonNumberToSeconds + +-- | Parse a json number as a number of seconds. +jsonNumberToSeconds :: FieldParser' Error Json.Value Seconds +jsonNumberToSeconds = Field.jsonNumber >>> scientificToSeconds + +-- | Return the number of seconds in a week +secondsInAWeek :: Seconds +secondsInAWeek = Seconds (3600 * 24 * 7) 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..b773f4444e --- /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}|]) + & thenValidateM + ( \() -> + (Posix.getFileStatus toolsDir <&> Posix.isDirectory) + & ifTrueOrErr () [fmt|{env.toolsEnvVar} does not point to a directory: {toolsDir}|] + ) + & thenValidateM + (\() -> 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}|] + & thenValidateM + ( \() -> + 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))) + ) |