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