lcc/Hcompta/LCC/Journal.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Hcompta.LCC.Journal where
   8
   9 -- import Data.NonNull (NonNull)
  10 -- import Data.Text (Text)
  11 -- import System.IO (IO)
  12 -- import qualified Data.NonNull as NonNull
  13 -- import qualified Data.Text as Text
  14 -- import qualified System.Directory as IO
  15 import Control.DeepSeq (NFData(..))
  16 import Data.Data (Data(..))
  17 import Data.Eq (Eq(..))
  18 import Data.Foldable (Foldable(..))
  19 import Data.Function (($), (.))
  20 import Data.Functor (Functor(..), (<$>))
  21 import Data.Functor.Compose (Compose(..))
  22 import Data.Map.Strict (Map)
  23 import Data.Monoid (Monoid(..))
  24 import Data.Ord (Ord(..))
  25 import Data.String (IsString(..))
  26 import Data.Traversable (Traversable(..))
  27 import Data.TreeMap.Strict (TreeMap)
  28 import Data.Typeable (Typeable)
  29 import Prelude (seq)
  30 import Text.Show (Show(..))
  31 import qualified Data.MonoTraversable as MT
  32 import qualified System.FilePath.Posix as FP
  33
  34 {-
  35 import Data.Tree
  36 import Control.Monad (Monad(..), foldM)
  37 import Data.List (reverse)
  38 import Data.Maybe (Maybe(..))
  39 import qualified Data.Monoid as Monoid
  40 import Data.Semigroup (Semigroup(..))
  41 -}
  42
  43 import qualified Hcompta as H
  44 import Hcompta.LCC.Account
  45 import Hcompta.LCC.Amount
  46 import Hcompta.LCC.Chart
  47 import Hcompta.LCC.Posting
  48 import Hcompta.LCC.Transaction
  49
  50 -- * Type 'PathFile'
  51 newtype PathFile = PathFile FP.FilePath
  52  deriving (Data, Eq, NFData, Ord, Show, Typeable)
  53 instance IsString PathFile where
  54         fromString = PathFile
  55
  56 -- * Type 'CanonFile'
  57 newtype CanonFile = CanonFile PathFile
  58  deriving (Data, Eq, NFData, Ord, Show, Typeable)
  59
  60 -- * Type 'Journal'
  61 data Journal j
  62  =   Journal
  63  {   journal_file           :: !PathFile
  64  ,   journal_last_read_time :: !Date
  65  ,   journal_content        :: !j
  66  ,   journal_includes       :: ![CanonFile]
  67  } deriving (Data, Eq, Show, Typeable)
  68
  69 type instance MT.Element (Journal j) = j
  70 instance Functor Journal where
  71         fmap f j@Journal{journal_content{- DELME: , journal_includes-}} =
  72                 j{ journal_content = f journal_content
  73                  {- DELME: , journal_includes = fmap f <$> journal_includes-}
  74                  }
  75 instance MT.MonoFunctor (Journal j)
  76 instance Foldable Journal where
  77         foldMap f Journal{journal_content{- DELME: , journal_includes-}} =
  78                 f journal_content {- DELME: `mappend`
  79                 (foldMap f `foldMap` journal_includes)-}
  80 instance MT.MonoFoldable (Journal j)
  81 instance Traversable Journal where
  82         traverse f j = (\c -> j{journal_content=c}) <$> f (journal_content j)
  83 instance NFData j => NFData (Journal j) where
  84         rnf Journal{..} =
  85                 rnf journal_file `seq`
  86                 rnf journal_last_read_time `seq`
  87                 rnf journal_content `seq`
  88                 rnf journal_includes
  89
  90 journal :: Monoid j => Journal j
  91 journal =
  92         Journal
  93          { journal_file           = ""
  94          , journal_last_read_time = H.date_epoch
  95          , journal_content        = mempty
  96          , journal_includes       = []
  97          }
  98
  99 {-
 100 instance Semigroup j => Semigroup (Journal j) where
 101         (<>) = journal_union
 102 instance (Monoid j, Semigroup j) => Monoid (Journal j) where
 103         mempty  = journal
 104         mappend = journal_union
 105
 106 journal_union :: Semigroup j => Journal j -> Journal j -> Journal j
 107 journal_union x y =
 108         Journal
 109          { journal_last_read_time = journal_last_read_time x `min` journal_last_read_time y
 110          , journal_content        = journal_content        x <>    journal_content        y
 111          , journal_includes       = journal_includes       x <>    journal_includes       y
 112          }
 113
 114 journal_unions :: (Foldable f, Monoid j, Semigroup j) => f (Journal j) -> Journal j
 115 journal_unions = foldl' (flip (<>)) journal
 116 -}
 117
 118 {-
 119 -- | Return the given accumulator folded over
 120 --   the given 'Journal' and its 'journal_includes' 'Journal's.
 121 journal_fold :: (Journal j -> a -> a) -> Journal j -> a -> a
 122 journal_fold f j@Journal{journal_includes} a =
 123         foldl'
 124          (flip $ journal_fold f) (f j a)
 125          journal_includes
 126
 127 -- | Return the given accumulator folded over
 128 --   the given 'Journal' and its 'journal_includes' 'Journal's.
 129 journal_foldM :: Monad m => (Journal j -> a -> m a) -> Journal j -> a -> m a
 130 journal_foldM f j@Journal{journal_includes} a = do
 131         ma <- f j a
 132         foldM
 133          (flip $ journal_foldM f) ma
 134          journal_includes
 135
 136 -- | Return the given accumulator folded with the given function
 137 --   over the given 'Journal' and its 'journal_includes' 'Journal's.
 138 journal_foldMap :: Monoid a => (Journal j -> a -> a) -> Journal j -> a -> a
 139 journal_foldMap f j@(Journal{journal_includes}) =
 140         f j `mappend` foldMap (journal_foldMap f) journal_includes
 141
 142 -- | Return the first non-'Nothing' value returned by the given function
 143 --   when applied to the given 'Journal' or its 'journal_includes' 'Journal's,
 144 --   with the parent 'Journal's.
 145 journal_find :: (Journal j -> Maybe a) -> Journal j -> Maybe (a, [Journal j])
 146 journal_find f =
 147         (\x -> case x of
 148          Nothing -> Nothing
 149          Just (a, path) -> Just (a, reverse path))
 150         . find_ []
 151         where
 152                 find_ path j =
 153                         case f j of
 154                          Just a -> Just (a, path)
 155                          Nothing ->
 156                                 Monoid.getFirst $
 157                                 foldMap (Monoid.First . (find_ (j:path))) $
 158                                 journal_includes j
 159
 160 -- | Return the given 'Journal' and its 'journal_includes' 'Journal's
 161 --   mapped by the given function.
 162 journal_traverse :: (Journal j -> Journal j) -> Journal j -> Journal j
 163 journal_traverse f =
 164         (\x -> case x of
 165          j@Journal{journal_includes} ->
 166                 j{journal_includes = journal_traverse f <$> journal_includes})
 167         . f
 168
 169 -- | Return the 'Journal' recursively 'mappend'-ed
 170 --   with its 'journal_includes', now empty.
 171 journal_flatten :: (Monoid j, Semigroup j) => Journal j -> Journal j
 172 journal_flatten jnl =
 173         (mconcat $ (:) jnl $ journal_flatten <$>
 174                 journal_includes jnl) { journal_includes = [] }
 175 -}
 176
 177
 178 -- * Type 'Compta'
 179 data Compta
 180  =   Compta
 181  {   compta_chart         :: Chart
 182  ,   compta_journals      :: Journals (Map Date Transaction)
 183  ,   compta_style_amounts :: Style_Amounts
 184  -- ,   compta_code  :: Map Name Text
 185  }
 186
 187 -- * Type 'Journals'
 188 newtype Journals j = Journals (Map CanonFile (Journal j))
 189  deriving (Data, Eq, Show, Typeable)
 190 type instance MT.Element (Journals j) = Journal j
 191
 192 instance MT.MonoFunctor (Journals j) where
 193         omap f (Journals m) = Journals $ f `MT.omap` m
 194 instance MT.MonoFoldable (Journals j) where
 195         ofoldMap f   (Journals m) = MT.ofoldMap f m
 196         ofoldr f a   (Journals m) = MT.ofoldr f a m
 197         ofoldl' f a  (Journals m) = MT.ofoldl' f a m
 198         ofoldr1Ex f  (Journals m) = MT.ofoldr1Ex f m
 199         ofoldl1Ex' f (Journals m) = MT.ofoldl1Ex' f m
 200 instance MT.MonoTraversable (Journals j) where
 201         otraverse f (Journals m) = Journals <$> MT.otraverse f m
 202
 203 instance Functor Journals where
 204         fmap f (Journals m) = Journals $ fmap f <$> m
 205 instance Foldable Journals where
 206         foldMap f (Journals m) = f `foldMap` Compose m
 207 instance Traversable Journals where
 208         traverse f (Journals m) =
 209                 Journals . getCompose <$> (f `traverse` Compose m)
 210
 211
 212
 213
 214 {-
 215 -- ** Type 'JournalFile'
 216 newtype JournalFile = JournalFile PathFile
 217  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 218 unJournalFile :: JournalFile -> PathFile
 219 unJournalFile (JournalFile fp) = fp
 220
 221 -- ** Type 'JournalFileCanon'
 222 newtype JournalFileCanon = JournalFileCanon JournalFile
 223  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 224 unJournalFileCanon :: JournalFileCanon -> JournalFile
 225 unJournalFileCanon (JournalFileCanon jf) = jf
 226
 227 journalFileCanon :: JournalFile -> IO JournalFileCanon
 228 journalFileCanon (JournalFile (PathFile fp)) =
 229         JournalFileCanon . JournalFile . fromString
 230          <$> IO.canonicalizePath fp
 231
 232 newtype Journals j = Journals (Forest (Journal j))
 233  deriving (Data, Eq, Show, Typeable)
 234 type instance MT.Element (Journals j) = Journal j
 235 instance MT.MonoFunctor (Journals j) where
 236         omap f (Journals m) = Journals $ f `MT.omap` m
 237 instance MT.MonoFoldable (Journals j) where
 238         ofoldMap f   (Journals m) = MT.ofoldMap f m
 239         ofoldr f a   (Journals m) = MT.ofoldr f a m
 240         ofoldl' f a  (Journals m) = MT.ofoldl' f a m
 241         ofoldr1Ex f  (Journals m) = MT.ofoldr1Ex f m
 242         ofoldl1Ex' f (Journals m) = MT.ofoldl1Ex' f m
 243 instance MT.MonoTraversable (Journals j) where
 244         otraverse f (Journals m) = Journals <$> MT.otraverse f m
 245
 246
 247 instance Functor Journals where
 248         fmap f (Journals m) = Journals $
 249                 getCompose $ getCompose . fmap f $ Compose (Compose m)
 250 instance Foldable Journals where
 251         foldMap f (Journals m) = foldMap f $ Compose (Compose m)
 252 instance Traversable Journals where
 253         traverse f (Journals m) =
 254                 Journals . getCompose . getCompose
 255                  <$> traverse f (Compose (Compose m))
 256
 257 instance Functor Journals where
 258         fmap f (Journals m) = Journals $ fmap f <$> m
 259 instance Foldable Journals where
 260         foldMap f (Journals m) = f `foldMap` Compose m
 261 instance Traversable Journals where
 262         traverse f (Journals m) =
 263                 Journals . getCompose <$> (f `traverse` Compose m)
 264
 265 journals_flatten :: Journals j -> Journal j
 266 journals_flatten js@(Journals m)
 267         Map.fold
 268         MT.ofoldr1Ex (\j) js
 269 -- | Return the 'Journal' recursively 'mappend'-ed
 270 --   with its 'journal_includes', now empty.
 271 journal_flatten :: (Monoid j, Semigroup j) => Journal j -> Journal j
 272 journal_flatten jnl =
 273         (mconcat $ (:) jnl $ journal_flatten <$>
 274                 journal_includes jnl) { journal_includes = [] }
 275 -}
 276
 277 type instance MT.Element (TreeMap k a) = a
 278 instance Ord k => MT.MonoFunctor     (TreeMap k a)
 279 instance Ord k => MT.MonoFoldable    (TreeMap k a)
 280 instance Ord k => MT.MonoTraversable (TreeMap k a)