diff options
Diffstat (limited to 'users/Profpatsch/my-prelude')
| -rw-r--r-- | users/Profpatsch/my-prelude/Aeson.hs | 188 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/Data/Error/Tree.hs | 113 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/Label.hs | 120 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/MyPrelude.hs | 587 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/Pretty.hs | 91 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/README.md | 42 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/RunCommand.hs | 162 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/Test.hs | 115 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/default.nix | 41 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/my-prelude.cabal | 44 |
10 files changed, 1503 insertions, 0 deletions
diff --git a/users/Profpatsch/my-prelude/Aeson.hs b/users/Profpatsch/my-prelude/Aeson.hs new file mode 100644 index 000000000000..ad095e1b43a7 --- /dev/null +++ b/users/Profpatsch/my-prelude/Aeson.hs @@ -0,0 +1,188 @@ +{-# 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/Data/Error/Tree.hs b/users/Profpatsch/my-prelude/Data/Error/Tree.hs new file mode 100644 index 000000000000..e8e45e704882 --- /dev/null +++ b/users/Profpatsch/my-prelude/Data/Error/Tree.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module Data.Error.Tree where + +import Data.String (IsString (..)) +import Data.Tree qualified as Tree +import MyPrelude + +-- | A tree of 'Error's, with a single root 'Error' and 0..n nested 'ErrorTree's. +-- +-- @@ +-- top error +-- | +-- |-- error 1 +-- | | +-- | -- error 1.1 +-- | +-- |-- error 2 +-- @@ +newtype ErrorTree = ErrorTree {unErrorTree :: (Tree.Tree Error)} + deriving stock (Show) + +instance IsString ErrorTree where + fromString = singleError . fromString + +-- deriving newtype (Ord) -- TODO: Add this instance with containers-0.6.5 + +-- | Turn a single 'Error' into an 'ErrorTree', a leaf. +singleError :: Error -> ErrorTree +singleError e = ErrorTree $ Tree.Node e [] + +-- | Take a list of errors & create a new 'ErrorTree' with the given 'Error' as the root. +errorTree :: Error -> NonEmpty Error -> ErrorTree +errorTree topLevelErr nestedErrs = + ErrorTree + ( Tree.Node + topLevelErr + (nestedErrs <&> (\e -> Tree.Node e []) & toList) + ) + +-- | Attach more context to the root 'Error' of the 'ErrorTree', via 'errorContext'. +errorTreeContext :: Text -> ErrorTree -> ErrorTree +errorTreeContext context (ErrorTree tree) = + ErrorTree $ + tree + { Tree.rootLabel = tree.rootLabel & errorContext context + } + +-- | Nest the given 'Error' around the ErrorTree +-- +-- @@ +-- top level error +-- | +-- -- nestedError +-- | +-- -- error 1 +-- | +-- -- error 2 +-- @@ +nestedError :: + Error -> -- top level + ErrorTree -> -- nested + ErrorTree +nestedError topLevelErr nestedErr = + ErrorTree $ + Tree.Node + { Tree.rootLabel = topLevelErr, + Tree.subForest = [nestedErr.unErrorTree] + } + +-- | Nest the given 'Error' around the list of 'ErrorTree's. +-- +-- @@ +-- top level error +-- | +-- |- nestedError1 +-- | | +-- | -- error 1 +-- | | +-- | -- error 2 +-- | +-- |- nestedError 2 +-- @@ +nestedMultiError :: + Error -> -- top level + NonEmpty ErrorTree -> -- nested + ErrorTree +nestedMultiError topLevelErr nestedErrs = + ErrorTree $ + Tree.Node + { Tree.rootLabel = topLevelErr, + Tree.subForest = nestedErrs & toList <&> (.unErrorTree) + } + +prettyErrorTree :: ErrorTree -> Text +prettyErrorTree (ErrorTree tree) = + tree + <&> prettyError + <&> textToString + & Tree.drawTree + & stringToText + +prettyErrorTrees :: NonEmpty ErrorTree -> Text +prettyErrorTrees forest = + forest + <&> (.unErrorTree) + <&> fmap prettyError + <&> fmap textToString + & toList + & Tree.drawForest + & stringToText diff --git a/users/Profpatsch/my-prelude/Label.hs b/users/Profpatsch/my-prelude/Label.hs new file mode 100644 index 000000000000..01b49353b987 --- /dev/null +++ b/users/Profpatsch/my-prelude/Label.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Label + ( Label, + label, + label', + getLabel, + T2 (..), + T3 (..), + ) +where + +import Data.Data (Proxy (..)) +import Data.Function ((&)) +import Data.Typeable (Typeable) +import GHC.Records (HasField (..)) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) + +-- | A labelled value. +-- +-- Use 'label'/'label'' to construct, +-- then use dot-syntax to get the inner value. +newtype Label (label :: Symbol) value = Label value + deriving stock (Eq, Ord) + deriving newtype (Typeable, Semigroup, Monoid) + +instance (KnownSymbol label, Show value) => Show (Label label value) where + showsPrec d (Label val) = + showParen (d > 10) $ + showString "Label @" + . showsPrec 11 (symbolVal (Proxy @label)) + . showString " " + . showsPrec 11 val + +-- | Attach a label to a value; should be used with a type application to name the label. +-- +-- @@ +-- let f = label @"foo" 'f' :: Label "foo" Char +-- in f.foo :: Char +-- @@ +-- +-- Use dot-syntax to get the labelled value. +label :: forall label value. value -> Label label value +label value = Label value + +-- | Attach a label to a value; Pass it a proxy with the label name in the argument type. +-- This is intended for passing through the label value; +-- you can also use 'label'. +-- +-- +-- @@ +-- let f = label' (Proxy @"foo") 'f' :: Label "foo" Char +-- in f.foo :: Char +-- @@ +-- +-- Use dot-syntax to get the labelled value. +label' :: forall label value. (Proxy label) -> value -> Label label value +label' Proxy value = Label value + +-- | Fetches the labelled value. +instance HasField label (Label label value) value where + getField :: (Label label value) -> value + getField (Label value) = value + +-- | Fetch a value from a record, like 'getField', but also keep it wrapped by its label. +getLabel :: forall label record a. HasField label record a => record -> Label label a +getLabel rec = rec & getField @label & label @label + +-- | A named 2-element tuple. Since the elements are named, you can access them with `.`. +-- +-- @@ +-- let t2 = T2 (label @"myfield" 'c') (label @"otherfield" True) :: T2 "myfield" Char "otherfield" Bool +-- in ( +-- t2.myfield :: Char, +-- t2.otherfield :: Bool +-- ) +-- @@ +data T2 (l1 :: Symbol) t1 (l2 :: Symbol) t2 = T2 (Label l1 t1) (Label l2 t2) + +-- | Access the first field by label +instance HasField l1 (T2 l1 t1 l2 t2) t1 where + getField (T2 t1 _) = getField @l1 t1 + +-- | Access the second field by label +instance HasField l2 (T2 l1 t1 l2 t2) t2 where + getField (T2 _ t2) = getField @l2 t2 + +instance (Semigroup t1, Semigroup t2) => Semigroup (T2 l1 t1 l2 t2) where + T2 t1 t2 <> T2 t1' t2' = T2 (t1 <> t1') (t2 <> t2') + +instance (Monoid t1, Monoid t2) => Monoid (T2 l1 t1 l2 t2) where + mempty = T2 mempty mempty + +-- | A named 3-element tuple. Since the elements are named, you can access them with `.`. See 'T2' for an example. +data T3 (l1 :: Symbol) t1 (l2 :: Symbol) t2 (l3 :: Symbol) t3 = T3 (Label l1 t1) (Label l2 t2) (Label l3 t3) + +-- | Access the first field by label +instance HasField l1 (T3 l1 t1 l2 t2 l3 t3) t1 where + getField (T3 t1 _ _) = getField @l1 t1 + +-- | Access the second field by label +instance HasField l2 (T3 l1 t1 l2 t2 l3 t3) t2 where + getField (T3 _ t2 _) = getField @l2 t2 + +-- | Access the third field by label +instance HasField l3 (T3 l1 t1 l2 t2 l3 t3) t3 where + getField (T3 _ _ t3) = getField @l3 t3 + +instance (Semigroup t1, Semigroup t2, Semigroup t3) => Semigroup (T3 l1 t1 l2 t2 l3 t3) where + T3 t1 t2 t3 <> T3 t1' t2' t3' = T3 (t1 <> t1') (t2 <> t2') (t3 <> t3') + +instance (Monoid t1, Monoid t2, Monoid t3) => Monoid (T3 l1 t1 l2 t2 l3 t3) where + mempty = T3 mempty mempty mempty diff --git a/users/Profpatsch/my-prelude/MyPrelude.hs b/users/Profpatsch/my-prelude/MyPrelude.hs new file mode 100644 index 000000000000..1be248d091a9 --- /dev/null +++ b/users/Profpatsch/my-prelude/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/Pretty.hs b/users/Profpatsch/my-prelude/Pretty.hs new file mode 100644 index 000000000000..8046c83e459c --- /dev/null +++ b/users/Profpatsch/my-prelude/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/README.md b/users/Profpatsch/my-prelude/README.md new file mode 100644 index 000000000000..2cc068579a52 --- /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/RunCommand.hs b/users/Profpatsch/my-prelude/RunCommand.hs new file mode 100644 index 000000000000..5c80eb3aacf4 --- /dev/null +++ b/users/Profpatsch/my-prelude/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/Test.hs b/users/Profpatsch/my-prelude/Test.hs new file mode 100644 index 000000000000..862ee16c255d --- /dev/null +++ b/users/Profpatsch/my-prelude/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/default.nix b/users/Profpatsch/my-prelude/default.nix new file mode 100644 index 000000000000..4d854b194b39 --- /dev/null +++ b/users/Profpatsch/my-prelude/default.nix @@ -0,0 +1,41 @@ +{ depot, pkgs, lib, ... }: + +pkgs.haskellPackages.mkDerivation { + pname = "my-prelude"; + version = "0.0.1-unreleased"; + + src = depot.users.Profpatsch.exactSource ./. [ + ./my-prelude.cabal + ./MyPrelude.hs + ./Label.hs + ./Pretty.hs + ./Data/Error/Tree.hs + ./Aeson.hs + ./RunCommand.hs + ./Test.hs + ]; + + isLibrary = true; + + libraryHaskellDepends = [ + pkgs.haskellPackages.aeson + 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.error + pkgs.haskellPackages.hspec + pkgs.haskellPackages.hspec-expectations-pretty-diff + pkgs.haskellPackages.hscolour + pkgs.haskellPackages.nicify-lib + pkgs.haskellPackages.typed-process + pkgs.haskellPackages.ansi-terminal + 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 new file mode 100644 index 000000000000..94f9c9e77417 --- /dev/null +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -0,0 +1,44 @@ +cabal-version: 2.4 +name: my-prelude +version: 0.0.1.0 +author: Profpatsch +maintainer: mail@profpatsch.de + +library + exposed-modules: + MyPrelude + Label + Pretty + Data.Error.Tree + Aeson + RunCommand + Test + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: + base >=4.15 && <5 + , aeson + , aeson-better-errors + , PyF + , validation-selective + , these + , text + , semigroupoids + , profunctors + , containers + , error + , exceptions + , bytestring + , mtl + , hspec + , hspec-expectations-pretty-diff + , hscolour + , nicify-lib + , typed-process + , ansi-terminal + , vector + default-language: GHC2021 |