{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.Quantity where

import Control.DeepSeq (NFData(..))
import Data.Bool
import Data.Data (Data)
import Data.Decimal (Decimal, DecimalRaw(..), roundTo)
import Data.Eq (Eq(..))
import Data.Function (const, flip)
import Data.Functor (Functor(..), (<$>))
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.TreeMap.Strict (TreeMap)
import Data.Tuple (curry, uncurry)
import Data.Typeable (Typeable)
import Data.Word (Word8)
import Prelude (Integer, Integral, fromIntegral, seq)
import Text.Show (Show(..))
import qualified Data.Foldable as Foldable
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.TreeMap.Strict as TM
import qualified Prelude

-- * Class 'Zeroable'
class Zeroable a where
	zero :: a

instance Zeroable () where
	zero = ()
instance Zeroable Integer where
	zero = 0
instance Zeroable Decimal where
	zero = 0
instance Zeroable (Seq a) where
	zero = Seq.empty
instance Zeroable [a] where
	zero = []
instance Zeroable (Map k a) where
	zero = Map.empty
instance Zeroable (TreeMap k a) where
	zero = TM.empty

-- * Class 'Nullable'
class Zeroable a => Nullable a where
	null :: a -> Bool
	default null :: Eq a => a -> Bool
	null = (== zero)

instance Nullable Integer where
	null = (==) 0
instance Nullable Decimal where
	null = (==) 0
instance Nullable [a] where
	null = L.null
instance Nullable (Seq a) where
	null = Seq.null
instance Nullable a => Nullable (Map k a) where
	null = Foldable.all null
instance Nullable (TreeMap k a) where
	null = TM.null

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

instance Signable Integer
instance Signable Decimal

-- * Class 'Addable'
class Addable a where
	(+) :: a -> a -> a; infixl 6 +
instance Addable () where
	(+) = const
instance Addable Integer where
	(+) = (Prelude.+)
instance Addable Decimal where
	(+) x y =
		Decimal e (fromIntegral (nx Prelude.+ ny))
		where (e, nx, ny) = roundMinDecimal x y
instance Addable [a] where
	(+) = (<>)
instance Addable (Seq a) where
	(+) = (<>)
instance (Ord k, Addable a) => Addable (Map k a) where
	(+) = Map.unionWith (flip (+))
instance (Ord k, Addable a) => Addable (TreeMap k a) where
	(+) = TM.union (+)

-- * Class 'Negable'
class Negable a where
	neg  :: a -> a
instance Negable Integer where
	neg = Prelude.negate
instance Negable Decimal where
	neg = Prelude.negate
instance Negable a => Negable (Map k a) where
	neg = Map.map neg

-- * Class 'Subable'
class Subable a where
	(-) :: a -> a -> a; infixl 6 -
instance Subable Integer where
	(-) = (Prelude.-)
instance Subable Decimal where
	(-) = (Prelude.-)
instance (Ord k, Addable a, Negable a) => Subable (Map k a) where
	(-) x y = Map.unionWith (flip (+)) x (neg y)

-- * Class 'Sumable'
class Sumable s a where
	(+=) :: s -> a -> s; infix 4 +=
	sum :: a -> s
	default sum :: Zeroable s => a -> s
	sum = (zero +=)
instance (Sumable s a, Zeroable s) => Sumable s [a] where
	(+=) = Foldable.foldr (flip (+=))
	sum = (zero +=)
instance (Ord k, Addable a) => Sumable (TreeMap k a) (TM.Path k, a) where
	(+=) = flip (uncurry (TM.insert (flip (+))))
instance (Ord k, Addable a, Sumable (Map k b) (TM.Path k, a)) =>
         Sumable (Map k b) (TreeMap k a) where
	(+=) = TM.foldrWithPath (curry (flip (+=)))

-- * Class 'Polarizable'
class Polarizable a where
	negativeOf :: a -> Maybe a
	positiveOf :: a -> Maybe a
instance Polarizable Integer where
	negativeOf q =
		case q of
		 _ | q < 0 -> Just q
		 _         -> Nothing
	positiveOf q =
		case q of
		 _ | q <= 0 -> Nothing
		 _          -> Just q
instance Polarizable Decimal where
	negativeOf q =
		case q of
		 _ | q < 0 -> Just q
		 _         -> Nothing
	positiveOf q =
		case q of
		 _ | q <= 0 -> Nothing
		 _          -> Just q
instance Polarizable (Polarized a) where
	negativeOf qty =
		case qty of
		 PolNegative _ -> Just qty
		 PolPositive _ -> Nothing
		 PolBoth n _   -> Just (PolNegative n)
	positiveOf qty =
		case qty of
		 PolNegative _ -> Nothing
		 PolPositive _ -> Just qty
		 PolBoth _ p   -> Just (PolPositive p)
instance Polarizable a => Polarizable (Map k a) where
	positiveOf q =
		case Map.mapMaybe positiveOf q of
		 m | Map.null m -> Nothing
		 m -> Just m
	negativeOf q =
		case Map.mapMaybe negativeOf q of
		 m | Map.null m -> Nothing
		 m -> Just m
instance Polarizable a => Polarizable (k, a) where
	positiveOf (u, q) = (u,) <$> positiveOf q
	negativeOf (u, q) = (u,) <$> negativeOf q

-- ** Type 'Polarized'
-- | Polarize a quantity to distinctively keep track
--   of negative and positive ones.
data Polarized a
 =   PolNegative !a
 |   PolPositive !a
 |   PolBoth     !a !a
 deriving (Data, Eq, Functor, Ord, Show, Typeable)
instance NFData a => NFData (Polarized a) where
	rnf (PolNegative n) = rnf n
	rnf (PolPositive p) = rnf p
	rnf (PolBoth n p)   = rnf n `seq` rnf p
instance Zeroable a => Zeroable (Polarized a) where
	zero = PolPositive zero
instance (Nullable a, Addable a) => Nullable (Polarized a) where
	null qty =
		case qty of
		 PolNegative n -> null n
		 PolPositive p -> null p
		 PolBoth n p   -> null (n + p)
instance Addable a => Addable (Polarized a) where
	PolNegative nx + PolNegative ny = PolNegative (nx + ny)
	PolNegative n  + PolPositive p  = PolBoth n p
	PolNegative nx + PolBoth ny p   = PolBoth (nx + ny) p
	
	PolPositive p  + PolNegative n  = PolBoth n p
	PolPositive px + PolPositive py = PolPositive (px + py)
	PolPositive p  + PolBoth ny py  = PolBoth ny (p + py)
	
	PolBoth nx px  + PolNegative n  = PolBoth (nx + n) px
	PolBoth nx px  + PolPositive py = PolBoth nx (px + py)
	PolBoth nx px  + PolBoth ny py  = PolBoth (nx + ny) (px + py)
instance Negable a => Negable (Polarized a) where
	neg (PolNegative n) = PolPositive (neg n)
	neg (PolPositive p) = PolNegative (neg p)
	neg (PolBoth n p)   = PolBoth     (neg p) (neg n)

unNegative :: Polarized a -> Maybe a
unNegative qty =
	case qty of
	 PolNegative n -> Just n
	 PolPositive _ -> Nothing
	 PolBoth n _   -> Just n

unPositive :: Polarized a -> Maybe a
unPositive qty =
	case qty of
	 PolNegative _ -> Nothing
	 PolPositive p -> Just p
	 PolBoth _ p   -> Just p

polarize :: Polarizable a => a -> Polarized a
polarize qty =
	case (negativeOf qty, positiveOf qty) of
	 (Just n, Nothing)  -> PolNegative n
	 (Nothing, Just p)  -> PolPositive p
	 (Just n, Just p)   -> PolBoth n p
	 (Nothing, Nothing) -> PolBoth qty qty
depolarize :: Addable a => Polarized a -> a
depolarize qty =
	case qty of
	 PolNegative n -> n
	 PolPositive p -> p
	 PolBoth n p   -> n + p

-- * Type 'Decimal'

-- Orphan instance
deriving instance Data Decimal

-- | 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