Add make target tar.
[comptalang.git] / lcc / Hcompta / LCC / Posting.hs
index b59eb5ee2f510034c80dfa4c6a87bda5a096cecc..20baef2cc9df5911c1aca74d162d4cc5a808f15d 100644 (file)
@@ -14,7 +14,7 @@ module Hcompta.LCC.Posting where
 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)
@@ -24,7 +24,6 @@ import Data.Semigroup (Semigroup(..))
 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
@@ -33,11 +32,12 @@ import qualified Data.Strict as S
 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
@@ -47,64 +47,92 @@ 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'
@@ -129,21 +157,23 @@ newtype Comment = Comment Text
  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)