{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.Quantity where

import           Data.Bool
import           Data.Data (Data)
import           Data.Decimal (Decimal, DecimalRaw(..), roundTo)
import           Data.Eq (Eq(..))
import qualified Data.Foldable as Foldable
import           Data.Function (flip)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Ord (Ord(..), Ordering(..))
import           Data.Proxy (Proxy(..))
import           Data.Word (Word8)
import           Prelude (Integer, Integral, Num(..), fromIntegral)

-- * Class 'Quantity'
class Zero q => Quantity q
instance Quantity Integer
instance Quantity Decimal
instance Quantity qty => Quantity (Map unit qty)

_Quantity :: Proxy Quantity
_Quantity = Proxy

-- * Class 'Zero'
class Zero q where
	quantity_zero :: q
	quantity_null :: q -> Bool
	default quantity_null :: Eq q => q -> Bool
	quantity_null = (== quantity_zero)
	quantity_sign :: Ord q => q -> Ordering
	default quantity_sign :: Ord q => q -> Ordering
	quantity_sign q =
		case () of
		 _ | quantity_null q -> EQ
		 _ | q < quantity_zero -> LT
		 _ -> GT

instance Zero Integer where
	quantity_zero = 0
	quantity_null = (==) 0
instance Zero Decimal where
	quantity_zero = 0
	quantity_null = (==) 0
instance -- Map unit qty
 Quantity qty => Zero (Map unit qty) where
	quantity_zero = Map.empty
	quantity_null = Foldable.all quantity_null

-- * Class 'Addable'
class Addable q where
	quantity_add :: q -> q -> q
instance Addable Integer where
	quantity_add = (+)
instance Addable Decimal where
	quantity_add d1 d2 =
		Decimal e (fromIntegral (n1 + n2))
		where (e, n1, n2) = decimal_round_min d1 d2
instance -- Map unit qty
 (Ord unit, Addable qty) => Addable (Map unit qty) where
	quantity_add = Map.unionWith (flip quantity_add)

-- * Class 'Negable'
class Negable q where
	quantity_neg  :: q -> q
instance Negable Integer where
	quantity_neg = negate
instance Negable Decimal where
	quantity_neg = negate
instance -- Map unit qty
 Negable qty => Negable (Map unit qty) where
	quantity_neg = Map.map quantity_neg

-- * Class 'Subable'
class Subable q where
	quantity_sub :: q -> q -> q
instance Subable Integer where
	quantity_sub = (-)
instance Subable Decimal where
	quantity_sub = (-)
instance -- Map unit qty
 ( Ord unit
 , Addable qty
 , Negable qty
 ) => Subable (Map unit qty) where
	quantity_sub x y =
		Map.unionWith (flip quantity_add) x (quantity_neg y)

-- * Type 'Decimal' (with orphan Data instance)

-- Orphan instance
deriving instance Data Decimal

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