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