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