src/Worksheets/Utils/Prelude.hs

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