{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}
module Hcompta.Polarize where

import           Control.DeepSeq
import           Data.Data (Data)
import           Data.Decimal (Decimal)
import           Data.Eq (Eq)
import           Data.Ord (Ord(..))
import           Data.Functor (Functor, (<$>))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..))
import           Data.Typeable
import           Prelude (Integer, seq)
import           Text.Show (Show)

import           Hcompta.Quantity

-- * Type 'Polarized'

-- | Polarize a 'Quantity' to distinctively keep track
--   of negative and positive 'Quantity's.
data Polarized q
 =   Polarized_Negative !q
 |   Polarized_Positive !q
 |   Polarized_Both     !q !q
 deriving (Data, Eq, Functor, Show, Typeable)
instance -- NFData
    NFData q
 => NFData (Polarized q) where
	rnf (Polarized_Negative n) = rnf n
	rnf (Polarized_Positive p) = rnf p
	rnf (Polarized_Both n p)   = rnf n `seq` rnf p
instance -- Zero
 ( Zero    q
 , Addable q
 ) => Zero (Polarized q) where
	quantity_zero = Polarized_Positive quantity_zero
	quantity_null qty =
		case qty of
		 Polarized_Negative n -> quantity_null n
		 Polarized_Positive p -> quantity_null p
		 Polarized_Both n p   -> quantity_null (quantity_add n p)
instance -- Addable
    Addable q
 => Addable (Polarized q) where
	quantity_add a0 a1 =
		case (a0, a1) of
		 (Polarized_Negative n0, Polarized_Negative n1) -> Polarized_Negative (quantity_add n0 n1)
		 (Polarized_Negative n , Polarized_Positive p)  -> Polarized_Both n p
		 (Polarized_Negative n0, Polarized_Both n1 p)   -> Polarized_Both (quantity_add n0 n1) p
		
		 (Polarized_Positive p , Polarized_Negative n)  -> Polarized_Both n p
		 (Polarized_Positive p0, Polarized_Positive p1) -> Polarized_Positive (quantity_add p0 p1)
		 (Polarized_Positive p , Polarized_Both n1 p1)  -> Polarized_Both n1 (quantity_add p p1)
		
		 (Polarized_Both n0 p0, Polarized_Negative n)  -> Polarized_Both (quantity_add n0 n) p0
		 (Polarized_Both n0 p0, Polarized_Positive p1) -> Polarized_Both n0 (quantity_add p0 p1)
		 (Polarized_Both n0 p0, Polarized_Both n1 p1)  -> Polarized_Both (quantity_add n0 n1) (quantity_add p0 p1)
instance -- Negable
    Negable q
 => Negable (Polarized q) where
	quantity_neg qty =
		case qty of
		 Polarized_Negative n -> Polarized_Positive (quantity_neg n)
		 Polarized_Positive p -> Polarized_Negative (quantity_neg p)
		 Polarized_Both n p   -> Polarized_Both     (quantity_neg p) (quantity_neg n)

polarized_negative :: Polarized q -> Maybe q
polarized_negative qty =
	case qty of
	 Polarized_Negative n -> Just n
	 Polarized_Positive _ -> Nothing
	 Polarized_Both n _   -> Just n
polarized_positive :: Polarized q -> Maybe q
polarized_positive qty =
	case qty of
	 Polarized_Negative _ -> Nothing
	 Polarized_Positive p -> Just p
	 Polarized_Both _ p   -> Just p

-- * Class 'Polarizable'

class Polarizable q where
	polarizable_negative :: q -> Maybe q
	polarizable_positive :: q -> Maybe q
instance Polarizable Integer where
	polarizable_negative q =
		case q of
		 _ | q < 0 -> Just q
		 _         -> Nothing
	polarizable_positive q =
		case q of
		 _ | q <= 0 -> Nothing
		 _          -> Just q
instance Polarizable Decimal where
	polarizable_negative q =
		case q of
		 _ | q < 0 -> Just q
		 _         -> Nothing
	polarizable_positive q =
		case q of
		 _ | q <= 0 -> Nothing
		 _          -> Just q
instance -- Polarized
    Polarizable q
 => Polarizable (Polarized q) where
	polarizable_negative qty =
		case qty of
		 Polarized_Negative _ -> Just qty
		 Polarized_Positive _ -> Nothing
		 Polarized_Both n _   -> Just (Polarized_Negative n)
	polarizable_positive qty =
		case qty of
		 Polarized_Negative _ -> Nothing
		 Polarized_Positive _ -> Just qty
		 Polarized_Both _ p   -> Just (Polarized_Positive p)
instance -- Map unit quantity
 ( Polarizable quantity
 , Data        unit
 , Ord         unit
 , Show        unit
 ) => Polarizable (Map unit quantity) where
	polarizable_positive q =
		case Map.mapMaybe polarizable_positive q of
		 m | Map.null m -> Nothing
		 m -> Just m
	polarizable_negative q =
		case Map.mapMaybe polarizable_negative q of
		 m | Map.null m -> Nothing
		 m -> Just m
instance -- (unit, quantity)
 ( Polarizable quantity
 ) => Polarizable (unit, quantity) where
	polarizable_positive (u, q) = (u,) <$> polarizable_positive q
	polarizable_negative (u, q) = (u,) <$> polarizable_negative q

polarize
 :: Polarizable q
 => q -> Polarized q
polarize qty =
	case ( polarizable_negative qty
	     , polarizable_positive qty ) of
	 (Just n, Nothing)  -> Polarized_Negative n
	 (Nothing, Just p)  -> Polarized_Positive p
	 (Just n, Just p)   -> Polarized_Both n p
	 (Nothing, Nothing) -> Polarized_Both qty qty
depolarize
 :: Addable q
 => Polarized q -> q
depolarize qty =
	case qty of
	 Polarized_Negative n -> n
	 Polarized_Positive p -> p
	 Polarized_Both n p   -> quantity_add n p