diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Application.hs | 3 | ||||
| -rw-r--r-- | Foundation.hs | 12 | ||||
| -rw-r--r-- | Hledger/JournalCSVs.hs | 41 | ||||
| -rw-r--r-- | Hledger/RegisterCSV.hs | 64 | ||||
| -rw-r--r-- | Settings.hs | 1 | ||||
| -rw-r--r-- | app/main.hs (renamed from main.hs) | 0 | ||||
| -rw-r--r-- | sflc-ledger-reports.cabal | 70 | ||||
| -rw-r--r-- | stack.yaml | 1 | ||||
| -rw-r--r-- | stack.yaml.lock | 12 |
10 files changed, 98 insertions, 107 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..0caeeda --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +/.stack-work diff --git a/Application.hs b/Application.hs index 2a16ab7..6c84b87 100644 --- a/Application.hs +++ b/Application.hs @@ -1,4 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ViewPatterns #-} + module Application ( makeApplication , getApplicationDev @@ -17,7 +19,6 @@ import Network.HTTP.Client.Conduit (newManager) import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize) import Network.Wai.Logger (clockDateCacher) import Data.Default (def) -import Data.Yaml ((.:)) import Control.Monad (mzero) import Yesod.Core.Types (loggerSet, Logger (Logger)) diff --git a/Foundation.hs b/Foundation.hs index c3c8cf0..46faef1 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ViewPatterns #-} + module Foundation where import Prelude @@ -85,12 +87,6 @@ instance Yesod App where $(widgetFile "default-layout") giveUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - -- This is done to provide an optimization for serving static files from - -- a separate domain. Please see the staticRoot setting in Settings.hs - urlRenderOverride y (StaticR s) = - Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s - urlRenderOverride _ _ = Nothing - -- Routes not requiring authenitcation. isAuthorized FaviconR _ = return Authorized isAuthorized RobotsR _ = return Authorized @@ -114,8 +110,8 @@ instance Yesod App where -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog _ _source level = - development || level == LevelWarn || level == LevelError + shouldLogIO _ _source level = return $ + development || level == LevelWarn || level == LevelError makeLogger = return . appLogger diff --git a/Hledger/JournalCSVs.hs b/Hledger/JournalCSVs.hs index 1d5ac5f..f70b8a5 100644 --- a/Hledger/JournalCSVs.hs +++ b/Hledger/JournalCSVs.hs @@ -15,32 +15,34 @@ -- along with this program. If not, see <http://www.gnu.org/licenses/>. {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} module Hledger.JournalCSVs (pAndL, assets, liabilities, everything, JReportType(..)) where -import Prelude (Enum(..), String, Integer, Int, Eq, Show, (.), ($), (*), (+), (++), (==), (&&), (>>=), (=<<), const, div, length, lookup, map, mod, subtract, filter, flip, fromIntegral, fst, return, snd, head, last, error, uncurry, Maybe(..), Bool(..), Either(..), IO, FilePath, Read) +import Prelude (Enum(..), Integer, Int, Eq, Show, (.), ($), (*), (+), (++), (==), (>>=), (=<<), const, div, lookup, map, mod, subtract, flip, fromIntegral, fst, return, snd, head, last, error, uncurry, Maybe(..), Bool(..), Either(..), IO, FilePath, Read) import Control.Applicative (liftA2) import Control.Monad (ap, when) -import Data.Conduit (($$), ($=)) +import Data.Conduit (runConduit, (.|)) import qualified Data.Conduit.List as CL import Data.CSV.Conduit (fromCSV, defCSVSettings, runResourceT) -import Data.List (nub, sort, sortBy, isPrefixOf, intercalate) -import Data.List.Split (splitOn) +import Data.List (nub, sort, sortBy) import Data.Maybe (fromMaybe) import Data.Ord (comparing) import qualified Data.Text as T import Data.Time.Calendar (fromGregorian, toGregorian, Day(..)) import Data.Time.Format (formatTime) -import Data.Tree (Tree(..)) -import System.Locale (defaultTimeLocale) +import Data.Time.Format (defaultTimeLocale) import Hledger.Data.Amount (showMixedAmount) import Hledger.Data.Journal (journalProfitAndLossAccountQuery, journalAssetAccountQuery, journalLiabilityAccountQuery) -import Hledger.Data.Types (DateSpan(..), Journal(..), Transaction(..)) +import Hledger.Data.Types (DateSpan(..), Journal(..), Transaction(..), MixedAmount (..)) import Hledger.Query (Query(..)) -import Hledger.Read (readJournalFile) +import Hledger.Read (readJournalFile, definputopts) import Hledger.Reports (balanceReport, defreportopts, ReportOpts(..)) +showMixedAmountT :: MixedAmount -> T.Text +showMixedAmountT = T.pack . showMixedAmount + data JReportType = PandL | Assets | Liabilities | Everything deriving (Eq, Read, Show) @@ -57,7 +59,7 @@ everything :: FilePath -> IO T.Text everything fn = fn2CSV (const Any) fn fn2CSV :: (Journal -> Query) -> FilePath -> IO T.Text -fn2CSV q fn = readJournalFile Nothing Nothing fn >>= \(Right j) -> jToCSV True j (q j) +fn2CSV q fn = readJournalFile definputopts fn >>= \(Right j) -> jToCSV True j (q j) -- sign-change Income lines @@ -84,12 +86,13 @@ jToCSV delta jnl q = do when (firstMonth == lastMonth) $ error "Need multiple months" let reports = map (\m -> balanceReport defreportopts { no_elide_ = True } (q' m) jnl) [firstMonth..lastMonth] reportT = balanceReport defreportopts { no_elide_ = True } Any jnl - reports' = map (map (\((n, _, _), a) -> (n, showMixedAmount a)) . fst) reports - reportT' = (map (\((n, _, _), a) -> (n, showMixedAmount a)) . fst) reportT + reports' = map (map (\(n, _, _, a) -> (n, showMixedAmountT a)) . fst) reports + reportT' = (map (\(n, _, _, a) -> (n, showMixedAmountT a)) . fst) reportT allaccounts = sort . nub . (map fst =<<) $ reports' concordant = map (\x -> x : fetchSeries reports' x ++ fetchSeries [reportT'] x) allaccounts - withheader = ("Account":map (formatTime defaultTimeLocale "%b of %Y" . yearMonthToDay) [firstMonth..lastMonth] ++ ["Period Total"]):concordant - c <- runResourceT $ CL.sourceList withheader $= CL.map (map T.pack) $= fromCSV defCSVSettings $$ CL.consume + withheader = ("Account":map (T.pack . formatTime defaultTimeLocale "%b of %Y" . yearMonthToDay) [firstMonth..lastMonth] ++ ["Period Total"]):concordant + c <- runResourceT . runConduit $ + CL.sourceList withheader .| fromCSV defCSVSettings .| CL.consume return $ T.concat c dS :: Bool -> YearMonth -> DateSpan @@ -98,15 +101,5 @@ dS delta (YearMonth (y,m)) = DateSpan (if delta then Just startD else Nothing) ( startD = fromGregorian y m 01 endD = fromGregorian y m 31 -fetchSeries :: [[(String, String)]] -> String -> [String] +fetchSeries :: [[(T.Text, T.Text)]] -> T.Text -> [T.Text] fetchSeries rs a = map (fromMaybe "$0.00" . lookup a) rs - -chirren :: [String] -> [[String]] -> [[String]] -chirren p = filter (\x -> length x == (length p + 1) && isPrefixOf p x) - -accts2Tree :: [[String]] -> Tree String -accts2Tree as = Node "" (subtrees []) - where - subtrees xs = map (\x -> Node (colonize x) (subtrees x)) (chirren xs as) - colonize = intercalate ":" - diff --git a/Hledger/RegisterCSV.hs b/Hledger/RegisterCSV.hs index 69fec77..dd5ee6c 100644 --- a/Hledger/RegisterCSV.hs +++ b/Hledger/RegisterCSV.hs @@ -15,30 +15,25 @@ -- along with this program. If not, see <http://www.gnu.org/licenses/>. {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} module Hledger.RegisterCSV (convertJournalToRegisterCSV) where -import Prelude (String, Double, Show, Eq, (||), Bool(..), const, (<), (>), snd, (.), ($), maybe, show, id, length, (==), (/=), head, map, FilePath, IO, Either(..), Maybe(..), return, concatMap, Char, otherwise) +import Prelude (String, Double, Show, Eq, (||), Bool(..), const, (<), (>), snd, (.), ($), maybe, show, id, length, (==), (/=), head, map, FilePath, IO, Either(..), return, concatMap, Char, otherwise) import Control.Applicative (many) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Resource (MonadThrow) -import Control.Monad.Primitive (PrimMonad) -import Control.Monad.Base (MonadBase) -import Data.List (isPrefixOf) import qualified Data.Text as T import Hledger.Data.Amount (showMixedAmount) import Hledger.Data.Journal (journalAccountNamesUsed) import Hledger.Data.Types (Journal(..), Transaction(..), Posting(..), MixedAmount(..)) import Hledger.Query (Query(..)) -import Hledger.Read (readJournalFile) +import Hledger.Read (readJournalFile, definputopts) import Hledger.Reports (postingsReport, defreportopts, PostingsReportItem) -import Data.Conduit (($=),($$)) -import Control.Monad.Trans.Resource (runResourceT) +import Data.Conduit (runConduit, (.|)) +import Control.Monad.Trans.Resource (MonadUnliftIO (), runResourceT) import qualified Data.Conduit.List as CL import Data.CSV.Conduit (fromCSV, defCSVSettings, CSV) @@ -47,27 +42,29 @@ import Text.Parsec.Combinator (many1) import Text.Parsec.Prim (ParsecT, Stream, parse) data AcctReg = AcctReg { - _acct :: String + _acct :: T.Text , _openingBalance :: Double , _items :: [PostingsReportItem] } deriving (Show, Eq) -cordGuess :: String -> MixedAmount -> T.Text +cordGuess :: T.Text -> MixedAmount -> T.Text cordGuess acct - | "Assets:" `isPrefixOf` acct || "Liabilities:" `isPrefixOf` acct || "Equity:" `isPrefixOf` acct = cordGuest' True - | "Income:" `isPrefixOf` acct || "Expenses:" `isPrefixOf` acct = cordGuest' False - | otherwise = const (T.pack "INVALID") + | "Assets:" `T.isPrefixOf` acct || "Liabilities:" `T.isPrefixOf` acct || "Equity:" `T.isPrefixOf` acct = cordGuest' True + | "Income:" `T.isPrefixOf` acct || "Expenses:" `T.isPrefixOf` acct = cordGuest' False + | otherwise = const "INVALID" where - cordGuest' True amt | amt > 0 = T.pack "Deposit" - cordGuest' True _ = T.pack "Check" - cordGuest' False amt | amt > 0 = T.pack "Check" - cordGuest' False _ = T.pack "Deposit" + cordGuest' True amt | amt > 0 = "Deposit" + cordGuest' True _ = "Check" + cordGuest' False amt | amt > 0 = "Check" + cordGuest' False _ = "Deposit" -acctReg :: String -> Journal -> AcctReg -acctReg a j = AcctReg a 0 (snd . postingsReport defreportopts (Acct a) $ j) +acctReg :: T.Text -> Journal -> AcctReg +acctReg a j = AcctReg a 0 (snd . postingsReport defreportopts (Acct . T.unpack $ a) $ j) + +-- (Maybe Day, Maybe Day, Maybe String, Posting, MixedAmount) priToLine :: PostingsReportItem -> [T.Text] -priToLine (mday, mdesc, p, mixa) = [T.empty, cord, date, num, name, memo, split, amt, bal] +priToLine (mday, _, mdesc, p, mixa) = [T.empty, cord, date, num, name, memo, split, amt, bal] where date = maybe T.empty (T.pack . show) mday desc' = maybe "" id mdesc @@ -82,32 +79,29 @@ priToLine (mday, mdesc, p, mixa) = [T.empty, cord, date, num, name, memo, split, splitField :: [Posting] -> T.Text splitField ps - | length ps < 2 = T.pack "ERROR" - | length ps == 2 = T.pack (paccount . head $ ps) - | otherwise = T.pack "-SPLIT-" + | length ps < 2 = "ERROR" + | length ps == 2 = paccount . head $ ps + | otherwise = "-SPLIT-" arToLines :: AcctReg -> [[T.Text]] -arToLines ar = [T.pack . _acct $ ar,T.empty,T.empty,T.empty,T.empty,T.empty,T.empty,T.empty,T.pack "0.000000"]:map priToLine (_items ar) +arToLines ar = [_acct ar,"","","","","","","","0.000000"]:map priToLine (_items ar) convertJournalToRegisterCSV :: FilePath -> IO (T.Text) convertJournalToRegisterCSV fp = do - Right j <- readJournalFile Nothing Nothing fp + Right j <- readJournalFile definputopts fp csv <- journalToRegisterCSV j return $ T.concat csv -journalToRegisterCSV :: ( PrimMonad base, - MonadBase base m, - MonadThrow m, - MonadIO m, - CSV a [T.Text], - MonadBaseControl IO m) +journalToRegisterCSV :: ( MonadUnliftIO m + , CSV a [T.Text]) => Journal -> m [a] journalToRegisterCSV j = do let accts = journalAccountNamesUsed j precsv' = concatMap (\x -> arToLines $ acctReg x j) accts - precsv = [T.empty, T.pack "Type",T.pack "Date",T.pack "Num",T.pack "Name",T.pack "Memo",T.pack "Split",T.pack "Amount",T.pack "Balance"]:precsv' - csv <- runResourceT $ CL.sourceList precsv $= fromCSV defCSVSettings $$ CL.consume + precsv = ["","Type","Date","Num","Name","Memo","Split","Amount","Balance"]:precsv' + csv <- runResourceT . runConduit $ + CL.sourceList precsv .| fromCSV defCSVSettings .| CL.consume return csv parseDesc :: String -> (String, String) diff --git a/Settings.hs b/Settings.hs index 87173c1..dd15cd3 100644 --- a/Settings.hs +++ b/Settings.hs @@ -13,7 +13,6 @@ import Yesod.Default.Config import Yesod.Default.Util import Data.Text (Text) import Data.Yaml -import Control.Applicative import Settings.Development import Data.Default (def) import Text.Hamlet diff --git a/sflc-ledger-reports.cabal b/sflc-ledger-reports.cabal index 7a03238..b246761 100644 --- a/sflc-ledger-reports.cabal +++ b/sflc-ledger-reports.cabal @@ -52,45 +52,41 @@ library EmptyDataDecls NoMonomorphismRestriction - build-depends: base >= 4 && < 5 - , yesod >= 1.2 && < 1.3 - , yesod-core >= 1.2 && < 1.3 - , yesod-auth >= 1.3 && < 1.4 - , yesod-static >= 1.2 && < 1.3 - , yesod-default >= 1.2 && < 1.3 - , yesod-form >= 1.3 && < 1.4 - , yesod-test >= 1.2 && < 1.3 - , clientsession >= 0.9 && < 0.10 - , bytestring >= 0.9 && < 0.11 - , text >= 0.11 && < 0.12 - , persistent >= 1.3 && < 1.4 - , persistent-sqlite >= 1.3 && < 1.4 + build-depends: base + , yesod + , yesod-core + , yesod-auth + , yesod-static + , yesod-form + , yesod-test + , clientsession + , bytestring + , text + , persistent + , persistent-sqlite , template-haskell - , hamlet >= 1.0 && < 1.2 - , shakespeare-css >= 1.0 && < 1.1 - , shakespeare-js >= 1.0 && < 1.3 - , shakespeare-text >= 1.0 && < 1.1 - , hjsmin >= 0.1 && < 0.2 - , monad-control >= 0.3 && < 0.4 - , wai-extra >= 3.0 && < 3.1 - , wai-logger >= 2.1 && < 2.2 - , yaml >= 0.8 && < 0.9 - , http-conduit >= 2.1 && < 2.2 - , directory >= 1.1 && < 1.3 - , warp >= 3.0 && < 3.1 - , fast-logger >= 2.1 && < 2.2 - , parsec >= 3 - , csv-conduit >= 0.2 - , conduit >= 0.4 - , hledger-lib >= 0.18.1 - , bifunctors >= 0.1.3.3 - , resourcet >= 0.3.2.1 - , transformers >= 0.3.0.0 + , shakespeare + , hjsmin + , monad-control + , wai-extra + , wai-logger + , yaml + , http-conduit + , directory + , warp + , fast-logger + , parsec + , csv-conduit + , conduit + , hledger-lib + , bifunctors + , resourcet + , transformers , containers , old-locale , time , split - , monad-logger >= 0.3 && < 0.4 + , monad-logger , transformers-base , primitive , data-default @@ -99,11 +95,10 @@ executable sflc-ledger-reports if flag(library-only) Buildable: False - main-is: ../main.hs - hs-source-dirs: dist + hs-source-dirs: app + main-is: main.hs build-depends: base , sflc-ledger-reports - , yesod-default , yesod test-suite test @@ -126,7 +121,6 @@ test-suite test build-depends: base , sflc-ledger-reports , yesod-test - , yesod-default , yesod-core , yesod , hspec diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..53095f7 --- /dev/null +++ b/stack.yaml @@ -0,0 +1 @@ +resolver: lts-16.31 diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..c222190 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 534126 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml + sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6 + original: lts-16.31 |