From c2ccadd943a63f2609db672fdf3c9190023fc8dd Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 11 Dec 2022 17:51:11 -0500 Subject: [PATCH] initial commit --- ChangeLog.md | 11 + LICENSE | 30 ++ README.md | 1 + app/Main.hs | 132 +++++++++ budget.cabal | 100 +++++++ dhall/Accounts.dhall | 50 ++++ dhall/common.dhall | 209 ++++++++++++++ lib/Internal/Config.hs | 76 +++++ lib/Internal/Database/Model.hs | 83 ++++++ lib/Internal/Database/Ops.hs | 294 ++++++++++++++++++++ lib/Internal/Insert.hs | 305 ++++++++++++++++++++ lib/Internal/Statement.hs | 209 ++++++++++++++ lib/Internal/Types.hs | 494 +++++++++++++++++++++++++++++++++ lib/Internal/Utils.hs | 254 +++++++++++++++++ package.yaml | 76 +++++ stack.yaml | 70 +++++ 16 files changed, 2394 insertions(+) create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 app/Main.hs create mode 100644 budget.cabal create mode 100644 dhall/Accounts.dhall create mode 100644 dhall/common.dhall create mode 100644 lib/Internal/Config.hs create mode 100644 lib/Internal/Database/Model.hs create mode 100644 lib/Internal/Database/Ops.hs create mode 100644 lib/Internal/Insert.hs create mode 100644 lib/Internal/Statement.hs create mode 100644 lib/Internal/Types.hs create mode 100644 lib/Internal/Utils.hs create mode 100644 package.yaml create mode 100644 stack.yaml diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..50a409f --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,11 @@ +# Changelog for budget + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..c4a92e4 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Nathan Dwarshuis (c) 2022 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Nathan Dwarshuis nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..62492aa --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# budget diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..22756fe --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import qualified Data.Text as T + +import Internal.Config +import Internal.Database.Ops +import Internal.Insert +import Internal.Types +import Internal.Utils + +-- import Import.Config + +import Control.Monad.Trans.Reader + +import Options.Applicative + +main :: IO () +main = parse =<< execParser o + where + o = info (options <**> helper) + ( fullDesc + <> progDesc "Pwn your budget" + <> header "pwncase - your budget, your life" + ) + +data Options = Reset + | DumpCurrencies + | DumpAccounts + | DumpAccountKeys + | Sync + +options :: Parser Options +options = reset + <|> dumpCurrencies + <|> dumpAccounts + <|> dumpAccountKeys + <|> sync + +reset :: Parser Options +reset = flag' Reset + ( long "reset" + <> short 'r' + <> help "Reset the database" + ) + +dumpCurrencies :: Parser Options +dumpCurrencies = flag' DumpCurrencies + ( long "currencies" + <> short 'c' + <> help "Dump all currencies in the configuration" + ) + +dumpAccounts :: Parser Options +dumpAccounts = flag' DumpAccounts + ( long "accounts" + <> short 'a' + <> help "Dump all accounts in the configuration" + ) + +-- TODO 'alias' is a better name for these +dumpAccountKeys :: Parser Options +dumpAccountKeys = flag' DumpAccountKeys + ( long "account_keys" + <> short 'k' + <> help "Dump all account keys/aliases" + ) + +sync :: Parser Options +sync = pure Sync + +parse :: Options -> IO () +parse Reset = migrate_ nukeTables +parse DumpAccounts = runDumpAccounts +parse DumpAccountKeys = runDumpAccountKeys +parse DumpCurrencies = runDumpCurrencies +parse Sync = runSync + +runDumpCurrencies :: IO () +runDumpCurrencies = do + cs <- currencies <$> readConfig "config/config.dhall" + putStrLn $ T.unpack $ T.unlines $ fmap fmt cs + where + fmt Currency { curSymbol = s, curFullname = f } = + T.concat [s, ": ", f] + +runDumpAccounts :: IO () +runDumpAccounts = do + ar <- accounts <$> readConfig "config/config.dhall" + mapM_ (\(h, f) -> printTree h $ f ar) ps + where + ps = [ ("Assets", arAssets) + , ("Equity", arEquity) + , ("Expenses", arExpenses) + , ("Income", arIncome) + , ("Liabilities", arLiabilities) + ] + printTree h ts = do + putStrLn h + mapM (go 1) ts + go i (Placeholder d n cs) = do + printAcnt i d n + mapM_ (go (i + 1)) cs + go i (Account d n) = printAcnt i d n + printAcnt i d n = do + let ind = T.replicate (i * 2) " " + putStrLn $ T.unpack $ T.concat [ind, n, ": ", d] + +runDumpAccountKeys :: IO () +runDumpAccountKeys = do + ar <- accounts <$> readConfig "config/config.dhall" + let ks = paths2IDs + $ fmap (double . fst) + $ concatMap (t3 . uncurry tree2Records) + $ flattenAcntRoot ar + mapM_ (uncurry printPair) ks + where + printPair i p = do + putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i] + t3 (_, _, x) = x + double x = (x, x) + +runSync :: IO () +runSync = do + config <- readConfig "config/config.dhall" + migrate_ $ do + s <- getDBState config + flip runReaderT s $ do + insertBudget $ budget config + insertStatements config + showBalances diff --git a/budget.cabal b/budget.cabal new file mode 100644 index 0000000..03252e0 --- /dev/null +++ b/budget.cabal @@ -0,0 +1,100 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.0. +-- +-- see: https://github.com/sol/hpack + +name: budget +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/ndwarshuis/budget#readme +bug-reports: https://github.com/ndwarshuis/budget/issues +author: Nathan Dwarshuis +maintainer: ndwar@yavin4.ch +copyright: 2022 Nathan Dwarshuis +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/ndwarshuis/budget + +library + exposed-modules: + Internal.Config + Internal.Types + Internal.Utils + Internal.Database.Ops + Internal.Database.Model + Internal.Insert + Internal.Statement + other-modules: + Paths_budget + hs-source-dirs: + lib/ + ghc-options: -Wall -Werror -threaded -Wpartial-fields + build-depends: + base >=4.12 && <10 + , bytestring + , cassava + , conduit >=1.3.4.2 + , containers >=0.6.4.1 + , data-fix + , dhall >=1.41.2 + , esqueleto + , ghc >=9.0.2 + , hashable + , lens >=5.0.1 + , monad-logger >=0.3.36 + , optparse-applicative + , persistent >=2.13.3.1 + , persistent-sqlite >=2.13.1.0 + , recursion-schemes + , regex-tdfa + , template-haskell + , text >=1.2.5.0 + , time >=1.9.3 + , transformers + , utf8-string + , vector + , yaml + default-language: Haskell2010 + +executable pwncash + main-is: Main.hs + other-modules: + Paths_budget + hs-source-dirs: + app + ghc-options: -Wall -Werror -threaded -Wpartial-fields -O2 + build-depends: + base >=4.12 && <10 + , budget + , bytestring + , cassava + , conduit >=1.3.4.2 + , containers >=0.6.4.1 + , data-fix + , dhall >=1.41.2 + , esqueleto + , ghc >=9.0.2 + , hashable + , lens >=5.0.1 + , monad-logger >=0.3.36 + , optparse-applicative + , persistent >=2.13.3.1 + , persistent-sqlite >=2.13.1.0 + , recursion-schemes + , regex-tdfa + , template-haskell + , text >=1.2.5.0 + , time >=1.9.3 + , transformers + , utf8-string + , vector + , yaml + default-language: Haskell2010 diff --git a/dhall/Accounts.dhall b/dhall/Accounts.dhall new file mode 100644 index 0000000..7b42b72 --- /dev/null +++ b/dhall/Accounts.dhall @@ -0,0 +1,50 @@ +let List/map = + https://prelude.dhall-lang.org/v21.1.0/List/map + sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680 + +let AccountTree + : Type + = forall (a : Type) -> + forall ( Fix + : < AccountF : { _1 : Text, _2 : Text } + | PlaceholderF : { _1 : Text, _2 : Text, _3 : List a } + > -> + a + ) -> + a + +let AccountTreeF = + \(a : Type) -> + < AccountF : { _1 : Text, _2 : Text } + | PlaceholderF : { _1 : Text, _2 : Text, _3 : List a } + > + +let Account + : Text -> Text -> AccountTree + = \(desc : Text) -> + \(name : Text) -> + \(a : Type) -> + let f = AccountTreeF a + + in \(Fix : f -> a) -> Fix (f.AccountF { _1 = desc, _2 = name }) + +let Placeholder + : Text -> Text -> List AccountTree -> AccountTree + = \(desc : Text) -> + \(name : Text) -> + \(children : List AccountTree) -> + \(a : Type) -> + let f = AccountTreeF a + + in \(Fix : f -> a) -> + let apply = \(x : AccountTree) -> x a Fix + + in Fix + ( f.PlaceholderF + { _1 = desc + , _2 = name + , _3 = List/map AccountTree a apply children + } + ) + +in { Account, Placeholder } diff --git a/dhall/common.dhall b/dhall/common.dhall new file mode 100644 index 0000000..9414b45 --- /dev/null +++ b/dhall/common.dhall @@ -0,0 +1,209 @@ +let List/map = + https://prelude.dhall-lang.org/v21.1.0/List/map + sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680 + +let nullSplit = + \(a : SplitAcnt) -> + \(c : SplitCur) -> + { sAcnt = a, sCurrency = c, sValue = None SplitNum, sComment = "" } + +let nullOpts = + { toDate = "Date" + , toAmount = "Amount" + , toDesc = "Description" + , toOther = [] : List Text + , toDateFmt = "%0m/%0d/%Y" + , toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?" + } + +let nullVal = + { mvSign = None Bool + , mvNum = None Natural + , mvDen = None Natural + , mvPrec = 2 + } + +let nullMatch = + { mDate = None MatchDate + , mVal = nullVal + , mDesc = None MatchDesc + , mOther = [] : List MatchOther + , mTx = None ToTx + , mTimes = None Natural + , mPriority = +0 + } + +let nullCron = + { cronWeekly = None WeekdayPat + , cronYear = None MDYPat + , cronMonth = None MDYPat + , cronDay = None MDYPat + } + +let nullMod = + \(by : Natural) -> + \(u : TimeUnit) -> + { mpStart = None Gregorian + , mpBy = by + , mpUnit = u + , mpRepeats = None Natural + } + +let cron1 = + \(y : Natural) -> + \(m : Natural) -> + \(d : Natural) -> + DatePat.Cron + ( nullCron + // { cronYear = Some (MDYPat.Single y) + , cronMonth = Some (MDYPat.Single m) + , cronDay = Some (MDYPat.Single d) + } + ) + +let matchInf_ = nullMatch + +let matchInf = \(x : ToTx) -> nullMatch // { mTx = Some x } + +let matchN_ = \(n : Natural) -> nullMatch // { mTimes = Some n } + +let matchN = \(n : Natural) -> \(x : ToTx) -> matchInf x // { mTimes = Some n } + +let match1_ = matchN_ 1 + +let match1 = matchN 1 + +let gregM = \(y : Natural) -> \(m : Natural) -> { gmYear = y, gmMonth = m } + +let greg = + \(y : Natural) -> + \(m : Natural) -> + \(d : Natural) -> + { gYear = y, gMonth = m, gDay = d } + +let mY = \(y : Natural) -> MatchDate.On (MatchYMD.Y y) + +let mYM = + \(y : Natural) -> \(m : Natural) -> MatchDate.On (MatchYMD.YM (gregM y m)) + +let mYMD = + \(y : Natural) -> + \(m : Natural) -> + \(d : Natural) -> + MatchDate.On (MatchYMD.YMD (greg y m d)) + +let mRngY = + \(y : Natural) -> + \(r : Natural) -> + MatchDate.In { rStart = MatchYMD.Y y, rLen = r } + +let mRngYM = + \(y : Natural) -> + \(m : Natural) -> + \(r : Natural) -> + MatchDate.In { rStart = MatchYMD.YM (gregM y m), rLen = r } + +let mRngYMD = + \(y : Natural) -> + \(m : Natural) -> + \(d : Natural) -> + \(r : Natural) -> + MatchDate.In { rStart = MatchYMD.YMD (greg y m d), rLen = r } + +let PartSplit = { _1 : AcntID, _2 : Decimal, _3 : Text } + +let partN = + \(c : SplitCur) -> + \(a : SplitAcnt) -> + \(comment : Text) -> + \(ss : List PartSplit) -> + let toSplit = + \(x : PartSplit) -> + nullSplit (SplitAcnt.ConstT x._1) c + // { sValue = Some (SplitNum.ConstN x._2), sComment = x._3 } + + in [ nullSplit a c // { sComment = comment } ] + # List/map PartSplit ExpSplit toSplit ss + +let part1 = + \(c : SplitCur) -> + \(a : SplitAcnt) -> + \(comment : Text) -> + partN c a comment ([] : List PartSplit) + +let part1_ = + \(c : SplitCur) -> \(a : SplitAcnt) -> partN c a "" ([] : List PartSplit) + +let dec = + \(s : Bool) -> + \(w : Natural) -> + \(d : Natural) -> + \(p : Natural) -> + { whole = w, decimal = d, precision = p, sign = s } : Decimal + +let dec2 = \(s : Bool) -> \(w : Natural) -> \(d : Natural) -> dec s w d 2 + +let d = dec2 True + +let d_ = dec2 False + +let addDay = + \(x : GregorianM) -> + \(d : Natural) -> + { gYear = x.gmYear, gMonth = x.gmMonth, gDay = d } + +let mvP = nullVal // { mvSign = Some True } + +let mvN = nullVal // { mvSign = Some False } + +let mvNum = \(x : Natural) -> nullVal // { mvNum = Some x } + +let mvDen = \(x : Natural) -> nullVal // { mvDen = Some x } + +let mvNumP = \(x : Natural) -> mvP // { mvNum = Some x } + +let mvNumN = \(x : Natural) -> mvN // { mvNum = Some x } + +let mvDenP = \(x : Natural) -> mvP // { mvDen = Some x } + +let mvDenN = \(x : Natural) -> mvN // { mvDen = Some x } + +in { nullSplit + , nullMatch + , nullVal + , nullOpts + , nullCron + , nullMod + , cron1 + , mY + , mYM + , mYMD + , mRngY + , mRngYM + , mRngYMD + , matchInf_ + , matchInf + , matchN_ + , matchN + , match1_ + , match1 + , greg + , gregM + , partN + , part1 + , part1_ + , d + , d_ + , addDay + , comma = 44 + , tab = 9 + , mvP + , mvN + , mvNum + , mvNumP + , mvNumN + , mvDen + , mvDenP + , mvDenN + , PartSplit + } diff --git a/lib/Internal/Config.hs b/lib/Internal/Config.hs new file mode 100644 index 0000000..00f1408 --- /dev/null +++ b/lib/Internal/Config.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Internal.Config + ( readConfig + , readYaml + ) where + +import Control.Exception +import Control.Lens + +import Data.Maybe +import qualified Data.Text as T +import Data.Typeable +import Data.Void +import Data.Yaml + +import Dhall hiding (record) +import qualified Dhall.Core as DC +import qualified Dhall.Map as DM +import Dhall.Src + +import Internal.Types + +readConfig :: FilePath -> IO Config +readConfig confpath = do + let subs = DM.fromList typeSubs + let settings = over substitutions (DM.union subs) defaultEvaluateSettings + unfix <$> inputFileWithSettings settings auto confpath + +typeSubs :: [(T.Text, DC.Expr Src Void)] +typeSubs = firstOrder ++ higherOrder + where + toVar a = fmap (\n -> (T.pack $ show n, maximum $ expected a)) + $ listToMaybe $ snd $ splitTyConApp $ typeOf a + higherOrder = + [ ("ExpSplit", maximum $ expected (auto :: Decoder ExpSplit)) + , ("ExpTx", maximum $ expected (auto :: Decoder ExpTx)) + , ("SplitCur", maximum $ expected (auto :: Decoder SplitCur)) + , ("SplitAcnt", maximum $ expected (auto :: Decoder SplitAcnt)) + , ("CurID", maximum $ expected (auto :: Decoder CurID)) + , ("AcntID", maximum $ expected (auto :: Decoder AcntID)) + ] + firstOrder = catMaybes + [ toVar (auto :: Decoder TimeUnit) + , toVar (auto :: Decoder WeekdayPat) + , toVar (auto :: Decoder MDYPat) + , toVar (auto :: Decoder Gregorian) + , toVar (auto :: Decoder GregorianM) + , toVar (auto :: Decoder ModPat) + , toVar (auto :: Decoder CronPat) + , toVar (auto :: Decoder DatePat) + , toVar (auto :: Decoder Income) + , toVar (auto :: Decoder Tax) + , toVar (auto :: Decoder Bucket) + , toVar (auto :: Decoder TimeAmount) + , toVar (auto :: Decoder Expense) + , toVar (auto :: Decoder Decimal) + , toVar (auto :: Decoder Statement) + , toVar (auto :: Decoder Manual) + , toVar (auto :: Decoder TxOpts) + , toVar (auto :: Decoder ToTx) + , toVar (auto :: Decoder Match) + , toVar (auto :: Decoder MatchYMD) + , toVar (auto :: Decoder MatchVal) + , toVar (auto :: Decoder MatchDate) + , toVar (auto :: Decoder SplitNum) + , toVar (auto :: Decoder MatchDesc) + , toVar (auto :: Decoder MatchOther) + ] + +readYaml :: FromJSON a => FilePath -> IO a +readYaml p = do + r <- decodeFileEither p + case r of + Right a -> return a + Left e -> throw e diff --git a/lib/Internal/Database/Model.hs b/lib/Internal/Database/Model.hs new file mode 100644 index 0000000..3a11627 --- /dev/null +++ b/lib/Internal/Database/Model.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Internal.Database.Model where + +import Control.Monad.Trans.Reader + +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Time + +import Database.Esqueleto.Experimental +import Database.Persist.TH + +import Internal.Types + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +CommitR sql=commits + hash Int + type ConfigType + deriving Show Eq +CurrencyR sql=currencies + symbol T.Text + fullname T.Text + deriving Show Eq +AccountR sql=accounts + name T.Text + fullpath T.Text + desc T.Text + deriving Show Eq +AccountPathR sql=account_paths + parent AccountRId OnDeleteCascade + child AccountRId OnDeleteCascade + depth Int + deriving Show Eq +TransactionR sql=transactions + commit CommitRId OnDeleteCascade + date Day + description T.Text + bucket T.Text Maybe + deriving Show Eq +SplitR sql=splits + transaction TransactionRId OnDeleteCascade + currency CurrencyRId OnDeleteCascade + account AccountRId OnDeleteCascade + memo T.Text + value Rational + deriving Show Eq +|] + +type AccountMap = M.Map AcntID (AccountRId, AcntSign) + +type CurrencyMap = M.Map CurID CurrencyRId + +data DBState = DBState + { kmCurrency :: !CurrencyMap + , kmAccount :: !AccountMap + , kmBudgetInterval :: !MaybeBounds + , kmStatementInterval :: !MaybeBounds + , kmNewCommits :: ![Int] + } + +type MappingT m a = ReaderT DBState (SqlPersistT m) a + +type KeySplit = Split AccountRId Rational CurrencyRId + +type KeyTx = Tx KeySplit + +type TreeR = Tree ([T.Text], AccountRId) diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs new file mode 100644 index 0000000..60c43a5 --- /dev/null +++ b/lib/Internal/Database/Ops.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Internal.Database.Ops + ( migrate_ + , nukeTables + , showBalances + , updateHashes + , getDBState + , tree2Records + , flattenAcntRoot + , paths2IDs + + ) where + +import Control.Monad.Logger +import Control.Monad.Trans.Reader + +import Conduit + +import Data.Bifunctor +import Data.Either +import Data.Hashable +import Data.List ((\\)) +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Text as T + +import Database.Esqueleto.Experimental +import Database.Persist.Sql hiding (delete, (==.), (||.)) +import Database.Persist.Sqlite hiding (delete, (==.), (||.)) +import Database.Sqlite hiding (Config) + +import Internal.Database.Model +import Internal.Types +import Internal.Utils + +migrate_ :: SqlPersistT (ResourceT (NoLoggingT IO)) () -> IO () +migrate_ more = runNoLoggingT $ runResourceT + $ withSqlConn openConnection (\backend -> + flip runSqlConn backend $ do + runMigration migrateAll + more + ) + +openConnection :: LogFunc -> IO SqlBackend +openConnection logfn = do + conn <- open "/tmp/test.db" + wrapConnection conn logfn + +nukeTables :: MonadIO m => SqlPersistT m () +nukeTables = do + deleteWhere ([] :: [Filter CommitR]) + deleteWhere ([] :: [Filter CurrencyR]) + deleteWhere ([] :: [Filter AccountR]) + deleteWhere ([] :: [Filter TransactionR]) + +showBalances :: MonadIO m => SqlPersistT m () +showBalances = do + xs <- select $ do + (accounts :& splits :& txs) <- + from $ table @AccountR + `innerJoin` table @SplitR + `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount) + `innerJoin` table @TransactionR + `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId) + where_ $ + isNothing (txs ^. TransactionRBucket) + &&. ((accounts ^. AccountRFullpath `like` val "asset" ++. (%)) + ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))) + groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName) + return ( accounts ^. AccountRFullpath + , accounts ^. AccountRName + , sum_ $ splits ^. SplitRValue) + -- TODO super stetchy table printing thingy + liftIO $ do + putStrLn $ T.unpack $ fmt "Account" "Balance" + putStrLn $ T.unpack $ fmt (T.replicate 60 "-") (T.replicate 15 "-") + mapM_ (putStrLn . T.unpack . fmtBalance) xs + where + fmtBalance (path, name, bal) = fmt (toFullPath path name) (toBal bal) + fmt a b = T.unwords ["| ", pad 60 a, " | ", pad 15 b, " |"] + pad n xs = T.append xs $ T.replicate (n - T.length xs) " " + toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name] + toBal = maybe "???" (fmtRational 2) . unValue + +hashConfig :: Config -> [Int] +hashConfig Config_ { budget = Budget { expenses = xs, income = is } + , statements = ss } = + (hash <$> xs) ++ (hash <$> is) ++ (hash <$> ms) ++ (hash <$> ps) + where + (ms, ps) = partitionEithers $ fmap go ss + go (StmtManual x) = Left x + go (StmtImport x) = Right x + +setDiff :: Eq a => [a] -> [a] -> ([a], [a]) +-- setDiff = setDiff' (==) +setDiff as bs = (as \\ bs, bs \\ as) + +-- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b]) +-- setDiff' f = go [] +-- where +-- go inA [] bs = (inA, bs) +-- go inA as [] = (as ++ inA, []) +-- go inA (a:as) bs = case inB a bs of +-- Just bs' -> go inA as bs' +-- Nothing -> go (a:inA) as bs +-- inB _ [] = Nothing +-- inB a (b:bs) +-- | f a b = Just bs +-- | otherwise = inB a bs + +getDBHashes :: MonadIO m => SqlPersistT m [Int] +getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl + +nukeDBHash :: MonadIO m => Int -> SqlPersistT m () +nukeDBHash h = delete $ do + c <- from table + where_ (c ^. CommitRHash ==. val h) + +nukeDBHashes :: MonadIO m => [Int] -> SqlPersistT m () +nukeDBHashes = mapM_ nukeDBHash + +getConfigHashes :: MonadIO m => Config -> SqlPersistT m ([Int], [Int]) +getConfigHashes c = do + let ch = hashConfig c + dh <- getDBHashes + return $ setDiff dh ch + +updateHashes :: MonadIO m => Config -> SqlPersistT m [Int] +updateHashes c = do + (del, new) <- getConfigHashes c + nukeDBHashes del + return new + +dumpTbl :: (PersistEntity r, MonadIO m) => SqlPersistT m [Entity r] +dumpTbl = select $ from table + +deleteAccount :: MonadIO m => Entity AccountR -> SqlPersistT m () +deleteAccount e = delete $ do + c <- from $ table @AccountR + where_ (c ^. AccountRId ==. val k) + where + k = entityKey e + +deleteCurrency :: MonadIO m => Entity CurrencyR -> SqlPersistT m () +deleteCurrency e = delete $ do + c <- from $ table @CurrencyR + where_ (c ^. CurrencyRId ==. val k) + where + k = entityKey e + +updateAccounts :: MonadIO m => AccountRoot -> SqlPersistT m AccountMap +updateAccounts ar = do + let (acnts, paths, acntMap) = indexAcntRoot ar + acnts' <- dumpTbl + let (toIns, toDel) = setDiff acnts acnts' + deleteWhere ([] :: [Filter AccountPathR]) + mapM_ deleteAccount toDel + -- liftIO $ mapM_ print toDel + mapM_ insertFull toIns + mapM_ insert paths + return acntMap + +insertFull :: (MonadIO m, PersistStoreWrite b, PersistRecordBackend r b) + => Entity r -> ReaderT b m () +insertFull (Entity k v) = insertKey k v + +updateCurrencies :: MonadIO m => [Currency] -> SqlPersistT m CurrencyMap +updateCurrencies cs = do + let curs = fmap currency2Record cs + curs' <- select $ from $ table @CurrencyR + let (toIns, toDel) = setDiff curs curs' + mapM_ deleteCurrency toDel + mapM_ insertFull toIns + return $ currencyMap curs + +currency2Record :: Currency -> Entity CurrencyR +currency2Record c@Currency {..} = Entity (toKey c) $ CurrencyR curSymbol curFullname + +currencyMap :: [Entity CurrencyR] -> CurrencyMap +currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e)) + +toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b +toKey = toSqlKey . fromIntegral . hash + +tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR +tree2Entity t parents name des = Entity (toSqlKey $ fromIntegral h) + $ AccountR name (toPath parents) des + where + p = AcntPath t (reverse (name:parents)) + h = hash p + toPath = T.intercalate "/" . (atName t:) . reverse + +tree2Records :: AcntType -> AccountTree + -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign))]) +tree2Records t = go [] + where + go ps (Placeholder d n cs) = + let + e = tree2Entity t (fmap snd ps) n d + k = entityKey e + (as, aps, ms) = unzip3 $ fmap (go ((k, n):ps)) cs + a0 = acnt k n (fmap snd ps) d + paths = expand k $ fmap fst ps + in (a0:concat as, paths ++ concat aps, concat ms) + go ps (Account d n) = + let e = tree2Entity t (fmap snd ps) n d + k = entityKey e + in ( [acnt k n (fmap snd ps) d] + , expand k $ fmap fst ps + , [(AcntPath t $ reverse $ n:fmap snd ps, (k, sign))] + ) + toPath = T.intercalate "/" . (atName t:) . reverse + acnt k n ps = Entity k . AccountR n (toPath ps) + expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0:hs) [0..] + sign = accountSign t + +paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)] +paths2IDs = uncurry zip + . first trimNames + . unzip + . L.sortOn fst + . fmap (first pathList) + where + pathList (AcntPath t ns) = reverse $ atName t : ns + +trimNames :: [[T.Text]] -> [AcntID] +trimNames = fmap fmt . trimAll 0 + where + fmt [] = err "blank path" + fmt ys = T.intercalate "_" $ reverse ys + trimAll _ [] = [] + trimAll i (y:ys) = case L.foldl' (matchPre i) (y, [], []) ys of + (a, [], bs) -> reverse $ trim i a:bs + (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a:as) + matchPre i (y, ys, old) new = case (y !? i, new !? i) of + (Nothing, Just _) -> + case ys of + [] -> (new, [], trim i y:old) + _ -> err "unsorted input" + (Just _, Nothing) -> err "unsorted input" + (Nothing, Nothing) -> err "duplicated inputs" + (Just a, Just b) + | a == b -> (new, y:ys, old) + | otherwise -> + let next = case ys of + [] -> [trim i y] + _ -> trimAll (i + 1) (reverse $ y:ys) + in (new, [], reverse next ++ old) + trim i = take (i + 1) + err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg + +(!?) :: [a] -> Int -> Maybe a +xs !? n + | n < 0 = Nothing + -- Definition adapted from GHC.List + | otherwise = foldr (\x r k -> case k of + 0 -> Just x + _ -> r (k-1)) (const Nothing) xs n + +flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)] +flattenAcntRoot AccountRoot_ {..} = + ((IncomeT,) <$> arIncome) + ++ ((ExpenseT,) <$> arExpenses) + ++ ((LiabilityT,) <$> arLiabilities) + ++ ((AssetT,) <$> arAssets) + ++ ((EquityT,) <$> arEquity) + +indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap) +indexAcntRoot r = + ( concat ars + , concat aprs + , M.fromList $ paths2IDs $ concat ms + ) + where + (ars, aprs, ms) = unzip3 $ uncurry tree2Records <$> flattenAcntRoot r + +getDBState :: MonadIO m => Config -> SqlPersistT m DBState +getDBState c = do + am <- updateAccounts $ accounts c + cm <- updateCurrencies $ currencies c + hs <- updateHashes c + return $ DBState + { kmCurrency = cm + , kmAccount = am + , kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c + , kmStatementInterval = intervalMaybeBounds $ statementInterval $ global c + , kmNewCommits = hs + } diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs new file mode 100644 index 0000000..3bcddbe --- /dev/null +++ b/lib/Internal/Insert.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Internal.Insert + ( insertStatements + , insertBudget + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader + +import Data.Either +import Data.Hashable +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import Data.Time + +import Database.Persist.Class +import Database.Persist.Sql hiding (Single, Statement) + +import Internal.Database.Model +import Internal.Statement +import Internal.Types hiding (sign) +import Internal.Utils + +import Numeric.Natural + +lookupKey :: (Show v, Ord k, Show k, MonadIO m) => M.Map k v -> k -> m (Maybe v) +lookupKey m k = do + let v = M.lookup k m + when (isNothing v) $ + liftIO $ putStrLn $ "key does not exist: " ++ show k + return v + +lookupAccount :: MonadIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign)) +lookupAccount p = do + m <- asks kmAccount + lookupKey m p + +lookupAccountKey :: MonadIO m => AcntID -> MappingT m (Maybe (Key AccountR)) +lookupAccountKey = fmap (fmap fst) . lookupAccount + +lookupAccountSign :: MonadIO m => AcntID -> MappingT m (Maybe AcntSign) +lookupAccountSign = fmap (fmap snd) . lookupAccount + +lookupCurrency :: MonadIO m => T.Text -> MappingT m (Maybe (Key CurrencyR)) +lookupCurrency c = do + m <- asks kmCurrency + lookupKey m c + +-------------------------------------------------------------------------------- +-- intervals + +expandDatePat :: Bounds -> DatePat -> [Day] +expandDatePat (a, b) (Cron cp) = filter (cronPatternMatches cp) [a..b] +expandDatePat i (Mod mp) = expandModPat mp i + +expandModPat :: ModPat -> Bounds -> [Day] +expandModPat ModPat { mpStart = s + , mpBy = b + , mpUnit = u + , mpRepeats = r + } (lower, upper) = + takeWhile (<= upper) + $ (`addFun` start) . (* b') + <$> maybe id (take . fromIntegral) r [0..] + where + start = maybe lower fromGregorian_ s + b' = fromIntegral b + fromGregorian_ (Gregorian {..}) = fromGregorian + (fromIntegral $ gYear + 2000) + (fromIntegral gMonth) + (fromIntegral gDay) + addFun = case u of + Day -> addDays + Week -> addDays . (* 7) + Month -> addGregorianMonthsClip + Year -> addGregorianYearsClip + +cronPatternMatches :: CronPat -> Day -> Bool +cronPatternMatches CronPat { cronWeekly = w + , cronYear = y + , cronMonth = m + , cronDay = d + } x = + mdyMaybe (y' - 2000) y && mdyMaybe m' m && mdyMaybe d' d && wdMaybe (dayOfWeek x) w + where + testMaybe = maybe True + mdyMaybe z = testMaybe (`mdyPatternMatches` fromIntegral z) + wdMaybe z = testMaybe (`weekdayPatternMatches` z) + (y', m', d') = toGregorian x + +weekdayPatternMatches :: WeekdayPat -> DayOfWeek -> Bool +weekdayPatternMatches (OnDay x) = (== x) +weekdayPatternMatches (OnDays xs) = (`elem` xs) + +mdyPatternMatches :: MDYPat -> Natural -> Bool +mdyPatternMatches (Single y) = (== y) +mdyPatternMatches (Multi xs) = (`elem` xs) +mdyPatternMatches (Repeat p) = repeatPatternMatches p + +repeatPatternMatches :: RepeatPat -> Natural -> Bool +repeatPatternMatches RepeatPat { rpStart = s, rpBy = b, rpRepeats = r } x = + s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r + +-------------------------------------------------------------------------------- +-- budget + +insertBudget :: MonadIO m => Budget -> MappingT m () +insertBudget Budget { income = is, expenses = es } = do + mapM_ insertIncome is + mapM_ insertExpense es + +-- TODO this hashes twice (not that it really matters) +whenHash :: Hashable a => MonadIO m => ConfigType -> a + -> (Key CommitR -> MappingT m ()) -> MappingT m () +whenHash t o f = do + let h = hash o + hs <- asks kmNewCommits + when (h `elem` hs) $ do + f =<< lift (insert $ CommitR h t) + +insertIncome :: MonadIO m => Income -> MappingT m () +insertIncome i@Income { incCurrency = cur + , incWhen = dp + , incAccount = from + , incTaxes = ts + } = + whenHash CTIncome i $ \c -> do + case balanceIncome i of + Left m -> liftIO $ print m + Right as -> do + bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval + forM_ (expandDatePat bounds dp) $ \day -> do + alloTx <- concat <$> mapM (allocationToTx from day) as + taxTx <- fmap (, Fixed) <$> mapM (taxToTx from day cur) ts + lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx + +balanceIncome :: Income -> Either T.Text [BalAllocation] +balanceIncome Income { incGross = g + , incPretax = pre + , incTaxes = tax + , incPosttax = post + } = (preRat ++) <$> balancePostTax bal postRat + where + preRat = mapAlloAmts dec2Rat <$> pre + postRat = mapAlloAmts (fmap dec2Rat) <$> post + bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax) + +mapAlloAmts :: (a -> b) -> Allocation a -> Allocation b +mapAlloAmts f a@Allocation { alloAmts = as } = a { alloAmts = fmap f <$> as } + +sumAllocations :: [BalAllocation] -> Rational +sumAllocations = sum . concatMap (fmap amtValue . alloAmts) + +sumTaxes :: [Tax] -> Rational +sumTaxes = sum . fmap (dec2Rat . taxValue) + +balancePostTax :: Rational -> [RawAllocation] -> Either T.Text [BalAllocation] +balancePostTax bal as + | null as = Left "no allocations to balance" + | otherwise = case partitionEithers $ fmap hasVal as of + ([([empty], nonmissing)], bs) -> + let s = bal - sumAllocations (nonmissing:bs) in + if s < 0 + then Left "allocations exceed total" + else Right $ mapAmts (empty { amtValue = s }:) nonmissing : bs + ([], _) -> Left "need one blank amount to balance" + _ -> Left "multiple blank amounts present" + where + hasVal a@Allocation { alloAmts = xs } = + case partitionEithers $ fmap maybeAmt xs of + ([], bs) -> Right a { alloAmts = bs } + (unbal, bs) -> Left (unbal, a { alloAmts = bs }) + maybeAmt a@Amount { amtValue = Just v } = Right a { amtValue = v } + maybeAmt a = Left a + +-- TODO lens reinvention +mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b +mapAmts f a@Allocation { alloAmts = xs } = a { alloAmts = f xs } + +allocationToTx :: MonadIO m => AcntID -> Day -> BalAllocation + -> MappingT m [(KeyTx, Bucket)] +allocationToTx from day Allocation { alloPath = to + , alloBucket = b + , alloCurrency = cur + , alloAmts = as + } = + fmap (, b) <$> mapM (transferToTx day from to cur) as + +taxToTx :: MonadIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx +taxToTx from day cur Tax { taxAcnt = to, taxValue = v } = + txPair day from to cur (dec2Rat v) "" + +transferToTx :: MonadIO m => Day -> AcntID -> AcntID -> T.Text -> BalAmount + -> MappingT m KeyTx +transferToTx day from to cur Amount { amtValue = v, amtDesc = d } = + txPair day from to cur v d + +insertExpense :: MonadIO m => Expense -> MappingT m () +insertExpense e@Expense { expFrom = from + , expTo = to + , expCurrency = cur + , expBucket = buc + , expAmounts = as + } = do + whenHash CTExpense e $ \c -> do + ts <- concat <$> mapM (timeAmountToTx from to cur) as + lift $ mapM_ (insertTxBucket (Just buc) c) ts + +timeAmountToTx :: MonadIO m => AcntID -> AcntID -> T.Text -> TimeAmount + -> MappingT m [KeyTx] +timeAmountToTx from to cur TimeAmount { taWhen = dp + , taAmt = Amount { amtValue = v + , amtDesc = d + } } = do + bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval + mapM tx $ expandDatePat bounds dp + where + tx day = txPair day from to cur (dec2Rat v) d + +-------------------------------------------------------------------------------- +-- statements + +insertStatements :: MonadIO m => Config -> MappingT m () +insertStatements = mapM_ insertStatement . statements + +insertStatement :: MonadIO m => Statement -> MappingT m () +insertStatement (StmtManual m) = insertManual m +insertStatement (StmtImport i) = insertImport i + +insertManual :: MonadIO m => Manual -> MappingT m () +insertManual m@Manual { manualDate = dp + , manualFrom = from + , manualTo = to + , manualValue = v + , manualCurrency = u + , manualDesc = e + } = do + whenHash CTManual m $ \c -> do + bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval + ts <- mapM tx $ expandDatePat bounds dp + lift $ mapM_ (insertTx c) ts + where + tx day = txPair day from to u (dec2Rat v) e + +insertImport :: MonadIO m => Import -> MappingT m () +insertImport i = whenHash CTImport i $ \c -> do + bounds <- asks kmStatementInterval + bs <- liftIO $ readImport i + -- TODO this isn't efficient, the whole file will be read and maybe no + -- transactions will be desired + rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs + lift $ mapM_ (insertTx c) rs + +-------------------------------------------------------------------------------- +-- low-level transaction stuff + +txPair :: MonadIO m => Day -> AcntID -> AcntID -> T.Text -> Rational -> T.Text + -> MappingT m KeyTx +txPair day from to cur val desc = resolveTx tx + where + split a v = Split { sAcnt = a, sValue = v, sComment = "", sCurrency = cur } + tx = Tx { txDescr = desc + , txDate = day + , txTags = [] + , txSplits = [split from (-val), split to val] + } + +resolveTx :: MonadIO m => BalTx -> MappingT m KeyTx +resolveTx t@Tx { txSplits = ss } = do + rs <- catMaybes <$> mapM resolveSplit ss + return $ t { txSplits = rs } + +resolveSplit :: MonadIO m => BalSplit -> MappingT m (Maybe KeySplit) +resolveSplit s@Split { sAcnt = p, sCurrency = c, sValue = v } = do + aid <- lookupAccountKey p + cid <- lookupCurrency c + sign <- lookupAccountSign p + -- TODO correct sign here? + -- TODO lenses would be nice here + return $ case (aid, cid, sign) of + (Just aid', Just cid', Just sign') + -> Just $ s { sAcnt = aid' + , sCurrency = cid' + , sValue = v * fromIntegral (sign2Int sign') + } + _ -> Nothing + +insertTxBucket :: MonadIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m () +insertTxBucket b c Tx { txDate = d, txDescr = e, txSplits = ss } = do + k <- insert $ TransactionR c d e (fmap (T.pack . show) b) + mapM_ (insertSplit k) ss + +insertTx :: MonadIO m => Key CommitR -> KeyTx -> SqlPersistT m () +insertTx = insertTxBucket Nothing + +insertSplit :: MonadIO m => Key TransactionR -> KeySplit -> SqlPersistT m () +insertSplit t Split { sAcnt = aid, sCurrency = cid, sValue = v, sComment = c } = do + insert_ $ SplitR t cid aid c v diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs new file mode 100644 index 0000000..b158cee --- /dev/null +++ b/lib/Internal/Statement.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Internal.Statement + ( readImport + ) where + +import Data.Bifunctor +import qualified Data.ByteString.Lazy as BL +import Data.Csv +import Data.Either +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import Data.Ord +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time +import qualified Data.Vector as V + +import Internal.Types +import Internal.Utils + +import Numeric.Natural + +-- TODO this probably won't scale well (pipes?) + +readImport :: Import -> IO [BalTx] +readImport Import { impPaths = ps + , impMatches = ms + , impTxOpts = ns + , impDelim = d + , impSkipLines = n + -- , impTx = f + } = do + rs <- L.sort . concat <$> mapM (readImport_ n d ns) ps + let (ts, es, notfound) = matchRecords ms rs + mapM_ putStrLn $ reverse es + mapM_ print notfound + return ts + +readImport_ :: Natural -> Word -> TxOpts -> FilePath -> IO [TxRecord] +readImport_ n delim tns p = do + bs <- BL.readFile p + case decodeByNameWithP (parseTxRecord tns) opts $ skip bs of + Left m -> putStrLn m >> return [] + Right (_, v) -> return $ catMaybes $ V.toList v + where + opts = defaultDecodeOptions { decDelimiter = fromIntegral delim } + skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10 + +-- TODO handle this better, this maybe thing is a hack to skip lines with +-- blank dates but will likely want to make this more flexible +parseTxRecord :: TxOpts -> NamedRecord -> Parser (Maybe TxRecord) +parseTxRecord TxOpts {..} r = do + d <- r .: TE.encodeUtf8 toDate + if d == "" + then return Nothing + else do + a <- parseRational toAmountFmt =<< r .: TE.encodeUtf8 toAmount + e <- r .: TE.encodeUtf8 toDesc + os <- M.fromList <$> mapM (\n -> (n, ) <$> r .: TE.encodeUtf8 n) toOther + d' <- parseTimeM True defaultTimeLocale toDateFmt d + return $ Just $ TxRecord d' a e os + +matchRecords :: [Match] -> [TxRecord] -> ([BalTx], [String], [Match]) +matchRecords ms rs = ( catMaybes ts + , T.unpack <$> (es ++ bu) + -- TODO record number of times each match hits for debugging + , notfound + ) + where + (matched, unmatched, notfound) = matchAll (matchPriorities ms) rs + (es, ts) = partitionEithers + $ fmap Just . balanceTx <$> catMaybes matched + bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched + +matchPriorities :: [Match] -> [MatchGroup] +matchPriorities = fmap matchToGroup + . L.groupBy (\a b -> mPriority a == mPriority b) + . L.sortOn (Down . mPriority) + +matchToGroup :: [Match] -> MatchGroup +matchToGroup ms = uncurry MatchGroup + $ first (L.sortOn mDate) + $ L.partition (isJust . mDate) ms + +-- TDOO could use a better struct to flatten the maybe date subtype +data MatchGroup = MatchGroup + { mgDate :: [Match] + , mgNoDate :: [Match] + } deriving (Show) + +data Zipped a = Zipped ![a] ![a] + +data Unzipped a = Unzipped ![a] ![a] ![a] + +initZipper :: [a] -> Zipped a +initZipper = Zipped [] + +resetZipper :: Zipped a -> Zipped a +resetZipper = initZipper . recoverZipper + +recoverZipper :: Zipped a -> [a] +recoverZipper (Zipped as bs) = reverse as ++ bs + +zipperSlice :: (a -> b -> Ordering) -> b -> Zipped a -> Either (Zipped a) (Unzipped a) +zipperSlice f x = go + where + go z@(Zipped _ []) = Left z + go z@(Zipped bs (a:as)) = case f a x of + GT -> go $ Zipped (a:bs) as + EQ -> Right $ goEq (Unzipped bs [a] as) + LT -> Left z + goEq z@(Unzipped _ _ []) = z + goEq z@(Unzipped bs cs (a:as)) = case f a x of + GT -> goEq $ Unzipped (a:bs) cs as + EQ -> goEq $ Unzipped bs (a:cs) as + LT -> z + +zipperMatch :: Unzipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx)) +zipperMatch (Unzipped bs cs as) x = go [] cs + where + go _ [] = (Zipped bs $ cs ++ as, Nothing) + go prev (m:ms) = case matches m x of + Nothing -> go (m:prev) ms + res@(Just _) -> let ps = reverse prev + ms' = maybe ms (:ms) (matchDec m) in + (Zipped bs $ ps ++ ms' ++ as, res) + +zipperMatch' :: Zipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx)) +zipperMatch' z x = go z + where + go (Zipped bs (a:as)) = case matches a x of + Nothing -> go (Zipped (a:bs) as) + res -> (Zipped (maybe bs (:bs) $ matchDec a) as, res) + go z' = (z', Nothing) + +matchDec :: Match -> Maybe Match +matchDec m@Match { mTimes = t } = + if t' == Just 0 then Nothing else Just $ m { mTimes = t' } + where + t' = fmap pred t + +matchAll :: [MatchGroup] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) +matchAll = go ([], []) + where + go (matched, unused) gs rs = case (gs, rs) of + (_, []) -> (matched, [], unused) + ([], _) -> (matched, rs, unused) + (g:gs', _) -> let (ts, unmatched, us) = matchGroup g rs in + go (ts ++ matched, us ++ unused) gs' unmatched + +matchGroup :: MatchGroup -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) +matchGroup MatchGroup { mgDate = ds, mgNoDate = ns } rs + = (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un) + where + (md, rest, ud) = matchDates ds rs + (mn, unmatched, un) = matchNonDates ns rest + +matchDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) +matchDates ms = go ([], [], initZipper ms) + where + go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z) + go (matched, unmatched, z) (r:rs) = case zipperSlice findDate r z of + Left res -> go (matched, r:unmatched, res) rs + Right res -> + let (z', p) = zipperMatch res r + (m, u) = case p of + Just p' -> (p':matched, unmatched) + Nothing -> (matched, r:unmatched) + in go (m, u, z') rs + findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m + +matchNonDates :: [Match] -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match]) +matchNonDates ms = go ([], [], initZipper ms) + where + go (matched, unmatched, z) [] = (matched, reverse unmatched, recoverZipper z) + go (matched, unmatched, z) (r:rs) = + let (z', res) = zipperMatch' z r + (m, u) = case res of + Just x -> (x:matched, unmatched) + Nothing -> (matched, r:unmatched) + in go (m, u, resetZipper z') rs + +balanceTx :: RawTx -> Either T.Text BalTx +balanceTx t@Tx { txSplits = ss } = do + bs <- balanceSplits ss + return $ t { txSplits = bs } + +balanceSplits :: [RawSplit] -> Either T.Text [BalSplit] +balanceSplits ss = fmap concat + <$> mapM (uncurry bal) + $ groupByKey + $ fmap (\s -> (sCurrency s, s)) ss + where + hasValue s@(Split { sValue = Just v }) = Right s { sValue = v } + hasValue s = Left s + bal cur rss + | length rss < 2 = Left $ T.append "Need at least two splits to balance: " cur + | otherwise = case partitionEithers $ fmap hasValue rss of + ([noVal], val) -> Right $ noVal { sValue = foldr (\s x -> x - sValue s) 0 val } : val + ([], val) -> Right val + _ -> Left $ T.append "Exactly one split must be blank: " cur + +groupByKey :: Ord k => [(k, v)] -> [(k, [v])] +groupByKey = M.toList . M.fromListWith (++) . fmap (second (:[])) diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs new file mode 100644 index 0000000..0ea0235 --- /dev/null +++ b/lib/Internal/Types.hs @@ -0,0 +1,494 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Internal.Types where + +import Data.Fix (Fix (..), foldFix) +import Data.Functor.Foldable (embed) +import qualified Data.Functor.Foldable.TH as TH +import Data.Hashable +import Data.Int +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Time +import Data.Yaml + +import Database.Persist.Sql hiding (In, Statement) + +import Dhall hiding (embed, maybe) + +import Language.Haskell.TH.Syntax (Lift) + +import Text.Read + +------------------------------------------------------------------------------- +-- | YAML CONFIG +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- | account tree + +data AccountTree = Placeholder T.Text T.Text [AccountTree] + | Account T.Text T.Text + +TH.makeBaseFunctor ''AccountTree + +deriving instance Generic (AccountTreeF a) +deriving instance FromDhall a => FromDhall (AccountTreeF a) + +data AccountRoot_ a = AccountRoot_ + { arAssets :: ![a] + , arEquity :: ![a] + , arExpenses :: ![a] + , arIncome :: ![a] + , arLiabilities :: ![a] + } + deriving (Generic) + +type AccountRootF = AccountRoot_ (Fix AccountTreeF) + +deriving instance FromDhall AccountRootF + +type AccountRoot = AccountRoot_ AccountTree + +------------------------------------------------------------------------------- +-- | curencies + +data Currency = Currency + { curSymbol :: !CurID + , curFullname :: !T.Text + } + deriving (Eq, Lift, Generic, Hashable, FromDhall) + +type CurID = T.Text + +instance FromJSON Currency where + parseJSON = withObject "Currency" $ \o -> Currency + <$> o .: "symbol" + <*> o .: "desc" + +------------------------------------------------------------------------------- +-- | DHALL CONFIG +------------------------------------------------------------------------------- + +data Config_ a = Config_ + { global :: !Global + , budget :: !Budget + , currencies :: ![Currency] + , statements :: ![Statement] + , accounts :: a + } + deriving (Generic) + +type ConfigF = Config_ AccountRootF + +type Config = Config_ AccountRoot + +unfix :: ConfigF -> Config +unfix c@Config_ { accounts = a } = c { accounts = a' } + where + a' = AccountRoot_ + { arAssets = unfixTree arAssets + , arEquity = unfixTree arEquity + , arExpenses = unfixTree arExpenses + , arIncome = unfixTree arIncome + , arLiabilities = unfixTree arLiabilities + } + unfixTree f = foldFix embed <$> f a + +instance FromDhall a => FromDhall (Config_ a) + +data Global = Global + { budgetInterval :: !Interval + , statementInterval :: !Interval + } + deriving (Generic, FromDhall) + +------------------------------------------------------------------------------- +-- | accounts + +data AcntType = AssetT + | EquityT + | ExpenseT + | IncomeT + | LiabilityT + deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall) + +atName :: AcntType -> T.Text +atName AssetT = "asset" +atName EquityT = "equity" +atName ExpenseT = "expense" +atName IncomeT = "income" +atName LiabilityT = "liability" + +data AcntPath = AcntPath + { apType :: !AcntType + , apChildren :: ![T.Text] + } deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall) + +type AcntID = T.Text + +-------------------------------------------------------------------------------- +-- | Time Patterns (for assigning when budget events will happen) + +data Interval = Interval + { intStart :: Maybe Gregorian + , intEnd :: Maybe Gregorian + } + deriving (Generic, FromDhall) + +data TimeUnit = Day | Week | Month | Year + deriving (Eq, Hashable, Generic, FromDhall) + +data WeekdayPat = OnDay !DayOfWeek | OnDays ![DayOfWeek] + deriving (Eq, Generic, FromDhall) + +instance Hashable WeekdayPat where + hashWithSalt s (OnDay d) = s `hashWithSalt` ("WPDay" :: T.Text) + `hashWithSalt` fromEnum d + hashWithSalt s (OnDays ds) = s `hashWithSalt` ("WPDays" :: T.Text) + `hashWithSalt` fromEnum <$> ds + +data RepeatPat = RepeatPat + { rpStart :: !Natural + , rpBy :: !Natural + , rpRepeats :: Maybe Natural + } + deriving (Eq, Hashable, Generic, FromDhall) + +data MDYPat = Single !Natural + | Multi ![Natural] + | Repeat !RepeatPat + deriving (Eq, Hashable, Generic, FromDhall) + +data Gregorian = Gregorian + { gYear :: !Natural + , gMonth :: !Natural + , gDay :: !Natural + } + deriving (Show, Ord, Eq, Hashable, Generic, FromDhall) + +data GregorianM = GregorianM + { gmYear :: !Natural + , gmMonth :: !Natural + } + deriving (Show, Ord, Eq, Hashable, Generic, FromDhall) + +data ModPat = ModPat + { mpStart :: Maybe Gregorian + , mpBy :: !Natural + , mpUnit :: !TimeUnit + , mpRepeats :: Maybe Natural + } + deriving (Eq, Hashable, Generic, FromDhall) + +data CronPat = CronPat + { cronWeekly :: Maybe WeekdayPat + , cronYear :: Maybe MDYPat + , cronMonth :: Maybe MDYPat + , cronDay :: Maybe MDYPat + } + deriving (Eq, Hashable, Generic, FromDhall) + +data DatePat = Cron !CronPat | Mod !ModPat + deriving (Eq, Hashable, Generic, FromDhall) + +-------------------------------------------------------------------------------- +-- | Budget (projecting into the future) + +data Income = Income + { incGross :: !Decimal + , incCurrency :: !CurID + , incWhen :: !DatePat + , incAccount :: !AcntID + , incPretax :: ![Allocation Decimal] + , incTaxes :: ![Tax] + , incPosttax :: ![Allocation (Maybe Decimal)] + } + deriving (Eq, Hashable, Generic, FromDhall) + +data Budget = Budget + { income :: ![Income] + , expenses :: ![Expense] + } + deriving (Generic, FromDhall) + +data Tax = Tax + { taxAcnt :: !AcntID + , taxValue :: !Decimal + } + deriving (Eq, Hashable, Generic, FromDhall) + +data Amount v = Amount + { amtValue :: !v + , amtDesc :: !T.Text + } deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall) + +data Allocation v = Allocation + { alloPath :: !AcntID + , alloBucket :: !Bucket + , alloAmts :: ![Amount v] + , alloCurrency :: !CurID + } + deriving (Eq, Hashable, Generic, FromDhall) + +data Bucket = Fixed | Investment | Savings | Guiltless + deriving (Show, Eq, Hashable, Generic, FromDhall) + +data TimeAmount = TimeAmount + { taWhen :: !DatePat + , taAmt :: Amount Decimal + } + deriving (Eq, Hashable, Generic, FromDhall) + +data Expense = Expense + { expFrom :: !AcntID + , expTo :: !AcntID + , expBucket :: !Bucket + , expAmounts :: ![TimeAmount] + , expCurrency :: !CurID + } + deriving (Eq, Hashable, Generic, FromDhall) + +-------------------------------------------------------------------------------- +-- | Statements (data from the past) + +data Statement = StmtManual Manual + | StmtImport Import + deriving (Generic, FromDhall) + +data Manual = Manual + { manualDate :: !DatePat + , manualFrom :: !AcntID + , manualTo :: !AcntID + , manualValue :: !Decimal + , manualDesc :: !T.Text + , manualCurrency :: !CurID + } + deriving (Hashable, Generic, FromDhall) + +data Split a v c = Split + { sAcnt :: !a + , sValue :: !v + , sCurrency :: !c + , sComment :: !T.Text + } + deriving (Eq, Generic, Hashable, Show, FromDhall) + +type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur + +data Tx s = Tx + { txDescr :: !T.Text + , txDate :: !Day + , txTags :: ![T.Text] + , txSplits :: ![s] + } + deriving (Generic) + +type ExpTx = Tx ExpSplit + +instance FromDhall ExpTx where + +data Import = Import + { impPaths :: ![FilePath] + , impMatches :: ![Match] + , impDelim :: !Word + , impTxOpts :: !TxOpts + , impSkipLines :: !Natural + } + deriving (Hashable, Generic, FromDhall) + +data MatchVal = MatchVal + { mvSign :: Maybe Bool + , mvNum :: Maybe Natural + , mvDen :: Maybe Natural + , mvPrec :: !Natural + } + deriving (Show, Eq, Hashable, Generic, FromDhall) + +data MatchYMD = Y !Natural | YM !GregorianM | YMD !Gregorian + deriving (Show, Eq, Hashable, Generic, FromDhall) + +data Range a = Range + { rStart :: !a + , rLen :: !Natural + } + deriving (Show, Eq, Hashable, Generic, FromDhall) + +data MatchDate = On !MatchYMD | In (Range MatchYMD) + deriving (Show, Eq, Hashable, Generic, FromDhall) + +-- TODO this just looks silly...but not sure how to simplify it +instance Ord MatchYMD where + compare (Y y) (Y y') = compare y y' + compare (YM g) (YM g') = compare g g' + compare (YMD g) (YMD g') = compare g g' + compare (Y y) (YM g) = compare y (gmYear g) <> LT + compare (Y y) (YMD g) = compare y (gYear g) <> LT + compare (YM g) (Y y') = compare (gmYear g) y' <> GT + compare (YMD g) (Y y') = compare (gYear g) y' <> GT + compare (YM (GregorianM y m)) (YMD (Gregorian y' m' _)) = compare (y, m) (y', m') <> LT + compare (YMD (Gregorian y m _)) (YM (GregorianM y' m')) = compare (y, m) (y', m') <> GT + +instance Ord MatchDate where + compare (On d) (On d') = compare d d' + compare (In (Range d r)) (In (Range d' r')) = compare d d' <> compare r r' + compare (On d) (In (Range d' _)) = compare d d' <> LT + compare (In (Range d _)) (On d') = compare d d' <> GT + +data SplitNum = LookupN !T.Text + | ConstN !Decimal + | AmountN + deriving (Eq, Generic, Hashable, Show, FromDhall) + +-- | the value of a field in split (text version) +-- can either be a raw (constant) value, a lookup from the record, or a map +-- between the lookup and some other value +data SplitText t = ConstT !t + | LookupT !T.Text + | MapT (FieldMap T.Text t) + | Map2T (FieldMap (T.Text, T.Text) t) + deriving (Eq, Generic, Hashable, Show, FromDhall) + +type SplitCur = SplitText CurID + +type SplitAcnt = SplitText AcntID + +data Field k v = Field + { fKey :: !k + , fVal :: !v + } + deriving (Show, Eq, Hashable, Generic, FromDhall) + +type FieldMap k v = Field k (M.Map k v) + +data MatchDesc = Re !T.Text | Exact !T.Text + deriving (Show, Eq, Hashable, Generic, FromDhall) + +data MatchOther = Desc (Field T.Text MatchDesc) + | Val (Field T.Text MatchVal) + deriving (Show, Eq, Hashable, Generic, FromDhall) + +data ToTx = ToTx + { ttCurrency :: !SplitCur + , ttPath :: !SplitAcnt + , ttSplit :: ![ExpSplit] + } + deriving (Eq, Generic, Hashable, Show, FromDhall) + +data Match = Match + { mDate :: Maybe MatchDate + , mVal :: MatchVal + , mDesc :: Maybe MatchDesc + , mOther :: ![MatchOther] + , mTx :: Maybe ToTx + , mTimes :: Maybe Natural + , mPriority :: !Integer + } + deriving (Eq, Generic, Hashable, Show, FromDhall) + +data TxRecord = TxRecord + { trDate :: !Day + , trAmount :: !Rational + , trDesc :: !T.Text + , trOther :: M.Map T.Text T.Text + } + deriving (Show, Eq, Ord) + +data TxOpts = TxOpts + { toDate :: !T.Text + , toAmount :: !T.Text + , toDesc :: !T.Text + , toOther :: ![T.Text] + , toDateFmt :: !String + , toAmountFmt :: !T.Text + } + deriving (Show, Eq, Hashable, Generic, FromDhall) + +-------------------------------------------------------------------------------- +-- | Specialized dhall types + +-- | hacky way to encode a rational +data Decimal = D + { whole :: Natural + , decimal :: Natural + , precision :: Natural + , sign :: Bool + } + deriving (Generic, FromDhall, Hashable, Show, Eq) + +-------------------------------------------------------------------------------- +-- | database cache types + +data ConfigHashes = ConfigHashes + { chIncome :: ![Int] + , chExpense :: ![Int] + , chManual :: ![Int] + , chImport :: ![Int] + } + +data ConfigType = CTIncome | CTExpense | CTManual | CTImport + deriving (Eq, Show, Read, Enum) + +instance PersistFieldSql ConfigType where + sqlType _ = SqlString + +instance PersistField ConfigType where + toPersistValue = PersistText . T.pack . show + -- TODO these error messages *might* be good enough? + fromPersistValue (PersistText v) = + maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v + fromPersistValue _ = Left "wrong type" + +------------------------------------------------------------------------------- +-- | misc + +type Bounds = (Day, Day) + +type MaybeBounds = (Maybe Day, Maybe Day) + +data Keyed a = Keyed + { kKey :: !Int64 + , kVal :: !a + } + deriving (Eq, Show, Functor) + +data Tree a = Branch !a ![Tree a] | Leaf !a deriving Show + +data AcntSign = Credit | Debit + deriving (Show) + +sign2Int :: AcntSign -> Int +sign2Int Debit = 1 +sign2Int Credit = 1 + +accountSign :: AcntType -> AcntSign +accountSign AssetT = Debit +accountSign ExpenseT = Debit +accountSign IncomeT = Credit +accountSign LiabilityT = Credit +accountSign EquityT = Credit + +type RawAmount = Amount (Maybe Rational) + +type BalAmount = Amount Rational + +type RawAllocation = Allocation (Maybe Rational) + +type BalAllocation = Allocation Rational + +type RawSplit = Split AcntID (Maybe Rational) CurID + +type BalSplit = Split AcntID Rational CurID + +type RawTx = Tx RawSplit +type BalTx = Tx BalSplit diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs new file mode 100644 index 0000000..22692a4 --- /dev/null +++ b/lib/Internal/Utils.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Internal.Utils where + +import Data.Bifunctor +import qualified Data.Map as M +import Data.Ratio +import qualified Data.Text as T +import Data.Time + +import GHC.Real + +import Numeric.Natural + +import Internal.Types + +import Text.Read +import Text.Regex.TDFA + +descMatches :: MatchDesc -> T.Text -> Bool +descMatches (Re re) = (=~ re) +descMatches (Exact t) = (== t) + +-- when bifunctor fails... +thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f) +thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) + +toGregorianI :: (Integral a, Integral b, Integral c) => Day -> (a, b, c) +toGregorianI = thrice fromIntegral fromIntegral fromIntegral . toGregorian + +fromGregorianI :: Natural -> Natural -> Natural -> Day +fromGregorianI y m d = + fromGregorian (fromIntegral y) (fromIntegral m) (fromIntegral d) + +toModifiedJulianDayI :: Day -> Natural +toModifiedJulianDayI = fromIntegral . toModifiedJulianDay + +compareDate :: MatchDate -> Day -> Ordering +compareDate (On md) x = case md of + Y y' -> compare sY y' + YM (GregorianM y' m') -> compare (sY, m) (y', m') + YMD (Gregorian y' m' d') -> compare (sY, m, d) (y', m', d') + where + -- TODO make this actually give a real gregorian type, which will clean + -- this up + (y, m, d) = toGregorianI x + sY = y2k y +compareDate (In (Range md o)) x = case md of + Y y' -> compareRange y' o sY + YM (GregorianM y' m') -> let s = toMonth y' m' in compareRange s o $ toMonth sY m + YMD (Gregorian y' m' d') -> + let s = toModifiedJulianDayI $ fromGregorianI (y' + 2000) m' d' + in compareRange s o $ toModifiedJulianDayI x + where + (y, m, _) = toGregorianI x :: (Natural, Natural, Natural) + sY = y2k y + compareRange start offset z + | z < start = LT + | otherwise = if (start + offset) < z then GT else EQ + toMonth year month = (year * 12) + month + +dateMatches :: MatchDate -> Day -> Bool +dateMatches md = (EQ ==) . compareDate md + +-- this apparently can't be eta reduced without triggering an underflow +y2k :: Natural -> Natural +y2k x = x - 2000 + +valMatches :: MatchVal -> Rational -> Bool +valMatches MatchVal {..} x = checkMaybe (s ==) mvSign + && checkMaybe (n ==) mvNum + && checkMaybe ((d * p ==) . fromIntegral) mvDen + where + (n, d) = properFraction $ abs x + p = 10 ^ mvPrec + s = signum x >= 0 + +evalSplit :: TxRecord -> ExpSplit -> RawSplit +evalSplit r s@Split { sAcnt = a, sValue = v, sCurrency = c } = + s { sAcnt = evalAcnt r a + , sValue = evalExp r =<< v + , sCurrency = evalCurrency r c } + +evalAcnt :: TxRecord -> SplitAcnt -> T.Text +evalAcnt TxRecord { trOther = o } s = case s of + ConstT p -> p + LookupT f -> read $ T.unpack $ lookupField f o + MapT (Field f m) -> let k = lookupField f o in lookupErr "account key" k m + Map2T (Field (f1, f2) m) -> let k1 = lookupField f1 o + k2 = lookupField f2 o + in lookupErr "account key" (k1, k2) m + +evalCurrency :: TxRecord -> SplitCur -> T.Text +evalCurrency TxRecord { trOther = o } s = case s of + ConstT p -> p + LookupT f -> lookupField f o + MapT (Field f m) -> let k = lookupField f o in lookupErr "currency key" k m + Map2T (Field (f1, f2) m) -> let k1 = lookupField f1 o + k2 = lookupField f2 o + in lookupErr "currency key" (k1, k2) m + +errorT :: T.Text -> a +errorT = error . T.unpack + +lookupField :: (Ord k, Show k) => k -> M.Map k v -> v +lookupField = lookupErr "field" + +lookupErr :: (Ord k, Show k) => T.Text -> k -> M.Map k v -> v +lookupErr what k m = case M.lookup k m of + Just x -> x + _ -> errorT $ T.concat [what, " does not exist: ", T.pack $ show k] + +matches :: Match -> TxRecord -> Maybe (Maybe RawTx) +matches Match {..} r@TxRecord {..} + | allPass = Just $ fmap eval mTx + | otherwise = Nothing + where + allPass = checkMaybe (`dateMatches` trDate) mDate + && valMatches mVal trAmount + && checkMaybe (`descMatches` trDesc) mDesc + && all (fieldMatches trOther) mOther + eval (ToTx cur a ss) = toTx cur a ss r + +-- TODO these error messages are useless +fieldMatches :: M.Map T.Text T.Text -> MatchOther -> Bool +fieldMatches dict m = case m of + Val (Field n mv) -> case readRational =<< M.lookup n dict of + (Just v) -> valMatches mv v + _ -> error "you dummy" + Desc (Field n md) -> case M.lookup n dict of + (Just d) -> descMatches md d + _ -> error "you dummy" + +checkMaybe :: (a -> Bool) -> Maybe a -> Bool +checkMaybe = maybe True + +toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> RawTx +toTx sc sa toSplits r@TxRecord {..} = + Tx { txTags = [] + , txDate = trDate + , txDescr = trDesc + , txSplits = fromSplit:fmap (evalSplit r) toSplits + } + where + fromSplit = Split { sAcnt = evalAcnt r sa + , sCurrency = evalCurrency r sc + , sValue = Just trAmount + , sComment = "" + } + +parseRational :: MonadFail m => T.Text -> T.Text -> m Rational +parseRational pat s = case ms of + [sign, x, ""] -> uncurry (*) <$> readWhole sign x + [sign, x, y] -> do + d <- readT "decimal" y + let p = 10 ^ T.length y + (k, w) <- readWhole sign x + return $ k * (w + d % p) + _ -> msg "malformed decimal" + where + (_, _, _, ms) = (s =~ pat) :: (T.Text, T.Text, T.Text, [T.Text]) + readT what t = case readMaybe $ T.unpack t of + Just d -> return $ fromInteger d + _ -> msg $ T.unwords ["could not parse", what, t] + msg m = fail $ T.unpack $ T.concat [ m + , "; pattern = ", pat + , "; query = ", s + ] + readSign x + | x == "-" = return (-1) + | x == "+" || x == "" = return 1 + | otherwise = msg $ T.append "invalid sign: " x + readWhole sign x = do + w <- readT "whole number" x + k <- readSign sign + return (k, w) + +readRational :: MonadFail m => T.Text -> m Rational +readRational s = case T.splitOn "." s of + [x] -> return $ fromInteger $ readT x + [x, y] -> let x' = readT x + y' = readT y + p = 10 ^ T.length y + k = if x' >= 0 then 1 else -1 in + if y' > p + then fail "not enough precision to parse" + else return $ fromInteger x' + k * y' % p + _ -> fail $ T.unpack $ T.append "malformed decimal: " s + where + readT = read . T.unpack + +-- TODO smells like a lens +mapTxSplits :: (a -> b) -> Tx a -> Tx b +mapTxSplits f t@Tx { txSplits = ss } = t { txSplits = fmap f ss } + +boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds +boundsFromGregorian = bimap fromGregorian' fromGregorian' + +fromGregorian' :: Gregorian -> Day +fromGregorian' (Gregorian y m d) = fromGregorianI y m d + +inBounds :: Bounds -> Day -> Bool +inBounds (d0, d1) x = d0 <= x && x <= d1 + +inMaybeBounds :: MaybeBounds -> Day -> Bool +inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1 + +intervalMaybeBounds :: Interval -> MaybeBounds +intervalMaybeBounds Interval { intStart = s, intEnd = e } = + (fromGregorian' <$> s, fromGregorian' <$> e) + +resolveBounds :: MaybeBounds -> IO Bounds +resolveBounds (s, e) = do + s' <- maybe getDay return s + e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e + return (s', e') + where + getDay = utctDay <$> getCurrentTime + +fmtRational :: Natural -> Rational -> T.Text +fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d'] + where + s = if x >= 0 then "" else "-" + x'@(n:%d) = abs x + p = 10 ^ precision + n' = toInteger $ div n d + d' = toInteger $ (\(a:%b) -> div a b) ((x' - fromIntegral n') * p) + txt = T.pack . show + pad i c z = T.append (T.replicate (i - T.length z) c) z + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c + +lpad :: a -> Int -> [a] -> [a] +lpad c n s = replicate (n - length s) c ++ s + +rpad :: a -> Int -> [a] -> [a] +rpad c n s = s ++ replicate (n - length s) c + +evalExp :: TxRecord -> SplitNum -> Maybe Rational +evalExp r s = case s of + (LookupN t) -> readRational =<< M.lookup t (trOther r) + (ConstN c) -> Just $ dec2Rat c + AmountN -> Just $ trAmount r + +dec2Rat :: Decimal -> Rational +dec2Rat (D w d p s) = k * (fromIntegral w + (fromIntegral d % (10 ^ p))) + where + k = if s then 1 else -1 + +acntPath2Text :: AcntPath -> T.Text +acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..20ed72b --- /dev/null +++ b/package.yaml @@ -0,0 +1,76 @@ +name: budget +version: 0.1.0.0 +github: "ndwarshuis/budget" +license: BSD3 +author: "Nathan Dwarshuis" +maintainer: "ndwar@yavin4.ch" +copyright: "2022 Nathan Dwarshuis" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.12 && < 10 +# - rio >= 0.1.22.0 +- persistent >= 2.13.3.1 +- persistent-sqlite >= 2.13.1.0 +- monad-logger >= 0.3.36 +- conduit >= 1.3.4.2 +- dhall >= 1.41.2 +- lens >= 5.0.1 +- text >= 1.2.5.0 +- time >= 1.9.3 +- containers >= 0.6.4.1 +- ghc >= 9.0.2 +- cassava +- bytestring +- vector +- regex-tdfa +- utf8-string +- transformers +- esqueleto +- template-haskell +- hashable +- yaml +- optparse-applicative +- recursion-schemes +- data-fix + +library: + source-dirs: lib/ + ghc-options: + - -Wall + - -Werror + - -threaded + - -Wpartial-fields + exposed-modules: + - Internal.Config + - Internal.Types + - Internal.Utils + - Internal.Database.Ops + - Internal.Database.Model + - Internal.Insert + - Internal.Statement + +executables: + pwncash: + main: Main.hs + source-dirs: app + ghc-options: + - -Wall + - -Werror + - -threaded + - -Wpartial-fields + - -O2 + dependencies: + - budget diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..d9f489b --- /dev/null +++ b/stack.yaml @@ -0,0 +1,70 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml + +# this resolver has persistent < version 2.13.3.4 which introduced a nasty +# name shadow bug +resolver: lts-19.2 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +# packages: +# - . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +extra-deps: + # this version isn't on the LTS yet and has an instance for DayOfWeek +- dhall-1.41.2@sha256:556edac8997a5fcf451c9bbb151b1f04996318019799724cc71cc03a9a9122be,16281 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.7" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor