{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}

module Literate.Accounting.Math where

import Control.Applicative (Applicative (..))
import Control.Exception (Exception, throw)
import Control.Monad.Classes qualified as MC
import Control.Monad.Classes.Run qualified as MC
import Control.Monad.Trans.Except as MT
import Control.Monad.Trans.Reader as MT
import Data.Bool
import Data.Data (Data)
import Data.Either (Either (..), either)
import Data.Eq (Eq (..))
import Data.Foldable (Foldable, foldl')
import Data.Function (flip, id, ($), (.))
import Data.Functor ((<$>))
import Data.Functor.Identity (Identity (..))
import Data.Int (Int)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (Maybe (..))
import Data.Monoid (Endo (..))
import Data.Ord (Ord (..), Ordering (..))
import Data.Proxy (Proxy (..))
import Data.Ratio (Rational)
import Data.String (String)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Data.Word
import GHC.Generics (Generic)
import GHC.Real (FractionalExponentBase (Base10), Ratio ((:%)), (%))
import GHC.Stack (HasCallStack)
import GHC.TypeLits (KnownNat, Nat, Symbol, natVal, type (<=))
import Literate.Prelude
import Numeric.Natural
import Text.Read (Read)
import Text.Show (Show (..), ShowS, showParen, showString, showsPrec)
import Prelude (Integer, Integral, error, fromIntegral, maxBound)
import Prelude qualified

-- import Data.Decimal (Decimal, DecimalRaw (..), roundTo)
-- import Data.Validity qualified as Validity
-- import Data.Reflection (Reifies(..), reify)
-- import Data.Modular
-- import Literate.Accounting.Rebindable (fromInteger, FromRational(..))

errorWithStack :: HasCallStack => String -> a
errorWithStack = error -- (msg <> "\n" <> prettyCallStack callStack)

-- * Class 'Zeroable'
class Zeroable a where
  zero :: a
  isZero :: a -> Bool
  default isZero :: Zeroable a => Eq a => a -> Bool
  isZero = (== zero)
instance Zeroable String where
  zero = ""
  isZero = null
instance Zeroable Word32 where
  zero = (0 :: Int) & fromIntegral
instance Zeroable Word64 where
  zero = (0 :: Int) & fromIntegral

-- instance Zeroable Decimal where
--  zero = 0
instance Zeroable (Map.Map k a) where
  zero = Map.empty
  isZero = Map.null

{-
instance Zeroable Decimal where
  zero = 0
instance Zeroable (Map k a) where
  zero = Map.empty
-}

-- * Class 'Signable'
class Signable a where
  sign :: a -> Ordering
  default sign :: Zeroable a => Ord a => a -> Ordering
  sign a =
    case () of
      _ | isZero a -> EQ
      _ | a < zero -> LT
      _ -> GT

-- instance Signable Decimal

-- * Class 'Addable'

-- | Can be added.
class Addable a where
  (+) :: HasCallStack => a -> a -> a
  infixl 6 +
  default (+) :: Prelude.Num a => HasCallStack => a -> a -> a
  (+) = (Prelude.+)

-- | For @'Addable' ('Map' k ())@.
instance Addable () where
  (+) () () = ()

instance (Ord k, Addable a) => Addable (Map k a) where
  (+) = Map.unionWith (flip (+))
instance Addable a => Addable (Maybe a) where
  Nothing + Nothing = Nothing
  Just x + Nothing = Just x
  Nothing + Just y = Just y
  Just x + Just y = Just (x + y)

{-
instance Addable Decimal where
  (+) x y = Decimal e (fromIntegral (nx Prelude.+ ny))
   where
    (e, nx, ny) = roundMinDecimal x y

-- | Round the two 'DecimalRaw' values to the smallest exponent.
roundMinDecimal :: Integral i => DecimalRaw i -> DecimalRaw i -> (Word8, i, i)
roundMinDecimal d1@(Decimal e1 _) d2@(Decimal e2 _) = (e, n1, n2)
 where
  e = min e1 e2
  Decimal _ n1 = roundTo e d1
  Decimal _ n2 = roundTo e d2
-}

-- * Class 'Negable'
class Negable a where
  negate :: a -> a
  default negate :: Prelude.Num a => a -> a
  negate = Prelude.negate

-- | For @'Negable' ('Map' k ())@.
instance Negable () where
  negate () = ()

instance Negable Int
instance Negable Integer

-- instance Negable Decimal
instance Negable a => Negable (Map k a) where
  negate = Map.map negate
instance Negable a => Negable (Endo a) where
  negate (Endo f) = Endo (f . negate)
instance Negable a => Negable [a] where
  negate = (negate <$>)

-- * Class 'Substractable'
class Substractable a where
  (-) :: a -> a -> a
  infixl 6 -
  default (-) :: Prelude.Num a => a -> a -> a
  (-) = (Prelude.-)

-- | For @'Substractable' ('Map' k ())@.
instance Substractable () where
  (-) () () = ()

instance Substractable Int
instance Substractable Integer

-- instance Substractable Decimal
instance (Ord k, Addable a, Negable a) => Substractable (Map k a) where
  (-) x y = Map.unionWith (flip (+)) x (negate y)

-- * Constraint 'MinQty'
type QuantFact n = (KnownNat n, 1 <= n, n <= 4294967295 {-Word32-})
quantisationFactor :: forall qf. QuantFact qf => Word32
quantisationFactor = Prelude.fromIntegral (natVal (Proxy @qf))

data Unit
  = UnitName Symbol
  | (:*:) Unit Unit
  | (:/:) Unit Unit

class UnitShowS (u :: Unit) where
  unitShowS :: Int -> ShowS
instance KnownSymbol u => UnitShowS (UnitName u) where
  unitShowS _prec = showString (symbolVal (Proxy @u))
instance (UnitShowS x, UnitShowS y) => UnitShowS (x :*: y) where
  unitShowS p = showParen (7 <= p) $ unitShowS @x 7 . showString "\x202F*\x202F" . unitShowS @y 7
instance (UnitShowS x, UnitShowS y) => UnitShowS (x :/: y) where
  unitShowS p = showParen (7 <= p) $ unitShowS @x 7 . showString "\x202F/\x202F" . unitShowS @y 7

unitShow :: forall u. UnitShowS u => String
unitShow = unitShowS @u 0 ""

-- * Type 'Amount'
newtype Amount (qf :: Nat) (unit :: Unit) = Amount
  { amountQuantity :: Quantity qf
  }
  deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)
instance QuantFact qf => FromInteger (MT.Except ErrorQuantity (Amount qf unit)) where
  fromInteger i = fromRational (i :% 1)

-- * Type 'Quantity'
newtype Quantity qf = Quantity
  { unQuantity :: Word64
  }
  deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)

instance Zeroable (Quantity qf) where
  zero = Quantity 0
  isZero (Quantity q) = q == 0

-- instance Validity Quantity
-- instance NFData Quantity
instance QuantFact qf => FromInteger (MT.Except ErrorQuantity (Quantity qf)) where
  fromInteger n = fromRational (n :% 1)
instance QuantFact qf => FromInteger (Quantity qf) where
  fromInteger n = fromRational (n :% 1)
instance QuantFact qf => FromInteger (Amount qf unit) where
  fromInteger = fromInteger >>> Amount

instance Integral a => Addable (Ratio a) where
  x + y = x Prelude.+ y
instance Addable (Maybe (Quantity qf)) where
  (+) mx my = do
    Quantity x <- mx
    Quantity y <- my
    let res = fromIntegral x Prelude.+ fromIntegral y
    if res > fromIntegral @Word64 maxBound
      then Nothing
      else Just (Quantity (Prelude.fromInteger res))
instance Addable (Quantity qf) where
  (+) x y = do
    let res = fromIntegral (unQuantity x) Prelude.+ fromIntegral (unQuantity y)
    if res > fromIntegral (maxBound @Word64)
      then errorWithStack "Quantity overflow"
      else Quantity (Prelude.fromInteger res)
instance Addable (Amount qf unit) where
  Amount x + Amount y = Amount (x + y)

{-
sum :: forall f. Foldable f => f Amount -> Maybe Amount
sum l =
  let maxBoundI :: Integer
      maxBoundI = fromIntegral (maxBound :: Word64)
      r :: Integer
      r = foldl' (\acc a -> (toInteger :: Word64 -> Integer) (amountQuantity a) + acc) 0 l
   in if r > maxBoundI
        then Nothing
        else Just (Amount ((fromInteger :: Integer -> Word64) r))
-}

instance Substractable (Maybe (Quantity qf)) where
  (-) mx my = do
    Quantity x <- mx
    Quantity y <- my
    let res = fromIntegral x - fromIntegral y
    if res < 0
      then Nothing
      else Just (Quantity (Prelude.fromInteger res))

sumAmounts :: forall qf unit f. Functor f => Foldable f => f (Amount qf unit) -> Maybe (Amount qf unit)
sumAmounts l = l <&> amountQuantity & sumQuantities <&> Amount

sumQuantities :: forall qf f. Foldable f => f (Quantity qf) -> Maybe (Quantity qf)
sumQuantities l =
  let res = foldl' (\acc a -> Prelude.toInteger (unQuantity a) Prelude.+ acc) 0 l
  in if res > fromIntegral (maxBound @Word64)
      then Nothing
      else Just (Quantity (Prelude.fromInteger res))

multiply :: Word32 -> Quantity qf -> Maybe (Quantity qf)
multiply c (Quantity qty) =
  let
    res :: Integer
    res = Prelude.fromIntegral c Prelude.* Prelude.fromIntegral qty
  in
    if res > fromIntegral (maxBound @Word64)
      then Nothing
      else Just (Quantity (Prelude.fromInteger res))

-- * Type 'CurrencyEnv'
newtype CurrencyEnv = CurrencyEnv
  { currencyDefault :: Text
  }

-- newtype CurrencyT repr a = CurrencyT { unCurrencyT :: MT.ReaderT CurrencyEnv repr a }

-- * Class 'CurrencyUSD'
class CurrencyUSD repr where
  usd :: repr a -> repr a
instance CurrencyUSD (MT.ReaderT CurrencyEnv repr) where
  usd = MT.local (\c -> c{currencyDefault = "$"})

-- * Type 'ErrorQuantity'
data ErrorQuantity
  = ErrorQuantityNaN
  | ErrorQuantityInfinite
  | ErrorQuantityNotNormalised
  | ErrorQuantityOverflow Natural
  | ErrorQuantityNegative
  | ErrorQuantityNotMultipleOfMinimalQuantity (Rational) (Word32) Natural Natural
  deriving (Eq, Show)
instance Exception ErrorQuantity

newtype MinimalQuantity = MinimalQuantity Word32

{-
quantityFromRational ::
  forall qf m.
  MC.MonadExcept ErrorQuantity m =>
  MC.MonadReader MinimalQuantity m =>
  --Reifies qf MinimalQuantity =>
  Rational ->
  m (Quantity qf)
-}

instance QuantFact qf => FromRational (MT.Except ErrorQuantity (Quantity qf)) where
  fromRational r@(rn :% rd)
    -- ToDo: replace with isValid
    | rd == 0 = MC.throw $ if rn == 0 then ErrorQuantityNaN else ErrorQuantityInfinite
    | gcd < 0 || Prelude.quot rn gcd :% Prelude.quot rd gcd /= rn :% rd =
        MC.throw ErrorQuantityNotNormalised
    | r < 0 = MC.throw ErrorQuantityNegative
    | (fromIntegral :: Word64 -> Natural) (maxBound :: Word64) < ceiled = MC.throw $ ErrorQuantityOverflow ceiled
    | floored == ceiled = pure $ Quantity $ fromIntegral floored
    | otherwise = MC.throw $ ErrorQuantityNotMultipleOfMinimalQuantity r minQty floored ceiled
    where
      gcd = Prelude.gcd rn rd
      minQty = quantisationFactor @qf
      qty :: Rational
      qty = r Prelude.* fromIntegral minQty
      ceiled :: Natural
      ceiled = Prelude.ceiling qty
      floored :: Natural
      floored = Prelude.floor qty
instance QuantFact qf => FromRational (MT.Except ErrorQuantity (Amount qf unit)) where
  fromRational r = Amount <$> fromRational r

-- | Warning(functional/completeness/partial)
instance QuantFact qf => FromRational (Quantity qf) where
  fromRational = fromRational >>> MT.runExcept >>> either (throw @_ @_ @ErrorQuantity) id

instance QuantFact qf => FromRational (Amount qf unit) where
  fromRational = Amount . fromRational

-- | Turn an amount of money into a 'Ratio'.
--
-- WARNING: that the result will be @Quantity :% 0@ if the quantisation factor is @0@.
quantityToRatio :: forall qf. QuantFact qf => Quantity qf -> Ratio Natural
quantityToRatio (Quantity q) =
  -- \| isZero qf = Prelude.fromIntegral q :% 0
  -- \| otherwise =
  (Prelude.fromIntegral :: Word64 -> Natural) q % (Prelude.fromIntegral :: Word32 -> Natural) qf
  where
    qf = quantisationFactor @qf

-- | Turn an amount of money into a 'Rational'.
--
-- WARNING: that the result will be @Quantity :% 0@ if the quantisation factor is @0@.
quantityToRational :: QuantFact qf => Quantity qf -> Rational
quantityToRational q = q & quantityToRatio & Prelude.toRational

-- instance QuantFact qf => FromRational (Amount qf unit) where
--   fromRational = either (throw @_ @_ @ErrorQuantity) id . MT.runExcept . fromRational

{-
validateNotNaN :: RealFloat a => a -> Validation
validateNotNaN x | isNaN x =

validateNotInfinite :: RealFloat a => a -> Validation
validateNotInfinite d = declare "The RealFloat is not infinite." $ not (isInfinite d)

validateRatioNotNaN :: Integral a => Ratio a -> Validation
validateRatioNotNaN r = declare "The Ratio is not NaN." $
  case r of
    (0 :% 0) -> False
    _ -> True

validateRatioNotInfinite :: Integral a => Ratio a -> Validation
validateRatioNotInfinite r = declare "The Ratio is not infinite." $
  case r of
    (1 :% 0) -> False
    ((-1) :% 0) -> False
    _ -> True

validateRatioNormalised :: Integral a => Ratio a -> Validation
validateRatioNormalised (n :% d) = declare "The Ratio is normalised." $
  case d of
    0 -> False
    _ ->
      let g = gcd n d
          gcdOverflows = g < 0
          n' :% d' = (n `quot` g) :% (d `quot` g)
          valueIsNormalised = n' :% d' == n :% d
       in not gcdOverflows && valueIsNormalised
-}
{-

-- | Turn a 'Ratio' into an amount of money.
--
-- This function will fail if the 'Ratio':
--
-- * Is NaN (0 :% 0)
-- * Is infinite (1 :% 0) or (-1 :% 0)
-- * Is non-normalised (5 :% 5)
-- * Does represent an integer number of minimal quantisations.
fromRatio :: Word32 -> Ratio Natural -> Maybe Quantity
fromRatio quantisationFactor r = quantityFromRational quantisationFactor (Prelude.quantityToRational r)

-- | Distribute an amount of money into chunks that are as evenly distributed as possible.
distribute :: Quantity -> Word32 -> QuantityDistribution
distribute (Quantity 0) _ = DistributedZeroQuantity
distribute _ 0 = DistributedIntoZeroChunks
distribute (Quantity a) f =
  let smallerChunkSize, rest :: Word64
      (smallerChunkSize, rest) = divMod a ((fromIntegral :: Word32 -> Word64) f)
      smallerChunk :: Quantity
      smallerChunk = Quantity smallerChunkSize
   in if rest == 0
        then DistributedIntoEqualChunks f smallerChunk
        else
          let -- This 'fromIntegral' is theoretically not safe, but it's
              -- necessarily smaller than f so it will fit.
              numberOfLargerChunks :: Word32
              numberOfLargerChunks = (fromIntegral :: Word64 -> Word32) rest
              numberOfSmallerChunks :: Word32
              numberOfSmallerChunks = f - numberOfLargerChunks
              largerChunk :: Quantity
              largerChunk = Quantity $ succ smallerChunkSize
           in DistributedIntoUnequalChunks
                numberOfLargerChunks
                largerChunk
                numberOfSmallerChunks
                smallerChunk

-- | The result of 'distribute'
data QuantityDistribution
  = -- | The second argument was zero.
    DistributedIntoZeroChunks
  | -- | The first argument was a zero amount.
    DistributedZeroQuantity
  | -- | Distributed into this many equal chunks of this amount
    DistributedIntoEqualChunks !Word32 !Quantity
  | -- | Distributed into unequal chunks, this many of the first (larger) amount, and this many of the second (slightly smaller) amount.
    DistributedIntoUnequalChunks !Word32 !Quantity !Word32 !Quantity
  deriving (Show, Read, Eq, Generic)

instance Validity QuantityDistribution where
  validate ad =
    mconcat
      [ genericValidate ad,
        case ad of
          DistributedIntoUnequalChunks _ a1 _ a2 ->
            declare "The larger chunks are larger" $
              a1 > a2
          _ -> valid
      ]

instance NFData QuantityDistribution

-- | Validate that an 'Quantity' is strictly positive. I.e. not 'zero'.
validateStrictlyPositive :: Quantity -> Validation
validateStrictlyPositive amount = declare "The Quantity is strictly positive" $ amount > zero
-}

-- | Fractional multiplication
fraction ::
  Zeroable (Quantity qf) =>
  Ratio Natural ->
  Quantity qf ->
  (Quantity qf, Ratio Natural)
fraction frac (Quantity 0) = (zero, frac)
fraction 0 _ = (zero, 0)
fraction frac (Quantity a) =
  let
    theoreticalResult :: Ratio Natural
    theoreticalResult = (fromIntegral :: Word64 -> Ratio Natural) a Prelude.* frac
    roundedResult :: Word64
    roundedResult = (Prelude.round :: Ratio Natural -> Word64) theoreticalResult
    actualRate :: Ratio Natural
    actualRate =
      (fromIntegral :: Word64 -> Natural) roundedResult
        % (fromIntegral :: Word64 -> Natural) a
  in
    (Quantity roundedResult, actualRate)