src/Prelude.hs

   1 {-# LANGUAGE FieldSelectors #-}
   2 {-# LANGUAGE PackageImports #-}
   3 {-# LANGUAGE UndecidableInstances #-}
   4 {-# LANGUAGE NoMonomorphismRestriction #-}
   5 {-# OPTIONS_GHC -Wno-orphans #-}
   6
   7 module Prelude (
   8   traceString,
   9   traceShow,
  10   traceShowId,
  11   traceShowM,
  12   IsList (..),
  13   pattern (:=),
  14   forMap,
  15   setSingle,
  16   setInsert,
  17   setSize,
  18   mapSize,
  19   mapLookup,
  20   DropPrefix (..),
  21   ($),
  22   (<$>),
  23   ($>),
  24   (<&>),
  25   (.),
  26   (&),
  27   (&&),
  28   (||),
  29   (>>>),
  30   (++),
  31   id,
  32   const,
  33   on,
  34   fold,
  35   foldr,
  36   foldMap,
  37   foldMapM,
  38   Foldable,
  39   forM,
  40   forM_,
  41   null,
  42   any,
  43   all,
  44   or,
  45   and,
  46   not,
  47   flip,
  48   first,
  49   second,
  50   void,
  51   Bool (..),
  52   otherwise,
  53   Enum (..),
  54   Eq (..),
  55   Ord (..),
  56   Show (..),
  57   Either (..),
  58   either,
  59   Generic,
  60   IsString,
  61   fromString,
  62   fromRational,
  63   HasCallStack,
  64   IO,
  65   FilePath,
  66   Char,
  67   -- Hashable (..),
  68   ShortText,
  69   Set,
  70   String,
  71   Natural,
  72   Int,
  73   Integer,
  74   Map,
  75   Maybe (..),
  76   fromMaybe,
  77   maybe,
  78   maybeToList,
  79   isJust,
  80   isNothing,
  81   Functor (..),
  82   Down (..),
  83   Sum (..),
  84   Identity (..),
  85   Applicative (..),
  86   Semigroup (..),
  87   Monoid (..),
  88   Monad (..),
  89   unless,
  90   when,
  91   Symbol,
  92   KnownSymbol (..),
  93   KnownNat (..),
  94   Real (..),
  95   Num (..),
  96   natVal,
  97   symbolVal,
  98   pShow,
  99   pShowNoColor,
 100   IsLabel (..),
 101   Proxy (..),
 102   Last (..),
 103   -- Surgery,
 104   -- Surgeries,
 105   -- ProductSurgery,
 106   -- ProductSurgeries,
 107   -- Surgery' (..),
 108   -- Generically (..),
 109   -- GenericProduct (..),
 110   -- Derecordify,
 111   -- OnField,
 112   -- OnFields,
 113   -- CopyRep,
 114   -- type (%~),
 115   Typeable,
 116   fst,
 117   snd,
 118   maximum,
 119   minimum,
 120   Max (..),
 121   Min (..),
 122 ) where
 123
 124 import Control.Applicative (Applicative (..))
 125 import Control.Arrow (first, second, (>>>))
 126 import Control.Monad (Monad (..), forM, forM_, unless, void, when)
 127 import Data.Bool (Bool (..), not, otherwise, (&&), (||))
 128 import Data.Char (Char)
 129 import Data.Either (Either (..), either)
 130 import Data.Eq (Eq (..))
 131 import Data.Foldable (Foldable, all, and, any, fold, foldMap, foldr, maximum, minimum, null, or)
 132 import Data.Function (const, flip, id, on, ($), (&), (.))
 133 import Data.Functor (Functor (..), ($>), (<$), (<$>), (<&>))
 134 import Data.Functor.Identity (Identity (..))
 135 import Data.List ((++))
 136 import Data.Map.Strict (Map)
 137 import Data.Map.Strict qualified as Map
 138 import Data.Maybe (Maybe (..), fromMaybe, isJust, isNothing, maybe, maybeToList)
 139 import Data.Monoid (Ap (..), Last (..), Monoid (..))
 140 import Data.Ord (Down (..), Ord (..))
 141 import Data.Proxy (Proxy (..))
 142 import Data.Semigroup (Max (..), Min (..), Semigroup (..), Sum (..))
 143 import Data.Set (Set)
 144 import Data.Set qualified as Set
 145 import Data.String (IsString, String, fromString)
 146 import Data.Text qualified as Text
 147 import Data.Text.Short (ShortText)
 148 import Data.Text.Short qualified as ShortText
 149 import Data.Tuple (fst, snd)
 150 import Debug.Pretty.Simple (pTrace, pTraceShow, pTraceShowId, pTraceShowM)
 151 import GHC.Generics (Generic)
 152 import GHC.IsList (IsList (..), toList)
 153 import GHC.OverloadedLabels (IsLabel (..))
 154 import GHC.Stack (HasCallStack)
 155 import GHC.TypeLits (KnownNat (..), KnownSymbol (..), Symbol, natVal, symbolVal)
 156 import System.IO (FilePath, IO)
 157
 158 -- import Generic.Data.Microsurgery (
 159 --   CopyRep,
 160 --   Derecordify,
 161 --   GenericProduct (..),
 162 --   Generically (..),
 163 --   OnField,
 164 --   OnFields,
 165 --   ProductSurgeries,
 166 --   ProductSurgery,
 167 --   Surgeries,
 168 --   Surgery,
 169 --   Surgery' (..),
 170 --   type (%~),
 171 --  )
 172 import Numeric.Natural (Natural)
 173
 174 -- import Optics.Core
 175 import Text.Pretty.Simple (pShow, pShowNoColor)
 176 import Text.Show (Show (..))
 177 import Type.Reflection (Typeable)
 178 import "base" Prelude (Enum (..), Int, Integer, Num (..), Real (..), fromRational)
 179
 180 traceString = pTrace
 181 traceShow = pTraceShow
 182 traceShowId = pTraceShowId
 183 traceShowM = pTraceShowM
 184
 185 pattern (:=) :: a -> b -> (a, b)
 186 pattern (:=) x y = (x, y)
 187 infixr 0 :=
 188
 189 class Assoc a b c where
 190   (~>) :: a -> b -> c
 191 instance Assoc a b (a, b) where
 192   (~>) = (,)
 193
 194 (<&) :: Functor f => a -> f b -> f a
 195 (&>) :: Functor f => f b -> a -> f a
 196 (<&) = flip ($>)
 197 (&>) = flip (<$)
 198 infixl 4 <&
 199 infixl 4 &>
 200
 201 -- l <>~ n = over l (<> n)
 202 -- {-# INLINE (<>~) #-}
 203
 204 instance IsList a => IsList (Last a) where
 205   type Item (Last a) = Item a
 206   fromList [] = Last Nothing
 207   fromList xs = Last (Just (fromList xs))
 208   toList (Last Nothing) = []
 209   toList (Last (Just x)) = toList x
 210
 211 -- | Like `Last` but `mempty` is `[]` instead not `Nothing`.
 212 -- Useful for deriving:
 213 --
 214 -- @
 215 -- deriving Semigroup via (ProductSurgery (OnFields Lasts) Foo)
 216 -- @
 217 newtype Lasts a = Lasts a
 218   deriving (Eq, Ord, Show, Generic)
 219
 220 instance Semigroup (Lasts [a]) where
 221   Lasts [] <> x = x
 222   x <> Lasts [] = x
 223   _x <> y = y
 224 instance (Monoid a, Semigroup (Lasts a)) => Monoid (Lasts a) where
 225   mempty = Lasts mempty
 226
 227 newtype Newest a = Newest {unNewest :: a}
 228   deriving (Eq, Ord, Generic)
 229   deriving newtype (Show)
 230 instance Semigroup (Newest a) where
 231   _x <> y = y
 232
 233 newtype MapUnion k a = MapUnion {unMapUnion :: Map.Map k a}
 234   deriving (Eq, Ord, Generic, Functor)
 235   deriving newtype (Show)
 236
 237 -- CorrectionWarning: `Monoid` is not derived correctly via `Generically`,
 238 -- it does not reuses `(<>)`.
 239 -- See https://github.com/haskell/core-libraries-committee/issues/324
 240 -- deriving (Monoid) via (Generically (MapUnion k a))
 241 instance (Ord k, Semigroup a) => Semigroup (MapUnion k a) where
 242   MapUnion x <> MapUnion y = MapUnion (Map.unionWith (<>) x y)
 243 instance (Ord k, Semigroup a) => Monoid (MapUnion k a) where
 244   mempty = MapUnion mempty
 245
 246 forMap :: (Foldable t, Monoid m) => t a -> (a -> m) -> m
 247 forMap = flip foldMap
 248
 249 class DropPrefix a where
 250   dropPrefix :: a -> a -> a
 251 instance DropPrefix Text.Text where
 252   dropPrefix p t = t & Text.stripPrefix p & fromMaybe t
 253 instance DropPrefix ShortText where
 254   dropPrefix p t = t & ShortText.stripPrefix p & fromMaybe t
 255
 256 setSingle = Set.singleton
 257 {-# INLINE setSingle #-}
 258 setInsert = Set.insert
 259 {-# INLINE setInsert #-}
 260 setSize = Set.size
 261 {-# INLINE setSize #-}
 262 mapSize = Map.size
 263 {-# INLINE mapSize #-}
 264 mapLookup = Map.lookup
 265 {-# INLINE mapLookup #-}
 266
 267 foldMapM :: (Applicative m, Foldable t, Monoid b) => (a -> m b) -> t a -> m b
 268 foldMapM f = getAp <$> foldMap (Ap . f)