cli/Hcompta/CLI/Convert.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 RecordWildCards #-}
  10 {-# LANGUAGE ScopedTypeVariables #-}
  11 {-# LANGUAGE TypeFamilies #-}
  12 module Hcompta.CLI.Convert where
  13
  14 import           Control.Applicative (Const(..))
  15 import           Data.Bool (Bool(..), not)
  16 import qualified Data.Char as Char
  17 import           Data.Decimal (Decimal)
  18 import           Data.Function (($), (.), id)
  19 import           Data.Functor (Functor(..), (<$>))
  20 import qualified Data.List as List
  21 import           Data.List.NonEmpty (NonEmpty(..))
  22 import           Data.Map.Strict (Map)
  23 import qualified Data.Map.Strict as Map
  24 import           Data.Maybe (Maybe(..))
  25 import           Data.Monoid (Monoid(..))
  26 import           Data.Ord (Ord(..))
  27 import           Data.Sequence (Seq)
  28 import           Data.Text (Text)
  29 import qualified Data.Text as Text
  30 import           Data.TreeMap.Strict (TreeMap)
  31 import qualified Data.TreeMap.Strict as TreeMap
  32
  33 import qualified Hcompta as H
  34 import qualified Hcompta.JCC as JCC
  35 import qualified Hcompta.Ledger as Ledger
  36
  37 import qualified Hcompta.Lib.Strict as Strict
  38
  39 -- * Class 'Convert'
  40
  41 -- | Generic class dedicated to transform any type
  42 --   into another one encoding more or less
  43 --   the same data.
  44 class Convert from to where
  45         convert :: from -> to
  46
  47 instance Convert () () where
  48         convert = id
  49
  50 -- Journal
  51 instance
  52  ( Convert ledger jcc
  53  , Monoid jcc
  54  , Monoid ledger
  55  )
  56  => Convert (Ledger.Journal ledger) (JCC.Journal jcc) where
  57         convert Ledger.Journal{..} =
  58                 JCC.Journal
  59                  { JCC.journal_amount_styles = convert journal_amount_styles
  60                  , JCC.journal_chart = convert journal_chart
  61                  , JCC.journal_files
  62                  , JCC.journal_includes = convert <$> journal_includes
  63                  , JCC.journal_last_read_time
  64                  , JCC.journal_content = convert journal_content
  65                  }
  66 instance
  67  ( Convert jcc ledger
  68  , Monoid jcc
  69  , Monoid ledger
  70  )
  71  => Convert (JCC.Journal jcc) (Ledger.Journal ledger) where
  72         convert JCC.Journal{..} =
  73                 Ledger.Journal
  74                  { Ledger.journal_amount_styles = convert journal_amount_styles
  75                  , Ledger.journal_chart = convert journal_chart
  76                  , Ledger.journal_files
  77                  , Ledger.journal_includes = convert <$> journal_includes
  78                  , Ledger.journal_last_read_time
  79                  , Ledger.journal_content = convert journal_content
  80                  }
  81 instance Convert ledger jcc
  82  => Convert
  83  (H.Journal ledger)
  84  (H.Journal jcc)
  85  where
  86         convert (H.Journal j) =
  87                 H.Journal $
  88                 convert <$>
  89                 Map.mapKeysMonotonic convert j
  90
  91 -- Unit
  92 instance Convert Ledger.Unit JCC.Unit where
  93         convert (Ledger.Unit u) =
  94                 JCC.Unit $
  95                 Text.map
  96                  (\c -> case Char.generalCategory c of
  97                         Char.CurrencySymbol  -> c
  98                         Char.LowercaseLetter -> c
  99                         Char.ModifierLetter  -> c
 100                         Char.OtherLetter     -> c
 101                         Char.TitlecaseLetter -> c
 102                         Char.UppercaseLetter -> c
 103                         _ -> '_') u
 104 instance Convert JCC.Unit Ledger.Unit where
 105         convert (JCC.Unit u) =
 106                 Ledger.Unit u
 107
 108 -- Account
 109 instance Convert H.Account_Anchor H.Account_Anchor where
 110         convert = id
 111 instance Convert H.Account_Tags H.Account_Tags where
 112         convert = id
 113
 114 -- Amount Style
 115 instance Convert Ledger.Amount_Styles JCC.Amount_Styles where
 116         convert (Ledger.Amount_Styles sty) =
 117                 JCC.Amount_Styles $ convert sty
 118 instance Convert JCC.Amount_Styles Ledger.Amount_Styles where
 119         convert (JCC.Amount_Styles sty) =
 120                 Ledger.Amount_Styles $ convert sty
 121 instance Convert Ledger.Amount_Style JCC.Amount_Style where
 122         convert Ledger.Amount_Style{..} =
 123                 JCC.Amount_Style
 124                  { JCC.amount_style_fractioning
 125                  , JCC.amount_style_grouping_integral =
 126                         (<$> amount_style_grouping_integral) $
 127                          \(Ledger.Amount_Style_Grouping c l) ->
 128                                 JCC.Amount_Style_Grouping c l
 129                  , JCC.amount_style_grouping_fractional =
 130                         (<$> amount_style_grouping_fractional) $
 131                          \(Ledger.Amount_Style_Grouping c l) ->
 132                                 JCC.Amount_Style_Grouping c l
 133                  , JCC.amount_style_unit_side =
 134                         (<$> amount_style_unit_side) $ \s ->
 135                                 case s of
 136                                  Ledger.Amount_Style_Side_Left  -> JCC.Amount_Style_Side_Left
 137                                  Ledger.Amount_Style_Side_Right -> JCC.Amount_Style_Side_Right
 138                  , JCC.amount_style_unit_spaced
 139                  }
 140 instance Convert JCC.Amount_Style Ledger.Amount_Style where
 141         convert JCC.Amount_Style{..} =
 142                 Ledger.Amount_Style
 143                  { Ledger.amount_style_fractioning
 144                  , Ledger.amount_style_grouping_integral =
 145                         (<$> amount_style_grouping_integral) $
 146                          \(JCC.Amount_Style_Grouping c l) ->
 147                                 Ledger.Amount_Style_Grouping c l
 148                  , Ledger.amount_style_grouping_fractional =
 149                         (<$> amount_style_grouping_fractional) $
 150                          \(JCC.Amount_Style_Grouping c l) ->
 151                                 Ledger.Amount_Style_Grouping c l
 152                  , Ledger.amount_style_unit_side =
 153                         (<$> amount_style_unit_side) $ \s ->
 154                                 case s of
 155                                  JCC.Amount_Style_Side_Left  -> Ledger.Amount_Style_Side_Left
 156                                  JCC.Amount_Style_Side_Right -> Ledger.Amount_Style_Side_Right
 157                  , Ledger.amount_style_unit_spaced
 158                  }
 159
 160 -- Transaction
 161 instance Convert Ledger.Transaction JCC.Transaction where
 162         convert Ledger.Transaction{..} =
 163                 JCC.Transaction
 164                  { JCC.transaction_anchors = mempty
 165                  , JCC.transaction_comments =
 166                         List.filter (not . Text.all Char.isSpace) $
 167                         Ledger.comments_without_tags $
 168                                 mappend
 169                                  transaction_comments_before
 170                                  transaction_comments_after
 171                  , JCC.transaction_dates
 172                  , JCC.transaction_postings = (convert <$>) <$> transaction_postings
 173                  , JCC.transaction_sourcepos
 174                  , JCC.transaction_tags =
 175                         (case transaction_code of
 176                          t | Text.null t -> id
 177                          t -> H.transaction_tag_cons (H.transaction_tag ("Code":|[]) t)
 178                         ) $
 179                         if transaction_status
 180                          then H.transaction_tag_cons
 181                                  (H.transaction_tag ("Status":|[]) "")
 182                                  transaction_tags
 183                          else transaction_tags
 184                  , JCC.transaction_wording
 185                  }
 186 instance Convert JCC.Transaction Ledger.Transaction where
 187         convert JCC.Transaction{..} =
 188                 let H.Transaction_Tags (H.Tags tags) = transaction_tags in
 189                 Ledger.Transaction
 190                  { Ledger.transaction_code = mconcat $ Map.findWithDefault [""] ("Code":|[]) tags
 191                  , Ledger.transaction_comments_after = mempty
 192                  , Ledger.transaction_comments_before = transaction_comments
 193                  , Ledger.transaction_dates
 194                  , Ledger.transaction_postings = (convert <$>) <$> transaction_postings
 195                  , Ledger.transaction_sourcepos
 196                  , Ledger.transaction_status =
 197                         case Map.lookup ("Status":|[]) tags of
 198                          Nothing -> False
 199                          Just _ -> True
 200                  , Ledger.transaction_tags =
 201                         H.Transaction_Tags $ H.Tags $
 202                         Map.delete ("Code":|[]) $
 203                         Map.delete ("Status":|[]) $
 204                         tags
 205                  , Ledger.transaction_wording
 206                  }
 207
 208 -- Posting
 209 instance Convert Ledger.Posting JCC.Posting where
 210         convert Ledger.Posting{..} =
 211                 JCC.Posting
 212                  { JCC.posting_account
 213                  , JCC.posting_account_anchor = Nothing
 214                  , JCC.posting_amounts =
 215                         convert <$>
 216                         Map.mapKeysMonotonic convert posting_amounts
 217                  , JCC.posting_anchors = mempty
 218                  , JCC.posting_comments =
 219                         List.filter (not . Text.all Char.isSpace) $
 220                         Ledger.comments_without_tags posting_comments
 221                  , JCC.posting_dates
 222                  , JCC.posting_sourcepos
 223                  , JCC.posting_tags =
 224                         if posting_status
 225                          then H.posting_tag_cons
 226                                  (H.Posting_Tag $ H.tag ("Status":|[]) "")
 227                                  posting_tags
 228                          else posting_tags
 229                  }
 230 instance Convert JCC.Posting Ledger.Posting where
 231         convert JCC.Posting{..} =
 232                 let H.Posting_Tags (H.Tags tags) = posting_tags in
 233                 Ledger.Posting
 234                  { Ledger.posting_account
 235                  , Ledger.posting_amounts =
 236                         convert <$>
 237                         Map.mapKeysMonotonic convert posting_amounts
 238                  , Ledger.posting_comments
 239                  , Ledger.posting_dates
 240                  , Ledger.posting_status =
 241                         case Map.lookup ("Status":|[]) tags of
 242                          Nothing -> False
 243                          Just _ -> True
 244                  , Ledger.posting_sourcepos
 245                  , Ledger.posting_tags =
 246                         H.Posting_Tags $ H.Tags $
 247                         Map.delete ("Status":|[]) $
 248                         tags
 249                  }
 250
 251 -- Chart
 252 instance Convert JCC.Chart Ledger.Chart where
 253         convert JCC.Chart{..} =
 254                 Ledger.Chart
 255                  { Ledger.chart_accounts = chart_accounts
 256                  }
 257 instance Convert Ledger.Chart JCC.Chart where
 258         convert Ledger.Chart{..} =
 259                 JCC.Chart
 260                  { JCC.chart_accounts = chart_accounts
 261                  , JCC.chart_anchors  = mempty
 262                  }
 263 {-
 264 instance Convert (Chart.Chart x) (Chart.Chart x) where
 265         convert = id
 266 instance
 267  ( Convert (Chart.Chart a0) (Chart.Chart a1)
 268  , Convert x y
 269  ) => Convert (Chart.Charted a0 x) (Chart.Charted a1 y) where
 270         convert (Chart.Charted a x) =
 271                 Chart.Charted (convert a) (convert x)
 272 -}
 273 {-
 274 instance Convert (Chart.Chart JCC.Account) (Chart.Chart Ledger.Account) where
 275         convert Chart.Chart
 276          { Chart.chart_accounts
 277          , Chart.chart_anchors
 278          } =
 279                 Chart.Chart
 280                  { Chart.chart_accounts = convert chart_accounts
 281                  , Chart.chart_anchors  = convert chart_anchors
 282                  }
 283 -}
 284
 285 instance Convert x y => Convert (JCC.Charted x) (Ledger.Charted y) where
 286         convert (JCC.Charted c x) =
 287                 Ledger.Charted (convert c) (convert x)
 288
 289 instance Convert x y => Convert (Ledger.Charted x) (JCC.Charted y) where
 290         convert (Ledger.Charted c x) =
 291                 JCC.Charted (convert c) (convert x)
 292
 293 -- Balance
 294 instance
 295  ( Convert unit unit_
 296  , Convert quantity quantity_
 297  ) => Convert (H.Balance_by_Account_Sum unit quantity)
 298               (H.Balance_by_Account_Sum unit_ quantity_) where
 299         convert (H.Balance_by_Account_Sum m) =
 300                 H.Balance_by_Account_Sum $
 301                 convert <$>
 302                 Map.mapKeysMonotonic convert m
 303
 304 -- * GL
 305
 306 -- ** Class 'GL'
 307 class
 308  ( Convert (H.Account_Section (H.Posting_Account (H.Transaction_Posting x)))
 309            (H.Account_Section (H.Posting_Account (H.Transaction_Posting y)))
 310  ) => GL x y
 311 instance GL    JCC.Transaction Ledger.Transaction
 312 instance GL Ledger.Transaction    JCC.Transaction
 313
 314 instance GL (   JCC.Charted    JCC.Transaction)
 315             (Ledger.Charted Ledger.Transaction)
 316 instance GL (Ledger.Charted Ledger.Transaction)
 317             (JCC.Charted       JCC.Transaction)
 318
 319 instance
 320  ( GL x y
 321  , GL_Line x y
 322  , H.GL_Transaction x
 323  , H.GL_Transaction y
 324  , Convert x y
 325  ) => Convert (H.GL x)
 326               (H.GL y) where
 327         convert (H.GL m)
 328          = H.GL $ TreeMap.map_monotonic convert (convert <$>) m
 329          -- NOTE: Date does not need to be converted,
 330          -- thus avoid a useless Map.mapKeysMonotonic
 331          -- from the Convert instance on Map.
 332
 333 -- *** Class 'GL_Line'
 334
 335 class
 336  ( Convert (H.GL_Transaction_Line x)
 337            (H.GL_Transaction_Line y)
 338  , Convert (H.Transaction_Posting x)
 339            (H.Transaction_Posting y)
 340  , Convert (H.GL_Posting_Quantity (H.Transaction_Posting x))
 341            (H.GL_Posting_Quantity (H.Transaction_Posting y))
 342  ) => GL_Line x y
 343 instance GL_Line    JCC.Transaction Ledger.Transaction
 344 instance GL_Line Ledger.Transaction    JCC.Transaction
 345
 346 instance GL_Line (   JCC.Charted    JCC.Transaction)
 347                  (Ledger.Charted Ledger.Transaction)
 348 instance GL_Line (Ledger.Charted Ledger.Transaction)
 349                  (JCC.Charted       JCC.Transaction)
 350
 351 instance
 352  ( GL_Line x y
 353  , H.GL_Transaction x
 354  , H.GL_Transaction y
 355  , Convert x y
 356  ) => Convert (H.GL_Line x)
 357               (H.GL_Line y) where
 358         convert H.GL_Line{..} =
 359                 H.GL_Line
 360                  { H.gl_line_transaction = convert gl_line_transaction
 361                  , H.gl_line_posting     = convert gl_line_posting
 362                  , H.gl_line_sum         = convert gl_line_sum
 363                  }
 364
 365 -- Class 'GL_Expanded'
 366
 367 instance
 368  ( GL x y
 369  , GL_Line x y
 370  , H.GL_Transaction x
 371  , H.GL_Transaction y
 372  , Convert x y
 373  ) => Convert (H.GL_Expanded x)
 374               (H.GL_Expanded y) where
 375         convert (H.GL_Expanded m)
 376          = H.GL_Expanded $ convert m
 377
 378 -- Class 'GL_Line_Expanded'
 379
 380 instance
 381  Convert x y
 382  => Convert (Strict.Clusive x)
 383             (Strict.Clusive y) where
 384         convert Strict.Clusive{..} =
 385                 Strict.Clusive
 386                  { Strict.exclusive = convert exclusive
 387                  , Strict.inclusive = convert inclusive
 388                  }
 389
 390 -- Const
 391 instance Convert x y
 392  => Convert (Const x w) (Const y w_) where
 393         convert (Const x) = Const $ convert x
 394
 395 -- Polarized
 396 instance
 397  Convert x y
 398  => Convert (H.Polarized x)
 399             (H.Polarized y) where
 400         convert = (convert <$>)
 401
 402 -- Date
 403 instance Convert H.Date H.Date where
 404         convert = id
 405
 406 -- Quantity
 407 instance Convert Decimal Decimal where
 408         convert = id
 409
 410 -- Text
 411 instance Convert Text Text where
 412         convert = id
 413
 414 -- List
 415 instance Convert x y => Convert [x] [y] where
 416         convert = fmap convert
 417 instance Convert x y => Convert (NonEmpty x) (NonEmpty y) where
 418         convert = fmap convert
 419
 420 -- TreeMap
 421
 422 instance (Convert kx ky, Convert x y, Ord kx, Ord ky)
 423  => Convert (TreeMap kx x) (TreeMap ky y) where
 424         convert = TreeMap.map_monotonic convert convert
 425
 426 -- Map
 427 instance (Convert kx ky, Convert x y, Ord kx)
 428  => Convert (Map kx x) (Map ky y) where
 429         convert = Map.mapKeysMonotonic convert . fmap convert
 430
 431 -- Seq
 432 instance Convert x y => Convert (Seq x) (Seq y) where
 433         convert = fmap convert
 434
 435 -- * Stats
 436
 437 -- ** Class 'Stats'
 438 class
 439  ( Convert (H.Posting_Account (H.Transaction_Posting x))
 440            (H.Posting_Account (H.Transaction_Posting y))
 441  , Convert (H.Amount_Unit (H.Posting_Amount (H.Transaction_Posting x)))
 442            (H.Amount_Unit (H.Posting_Amount (H.Transaction_Posting y)))
 443  ) => Stats x y
 444
 445 instance Stats    JCC.Transaction Ledger.Transaction
 446 instance Stats Ledger.Transaction    JCC.Transaction
 447
 448 instance Stats (   JCC.Charted    JCC.Transaction)
 449                (Ledger.Charted Ledger.Transaction)
 450 instance Stats (Ledger.Charted Ledger.Transaction)
 451                (JCC.Charted       JCC.Transaction)
 452
 453 instance
 454  ( Stats x y
 455  , H.Stats_Transaction x
 456  , H.Stats_Transaction y
 457  ) => Convert (H.Stats x) (H.Stats y) where
 458         convert s@H.Stats{..} =
 459                 s
 460                  { H.stats_accounts = Map.mapKeysMonotonic convert stats_accounts
 461                  , H.stats_units    = Map.mapKeysMonotonic convert stats_units
 462                  }