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   Ord (..),
  61   Ordering (..),
  62   Proxy (..),
  63   Ratio,
  64   Rational,
  65   Real (..),
  66   Semigroup (..),
  67   Set,
  68   ShortText,
  69   Show (..),
  70   String,
  71   Sum (..),
  72   Symbol,
  73   Text,
  74   ToMaybe (..),
  75   Typeable,
  76   all,
  77   and,
  78   any,
  79   catMaybes,
  80   const,
  81   either,
  82   even,
  83   first,
  84   flip,
  85   fold,
  86   foldM,
  87   foldM_,
  88   foldMap,
  89   foldr,
  90   forM,
  91   forM_,
  92   fromMaybe,
  93   fromIntegral,
  94   fst,
  95   id,
  96   isJust,
  97   isNothing,
  98   lefts,
  99   length,
 100   mapM,
 101   mapM_,
 102   fromRight,
 103   mapMaybe,
 104   maximum,
 105   maybe,
 106   maybeToList,
 107   minimum,
 108   natVal,
 109   nonEmpty,
 110   not,
 111   null,
 112   odd,
 113   on,
 114   or,
 115   otherwise,
 116   pShow,
 117   pHPrint,
 118   pShowNoColor,
 119   partitionEithers,
 120   rights,
 121   second,
 122   snd,
 123   sum,
 124   symbolVal,
 125   unless,
 126   void,
 127   when,
 128 ) where
 129
 130 import Control.Applicative (Applicative (..))
 131 import Control.Arrow (first, second, (>>>))
 132 import Control.Monad (foldM, foldM_, forM, forM_, mapM, mapM_, unless, void, when)
 133 import Data.Bool (Bool (..), not, otherwise, (&&), (||))
 134 import Data.Char (Char)
 135 import Data.Either (Either (..), either, fromRight, lefts, partitionEithers, rights)
 136 import Data.Eq (Eq (..))
 137 import Data.Foldable (Foldable (..), all, and, any, fold, foldMap, foldr, maximum, minimum, null, or)
 138 import Data.Function (const, flip, id, on, ($), (&), (.))
 139 import Data.Functor (Functor (..), ($>), (<$), (<$>), (<&>))
 140 import Data.Functor.Identity (Identity (..))
 141 import Data.List ((++))
 142 import Data.List qualified as List
 143 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 144 import Data.List.NonEmpty qualified as NonEmpty
 145 import Data.Map.Merge.Strict qualified as Map
 146 import Data.Map.Strict (Map)
 147 import Data.Map.Strict qualified as Map
 148 import Data.Maybe (Maybe (..), catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybe, maybeToList)
 149 import Data.Monoid (Ap (..), Endo (..), Last (..), Monoid (..))
 150 import Data.Ord (Down (..), Ord (..), Ordering (..))
 151 import Data.Proxy (Proxy (..))
 152 import Data.Ratio (Ratio, Rational)
 153 import Data.Semigroup (Max (..), Min (..), Semigroup (..), Sum (..))
 154 import Data.Set (Set)
 155 import Data.Set qualified as Set
 156 import Data.String (String)
 157 import Data.Text (Text)
 158 import Data.Text qualified as Text
 159 import Data.Text.Lazy qualified as Text.Lazy
 160 import Data.Text.Short (ShortText)
 161 import Data.Text.Short qualified as Text.Short
 162 import Data.Tuple (curry, fst, snd, uncurry)
 163 import Debug.Pretty.Simple (pTrace, pTraceM, pTraceShow, pTraceShowId, pTraceShowM)
 164 import GHC.Generics (Generic, Generically (..))
 165 import GHC.OverloadedLabels (IsLabel (..))
 166 import GHC.Stack (HasCallStack)
 167 import GHC.TypeLits (KnownNat (..), KnownSymbol (..), Symbol, natVal, symbolVal)
 168 import Literate.Rebindable
 169 import Numeric.Natural (Natural)
 170 import Paths_literate_invoice qualified as Self
 171 import System.IO (FilePath, IO)
 172 import System.IO qualified as Sys
 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 withDataFile n f = do
 287   path <- Self.getDataFileName $ n & List.stripPrefix "data/" & fromMaybe n
 288   Sys.withFile path Sys.ReadMode f
 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 :: Integer ..]
 381 ol1 = List.zip [1 :: Integer ..]