src/Symantic/Compta/Eval.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DataKinds #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5 {-# LANGUAGE GADTs #-}
   6 {-# LANGUAGE KindSignatures #-}
   7 {-# LANGUAGE MultiParamTypeClasses #-}
   8 {-# LANGUAGE NoOverloadedLists #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# LANGUAGE TupleSections #-}
  11 {-# LANGUAGE UndecidableInstances #-}
  12 {-# LANGUAGE OverloadedStrings #-}
  13 {-# OPTIONS_GHC -Wno-missing-signatures #-}
  14 {-# OPTIONS_GHC -Wno-unused-imports #-}
  15 {-# OPTIONS_GHC -Wno-dodgy-exports #-}
  16 module Symantic.Compta.Eval where
  17 import Control.Applicative (Applicative(..))
  18 import Control.Monad (Monad(..), sequence)
  19 import Data.Decimal (Decimal)
  20 import Data.Either (Either(..))
  21 import Data.Function (($), (.), id)
  22 import Data.Functor (Functor, (<$>))
  23 import Data.Int (Int)
  24 import Data.Kind
  25 import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
  26 import Data.Map.Strict (Map)
  27 import Data.Maybe (Maybe(..))
  28 import Data.Monoid (Monoid(..), Endo(..))
  29 import Data.Semigroup (Semigroup(..))
  30 import Data.String (String)
  31 import Data.Typeable
  32 import Numeric.Natural (Natural)
  33 import Prelude (Enum(..), fromIntegral, Integer)
  34 import Text.Show (Show(..))
  35 import qualified Control.Monad.Classes as MC
  36 import qualified Control.Monad.Trans.Reader as MT
  37 import qualified Data.Foldable as Foldable
  38 import qualified Data.List as List
  39 import qualified Data.Map.Strict as Map
  40 import qualified Data.Time.Calendar as Time
  41 import qualified Data.Tree as Tree
  42
  43 import Symantic.Compta.Utils.Monoid ()
  44 import Symantic.Compta.Lang
  45 import Symantic.Compta.Calc
  46 import Symantic.Compta.Norm.PCG
  47
  48 -- * Type 'Journal'
  49 data Journal a where
  50   JournalList :: Endo [Journal a] -> Journal [a]
  51   JournalMove :: Journal [TyPost] -> Journal TyMove
  52   JournalPost :: Journal TyAccount -> Journal TyAmount -> Journal TyPost
  53   JournalAccount :: Ty Journal TyAccount -> Journal TyAccount
  54   JournalAmount :: Ty Journal TyAmount -> Journal TyAmount
  55 deriving instance Show (Journal a)
  56 type instance Ty Journal TyAccount = ChartPath AccountCode
  57 type instance Ty Journal TyAmount = Map Unit (Quantity (Flow Decimal))
  58 type instance Ty Journal TyUnit = Unit
  59 type instance Ty Journal TyQuantity = Quantity (Flow Decimal)
  60 type instance Ty Journal TyAccountSection = AccountCode
  61 instance Inject (ChartPath AccountCode) Journal TyAccount where
  62   inject = JournalAccount
  63 instance Inject (Map Unit (Quantity (Flow Decimal))) Journal TyAmount where
  64   inject = JournalAmount
  65 instance Zeroable (Journal TyAmount) where
  66   zero = JournalAmount zero
  67 instance Negable (Journal TyAmount) where
  68   negate (JournalAmount x) = JournalAmount (negate x)
  69 instance Negable (Journal TyPost) where
  70   negate (JournalPost acct amt) = JournalPost acct (negate amt)
  71 instance Negable (Journal TyMove) where
  72   negate (JournalMove x) = JournalMove (negate x)
  73 instance Negable (Journal a) => Negable (Journal [a]) where
  74   negate (JournalList x) = JournalList (negate x)
  75 instance Listable Journal where
  76   nil = JournalList (Endo id)
  77   cons x (JournalList xs) = JournalList (Endo (x :) <> xs)
  78   concat (JournalList xs) (JournalList ys) = JournalList (xs <> ys)
  79 instance Accountable Journal where
  80   account = JournalAccount
  81 instance Amountable Journal where
  82   amount = JournalAmount
  83 instance Postable Journal where
  84   post = JournalPost
  85 instance Moveable Journal where
  86   move = JournalMove
  87 instance
  88   ( Listable repr
  89   , Postable repr
  90   , Moveable repr
  91   , Inject (Ty Journal TyAccount) repr TyAccount
  92   , Inject (Ty Journal TyAmount)  repr TyAmount
  93   ) => Trans Journal repr where
  94   trans = \case
  95     JournalList xs -> Foldable.foldr (cons . trans) nil (appEndo xs [])
  96     JournalMove ps -> move (trans ps)
  97     JournalPost acct amt -> post (trans acct) (trans amt)
  98     JournalAccount x -> inject x
  99     JournalAmount x -> inject x
 100
 101 {-
 102 -- * Eval
 103 data Error
 104   =  Error_Date Year Month Int
 105   deriving (Show)
 106 newtype Eval a = Eval { unEval :: Either Error a }
 107   deriving (Functor, Applicative, Monad, Show)
 108 type instance Account Eval = [String]
 109 type instance Unit Eval = String
 110 type instance Quantity Eval = Decimal
 111 type instance Amount Eval = (Unit Eval, Quantity Eval)
 112 type instance Amounts Eval = Map (Unit Eval) (Quantity Eval)
 113 type instance Date Eval = Time.Day
 114 type instance Wording Eval = String
 115 type instance PolarizedAmount Eval = Decimal
 116 type instance Posting Eval = (Account Eval, Map (Unit Eval) (Quantity Eval))
 117 type instance Transaction Eval =
 118   ( Date Eval
 119   , Wording Eval
 120   , [Posting Eval]
 121   )
 122 --type instance YearDo (Eval repr) = MT.Reader Year repr
 123 instance Dateable Eval where
 124   day i kd = \m y -> Eval $
 125     case Time.fromGregorianValid (fromIntegral y) (fromEnum m) i of
 126       Nothing -> Left $ Error_Date y m i
 127       Just d -> unEval (MT.runReaderT kd (Day d))
 128 instance Postingable Eval where
 129   act -= amts = (,) <$> act <*> amts
 130   act += amts = (,) <$> act <*> amts
 131 instance Transactionable Eval where
 132   transaction rw rps = do
 133     w <- rw
 134     ps <- sequence rps
 135     return (w, ps)
 136
 137 type instance Account Eval = [String]
 138 type instance AccountSection Eval = String
 139 type instance Chart Eval = Tree.Tree (String{-, [(String, String)]-})
 140 --type instance Transaction Tree.Tree = Tree (Day, Wording)
 141 --instance Fieldable Eval where
 142   --x|=v =
 143 instance Chartable Eval where
 144   section n ss = Eval (Right ss)
 145 type instance Merge String (Tree.Tree String) = Tree.Tree String
 146 instance Nodable String (Tree.Tree String) Eval where
 147   sct \= acts = Tree.Node <$> sct <*> sequence acts
 148     --List.foldr (\a acc -> [Tree.Node a acc]) acts act
 149   --x ./ y = Tree.Node (Tree.rootLabel x) [y]
 150   --x .| y = Tree.Node (0,"") [x,y]
 151 -}