src/Literate/Accounting/Flow.hs

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