src/Literate/Accounting/Flow.hs

   1 module Literate.Accounting.Flow where
   2
   3 import Control.DeepSeq (NFData)
   4 import Data.Bool
   5 import Data.Eq (Eq)
   6 import Data.Functor (Functor)
   7 import Data.Maybe (Maybe (..))
   8 import Data.Ord (Ord (..))
   9 import GHC.Generics (Generic)
  10 import Text.Show (Show (..))
  11
  12 import Literate.Accounting.Math
  13 import Literate.Accounting.Rebindable
  14
  15 -- ** Type 'Flow'
  16
  17 {- | A 'Flow keeps track separatly of what goes 'In'
  18  and what goes 'Out' of an account.
  19 -}
  20 data Flow a
  21   = In !a
  22   | Out !a
  23   | Bidir !a !a
  24   deriving (Eq, Show, Generic, NFData, Functor)
  25
  26 instance FromInteger qty => FromInteger (Flow qty) where
  27   fromInteger i
  28     | i <= 0 = Out (fromInteger i)
  29     | otherwise = In (fromInteger i)
  30
  31 flowIn :: Flow a -> Maybe a
  32 flowIn = \case
  33   In i -> Just i
  34   Out _ -> Nothing
  35   Bidir _ i -> Just i
  36
  37 flowOut :: Flow a -> Maybe a
  38 flowOut = \case
  39   In _ -> Nothing
  40   Out o -> Just o
  41   Bidir o _ -> Just o
  42
  43 flow :: Flowable a => a -> Flow a
  44 flow f =
  45   case (outOf f, inOf f) of
  46     (Just o, Nothing) -> Out o
  47     (Nothing, Just i) -> In i
  48     (Just o, Just i) -> Bidir o i
  49     (Nothing, Nothing) -> Bidir f f
  50 unFlow :: Addable a => Flow a -> a
  51 unFlow = \case
  52   In i -> i
  53   Out o -> o
  54   Bidir o i -> o + i
  55
  56 instance Zeroable a => Zeroable (Flow a) where
  57   zero = In zero
  58 instance (Nullable a, Addable a) => Nullable (Flow a) where
  59   null = \case
  60     Out o -> null o
  61     In i -> null i
  62     Bidir o i -> null (o + i)
  63 instance Addable a => Addable (Flow a) where
  64   In i + Out o = Bidir o i
  65   In ix + In py = In (ix + py)
  66   In i + Bidir ny py = Bidir ny (i + py)
  67   Out ox + Out ny = Out (ox + ny)
  68   Out o + In i = Bidir o i
  69   Out ox + Bidir ny i = Bidir (ox + ny) i
  70   Bidir ox ix + Out o = Bidir (ox + o) ix
  71   Bidir ox ix + In py = Bidir ox (ix + py)
  72   Bidir ox ix + Bidir ny py = Bidir (ox + ny) (ix + py)
  73 instance Negable a => Negable (Flow a) where
  74   negate = \case
  75     In i -> Out (negate i)
  76     Out o -> In (negate o)
  77     Bidir o i -> Bidir (negate i) (negate o)
  78 instance Flowable (Flow a) where
  79   outOf f = case f of
  80     In _ -> Nothing
  81     Out _ -> Just f
  82     Bidir n _ -> Just (Out n)
  83   inOf f = case f of
  84     In _ -> Just f
  85     Out _ -> Nothing
  86     Bidir _ p -> Just (In p)
  87
  88 --instance Eq
  89
  90 -- * Class 'Flowable'
  91 class Flowable a where
  92   outOf :: a -> Maybe a
  93   inOf :: a -> Maybe a
  94
  95 {-
  96 instance Flowable Decimal where
  97   outOf q =
  98     case q of
  99      _ | q < 0 -> Just q
 100      _         -> Nothing
 101   inOf q =
 102     case q of
 103      _ | q <= 0 -> Nothing
 104      _          -> Just q
 105 instance Flowable a => Flowable (Map k a) where
 106   inOf q =
 107     case Map.mapMaybe inOf q of
 108      m | Map.null m -> Nothing
 109      m -> Just m
 110   outOf q =
 111     case Map.mapMaybe outOf q of
 112      m | Map.null m -> Nothing
 113      m -> Just m
 114 instance Flowable a => Flowable (k, a) where
 115   inOf (u, q) = (u,) <$> inOf q
 116   outOf (u, q) = (u,) <$> outOf q
 117 -}