{-# LANGUAGE FieldSelectors #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Literate.Prelude (
  module Literate.Prelude,
  module Literate.Rebindable,
  ($),
  ($>),
  (&&),
  (&),
  (++),
  (.),
  (<$>),
  (<&>),
  (>>>),
  (||),
  uncurry,
  curry,
  Applicative (..),
  Bool (..),
  Boolable (..),
  Char,
  Double,
  Down (..),
  DropPrefix (..),
  Either (..),
  Endo (..),
  Enum (..),
  Eq (..),
  FilePath,
  Foldable,
  Functor (..),
  Generic,
  Generically (..),
  HasCallStack,
  IO,
  Identity (..),
  Int,
  Integer,
  IsLabel (..),
  IsList (..),
  IsString (..),
  KnownNat (..),
  KnownSymbol (..),
  Last (..),
  Lookup (..),
  Map,
  MapUnion (..),
  Max (..),
  Maybe (..),
  Min (..),
  Monad (..),
  Monoid (..),
  Natural,
  NonEmpty (..),
  -- Num (..),
  Ord (..),
  Ordering (..),
  Proxy (..),
  Ratio,
  Rational,
  Real (..),
  Semigroup (..),
  Set,
  ShortText,
  Show (..),
  String,
  Sum (..),
  Symbol,
  Text,
  ToMaybe (..),
  Typeable,
  all,
  and,
  any,
  catMaybes,
  const,
  either,
  even,
  first,
  flip,
  fold,
  foldM,
  foldM_,
  foldMap,
  foldr,
  forM,
  forM_,
  fromMaybe,
  fromIntegral,
  fst,
  id,
  isJust,
  isNothing,
  lefts,
  length,
  mapM,
  mapM_,
  fromRight,
  mapMaybe,
  maximum,
  maybe,
  maybeToList,
  minimum,
  natVal,
  nonEmpty,
  not,
  null,
  odd,
  on,
  or,
  otherwise,
  pShow,
  pHPrint,
  pShowNoColor,
  partitionEithers,
  rights,
  second,
  snd,
  sum,
  symbolVal,
  unless,
  void,
  when,
) where

import Control.Applicative (Applicative (..))
import Control.Arrow (first, second, (>>>))
import Control.Monad (foldM, foldM_, forM, forM_, mapM, mapM_, unless, void, when)
import Data.Bool (Bool (..), not, otherwise, (&&), (||))
import Data.Char (Char)
import Data.Either (Either (..), either, fromRight, lefts, partitionEithers, rights)
import Data.Eq (Eq (..))
import Data.Foldable (Foldable (..), all, and, any, fold, foldMap, foldr, maximum, minimum, null, or)
import Data.Function (const, flip, id, on, ($), (&), (.))
import Data.Functor (Functor (..), ($>), (<$), (<$>), (<&>))
import Data.Functor.Identity (Identity (..))
import Data.List ((++))
import Data.List qualified as List
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Merge.Strict qualified as Map
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (Maybe (..), catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybe, maybeToList)
import Data.Monoid (Ap (..), Endo (..), Last (..), Monoid (..))
import Data.Ord (Down (..), Ord (..), Ordering (..))
import Data.Proxy (Proxy (..))
import Data.Ratio (Ratio, Rational)
import Data.Semigroup (Max (..), Min (..), Semigroup (..), Sum (..))
import Data.Set (Set)
import Data.Set qualified as Set
import Data.String (String)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Lazy qualified as Text.Lazy
import Data.Text.Short (ShortText)
import Data.Text.Short qualified as Text.Short
import Data.Tuple (curry, fst, snd, uncurry)
import Debug.Pretty.Simple (pTrace, pTraceM, pTraceShow, pTraceShowId, pTraceShowM)
import GHC.Generics (Generic, Generically (..))
import GHC.OverloadedLabels (IsLabel (..))
import GHC.Stack (HasCallStack)
import GHC.TypeLits (KnownNat (..), KnownSymbol (..), Symbol, natVal, symbolVal)
import Literate.Rebindable
import Numeric.Natural (Natural)
import Paths_literate_invoice qualified as Self
import System.IO (FilePath, IO)
import System.IO qualified as Sys
import Text.Pretty.Simple (pHPrint, pShow, pShowNoColor)
import Text.Show (Show (..))
import Type.Reflection (Typeable)
import Prelude (Double, Enum (..), Int, Integer, Real (..), error, even, fromIntegral, odd)

traceStringM = pTraceM
traceString = pTrace
traceShow = pTraceShow
traceShowId = pTraceShowId
traceShowM = pTraceShowM

xtraceStringM _ = return ()
xtraceString _ = id
xtraceShow _ = id
xtraceShowId = id
xtraceShowM _ = return ()

pattern (:=) :: a -> b -> (a, b)
pattern (:=) x y = (x, y)
infixr 0 :=

class Assoc a b c where
  (~>) :: a -> b -> c
instance Assoc a b (a, b) where
  (~>) = (,)

(<&) :: Functor f => a -> f b -> f a
(&>) :: Functor f => f b -> a -> f a
(<&) = flip ($>)
(&>) = flip (<$)
infixl 4 <&
infixl 4 &>

-- l <>~ n = over l (<> n)
-- {-# INLINE (<>~) #-}

-- instance IsList a => IsList (Last a) where
--   type Item (Last a) = Item a
--   fromList [] = Last Nothing
--   fromList xs = Last (Just (fromList xs))
--   toList (Last Nothing) = []
--   toList (Last (Just x)) = IsList.toList x

-- | Like `Last` but `mempty` is `[]` instead not `Nothing`.
-- Useful for deriving:
--
-- @
-- deriving Semigroup via (ProductSurgery (OnFields Lasts) Foo)
-- @
newtype Lasts a = Lasts a
  deriving (Eq, Ord, Show, Generic)

instance Semigroup (Lasts [a]) where
  Lasts [] <> x = x
  x <> Lasts [] = x
  _x <> y = y
instance (Monoid a, Semigroup (Lasts a)) => Monoid (Lasts a) where
  mempty = Lasts mempty

newtype Newest a = Newest {unNewest :: a}
  deriving (Eq, Ord, Generic)
  deriving newtype (Show)
instance Semigroup (Newest a) where
  _x <> y = y

newtype MapUnion k a = MapUnion {unMapUnion :: Map.Map k a}
  deriving (Eq, Ord, Generic, Functor)
  deriving newtype (Show)

-- CorrectionWarning: as of GHC 9.6.6, `Monoid` is not derived correctly via `Generically`:
-- it does not reuses `(<>)`.
-- See https://github.com/haskell/core-libraries-committee/issues/324
-- deriving (Monoid) via (Generically (MapUnion k a))
instance (Ord k, Semigroup a) => Semigroup (MapUnion k a) where
  MapUnion x <> MapUnion y = MapUnion (Map.unionWith (<>) x y)
instance (Ord k, Semigroup a) => Monoid (MapUnion k a) where
  mempty = MapUnion mempty
instance (Ord k, Semigroup a) => IsList (MapUnion k a) where
  type Item (MapUnion k a) = (k, a)
  fromList = MapUnion . Map.fromListWith (<>)
  toList = Map.toList . unMapUnion

forMap :: (Foldable t, Monoid m) => t a -> (a -> m) -> m
forMap = flip foldMap

class DropPrefix a where
  dropPrefix :: a -> a -> a
instance DropPrefix Text.Text where
  dropPrefix p t = t & Text.stripPrefix p & fromMaybe t
instance DropPrefix ShortText where
  dropPrefix p t = t & Text.Short.stripPrefix p & fromMaybe t

setSingle = Set.singleton
{-# INLINE setSingle #-}
setInsert = Set.insert
{-# INLINE setInsert #-}
setSize = Set.size
{-# INLINE setSize #-}
mapSize = Map.size
{-# INLINE mapSize #-}
mapEachPiece f g h = Map.merge (Map.mapMissing f) (Map.mapMissing g) (Map.zipWithMatched h)
{-# NOINLINE mapEachPiece #-}

foldMapM :: (Applicative m, Foldable t, Monoid b) => (a -> m b) -> t a -> m b
foldMapM f = getAp <$> foldMap (Ap . f)

class ToMaybe a b where
  toMaybe :: a -> Maybe b
instance ToMaybe Int Natural where
  toMaybe x
    | x >= 0 = Just (fromIntegral x)
    | otherwise = Nothing

withDataFile n f = do
  path <- Self.getDataFileName $ n & List.stripPrefix "data/" & fromMaybe n
  Sys.withFile path Sys.ReadMode f

-- | Useful to constrain a literal list to a bare list when using `OverloadedLists`.
list :: [a] -> [a]
list = id
{-# INLINE list #-}

enumAll = enumFrom (toEnum 0)

last :: a -> Last a
last = Last . Just

-- instance Fractional a => Fractional (Last a) where
--   fromRational = Last . Just . fromRational
--   (/) = liftA2 (/)
--   recip = fmap recip
-- instance Num a => Num (Last a) where
--   (+) = liftA2 (+)
--   (-) = liftA2 (-)
--   (*) = liftA2 (*)
--   abs = fmap abs
--   signum = fmap signum
--   fromInteger = Last . Just . fromInteger

class Boolable a where
  true :: a
  false :: a

instance Boolable Bool where
  true = True
  false = False
instance Boolable a => Boolable (Last a) where
  true = last true
  false = last false

class Lookup a where
  type Key a
  type Value a
  lookup :: Key a -> a -> Maybe (Value a)
instance Ord k => Lookup (Map k a) where
  type Key (Map k a) = k
  type Value (Map k a) = a
  lookup = Map.lookup
instance Ord a => Lookup (Set a) where
  type Key (Set a) = a
  type Value (Set a) = ()
  lookup k m
    | Set.member k m = Just ()
    | otherwise = Nothing
instance Ord a => Lookup [a] where
  type Key [a] = a
  type Value [a] = ()
  lookup k m
    | List.elem k m = Just ()
    | otherwise = Nothing
instance Ord k => Lookup (MapUnion k a) where
  type Key (MapUnion k a) = Key (Map k a)
  type Value (MapUnion k a) = Value (Map k a)
  lookup k = unMapUnion >>> lookup k
instance Lookup a => Lookup (Last a) where
  type Key (Last a) = Key a
  type Value (Last a) = Value a
  lookup k = getLast >>> maybe Nothing (lookup k)

lookupOrDefaultTo d k = lookup k >>> fromMaybe d
{-# INLINE lookupOrDefaultTo #-}

type Modifier a = a -> a

nonEmptyHead = NonEmpty.head

headMaybe = listToMaybe
lastMaybe xs
  | null xs = Nothing
  | otherwise = Just (List.last xs)

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf n xs = ys : chunksOf n zs
  where
    (ys, zs) = List.splitAt n xs

mapFromListCheckingDuplicates :: HasCallStack => Ord k => Show k => [(k, v)] -> Map k v
mapFromListCheckingDuplicates = Map.fromListWithKey (\key -> errorShow ("key duplicate" :: Text, key))

errorShow :: HasCallStack => Show a => a -> b
errorShow x = error $ pShowNoColor x & Text.Lazy.unpack

mapButLast :: (a -> a) -> [a] -> [a]
mapButLast f (x : y : xs) = f x : mapButLast f (y : xs)
mapButLast _f other = other

ol0 = List.zip [0 :: Integer ..]
ol1 = List.zip [1 :: Integer ..]