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