import Control.DeepSeq (NFData(..))
import Data.Data (Data(..))
import Data.Eq (Eq(..))
-import Data.Function (($), (.), flip)
+import Data.Function (($), (.), flip, id)
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Map.Strict (Map)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Prelude (seq)
-import Text.Megaparsec.Pos (SourcePos, initialPos)
import Text.Show (Show)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Time.Clock as Time
import qualified Data.TreeMap.Strict as TreeMap
+import Language.Symantic.Grammar (Source(..))
import qualified Hcompta as H
-import Hcompta.LCC.Account
-import Hcompta.LCC.Amount
-import Hcompta.LCC.Tag
+import Hcompta.LCC.Account
+import Hcompta.LCC.Amount
+import Hcompta.LCC.Tag
deriving instance (Data a, Data b) => Data (S.Pair a b)
instance (NFData a, NFData b) => NFData (S.Pair a b) where
type Date = Time.UTCTime
-- * Type 'Posting'
-data Posting
+data Posting src
= Posting
{ posting_account :: !Account
, posting_account_ref :: !(S.Maybe (S.Pair Tag_Path (S.Maybe Account)))
, posting_amounts :: !Amounts
, posting_comments :: ![Comment]
, posting_dates :: ![Date]
- , posting_sourcepos :: !SourcePos
+ , posting_sourcepos :: !src
, posting_tags :: !Posting_Tags
} deriving (Data, Eq, Ord, Show, Typeable)
-instance NFData Posting where
+instance NFData src => NFData (Posting src) where
rnf Posting{..} =
rnf posting_account `seq`
rnf posting_account_ref `seq`
rnf posting_amounts `seq`
rnf posting_comments `seq`
rnf posting_dates `seq`
- -- rnf posting_sourcepos `seq`
+ rnf posting_sourcepos `seq`
rnf posting_tags
-instance H.Get (TreeMap.Path Account_Section) Posting where
- get = H.get . posting_account
-instance H.Get (Map Unit (H.Polarized Quantity)) Posting where
+{-
+type instance H.UnitFor Posting = Unit
+type instance H.QuantityFor Posting = H.Polarized Quantity
+type instance H.AccountFor Posting = Account
+-}
+
+instance H.Get (TreeMap.Path NameAccount) (Posting src) where
+ get = H.to . posting_account
+instance H.Get Account (Posting src) where
+ get Posting{posting_account = acct} = acct
+instance H.Get (Map Unit Quantity) (Posting src) where
+ get Posting{posting_amounts = Amounts amts} = amts
+instance H.Set (Map Unit Quantity) (Posting src) where
+ set amts p = p{posting_amounts = Amounts amts}
+instance H.Get (Map Unit (H.Polarized Quantity)) (Posting src) where
get Posting{posting_amounts = Amounts amts} = H.polarize <$> amts
-instance H.Set (Map Unit (H.Polarized Quantity)) Posting where
+instance H.Set (Map Unit (H.Polarized Quantity)) (Posting src) where
set amts p = p{posting_amounts = Amounts $ H.depolarize <$> amts}
-instance H.Get (H.Balance_Amounts Unit Quantity) Posting where
- get = H.get . posting_amounts
+-- instance H.Get (H.Balance_Amounts Unit Quantity) Posting where
+-- get = H.get . posting_amounts
+
+{-
+instance H.ConsBalByAccount Posting where
+ consBalByAccount Posting
+ { posting_account = Account acct
+ , posting_amounts = Amounts amts
+ } = H.consBalByAccount (acct, H.polarize <$> amts)
+instance H.ConsBalByUnit Posting where
+ consBalByUnit Posting
+ { posting_account = Account acct
+ , posting_amounts = Amounts amts
+ } = H.consBalByUnit (acct, H.polarize <$> amts)
+type instance H.AccountFor (Account, Amounts) = Account
+-}
-posting :: Account -> Posting
+posting :: Source src => Account -> Posting src
posting acct =
Posting
{ posting_account = acct
, posting_account_ref = S.Nothing
- , posting_amounts = H.quantity_zero
+ , posting_amounts = H.zero
, posting_comments = mempty
, posting_dates = mempty
- , posting_sourcepos = initialPos ""
+ , posting_sourcepos = noSource
, posting_tags = mempty
}
-postings_by_account :: [Posting] -> Map Account [Posting]
+postings_by_account :: [Posting src] -> Map Account [Posting src]
postings_by_account =
- Map.fromListWith (flip mappend) .
+ Map.fromListWith (flip (<>)) .
List.map (\p -> (posting_account p, [p]))
+{-
instance H.Posting Posting
type instance H.Account H.:@ Posting = Account
instance H.GetI H.Account Posting where
- getI_ _ = posting_account
+ getI = posting_account
instance H.SetI H.Account Posting where
- setI_ _ posting_account p = p{posting_account}
+ setI posting_account p = p{posting_account}
type instance H.Amounts H.:@ Posting = Amounts
instance H.GetI H.Amounts Posting where
- getI_ _ = posting_amounts
-instance H.SetI H.Amounts Posting where
- setI_ _ posting_amounts p = p{posting_amounts}
+ getI = posting_amounts
+instance H.SetI H.Amounts (Posting src) where
+ setI posting_amounts p = p{posting_amounts}
+-}
{-
-- * Type 'Posting_Anchor'
deriving (Data, Eq, NFData, Ord, Show, Typeable)
-- * Type 'Postings'
-newtype Postings = Postings (Map Account [Posting])
+newtype Postings src = Postings (Map Account [Posting src])
deriving (Data, Eq, NFData, Ord, Show, Typeable)
-unPostings :: Postings -> Map Account [Posting]
+unPostings :: Postings src -> Map Account [Posting src]
unPostings (Postings ps) = ps
-instance H.Postings Postings
-instance Semigroup Postings where
- Postings x <> Postings y =
- Postings $ Map.unionWith (flip (<>)) x y
-instance Monoid Postings where
+-- type instance H.Postings H.:@ Postings = Postings
+instance H.Get (Postings src) (Postings src) where
+ get = id
+-- instance H.Postings Postings
+instance Semigroup (Postings src) where
+ Postings x <> Postings y = Postings $ Map.unionWith (flip (<>)) x y
+instance Monoid (Postings src) where
mempty = Postings mempty
mappend = (<>)
-type instance MT.Element Postings = Posting
-instance MT.MonoFunctor Postings where
+type instance MT.Element (Postings src) = Posting src
+instance MT.MonoFunctor (Postings src) where
omap f (Postings m) = Postings (MT.omap f `MT.omap` m)
-instance MT.MonoFoldable Postings where
+instance MT.MonoFoldable (Postings src) where
ofoldMap f (Postings m) = MT.ofoldMap f (Compose m)
ofoldr f a (Postings m) = MT.ofoldr f a (Compose m)
ofoldr1Ex f (Postings m) = MT.ofoldr1Ex f (Compose m)