cli/Hcompta/CLI/Format.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE ExistentialQuantification #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE NamedFieldPuns #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE Rank2Types #-}
   9 {-# LANGUAGE ScopedTypeVariables #-}
  10 {-# LANGUAGE TypeFamilies #-}
  11 module Hcompta.CLI.Format where
  12
  13 import           Control.Monad.Trans.Except (runExceptT)
  14 import           Data.Either (Either(..))
  15 import           Data.Function (($), (.))
  16 import           Data.Functor (Functor, (<$>))
  17 import           Data.Monoid (Monoid(..))
  18 import           System.IO (FilePath, IO)
  19 import           Text.Show (Show)
  20 import qualified Text.Parsec.Error.Custom as R
  21
  22 import qualified Hcompta.CLI.Lang as Lang
  23 import qualified Text.WalderLeijen.ANSI.Text as W
  24
  25 import qualified Hcompta.JCC as JCC
  26 import qualified Hcompta.Ledger as Ledger
  27
  28 import           Hcompta.Lib.Consable (Consable)
  29 import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
  30
  31 import Hcompta.CLI.Convert
  32
  33 -- * Type 'Format'
  34
  35 data Format jcc ledger
  36  =   Format_JCC    jcc
  37  |   Format_Ledger ledger
  38  deriving (Show)
  39 type Formats = Format () ()
  40
  41 instance
  42  ( Convert jcc ledger
  43  , Convert ledger jcc
  44  , Monoid jcc
  45  , Monoid ledger
  46  ) => Monoid (Format jcc ledger) where
  47         mempty = Format_JCC mempty
  48         mappend x y =
  49                 case x of
  50                  Format_JCC xj ->
  51                         Format_JCC $
  52                         case y of
  53                          Format_JCC    yj -> mappend xj yj
  54                          Format_Ledger yj -> mappend xj (convert yj)
  55                  Format_Ledger xj ->
  56                         Format_Ledger $
  57                         case y of
  58                          Format_JCC    yj -> mappend xj (convert yj)
  59                          Format_Ledger yj -> mappend xj yj
  60
  61 format :: Formats
  62 format = Format_JCC ()
  63
  64 -- * Type family 'Journal_Account'
  65 type family   Journal_Account (j:: * -> *)
  66 type instance Journal_Account    JCC.Journal =    JCC.Account
  67 type instance Journal_Account Ledger.Journal = Ledger.Account
  68
  69 -- * Type family 'Journal_Account_Section'
  70 type family   Journal_Account_Section (j:: * -> *)
  71 type instance Journal_Account_Section    JCC.Journal =    JCC.Account_Section
  72 type instance Journal_Account_Section Ledger.Journal = Ledger.Account_Section
  73
  74 -- * Type family 'Journal_Charted'
  75 type family   Journal_Charted (j:: * -> *) :: * -> *
  76 type instance Journal_Charted    JCC.Journal =    JCC.Charted
  77 type instance Journal_Charted Ledger.Journal = Ledger.Charted
  78
  79 -- * Type family 'Journal_Quantity'
  80 type family   Journal_Quantity (j:: * -> *)
  81 type instance Journal_Quantity    JCC.Journal =    JCC.Quantity
  82 type instance Journal_Quantity Ledger.Journal = Ledger.Quantity
  83
  84 -- * Type family 'Journal_Unit'
  85 type family   Journal_Unit (j:: * -> *)
  86 type instance Journal_Unit    JCC.Journal =    JCC.Unit
  87 type instance Journal_Unit Ledger.Journal = Ledger.Unit
  88
  89 -- * Type family 'Journal_Posting'
  90 type family   Journal_Posting (j:: * -> *)
  91 type instance Journal_Posting    JCC.Journal =    JCC.Posting
  92 type instance Journal_Posting Ledger.Journal = Ledger.Posting
  93
  94 -- * Type family 'Journal_Transaction'
  95 type family   Journal_Transaction (j:: * -> *)
  96 type instance Journal_Transaction    JCC.Journal =    JCC.Transaction
  97 type instance Journal_Transaction Ledger.Journal = Ledger.Transaction
  98
  99 -- * Class 'Journal'
 100
 101 class Journal j where
 102         type Journal_Format j
 103         journal_format
 104          :: j -> Journal_Format j
 105
 106 -- * Class 'Journal_Empty'
 107
 108 class Journal_Empty j where
 109         journal_empty :: Formats -> j
 110
 111 -- * Class 'Journal_Files'
 112
 113 class Journal_Files j where
 114         journal_files :: forall m. j m -> [FilePath]
 115 instance Journal_Files JCC.Journal where
 116         journal_files = JCC.journal_files
 117 instance Journal_Files Ledger.Journal where
 118         journal_files = Ledger.journal_files
 119
 120 -- * Class 'Journal_Read'
 121
 122 class Journal_Read (j:: * -> *) where
 123         type Journal_Read_Error       j
 124         type Journal_Read_Transaction j
 125         journal_read
 126          :: forall c m. (Monoid m, Consable c m)
 127          => (Journal_Read_Transaction j -> c)
 128          -> FilePath
 129          -> IO (Either (Journal_Read_Error j) (j m))
 130 instance Journal_Read JCC.Journal where
 131         type Journal_Read_Error JCC.Journal
 132          = [R.Error JCC.Error_Read]
 133         type Journal_Read_Transaction JCC.Journal
 134          = JCC.Charted JCC.Transaction
 135         journal_read cons =
 136                 runExceptT . JCC.read_file
 137                  (JCC.context_read cons JCC.journal)
 138 instance Journal_Read Ledger.Journal where
 139         type Journal_Read_Error Ledger.Journal
 140          = [R.Error Ledger.Error_Read]
 141         type Journal_Read_Transaction Ledger.Journal
 142          = Ledger.Charted Ledger.Transaction
 143         journal_read cons =
 144                 runExceptT . Ledger.read_file
 145                  (Ledger.context_read cons Ledger.journal)
 146
 147 {-
 148 -- * Class 'Journal_Chart'
 149
 150 class Journal_Chart (j:: * -> *) where
 151         journal_chart
 152          :: forall m. j m
 153          -> Chart.Chart (NonEmpty (Journal_Account_Section j))
 154 instance Journal_Chart JCC.Journal where
 155         journal_chart = JCC.journal_chart
 156 instance Journal_Chart Ledger.Journal where
 157         journal_chart = Ledger.journal_chart
 158 -}
 159
 160 -- * Class 'Journal_Monoid'
 161
 162 class Journal_Monoid j where
 163         journal_flatten :: j -> j
 164         journal_fold    :: (j -> a -> a) -> j -> a -> a
 165 instance Monoid m => Journal_Monoid (JCC.Journal m) where
 166         journal_flatten = JCC.journal_flatten
 167         journal_fold    = JCC.journal_fold
 168 instance Monoid m => Journal_Monoid (Ledger.Journal m) where
 169         journal_flatten = Ledger.journal_flatten
 170         journal_fold    = Ledger.journal_fold
 171
 172 -- * Class 'Journal_Filter'
 173
 174 class Functor j => Journal_Filter context j m where
 175         journal_filter
 176          :: context -> j m -> j m
 177
 178 -- * Class 'Journal_Functor'
 179
 180 class Journal_Functor x y where
 181         journal_functor_map :: x -> y
 182         journal_fmap :: forall j. Functor j => j x -> j y
 183         journal_fmap = (journal_functor_map <$>)
 184
 185 -- * Class 'Journal_Table'
 186
 187 -- | A class to render a journal
 188 --   into 'Leijen.Table.Cell's.
 189 class Journal_Leijen_Table_Cells j m where
 190         journal_leijen_table_cells
 191          :: j m
 192          -> [[Leijen.Table.Cell]]
 193          -> [[Leijen.Table.Cell]]
 194
 195
 196 -- * Class 'Journal_Wrap'
 197
 198 -- | A class dedicated to transform a journal
 199 --   to another one using existential quantification
 200 --   to gather multiple journals under a single type,
 201 --   by writing instances between fully monomorphic types,
 202 --   which ease a lot meeting the requirements
 203 --   of the constraints in the wrap type.
 204 class Journal_Wrap j wrap where
 205         journal_wrap :: j -> wrap
 206
 207 class Journal_Content j where
 208         journal_content :: forall m. j m -> m
 209 instance Journal_Content JCC.Journal where
 210         journal_content = JCC.journal_content
 211 instance Journal_Content Ledger.Journal where
 212         journal_content = Ledger.journal_content
 213
 214 -- * Type 'Message'
 215
 216 -- data Journal jnl m = forall j. jnl j => Journal (j m)
 217 data Message w = forall msg. Lang.Translate msg w => Message msg
 218 instance Lang.Translate (Message W.Doc) W.Doc where
 219         translate lang (Message x) = Lang.translate lang x