src/Literate/Prelude.hs

   1 {-# LANGUAGE FieldSelectors #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3 {-# LANGUAGE NoMonomorphismRestriction #-}
   4 {-# OPTIONS_GHC -Wno-deprecations #-}
   5 {-# OPTIONS_GHC -Wno-orphans #-}
   6
   7 module Literate.Prelude (
   8   module Literate.Prelude,
   9   module Literate.Rebindable,
  10   type (~),
  11   ($),
  12   ($>),
  13   (&&),
  14   (&),
  15   (++),
  16   (.),
  17   (<$>),
  18   (<&>),
  19   (>>>),
  20   (||),
  21   uncurry,
  22   curry,
  23   Applicative (..),
  24   Bool (..),
  25   Boolable (..),
  26   Char,
  27   Double,
  28   Down (..),
  29   DropPrefix (..),
  30   Either (..),
  31   Endo (..),
  32   Enum (..),
  33   Eq (..),
  34   FilePath,
  35   Foldable,
  36   Functor (..),
  37   Generic,
  38   Generically (..),
  39   HasCallStack,
  40   IO,
  41   Identity (..),
  42   Int,
  43   Integer,
  44   IsLabel (..),
  45   IsList (..),
  46   IsString (..),
  47   KnownNat (..),
  48   KnownSymbol (..),
  49   Last (..),
  50   Lookup (..),
  51   Map,
  52   MapUnion (..),
  53   Max (..),
  54   Maybe (..),
  55   Min (..),
  56   Monad (..),
  57   Monoid (..),
  58   Natural,
  59   NonEmpty (..),
  60   -- Num (..),
  61   NFData (..),
  62   Ord (..),
  63   Ordering (..),
  64   Proxy (..),
  65   Ratio,
  66   Rational,
  67   Real (..),
  68   Semigroup (..),
  69   Set,
  70   ShortText,
  71   Show (..),
  72   String,
  73   Sum (..),
  74   Symbol,
  75   Text,
  76   ToMaybe (..),
  77   Type,
  78   Typeable,
  79   all,
  80   and,
  81   any,
  82   catMaybes,
  83   const,
  84   either,
  85   even,
  86   first,
  87   flip,
  88   fold,
  89   foldM,
  90   foldM_,
  91   foldMap,
  92   foldr,
  93   forM,
  94   forM_,
  95   fromMaybe,
  96   fromIntegral,
  97   fst,
  98   id,
  99   isJust,
 100   isNothing,
 101   lefts,
 102   length,
 103   mapM,
 104   mapM_,
 105   fromRight,
 106   mapMaybe,
 107   maximum,
 108   maybe,
 109   maybeToList,
 110   minimum,
 111   natVal,
 112   nonEmpty,
 113   not,
 114   null,
 115   odd,
 116   on,
 117   or,
 118   otherwise,
 119   pShow,
 120   pHPrint,
 121   pShowNoColor,
 122   partitionEithers,
 123   rights,
 124   second,
 125   snd,
 126   sum,
 127   symbolVal,
 128   unless,
 129   void,
 130   when,
 131 ) where
 132
 133 import Control.Applicative (Applicative (..))
 134 import Control.Arrow (first, second, (>>>))
 135 import Control.DeepSeq (NFData (..))
 136 import Control.Monad (foldM, foldM_, forM, forM_, mapM, mapM_, unless, void, when)
 137 import Data.Bool (Bool (..), not, otherwise, (&&), (||))
 138 import Data.Char (Char)
 139 import Data.Either (Either (..), either, fromRight, lefts, partitionEithers, rights)
 140 import Data.Eq (Eq (..))
 141 import Data.Foldable (Foldable (..), all, and, any, fold, foldMap, foldr, maximum, minimum, null, or)
 142 import Data.Function (const, flip, id, on, ($), (&), (.))
 143 import Data.Functor (Functor (..), ($>), (<$), (<$>), (<&>))
 144 import Data.Functor.Identity (Identity (..))
 145 import Data.Kind (Type)
 146 import Data.List ((++))
 147 import Data.List qualified as List
 148 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 149 import Data.List.NonEmpty qualified as NonEmpty
 150 import Data.Map.Merge.Strict qualified as Map
 151 import Data.Map.Strict (Map)
 152 import Data.Map.Strict qualified as Map
 153 import Data.Maybe (Maybe (..), catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybe, maybeToList)
 154 import Data.Monoid (Ap (..), Endo (..), Last (..), Monoid (..))
 155 import Data.Ord (Down (..), Ord (..), Ordering (..))
 156 import Data.Proxy (Proxy (..))
 157 import Data.Ratio (Ratio, Rational)
 158 import Data.Semigroup (Max (..), Min (..), Semigroup (..), Sum (..))
 159 import Data.Set (Set)
 160 import Data.Set qualified as Set
 161 import Data.String (String)
 162 import Data.Text (Text)
 163 import Data.Text qualified as Text
 164 import Data.Text.Lazy qualified as Text.Lazy
 165 import Data.Text.Short (ShortText)
 166 import Data.Text.Short qualified as Text.Short
 167 import Data.Tuple (curry, fst, snd, uncurry)
 168 import Data.Type.Equality (type (~))
 169 import Debug.Pretty.Simple (pTrace, pTraceM, pTraceShow, pTraceShowId, pTraceShowM)
 170 import GHC.Generics (Generic, Generically (..))
 171 import GHC.OverloadedLabels (IsLabel (..))
 172 import GHC.Stack (HasCallStack)
 173 import GHC.TypeLits (KnownNat (..), KnownSymbol (..), Symbol, natVal, symbolVal)
 174 import Literate.Rebindable
 175 import Numeric.Natural (Natural)
 176 import System.IO (FilePath, IO)
 177 import Text.Pretty.Simple (pHPrint, pShow, pShowNoColor)
 178 import Text.Show (Show (..))
 179 import Type.Reflection (Typeable)
 180 import Prelude (Double, Enum (..), Int, Integer, Real (..), error, even, fromIntegral, odd)
 181
 182 traceStringM = pTraceM
 183 traceString = pTrace
 184 traceShow = pTraceShow
 185 traceShowId = pTraceShowId
 186 traceShowM = pTraceShowM
 187
 188 xtraceStringM _ = return ()
 189 xtraceString _ = id
 190 xtraceShow _ = id
 191 xtraceShowId = id
 192 xtraceShowM _ = return ()
 193
 194 pattern (:=) :: a -> b -> (a, b)
 195 pattern (:=) x y = (x, y)
 196 infixr 0 :=
 197
 198 class Assoc a b c where
 199   (~>) :: a -> b -> c
 200 instance Assoc a b (a, b) where
 201   (~>) = (,)
 202
 203 (<&) :: Functor f => a -> f b -> f a
 204 (&>) :: Functor f => f b -> a -> f a
 205 (<&) = flip ($>)
 206 (&>) = flip (<$)
 207 infixl 4 <&
 208 infixl 4 &>
 209
 210 -- l <>~ n = over l (<> n)
 211 -- {-# INLINE (<>~) #-}
 212
 213 -- instance IsList a => IsList (Last a) where
 214 --   type Item (Last a) = Item a
 215 --   fromList [] = Last Nothing
 216 --   fromList xs = Last (Just (fromList xs))
 217 --   toList (Last Nothing) = []
 218 --   toList (Last (Just x)) = IsList.toList x
 219
 220 -- | Like `Last` but `mempty` is `[]` instead not `Nothing`.
 221 -- Useful for deriving:
 222 --
 223 -- @
 224 -- deriving Semigroup via (ProductSurgery (OnFields Lasts) Foo)
 225 -- @
 226 newtype Lasts a = Lasts a
 227   deriving (Eq, Ord, Show, Generic)
 228
 229 instance Semigroup (Lasts [a]) where
 230   Lasts [] <> x = x
 231   x <> Lasts [] = x
 232   _x <> y = y
 233 instance (Monoid a, Semigroup (Lasts a)) => Monoid (Lasts a) where
 234   mempty = Lasts mempty
 235
 236 newtype Newest a = Newest {unNewest :: a}
 237   deriving (Eq, Ord, Generic)
 238   deriving newtype (Show)
 239 instance Semigroup (Newest a) where
 240   _x <> y = y
 241
 242 newtype MapUnion k a = MapUnion {unMapUnion :: Map.Map k a}
 243   deriving (Eq, Ord, Generic, Functor)
 244   deriving newtype (Show)
 245
 246 -- CorrectionWarning: as of GHC 9.6.6, `Monoid` is not derived correctly via `Generically`:
 247 -- it does not reuses `(<>)`.
 248 -- See https://github.com/haskell/core-libraries-committee/issues/324
 249 -- deriving (Monoid) via (Generically (MapUnion k a))
 250 instance (Ord k, Semigroup a) => Semigroup (MapUnion k a) where
 251   MapUnion x <> MapUnion y = MapUnion (Map.unionWith (<>) x y)
 252 instance (Ord k, Semigroup a) => Monoid (MapUnion k a) where
 253   mempty = MapUnion mempty
 254 instance (Ord k, Semigroup a) => IsList (MapUnion k a) where
 255   type Item (MapUnion k a) = (k, a)
 256   fromList = MapUnion . Map.fromListWith (<>)
 257   toList = Map.toList . unMapUnion
 258
 259 forMap :: (Foldable t, Monoid m) => t a -> (a -> m) -> m
 260 forMap = flip foldMap
 261
 262 class DropPrefix a where
 263   dropPrefix :: a -> a -> a
 264 instance DropPrefix Text.Text where
 265   dropPrefix p t = t & Text.stripPrefix p & fromMaybe t
 266 instance DropPrefix ShortText where
 267   dropPrefix p t = t & Text.Short.stripPrefix p & fromMaybe t
 268
 269 setSingle = Set.singleton
 270 {-# INLINE setSingle #-}
 271 setInsert = Set.insert
 272 {-# INLINE setInsert #-}
 273 setSize = Set.size
 274 {-# INLINE setSize #-}
 275 mapSize = Map.size
 276 {-# INLINE mapSize #-}
 277 mapEachPiece f g h = Map.merge (Map.mapMissing f) (Map.mapMissing g) (Map.zipWithMatched h)
 278 {-# NOINLINE mapEachPiece #-}
 279
 280 foldMapM :: (Applicative m, Foldable t, Monoid b) => (a -> m b) -> t a -> m b
 281 foldMapM f = getAp <$> foldMap (Ap . f)
 282
 283 class ToMaybe a b where
 284   toMaybe :: a -> Maybe b
 285 instance ToMaybe Int Natural where
 286   toMaybe x
 287     | x >= 0 = Just (fromIntegral x)
 288     | otherwise = Nothing
 289
 290 -- | Useful to constrain a literal list to a bare list when using `OverloadedLists`.
 291 list :: [a] -> [a]
 292 list = id
 293 {-# INLINE list #-}
 294
 295 enumAll = enumFrom (toEnum 0)
 296
 297 last :: a -> Last a
 298 last = Last . Just
 299
 300 -- instance Fractional a => Fractional (Last a) where
 301 --   fromRational = Last . Just . fromRational
 302 --   (/) = liftA2 (/)
 303 --   recip = fmap recip
 304 -- instance Num a => Num (Last a) where
 305 --   (+) = liftA2 (+)
 306 --   (-) = liftA2 (-)
 307 --   (*) = liftA2 (*)
 308 --   abs = fmap abs
 309 --   signum = fmap signum
 310 --   fromInteger = Last . Just . fromInteger
 311
 312 class Boolable a where
 313   true :: a
 314   false :: a
 315
 316 instance Boolable Bool where
 317   true = True
 318   false = False
 319 instance Boolable a => Boolable (Last a) where
 320   true = last true
 321   false = last false
 322
 323 class Lookup a where
 324   type Key a
 325   type Value a
 326   lookup :: Key a -> a -> Maybe (Value a)
 327 instance Ord k => Lookup (Map k a) where
 328   type Key (Map k a) = k
 329   type Value (Map k a) = a
 330   lookup = Map.lookup
 331 instance Ord a => Lookup (Set a) where
 332   type Key (Set a) = a
 333   type Value (Set a) = ()
 334   lookup k m
 335     | Set.member k m = Just ()
 336     | otherwise = Nothing
 337 instance Ord a => Lookup [a] where
 338   type Key [a] = a
 339   type Value [a] = ()
 340   lookup k m
 341     | List.elem k m = Just ()
 342     | otherwise = Nothing
 343 instance Ord k => Lookup (MapUnion k a) where
 344   type Key (MapUnion k a) = Key (Map k a)
 345   type Value (MapUnion k a) = Value (Map k a)
 346   lookup k = unMapUnion >>> lookup k
 347 instance Lookup a => Lookup (Last a) where
 348   type Key (Last a) = Key a
 349   type Value (Last a) = Value a
 350   lookup k = getLast >>> maybe Nothing (lookup k)
 351
 352 lookupOrDefaultTo d k = lookup k >>> fromMaybe d
 353 {-# INLINE lookupOrDefaultTo #-}
 354
 355 type Modifier a = a -> a
 356
 357 nonEmptyHead = NonEmpty.head
 358
 359 headMaybe = listToMaybe
 360 lastMaybe xs
 361   | null xs = Nothing
 362   | otherwise = Just (List.last xs)
 363
 364 chunksOf :: Int -> [a] -> [[a]]
 365 chunksOf _ [] = []
 366 chunksOf n xs = ys : chunksOf n zs
 367   where
 368     (ys, zs) = List.splitAt n xs
 369
 370 mapFromListCheckingDuplicates :: HasCallStack => Ord k => Show k => [(k, v)] -> Map k v
 371 mapFromListCheckingDuplicates = Map.fromListWithKey (\key -> errorShow ("key duplicate" :: Text, key))
 372
 373 errorShow :: HasCallStack => Show a => a -> b
 374 errorShow x = error $ pShowNoColor x & Text.Lazy.unpack
 375
 376 mapButLast :: (a -> a) -> [a] -> [a]
 377 mapButLast f (x : y : xs) = f x : mapButLast f (y : xs)
 378 mapButLast _f other = other
 379
 380 ol0 = List.zip [0 :: Natural ..]
 381 ol1 = List.zip [1 :: Natural ..]