initial commit
This commit is contained in:
commit
c2ccadd943
|
|
@ -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
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
|
@ -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 <https://github.com/ndwarshuis/budget#readme>
|
||||
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
|
||||
|
|
@ -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 }
|
||||
|
|
@ -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
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -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 (:[]))
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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 <https://github.com/ndwarshuis/budget#readme>
|
||||
|
||||
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
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue