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 -- * Type 'Journals'
 178 newtype Journals j = Journals (Map CanonFile (Journal j))
 179  deriving (Data, Eq, Show, Typeable)
 180 type instance MT.Element (Journals j) = Journal j
 181
 182 instance MT.MonoFunctor (Journals j) where
 183         omap f (Journals m) = Journals $ f `MT.omap` m
 184 instance MT.MonoFoldable (Journals j) where
 185         ofoldMap f   (Journals m) = MT.ofoldMap f m
 186         ofoldr f a   (Journals m) = MT.ofoldr f a m
 187         ofoldl' f a  (Journals m) = MT.ofoldl' f a m
 188         ofoldr1Ex f  (Journals m) = MT.ofoldr1Ex f m
 189         ofoldl1Ex' f (Journals m) = MT.ofoldl1Ex' f m
 190 instance MT.MonoTraversable (Journals j) where
 191         otraverse f (Journals m) = Journals <$> MT.otraverse f m
 192
 193 instance Functor Journals where
 194         fmap f (Journals m) = Journals $ fmap f <$> m
 195 instance Foldable Journals where
 196         foldMap f (Journals m) = f `foldMap` Compose m
 197 instance Traversable Journals where
 198         traverse f (Journals m) =
 199                 Journals . getCompose <$> (f `traverse` Compose m)
 200
 201
 202
 203
 204 {-
 205 -- ** Type 'JournalFile'
 206 newtype JournalFile = JournalFile PathFile
 207  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 208 unJournalFile :: JournalFile -> PathFile
 209 unJournalFile (JournalFile fp) = fp
 210
 211 -- ** Type 'JournalFileCanon'
 212 newtype JournalFileCanon = JournalFileCanon JournalFile
 213  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 214 unJournalFileCanon :: JournalFileCanon -> JournalFile
 215 unJournalFileCanon (JournalFileCanon jf) = jf
 216
 217 journalFileCanon :: JournalFile -> IO JournalFileCanon
 218 journalFileCanon (JournalFile (PathFile fp)) =
 219         JournalFileCanon . JournalFile . fromString
 220          <$> IO.canonicalizePath fp
 221
 222 newtype Journals j = Journals (Forest (Journal j))
 223  deriving (Data, Eq, Show, Typeable)
 224 type instance MT.Element (Journals j) = Journal j
 225 instance MT.MonoFunctor (Journals j) where
 226         omap f (Journals m) = Journals $ f `MT.omap` m
 227 instance MT.MonoFoldable (Journals j) where
 228         ofoldMap f   (Journals m) = MT.ofoldMap f m
 229         ofoldr f a   (Journals m) = MT.ofoldr f a m
 230         ofoldl' f a  (Journals m) = MT.ofoldl' f a m
 231         ofoldr1Ex f  (Journals m) = MT.ofoldr1Ex f m
 232         ofoldl1Ex' f (Journals m) = MT.ofoldl1Ex' f m
 233 instance MT.MonoTraversable (Journals j) where
 234         otraverse f (Journals m) = Journals <$> MT.otraverse f m
 235
 236
 237 instance Functor Journals where
 238         fmap f (Journals m) = Journals $
 239                 getCompose $ getCompose . fmap f $ Compose (Compose m)
 240 instance Foldable Journals where
 241         foldMap f (Journals m) = foldMap f $ Compose (Compose m)
 242 instance Traversable Journals where
 243         traverse f (Journals m) =
 244                 Journals . getCompose . getCompose
 245                  <$> traverse f (Compose (Compose m))
 246
 247 instance Functor Journals where
 248         fmap f (Journals m) = Journals $ fmap f <$> m
 249 instance Foldable Journals where
 250         foldMap f (Journals m) = f `foldMap` Compose m
 251 instance Traversable Journals where
 252         traverse f (Journals m) =
 253                 Journals . getCompose <$> (f `traverse` Compose m)
 254
 255 journals_flatten :: Journals j -> Journal j
 256 journals_flatten js@(Journals m)
 257         Map.fold
 258         MT.ofoldr1Ex (\j) js
 259 -- | Return the 'Journal' recursively 'mappend'-ed
 260 --   with its 'journal_includes', now empty.
 261 journal_flatten :: (Monoid j, Semigroup j) => Journal j -> Journal j
 262 journal_flatten jnl =
 263         (mconcat $ (:) jnl $ journal_flatten <$>
 264                 journal_includes jnl) { journal_includes = [] }
 265 -}
 266
 267 type instance MT.Element (TreeMap k a) = a
 268 instance Ord k => MT.MonoFunctor     (TreeMap k a)
 269 instance Ord k => MT.MonoFoldable    (TreeMap k a)
 270 instance Ord k => MT.MonoTraversable (TreeMap k a)