From 768f1fe755974ca7262979f956ee07fd9880824c Mon Sep 17 00:00:00 2001 From: Adrian Sieber Date: Thu, 8 Feb 2024 22:15:41 +0000 Subject: [PATCH] Auto-format all code with purs-tidy --- .tidyrc.json | 3 + package-lock.json | 16 +- package.json | 3 +- src/CliSpec.purs | 112 ++++--- src/CliSpec/Parser.purs | 224 +++++++------ src/CliSpec/Tokenizer.purs | 53 ++- src/CliSpec/Types.purs | 48 ++- src/Main.purs | 221 +++++++------ src/Transity/ApproxRatio.purs | 1 - src/Transity/Data/Account.purs | 64 ++-- src/Transity/Data/Amount.purs | 22 +- src/Transity/Data/Balance.purs | 10 +- src/Transity/Data/CommodityMap.purs | 36 +-- src/Transity/Data/Config.purs | 2 - src/Transity/Data/Entity.purs | 69 ++-- src/Transity/Data/Ledger.purs | 457 ++++++++++++++------------ src/Transity/Data/Transaction.purs | 57 ++-- src/Transity/Data/Transfer.purs | 84 ++--- src/Transity/Plot.purs | 115 +++---- src/Transity/Utils.purs | 211 +++++++----- src/Transity/Xlsx.purs | 187 +++++------ src/Webapp.purs | 1 - test/CliSpec.purs | 466 ++++++++++++++------------- test/Fixtures.purs | 172 +++++----- test/Main.purs | 481 +++++++++++++++------------- 25 files changed, 1659 insertions(+), 1456 deletions(-) create mode 100644 .tidyrc.json diff --git a/.tidyrc.json b/.tidyrc.json new file mode 100644 index 0000000..25d327e --- /dev/null +++ b/.tidyrc.json @@ -0,0 +1,3 @@ +{ + "width": 80 +} diff --git a/package-lock.json b/package-lock.json index 14ebcee..0f93e24 100644 --- a/package-lock.json +++ b/package-lock.json @@ -14,7 +14,8 @@ "big-integer": "^1.6.52", "chrono-node": "^2.7.5", "csvnorm": "^1.1.0", - "js-yaml": "^4.1.0" + "js-yaml": "^4.1.0", + "purs-tidy": "^0.10.1" }, "bin": { "transity": "index.js" @@ -11500,6 +11501,14 @@ "integrity": "sha512-3wdGidZyq5PB084XLES5TpOSRA3wjXAlIWMhum2kRcv/41Sn2emQ0dycQW4uZXLejwKvg6EsvbdlVL+FYEct7A==", "dev": true }, + "node_modules/purs-tidy": { + "version": "0.10.1", + "resolved": "https://registry.npmjs.org/purs-tidy/-/purs-tidy-0.10.1.tgz", + "integrity": "sha512-i1QvMaDEaZXv/GWZNFWs5CISiBOkwPhG4D1S4Rw6zUCGaE+NQNWTjvwY21rifynGa2N2TiBJRC61LkORbmGxrA==", + "bin": { + "purs-tidy": "bin/index.js" + } + }, "node_modules/qs": { "version": "6.5.2", "resolved": "https://registry.npmjs.org/qs/-/qs-6.5.2.tgz", @@ -21766,6 +21775,11 @@ } } }, + "purs-tidy": { + "version": "0.10.1", + "resolved": "https://registry.npmjs.org/purs-tidy/-/purs-tidy-0.10.1.tgz", + "integrity": "sha512-i1QvMaDEaZXv/GWZNFWs5CISiBOkwPhG4D1S4Rw6zUCGaE+NQNWTjvwY21rifynGa2N2TiBJRC61LkORbmGxrA==" + }, "qs": { "version": "6.5.2", "resolved": "https://registry.npmjs.org/qs/-/qs-6.5.2.tgz", diff --git a/package.json b/package.json index 656cb32..f5f70e5 100644 --- a/package.json +++ b/package.json @@ -41,7 +41,8 @@ "big-integer": "^1.6.52", "chrono-node": "^2.7.5", "csvnorm": "^1.1.0", - "js-yaml": "^4.1.0" + "js-yaml": "^4.1.0", + "purs-tidy": "^0.10.1" }, "optionalDependencies": { "converter": "0.0.5", diff --git a/src/CliSpec.purs b/src/CliSpec.purs index 41413a4..6233600 100644 --- a/src/CliSpec.purs +++ b/src/CliSpec.purs @@ -21,7 +21,6 @@ import Effect (Effect) import Effect.Class.Console (log, error) import Node.Process (argv, setExitCode) - -- TODO: Automatically disable colors if not supported makeRed :: String -> String makeRed str = @@ -31,14 +30,12 @@ makeYellow :: String -> String makeYellow str = withGraphics (foreground Yellow) str - errorAndExit :: String -> Effect (Result String Unit) errorAndExit message = do error (makeRed message) setExitCode 1 pure $ Error message - parseCliSpec :: String -> Result String CliSpec parseCliSpec cliSpecJsonStr = do let cliSpecRes = fromEither $ jsonParser cliSpecJsonStr @@ -51,13 +48,12 @@ parseCliSpec cliSpecJsonStr = do # (lmap printJsonDecodeError) # fromEither - callCommand :: CliSpec -> String -> Array CliArgument -> (String -> String -> Array CliArgument -> Effect (Result String Unit)) - -> Effect (Result String Unit) + -> Effect (Result String Unit) callCommand (CliSpec cliSpec) usageString args executor = do case args # head of Nothing -> do @@ -65,33 +61,37 @@ callCommand (CliSpec cliSpec) usageString args executor = do setExitCode 1 pure (Error "No arguments provided") - Just firstArg | firstArg == FlagShort 'h' - || firstArg == FlagLong "help" - || firstArg == CmdArg "help" -> do - log usageString - pure $ Ok unit + Just firstArg + | firstArg == FlagShort 'h' + || firstArg == FlagLong "help" + || firstArg == CmdArg "help" -> do + log usageString + pure $ Ok unit - Just firstArg | firstArg == FlagShort 'v' - || firstArg == FlagLong "version" - || firstArg == CmdArg "version" -> do - log usageString - pure $ Ok unit + Just firstArg + | firstArg == FlagShort 'v' + || firstArg == FlagLong "version" + || firstArg == CmdArg "version" -> do + log usageString + pure $ Ok unit Just _mainCmd -> case args # drop 1 # head of - Just arg | arg == (CmdArg "help") - || arg == (FlagLong "help") - || arg == (FlagShort 'h') -> do - -- TODO: Only show help for subcommand - log usageString - pure $ Ok unit - - Just arg | arg == (CmdArg "version") - || arg == (FlagLong "version") - || arg == (FlagShort 'v') -> do - -- TODO: Only show version of subcommand (if available) - log (cliSpec.version # fromMaybe "0") - pure $ Ok unit + Just arg + | arg == (CmdArg "help") + || arg == (FlagLong "help") + || arg == (FlagShort 'h') -> do + -- TODO: Only show help for subcommand + log usageString + pure $ Ok unit + + Just arg + | arg == (CmdArg "version") + || arg == (FlagLong "version") + || arg == (FlagShort 'v') -> do + -- TODO: Only show version of subcommand (if available) + log (cliSpec.version # fromMaybe "0") + pure $ Ok unit Just (CmdArg cmdName) -> do let @@ -102,8 +102,9 @@ callCommand (CliSpec cliSpec) usageString args executor = do case commandMb of Nothing -> do - let errStr = - makeRed ("ERROR: Unknown command \"" <> cmdName <> "\"") + let + errStr = + makeRed ("ERROR: Unknown command \"" <> cmdName <> "\"") <> "\n\n" <> usageString log errStr @@ -114,8 +115,9 @@ callCommand (CliSpec cliSpec) usageString args executor = do executor cmdName usageString providedArgs Just arg -> do - let errMsg = - "ERROR: First argument must be a command and not \"" + let + errMsg = + "ERROR: First argument must be a command and not \"" <> cliArgToString arg <> "\"\n\n" log $ makeRed $ errMsg <> usageString @@ -127,13 +129,11 @@ callCommand (CliSpec cliSpec) usageString args executor = do setExitCode 1 pure $ Error "No arguments provided" - -- | Function to repeat a string n times repeatString :: String -> Int -> String repeatString str n = fold $ replicate n str - callCliApp :: CliSpec -> (String -> String -> Array CliArgument -> Effect (Result String Unit)) @@ -144,32 +144,40 @@ callCliApp cliSpec@(CliSpec cliSpecRaw) executor = do lengthLongestCmd = cliSpecRaw.commands # fromMaybe [] - # foldl (\acc (CliSpec cmd) -> - if acc > Str.length cmd.name - then acc - else Str.length cmd.name - ) 0 + # foldl + ( \acc (CliSpec cmd) -> + if acc > Str.length cmd.name then acc + else Str.length cmd.name + ) + 0 usageString = "USAGE: " <> cliSpecRaw.name <> " [options]" - <> "\n\n" - <> cliSpecRaw.description - <> "\n\n" - <> "COMMANDS:" - <> "\n\n" - <> (cliSpecRaw.commands - # fromMaybe [] - # foldMap (\(CliSpec cmd) -> - cmd.name - <> (repeatString " " (lengthLongestCmd - Str.length cmd.name)) - <> " " <> cmd.description <> "\n" - ) + <> "\n\n" + <> cliSpecRaw.description + <> "\n\n" + <> "COMMANDS:" + <> "\n\n" + <> + ( cliSpecRaw.commands + # fromMaybe [] + # foldMap + ( \(CliSpec cmd) -> + cmd.name + <> + ( repeatString " " + (lengthLongestCmd - Str.length cmd.name) + ) + <> " " + <> cmd.description + <> "\n" + ) ) arguments <- argv let - argsNoInterpreter = arguments # drop 1 -- Drop "node" + argsNoInterpreter = arguments # drop 1 -- Drop "node" cliArgsMb = tokensToCliArguments cliSpec diff --git a/src/CliSpec/Parser.purs b/src/CliSpec/Parser.purs index 1008ba9..2c345a2 100644 --- a/src/CliSpec/Parser.purs +++ b/src/CliSpec/Parser.purs @@ -2,8 +2,7 @@ module CliSpec.Parser ( findFlagLong , findSubCmd , tokensToCliArguments - ) - where + ) where import Data.Result @@ -16,14 +15,12 @@ import Data.Traversable (sequence) import Data.Tuple (Tuple(Tuple)) import Prelude (show, (#), ($), (&&), (/=), (<#>), (<>), (==)) - findFlagShort :: Maybe (Array Option) -> Char -> Maybe Option findFlagShort cliSpecOptionsMb flagChar = do cliSpecOptionsMb # fromMaybe [] # find (\opt -> opt.shortName == Just (singleton flagChar)) - findFlagLong :: Maybe (Array Option) -> String -> Maybe Option findFlagLong cliSpecOptionsMb flagName = do cliSpecOptionsMb @@ -36,21 +33,18 @@ findOptionShort cliSpecOptionsMb flagChar = do # fromMaybe [] # find (\opt -> opt.shortName == Just (singleton flagChar)) - findOptionLong :: Maybe (Array Option) -> String -> Maybe Option findOptionLong cliSpecOptionsMb flagName = do cliSpecOptionsMb # fromMaybe [] # find (\opt -> opt.name == Just flagName) - findSubCmd :: Maybe (Array CliSpec) -> String -> Maybe CliSpec -findSubCmd cliSpecCommands value = do +findSubCmd cliSpecCommands value = do cliSpecCommands # fromMaybe [] # find (\(CliSpec cmd) -> cmd.name == value) - -- | Verify that the remaining tokens are allowed -- | for the given command specification and return -- | the corresponding `CliArgument`s. @@ -65,45 +59,47 @@ verifyTokensAreAllowed (CliSpec cliSpecRaw) tokens = do tokens argsAndTokens - # (foldl - (\(Tuple cliArgs remainingTokens) (Tuple arg token) -> - if remainingTokens == [] - then - -- Finish looping, but don't change cliArgs anymore - Tuple cliArgs [] - else - case arg.type, token of - "Text", TextToken txt -> - Tuple - (cliArgs <> [Ok $ ValArg (TextArg txt)]) - (remainingTokens # drop 1) - - "List-Text", TextToken _ -> - Tuple - (cliArgs - <> [(remainingTokens - <#> (\tok -> case tok of - TextToken t -> Ok $ TextArg t - _ -> Error $ "Unsupported token: " <> show tok - ) - # sequence - <#> ValArgList - )] - ) - [] -- No more remaining tokens - - _, _ -> - Tuple - (cliArgs <> [Error $ "Invalid argument:" <> show arg]) - (remainingTokens # drop 1) - ) - (Tuple [] tokens) + # + ( foldl + ( \(Tuple cliArgs remainingTokens) (Tuple arg token) -> + if remainingTokens == [] then + -- Finish looping, but don't change cliArgs anymore + Tuple cliArgs [] + else + case arg.type, token of + "Text", TextToken txt -> + Tuple + (cliArgs <> [ Ok $ ValArg (TextArg txt) ]) + (remainingTokens # drop 1) + + "List-Text", TextToken _ -> + Tuple + ( cliArgs + <> + [ ( remainingTokens + <#> + ( \tok -> case tok of + TextToken t -> Ok $ TextArg t + _ -> Error $ "Unsupported token: " <> + show tok + ) + # sequence + <#> ValArgList + ) + ] + ) + [] -- No more remaining tokens + + _, _ -> + Tuple + (cliArgs <> [ Error $ "Invalid argument:" <> show arg ]) + (remainingTokens # drop 1) + ) + (Tuple [] tokens) ) # (\(Tuple cliArgs _) -> cliArgs) # sequence - - -- | Determine the correct value of the `CliArgToken`s -- | by matching them against the spec. -- | Especially for the differentiation between `Option`s and `Flag`s. @@ -118,8 +114,7 @@ tokensToCliArguments cliSpec@(CliSpec cliSpecRaw) tokens = do Just (TextToken cmdName) -> if cliSpecRaw.name /= cmdName && - cliSpecRaw.enforceValidName == Just true - then Error $ + cliSpecRaw.enforceValidName == Just true then Error $ "ERROR: \"" <> cliSpecRaw.name <> "\" is executed with the differently named executable \"" @@ -127,17 +122,17 @@ tokensToCliArguments cliSpec@(CliSpec cliSpecRaw) tokens = do <> "\"" else Ok cliSpec _ -> Error $ - "Something went wrong. " - <> "The first token should be a command or a value." + "Something went wrong. " + <> "The first token should be a command or a value." case tokens # drop 1 # head of - Just (FlagShortToken 'h') -> Ok [FlagShort 'h'] - Just (FlagLongToken "help") -> Ok [FlagLong "help"] - Just (TextToken "help") -> Ok [CmdArg "help"] + Just (FlagShortToken 'h') -> Ok [ FlagShort 'h' ] + Just (FlagLongToken "help") -> Ok [ FlagLong "help" ] + Just (TextToken "help") -> Ok [ CmdArg "help" ] - Just (FlagShortToken 'v') -> Ok [FlagShort 'v'] - Just (FlagLongToken "version") -> Ok [FlagLong "version"] - Just (TextToken "version") -> Ok [CmdArg "version"] + Just (FlagShortToken 'v') -> Ok [ FlagShort 'v' ] + Just (FlagLongToken "version") -> Ok [ FlagLong "version" ] + Just (TextToken "version") -> Ok [ CmdArg "version" ] -- | If first token after the main command is a subcommand -- | recursively parse the rest of the tokens. @@ -148,15 +143,15 @@ tokensToCliArguments cliSpec@(CliSpec cliSpecRaw) tokens = do case tokensToCliArguments cmd (tokens # drop 1) of Ok args -> case mainCmdRes of Error err -> Error err - Ok _ -> Ok $ [CmdArg cliSpecRaw.name] <> args + Ok _ -> Ok $ [ CmdArg cliSpecRaw.name ] <> args err -> err -- Is value Nothing -> case mainCmdRes of - Error err -> Error err - Ok mainCmd -> - verifyTokensAreAllowed mainCmd (tokens # drop 1) - <#> (\cliArgs -> [CmdArg cliSpecRaw.name] <> cliArgs ) + Error err -> Error err + Ok mainCmd -> + verifyTokensAreAllowed mainCmd (tokens # drop 1) + <#> (\cliArgs -> [ CmdArg cliSpecRaw.name ] <> cliArgs) _ -> do let @@ -177,67 +172,70 @@ tokensToCliArguments cliSpec@(CliSpec cliSpecRaw) tokens = do remainingTokensWithSucc = zip (tokens # drop 1) - ((tokens # drop 2 <#> Just) <> [Nothing]) + ((tokens # drop 2 <#> Just) <> [ Nothing ]) options :: Array (Result String CliArgument) options = remainingTokensWithSucc - # foldl - (\acc (Tuple token nextTokenMb) -> case token of - FlagLongToken flagName -> - case findFlagLong cliSpecRaw.options flagName of - Just flagOrOpt -> case flagOrOpt.argument of - Just _arg -> - case nextTokenMb of - Just (TextToken val) -> - -- TODO: Check if val is allowed at this position - acc <> [Ok $ OptionLong flagName (TextArg val)] - _ -> acc <> [Ok $ FlagLong flagName] - Nothing -> acc <> [Ok $ FlagLong flagName] - Nothing -> - -- Maybe it's a long option - case findOptionLong cliSpecRaw.options flagName of - Just _ -> - acc <> [Ok $ OptionLong flagName (TextArg "TODO")] + # foldl + ( \acc (Tuple token nextTokenMb) -> case token of + FlagLongToken flagName -> + case findFlagLong cliSpecRaw.options flagName of + Just flagOrOpt -> case flagOrOpt.argument of + Just _arg -> + case nextTokenMb of + Just (TextToken val) -> + -- TODO: Check if val is allowed at this position + acc <> + [ Ok $ OptionLong flagName (TextArg val) ] + _ -> acc <> [ Ok $ FlagLong flagName ] + Nothing -> acc <> [ Ok $ FlagLong flagName ] Nothing -> - acc <> [toError token] - - FlagShortToken flagChar -> - case findFlagShort cliSpecRaw.options flagChar of - Just _ -> - acc <> [Ok $ OptionShort flagChar (TextArg "TODO")] - Nothing -> - -- Maybe it's a short option - case findOptionShort cliSpecRaw.options flagChar of + -- Maybe it's a long option + case findOptionLong cliSpecRaw.options flagName of + Just _ -> + acc <> + [ Ok $ OptionLong flagName (TextArg "TODO") ] + Nothing -> + acc <> [ toError token ] + + FlagShortToken flagChar -> + case findFlagShort cliSpecRaw.options flagChar of Just _ -> - acc <> [Ok $ OptionShort flagChar (TextArg "TODO")] + acc <> [ Ok $ OptionShort flagChar (TextArg "TODO") ] Nothing -> - acc <> [toError token] - - OptionShortToken flagChar _arg -> - case findFlagShort cliSpecRaw.options flagChar of - Just _option -> - acc <> [Ok $ OptionShort flagChar (TextArg "TODO")] - Nothing -> - acc <> [toError token] - - OptionLongToken flagName _arg -> - case findFlagLong cliSpecRaw.options flagName of - Just _option -> - acc <> [Ok $ OptionLong flagName (TextArg "TODO")] - Nothing -> - acc <> [toError token] - - TextToken txt -> - case acc # last of - -- This token was already consumed so don't add it - Just (Ok (OptionLong _ _)) -> acc - _ -> acc <> [Ok $ ValArg (TextArg txt)] - - _ -> [] - ) - [] + -- Maybe it's a short option + case findOptionShort cliSpecRaw.options flagChar of + Just _ -> + acc <> + [ Ok $ OptionShort flagChar (TextArg "TODO") ] + Nothing -> + acc <> [ toError token ] + + OptionShortToken flagChar _arg -> + case findFlagShort cliSpecRaw.options flagChar of + Just _option -> + acc <> [ Ok $ OptionShort flagChar (TextArg "TODO") ] + Nothing -> + acc <> [ toError token ] + + OptionLongToken flagName _arg -> + case findFlagLong cliSpecRaw.options flagName of + Just _option -> + acc <> [ Ok $ OptionLong flagName (TextArg "TODO") ] + Nothing -> + acc <> [ toError token ] + + TextToken txt -> + case acc # last of + -- This token was already consumed so don't add it + Just (Ok (OptionLong _ _)) -> acc + _ -> acc <> [ Ok $ ValArg (TextArg txt) ] + + _ -> [] + ) + [] sequence - $ [mainCmdRes <#> (\(CliSpec cmdSpec) -> CmdArg cmdSpec.name)] - <> options + $ [ mainCmdRes <#> (\(CliSpec cmdSpec) -> CmdArg cmdSpec.name) ] + <> options diff --git a/src/CliSpec/Tokenizer.purs b/src/CliSpec/Tokenizer.purs index 7ebc3bb..b307dd2 100644 --- a/src/CliSpec/Tokenizer.purs +++ b/src/CliSpec/Tokenizer.purs @@ -1,9 +1,8 @@ -module CliSpec.Tokenizer ( - CliArgToken(..), - tokenizeCliArgument, - tokenizeCliArguments -) - where +module CliSpec.Tokenizer + ( CliArgToken(..) + , tokenizeCliArgument + , tokenizeCliArguments + ) where import CliSpec.Types (CliArgPrim(..)) import Data.Array (concat, drop, groupBy, null, take, (:)) @@ -14,12 +13,11 @@ import Data.Show.Generic (genericShow) import Data.String.CodeUnits (toCharArray, fromCharArray) import Prelude (class Eq, class Show, map, (#), (&&), (/=), (<#>), (==)) - -- | Intermediate representation of CLI arguments. -- | This might not yet differentiate correctly between `Option`s and `Flag`s -- | and between `CmdArg`s and `ValArg`s. -data CliArgToken = - TextToken String -- ^ Could be a command or a value argument +data CliArgToken + = TextToken String -- ^ Could be a command or a value argument | FlagShortToken Char | FlagLongToken String | OptionShortToken Char CliArgPrim -- ^ `-n=3` @@ -35,7 +33,6 @@ derive instance eqCliArgToken :: Eq CliArgToken instance showCliArgToken :: Show CliArgToken where show = genericShow - optionLongTokenFromChars :: Array Char -> Array CliArgToken optionLongTokenFromChars charsRest = do let @@ -43,14 +40,13 @@ optionLongTokenFromChars charsRest = do # groupBy (\a b -> a /= '=' && b /= '=') case groupedChars of - [keyPart, _equalSign, valuePart] -> - [OptionLongToken + [ keyPart, _equalSign, valuePart ] -> + [ OptionLongToken (keyPart # toArray # fromCharArray) (TextArg (valuePart # toArray # fromCharArray)) - ] + ] _ -> [] - -- | Parse CLI arguments into a list of `CliArgToken`s -- | One argument can lead to multiple `CliArgToken`s -- | e.g. `-ab` -> `[FlagShortToken 'a', FlagShortToken 'b']` @@ -61,30 +57,25 @@ tokenizeCliArgument arg = do charsRest = chars # drop 2 :: Array Char case chars # take 2 of - ['-', '-'] -> - if charsRest == [] - then [SeparatorToken] + [ '-', '-' ] -> + if charsRest == [] then [ SeparatorToken ] + else if '=' `elem` charsRest then optionLongTokenFromChars charsRest else - if '=' `elem` charsRest - then optionLongTokenFromChars charsRest - else - [FlagLongToken (charsRest # fromCharArray)] + [ FlagLongToken (charsRest # fromCharArray) ] - ['-', singleFlag] -> - if (charsRest # take 1) == ['='] - then - [OptionShortToken - singleFlag - (TextArg (charsRest # drop 1 # fromCharArray)) + [ '-', singleFlag ] -> + if (charsRest # take 1) == [ '=' ] then + [ OptionShortToken + singleFlag + (TextArg (charsRest # drop 1 # fromCharArray)) ] else FlagShortToken singleFlag - : if null charsRest - then [] + : + if null charsRest then [] else charsRest # map FlagShortToken - _ -> [TextToken arg] - + _ -> [ TextToken arg ] tokenizeCliArguments :: Array String -> Array CliArgToken tokenizeCliArguments arguments = do diff --git a/src/CliSpec/Types.purs b/src/CliSpec/Types.purs index c80b25d..35febf9 100644 --- a/src/CliSpec/Types.purs +++ b/src/CliSpec/Types.purs @@ -10,7 +10,6 @@ import Data.Show.Generic (genericShow) import Data.String (joinWith) import Prelude (class Eq, class Show, bind, map, pure, show, (#), (<>)) - data CliArgPrim = TextArg String | IntArg Int @@ -22,10 +21,10 @@ derive instance genericCliArgPrim :: Generic CliArgPrim _ derive instance eqCliArgPrim :: Eq CliArgPrim instance showCliArgPrim :: Show CliArgPrim where show = genericShow + instance decodeJsonCliArgPrim :: DecodeJson CliArgPrim where decodeJson = genericDecodeJson - cliArgPrimToString :: CliArgPrim -> String cliArgPrimToString arg = case arg of TextArg str -> str @@ -45,12 +44,12 @@ data CliArgument | OptionLongList String (Array CliArgPrim) | ValArg CliArgPrim | ValArgList (Array CliArgPrim) - -- TODO: Add support for the following list types - -- | ValArgList (Array String) - -- | ValArgListInt (Array Int) - -- | ValArgListNumber (Array Number) - -- | ValArgListBoolean (Array Boolean) +-- TODO: Add support for the following list types +-- | ValArgList (Array String) +-- | ValArgListInt (Array Int) +-- | ValArgListNumber (Array Number) +-- | ValArgListBoolean (Array Boolean) derive instance genericCliArgument :: Generic CliArgument _ derive instance eqCliArgument :: Eq CliArgument @@ -71,23 +70,23 @@ cliArgToString arg = case arg of ValArg val -> cliArgPrimToString val ValArgList vals -> vals # map cliArgPrimToString # joinWith "," +type Argument = + { name :: String + , description :: String + , type :: String + , optional :: Maybe Boolean + , default :: Maybe CliArgPrim + } -type Argument = { - name :: String, - description :: String, - type :: String, - optional :: Maybe Boolean, - default :: Maybe CliArgPrim -} - -type Option = { - name :: Maybe String, - shortName :: Maybe String, -- TODO: Change to Char - description :: String, - argument :: Maybe Argument, - optional :: Maybe Boolean, - default :: Maybe CliArgPrim -} +type Option = + { name :: Maybe String + , shortName :: Maybe String + , -- TODO: Change to Char + description :: String + , argument :: Maybe Argument + , optional :: Maybe Boolean + , default :: Maybe CliArgPrim + } type CliSpecRaw = { name :: String @@ -108,12 +107,12 @@ derive instance eqCliSpec :: Eq CliSpec derive instance newtypeCliSpec :: Newtype CliSpec _ instance showCliSpec :: Show CliSpec where show = \(CliSpec specRaw) -> show specRaw + instance decodeJsonCliSpec :: DecodeJson CliSpec where decodeJson = \json -> do raw <- decodeJson json pure (CliSpec raw) - emptyCliSpecRaw :: CliSpecRaw emptyCliSpecRaw = { name: "" @@ -126,7 +125,6 @@ emptyCliSpecRaw = , commands: Nothing } - emptyCliSpec :: CliSpec emptyCliSpec = CliSpec emptyCliSpecRaw diff --git a/src/Main.purs b/src/Main.purs index c97713a..650d51f 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -1,8 +1,18 @@ module Main where import Prelude - ( Unit, bind, discard, pure, show, unit - , (#), ($), (/=), (<#>), (<>), (>) + ( Unit + , bind + , discard + , pure + , show + , unit + , (#) + , ($) + , (/=) + , (<#>) + , (<>) + , (>) ) import Ansi.Codes (Color(..)) @@ -37,59 +47,67 @@ import Transity.Plot as Plot import Transity.Utils (SortOrder(..), makeRed, errorAndExit) import Transity.Xlsx (writeToZip, entriesAsXlsx) - -- TODO: Move validation to parsing utcError :: String utcError = "All transfers or their parent transaction must have a valid UTC field" - runSimpleCmd :: String -> String -> Ledger -> Result String String runSimpleCmd command filePathRel ledger = case command of - "balance" -> Ok $ + "balance" -> Ok $ Ledger.showBalance BalanceOnlyOwner ColorYes ledger - "balance-all" -> Ok $ Ledger.showBalance BalanceAll ColorYes ledger + "balance-all" -> Ok $ Ledger.showBalance BalanceAll ColorYes ledger -- "balance-on" -> Ok $ -- Ledger.showBalanceOn dateMaybe ColorYes ledger - "transactions" -> Ok $ Ledger.showPrettyAligned ColorYes ledger - "transfers" -> Ok $ Ledger.showTransfers ColorYes ledger - "entries" -> note utcError $ Ledger.showEntries " " ledger - "entities" -> Ok $ Ledger.showEntities CustomSort ledger - "entities-sorted" -> Ok $ Ledger.showEntities Alphabetically ledger - "ledger-entries" -> Ok $ Ledger.entriesToLedger ledger - "csv" -> note utcError $ Ledger.showEntries "," ledger - "tsv" -> note utcError $ Ledger.showEntries "\t" ledger + "transactions" -> Ok $ Ledger.showPrettyAligned ColorYes ledger + "transfers" -> Ok $ Ledger.showTransfers ColorYes ledger + "entries" -> note utcError $ Ledger.showEntries " " ledger + "entities" -> Ok $ Ledger.showEntities CustomSort ledger + "entities-sorted" -> Ok $ Ledger.showEntities Alphabetically ledger + "ledger-entries" -> Ok $ Ledger.entriesToLedger ledger + "csv" -> note utcError $ Ledger.showEntries "," ledger + "tsv" -> note utcError $ Ledger.showEntries "\t" ledger "entries-by-account" -> note utcError $ Ledger.showEntriesByAccount ledger "gplot" -> (note utcError $ Ledger.showEntriesByAccount ledger) - <#> (\entries -> Plot.gplotCode $ Plot.configDefault - # (Plot.GplotConfig `over` (_ - { data = entries - , title = filePathRel - }))) + <#> + ( \entries -> Plot.gplotCode $ Plot.configDefault + # + ( Plot.GplotConfig `over` + ( _ + { data = entries + , title = filePathRel + } + ) + ) + ) "gplot-cumul" -> (note utcError $ Ledger.showEntriesByAccount ledger) - <#> (\entries -> Plot.gplotCodeCumul $ Plot.configDefault - # (Plot.GplotConfig `over` (_ - { data = entries - , title = filePathRel <> " - Cumulative" - }))) + <#> + ( \entries -> Plot.gplotCodeCumul $ Plot.configDefault + # + ( Plot.GplotConfig `over` + ( _ + { data = entries + , title = filePathRel <> " - Cumulative" + } + ) + ) + ) other -> Error ("\"" <> other <> "\" is not a valid command") - -- | Asynchronously logs all non existent referenced files checkFilePaths :: String -> Ledger -> Effect (Result String String) -checkFilePaths ledgerFilePath (Ledger {transactions}) = do +checkFilePaths ledgerFilePath (Ledger { transactions }) = do let files = foldMap (\(Transaction tact) -> tact.files) transactions for_ files \filePathRel -> do - filePathAbs <- Path.resolve [ledgerFilePath] filePathRel + filePathAbs <- Path.resolve [ ledgerFilePath ] filePathRel stat filePathAbs $ \statsResult -> - if isOk $ fromEither statsResult - then pure unit + if isOk $ fromEither statsResult then pure unit else log $ withGraphics (foreground Yellow) @@ -97,7 +115,6 @@ checkFilePaths ledgerFilePath (Ledger {transactions}) = do pure $ Ok "" - execForLedger :: String -> String @@ -105,30 +122,28 @@ execForLedger -> Ledger -> Effect (Result String String) execForLedger currentDir filePathRel command ledger = do - filePathAbs <- Path.resolve [currentDir] filePathRel + filePathAbs <- Path.resolve [ currentDir ] filePathRel let journalDir = - if indexOf (Pattern "/dev/fd/") filePathAbs == Just 0 - then currentDir + if indexOf (Pattern "/dev/fd/") filePathAbs == Just 0 then currentDir else Path.dirname filePathAbs _ <- checkFilePaths journalDir ledger case command of "xlsx" -> do launchAff_ $ writeToZip - Nothing -- Means stdout + Nothing -- Means stdout (entriesAsXlsx ledger) pure (Ok "") _ -> pure $ runSimpleCmd command filePathRel ledger - loadAndExec :: String -> Array String -> Effect (Result String String) -loadAndExec currentDir [command, filePathRel] = do - filePathAbs <- Path.resolve [currentDir] filePathRel +loadAndExec currentDir [ command, filePathRel ] = do + filePathAbs <- Path.resolve [ currentDir ] filePathRel ledgerFileContent <- Sync.readTextFile UTF8 filePathAbs case (Ledger.fromYaml ledgerFileContent) of @@ -138,7 +153,6 @@ loadAndExec currentDir [command, filePathRel] = do loadAndExec _ _ = pure $ Error "loadAndExec expects an array with length 2" - executor :: String -> String -> Array CliArgument -> Effect (Result String Unit) executor cmdName usageString args = do case cmdName, args of @@ -152,12 +166,12 @@ executor cmdName usageString args = do case (Ledger.fromYaml ledgerFileContent) of Error msg -> errorAndExit config msg - Ok ledger@(Ledger {transactions}) -> do + Ok ledger@(Ledger { transactions }) -> do currentDir <- cwd let journalDir = - if indexOf (Pattern "/dev/fd/") ledgerFilePathAbs == Just 0 - then currentDir + if indexOf (Pattern "/dev/fd/") ledgerFilePathAbs == Just 0 then + currentDir else Path.dirname ledgerFilePathAbs _ <- checkFilePaths journalDir ledger @@ -169,15 +183,14 @@ executor cmdName usageString args = do (\(Transaction tact) -> tact.files) transactions ledgerFilesAbs <- sequence $ ledgerFilesRel - <#> (\fileRel -> Path.resolve [journalDir] fileRel) + <#> (\fileRel -> Path.resolve [ journalDir ] fileRel) let unusedFiles = difference foundFiles ledgerFilesAbs makeGreen = withGraphics (foreground Green) makeYellow = withGraphics (foreground Yellow) - if null unusedFiles - then + if null unusedFiles then log $ makeGreen $ "No unused files found in " <> filesDir else do warn $ makeYellow $ "Warning: " @@ -196,70 +209,71 @@ executor cmdName usageString args = do pure $ Error errStr _, - [ValArg (TextArg journalPathRel)] -> do - currentDir <- cwd - result <- loadAndExec currentDir [cmdName, journalPathRel] - - case result of - Ok output -> - if length output > 0 - then do - log output - pure $ Ok unit - else - pure $ Ok unit - Error message -> - errorAndExit config message + [ ValArg (TextArg journalPathRel) ] -> do + currentDir <- cwd + result <- loadAndExec currentDir [ cmdName, journalPathRel ] + + case result of + Ok output -> + if length output > 0 then do + log output + pure $ Ok unit + else + pure $ Ok unit + Error message -> + errorAndExit config message _, [ ValArg (TextArg journalPathRel) , ValArgList extraJournalPaths ] -> do - currentDir <- cwd - - let - journalPaths :: Result String (Array String) - journalPaths = sequence $ - [Ok journalPathRel] <> - (extraJournalPaths - <#> (\valArg -> case valArg of - (TextArg path) -> Ok path - _ -> Error $ "Invalid argument type: " <> show valArg - ) - ) - - combineJournals :: Array String -> Effect (Result String Ledger) - combineJournals paths = do - paths - <#> (\filePathRel -> do - filePathAbs <- Path.resolve [currentDir] filePathRel - ledgerFileContent <- Sync.readTextFile UTF8 filePathAbs + currentDir <- cwd - pure $ Ledger.fromYaml ledgerFileContent - ) - # sequence - <#> sequence - <#> (\ledgerRes -> ledgerRes <#> fold ) - - case journalPaths of + let + journalPaths :: Result String (Array String) + journalPaths = sequence $ + [ Ok journalPathRel ] <> + ( extraJournalPaths + <#> + ( \valArg -> case valArg of + (TextArg path) -> Ok path + _ -> Error $ "Invalid argument type: " <> show valArg + ) + ) + + combineJournals :: Array String -> Effect (Result String Ledger) + combineJournals paths = do + paths + <#> + ( \filePathRel -> do + filePathAbs <- Path.resolve [ currentDir ] filePathRel + ledgerFileContent <- Sync.readTextFile UTF8 filePathAbs + + pure $ Ledger.fromYaml ledgerFileContent + ) + # sequence + <#> sequence + <#> (\ledgerRes -> ledgerRes <#> fold) + + case journalPaths of + Error message -> errorAndExit config message + Ok paths -> do + combineRes <- combineJournals paths + case combineRes of Error message -> errorAndExit config message - Ok paths -> do - combineRes <- combineJournals paths - case combineRes of - Error message -> errorAndExit config message - Ok ledger -> do - result <- execForLedger - currentDir - journalPathRel -- TODO: Must incorporate all paths - cmdName - ledger - - case result of - Ok output -> do - log output - pure $ Ok unit - Error message -> - errorAndExit config message + Ok ledger -> do + result <- execForLedger + currentDir + journalPathRel -- TODO: Must incorporate all paths + cmdName + ledger + + case result of + Ok output -> do + log output + pure $ Ok unit + Error message -> + errorAndExit config message _, _ -> do @@ -267,7 +281,6 @@ executor cmdName usageString args = do setExitCode 1 pure $ Ok unit - getAllFiles :: String -> Effect (Array String) getAllFiles directoryPath = let @@ -285,8 +298,7 @@ getAllFiles directoryPath = dirTuples = filter (\tuple -> isDirectory $ snd tuple) pathStatsTuples files = fileTuples <#> fst - if null dirTuples - then + if null dirTuples then pure $ files else do filesNested <- sequence $ dirTuples @@ -295,7 +307,6 @@ getAllFiles directoryPath = in addFiles directoryPath - main :: Effect Unit main = do _ <- case parseCliSpec CliSpec.JsonEmbed.fileContent of diff --git a/src/Transity/ApproxRatio.purs b/src/Transity/ApproxRatio.purs index 5571d75..883c250 100644 --- a/src/Transity/ApproxRatio.purs +++ b/src/Transity/ApproxRatio.purs @@ -32,7 +32,6 @@ module ApproxRatio where -- else if q /= q' then (q + 1) % 1 -- else (q * n'' + d'') % n'' - -- approxRational :: Number -> Number -> Ratio BigInt -- approxRational rat eps = -- simplest (rat - eps) (rat + eps) diff --git a/src/Transity/Data/Account.purs b/src/Transity/Data/Account.purs index b1fa338..d280745 100644 --- a/src/Transity/Data/Account.purs +++ b/src/Transity/Data/Account.purs @@ -38,7 +38,6 @@ import Transity.Utils , resultWithJsonDecodeError ) - -- | A physical account which can contain one or several commodities. -- | E.g. wallet, bank account, barn. -- | You shouldn't misuse this for abstract concepts like expenses or income. @@ -73,22 +72,21 @@ instance decodeAccount :: DecodeJson Account where decodeJson json = toEither $ resultWithJsonDecodeError $ decodeJsonAccount json - decodeJsonAccount :: Json -> Result String Account decodeJsonAccount json = do - object <- maybe + object <- maybe (Error $ "Account is not an object") - Ok (toObject json) - id <- object `getObjField` "id" + Ok + (toObject json) + id <- object `getObjField` "id" commodityMap <- object `getFieldMaybe` "commodityMap" - balances <- object `getFieldMaybe` "balances" + balances <- object `getFieldMaybe` "balances" pure $ Account { id , commodityMap: (fromMaybe commodityMapZero commodityMap) , balances } - zero :: Account zero = Account { id: "" @@ -96,53 +94,53 @@ zero = Account , balances: Nothing } - addAmount :: Account -> Amount -> Account addAmount (Account account) amount = - let newMap = account.commodityMap `addAmountToMap` amount - in Account account {commodityMap = newMap} - + let + newMap = account.commodityMap `addAmountToMap` amount + in + Account account { commodityMap = newMap } subtractAmount :: Account -> Amount -> Account subtractAmount (Account account) amount = - let newMap = account.commodityMap `subtractAmountFromMap` amount - in Account account {commodityMap = newMap} - + let + newMap = account.commodityMap `subtractAmountFromMap` amount + in + Account account { commodityMap = newMap } toWidthRecord :: Id -> CommodityMap -> WidthRecord toWidthRecord accountId commodityMap = let widthRecord = CommodityMap.toWidthRecord commodityMap in - widthRecord { - account = max (length accountId) widthRecord.account - } - + widthRecord + { account = max (length accountId) widthRecord.account + } showPretty :: Id -> CommodityMap -> String showPretty = showPrettyAligned ColorNo widthRecordZero - showPrettyAligned :: ColorFlag -> WidthRecord -> Id -> CommodityMap -> String showPrettyAligned colorFlag widthRec accountId commodityMap = let gap = 2 accountWidth = max widthRec.account (length accountId) accName = format (width accountWidth) accountId - accColor = if colorFlag == ColorYes - then foreground Blue + accColor = + if colorFlag == ColorYes then foreground Blue else foreground White in -- TODO: Fix after https://github.com/hdgarrood/purescript-ansi/issues/7 - (if colorFlag == ColorYes - then withGraphics accColor accName - else accName) - <> " " `power` gap - <> indentSubsequent (accountWidth + gap) - (CommodityMap.showPrettyAligned - colorFlag - widthRec.integer - widthRec.fraction - widthRec.commodity - commodityMap) - <> "\n" + ( if colorFlag == ColorYes then withGraphics accColor accName + else accName + ) + <> " " `power` gap + <> indentSubsequent (accountWidth + gap) + ( CommodityMap.showPrettyAligned + colorFlag + widthRec.integer + widthRec.fraction + widthRec.commodity + commodityMap + ) + <> "\n" diff --git a/src/Transity/Data/Amount.purs b/src/Transity/Data/Amount.purs index 194d81e..3c19c61 100644 --- a/src/Transity/Data/Amount.purs +++ b/src/Transity/Data/Amount.purs @@ -1,5 +1,4 @@ -module Transity.Data.Amount -where +module Transity.Data.Amount where import Control.Bind (bind) import Data.Argonaut.Core (toString, fromString, Json) @@ -39,7 +38,6 @@ import Transity.Utils , ratioZero ) - -- | Economic good or service that has full or substantial fungibility -- | E.g. €, cows, minutes, … @@ -66,7 +64,6 @@ decodeJsonCommodity json = (\x -> Ok (Commodity x)) (toString json) - -- | E.g. "20 €", "10 cows", or "20 minutes" -- | `amount = Amount (fromInt 20) (Commodity "€") @@ -94,42 +91,37 @@ instance encodeAmount :: EncodeJson Amount where instance decodeAmount :: DecodeJson Amount where decodeJson json = toEither $ decodeJsonAmount json - parseAmount :: String -> Result JsonDecodeError Amount parseAmount string = do let amountFrags = split (Pattern " ") string case take 2 amountFrags of - [value, currency] -> case digitsToRational value of + [ value, currency ] -> case digitsToRational value of Nothing -> Error $ TypeMismatch "Amount does not contain a valid value" Just quantity -> Ok $ Amount quantity (Commodity currency) _ -> Error $ TypeMismatch "Amount does not contain a value and a commodity" - decodeJsonAmount :: Json -> Result JsonDecodeError Amount decodeJsonAmount json = do amount <- maybe (Error $ TypeMismatch "Amount is not a string") - Ok (toString json) + Ok + (toString json) parseAmount amount - subtract :: Amount -> Amount -> Amount subtract (Amount numA (Commodity comA)) (Amount numB (Commodity comB)) | comA /= comB = Amount ratioZero (Commodity "INVALID COMPUTATION") | otherwise = Amount (numA - numB) (Commodity comA) - negate :: Amount -> Amount negate (Amount num com) = Amount (Ring.negate num) com - isZero :: Amount -> Boolean isZero (Amount quantity _) = quantity == ratioZero - toWidthRecord :: Amount -> WidthRecord toWidthRecord (Amount quantity (Commodity commodity)) = let @@ -141,11 +133,9 @@ toWidthRecord (Amount quantity (Commodity commodity)) = , commodity = length commodity } - showPretty :: Amount -> String showPretty = showPrettyAligned ColorNo 0 0 0 - -- | Specify the width (in characters) of the integer part, -- | the width of the fractional part (including decimal point), -- | the width of commodity part @@ -154,5 +144,5 @@ showPretty = showPrettyAligned ColorNo 0 0 0 showPrettyAligned :: ColorFlag -> Int -> Int -> Int -> Amount -> String showPrettyAligned colorFlag intWid fracWid comWid (Amount val (Commodity com)) = alignNumber colorFlag intWid fracWid (Rational.toNumber val) - <> " " - <> padEnd comWid com + <> " " + <> padEnd comWid com diff --git a/src/Transity/Data/Balance.purs b/src/Transity/Data/Balance.purs index cdd8c42..7b1411e 100644 --- a/src/Transity/Data/Balance.purs +++ b/src/Transity/Data/Balance.purs @@ -25,10 +25,8 @@ import Transity.Utils , utcToIsoString ) - data Balance = Balance DateTime CommodityMap - derive instance genericBalance :: Generic Balance _ derive instance eqBalance :: Eq Balance @@ -46,13 +44,13 @@ instance encodeBalance :: EncodeJson Balance where instance decodeBalance :: DecodeJson Balance where decodeJson json = toEither - $ resultWithJsonDecodeError $ decodeJsonBalance json - + $ resultWithJsonDecodeError + $ decodeJsonBalance json decodeJsonBalance :: Json -> Result String Balance decodeJsonBalance json = do - object <- maybe (Error "Balance is not an object") Ok (toObject json) - utc <- object `getObjField` "utc" + object <- maybe (Error "Balance is not an object") Ok (toObject json) + utc <- object `getObjField` "utc" (amounts :: Array String) <- object `getObjField` "amounts" amountList <- sequence $ amounts <#> parseAmount <#> stringifyJsonDecodeError diff --git a/src/Transity/Data/CommodityMap.purs b/src/Transity/Data/CommodityMap.purs index 42d4e4d..0476af0 100644 --- a/src/Transity/Data/CommodityMap.purs +++ b/src/Transity/Data/CommodityMap.purs @@ -23,47 +23,40 @@ import Transity.Utils , mergeWidthRecords ) - type CommodityMap = Map.Map Commodity Amount - commodityMapZero :: CommodityMap commodityMapZero = Map.empty :: CommodityMap - fromAmounts :: Array Amount -> CommodityMap fromAmounts = foldr (flip addAmountToMap) commodityMapZero - addAmountToMap :: CommodityMap -> Amount -> CommodityMap addAmountToMap commodityMap amount@(Amount _ (Commodity commodity)) = Map.alter - (\maybeValue -> case maybeValue of - Nothing -> Just amount - Just amountNow -> Just (amountNow <> amount) + ( \maybeValue -> case maybeValue of + Nothing -> Just amount + Just amountNow -> Just (amountNow <> amount) ) (Commodity commodity) commodityMap - subtractAmountFromMap :: CommodityMap -> Amount -> CommodityMap subtractAmountFromMap commodityMap amount@(Amount _ (Commodity commodity)) = Map.alter - (\maybeValue -> case maybeValue of - Nothing -> Just (Amount.negate amount) - Just amountNow -> Just (amountNow `Amount.subtract` amount) + ( \maybeValue -> case maybeValue of + Nothing -> Just (Amount.negate amount) + Just amountNow -> Just (amountNow `Amount.subtract` amount) ) (Commodity commodity) commodityMap - isCommodityMapZero :: CommodityMap -> Boolean isCommodityMapZero comMap = (Map.values comMap) - # fromFoldable - # all Amount.isZero - + # fromFoldable + # all Amount.isZero isCommodityZero :: CommodityMap -> Commodity -> Boolean isCommodityZero comMap commodity = @@ -73,15 +66,12 @@ isCommodityZero comMap commodity = fromMaybe false $ amountMaybe <#> Amount.isZero - -- TODO: Verify commodity map -- by checking that the commodity of the key and the value match - showPretty :: CommodityMap -> String showPretty = showPrettyAligned ColorNo 0 0 0 - -- | Specify the width (in characters) of the integer part, -- | the width of the fractional part -- | (both exluding the decimal point) and receive a pretty printed @@ -91,11 +81,13 @@ showPrettyAligned :: ColorFlag -> Int -> Int -> Int -> CommodityMap -> String showPrettyAligned colorFlag intWidth fracWidth comWidth commodityMap = commodityMap # (Map.toUnfoldable :: CommodityMap -> Array (Tuple Commodity Amount)) - # map (\(Tuple _ amount) -> - Amount.showPrettyAligned colorFlag intWidth fracWidth comWidth amount) + # map + ( \(Tuple _ amount) -> + Amount.showPrettyAligned colorFlag intWidth fracWidth comWidth + amount + ) # joinWith "\n" - toWidthRecord :: CommodityMap -> WidthRecord toWidthRecord commodityMap = commodityMap @@ -104,5 +96,3 @@ toWidthRecord commodityMap = # map Amount.toWidthRecord # foldr mergeWidthRecords widthRecordZero - - diff --git a/src/Transity/Data/Config.purs b/src/Transity/Data/Config.purs index 6cee1f3..ffcc06a 100644 --- a/src/Transity/Data/Config.purs +++ b/src/Transity/Data/Config.purs @@ -2,13 +2,11 @@ module Transity.Data.Config where import Prelude (class Eq) - -- | Flag to switch colorized output on or off data ColorFlag = ColorYes | ColorNo derive instance eqColorFlag :: Eq ColorFlag - type Config = { colorState :: ColorFlag } config :: Config diff --git a/src/Transity/Data/Entity.purs b/src/Transity/Data/Entity.purs index d6e7a36..f3ad7ba 100644 --- a/src/Transity/Data/Entity.purs +++ b/src/Transity/Data/Entity.purs @@ -30,7 +30,6 @@ import Transity.Utils , resultWithJsonDecodeError ) - newtype Entity = Entity { id :: String , name :: Maybe String @@ -50,17 +49,15 @@ instance showEntity :: Show Entity where instance decodeEntity :: DecodeJson Entity where decodeJson json = toEither $ resultWithJsonDecodeError $ decodeJsonEntity json - - decodeJsonEntity :: Json -> Result String Entity decodeJsonEntity json = do object <- maybe (Error "Entity is not an object") Ok (toObject json) - id <- object `getObjField` "id" - name <- object `getFieldMaybe` "name" - note <- object `getFieldMaybe` "note" - utc <- object `getFieldMaybe` "utc" - tags <- object `getFieldMaybe` "tags" + id <- object `getObjField` "id" + name <- object `getFieldMaybe` "name" + note <- object `getFieldMaybe` "note" + utc <- object `getFieldMaybe` "utc" + tags <- object `getFieldMaybe` "tags" accounts <- object `getFieldMaybe` "accounts" pure $ Entity @@ -72,13 +69,11 @@ decodeJsonEntity json = do , accounts } - fromJson :: String -> Result String Entity fromJson json = do jsonObj <- fromEither $ jsonParser json stringifyJsonDecodeError $ fromEither $ decodeJson jsonObj - zero :: Entity zero = Entity { id: "" @@ -89,30 +84,29 @@ zero = Entity , accounts: Nothing } - showPretty :: Entity -> String showPretty (Entity entity) = entity.id - <> " | " - <> (fromMaybe "" entity.name) - <> " | " - <> (fromMaybe "" entity.note) - <> " | " - <> (fromMaybe "" (entity.utc <#> dateShowPretty)) - <> " | " - <> (joinWith ", " $ fromMaybe [] entity.tags) - <> " | " - <> (joinWith ", " $ (fromMaybe [] entity.accounts) - <#> (\(Account acc) -> Account.showPretty acc.id acc.commodityMap)) - + <> " | " + <> (fromMaybe "" entity.name) + <> " | " + <> (fromMaybe "" entity.note) + <> " | " + <> (fromMaybe "" (entity.utc <#> dateShowPretty)) + <> " | " + <> (joinWith ", " $ fromMaybe [] entity.tags) + <> " | " + <> + ( joinWith ", " $ (fromMaybe [] entity.accounts) + <#> (\(Account acc) -> Account.showPretty acc.id acc.commodityMap) + ) -- | Map to fully qualified array of accounts -- | (e.g _default_ becomes john:_default_) toAccountsWithId :: Entity -> Array Account toAccountsWithId (Entity entity) = (fromMaybe [] entity.accounts) - <#> \(Account a) -> Account a {id = entity.id <> ":" <> a.id} - + <#> \(Account a) -> Account a { id = entity.id <> ":" <> a.id } -- | Map the entity's balance to an array of balancing transfers toTransfers :: Entity -> Array Transfer @@ -120,26 +114,33 @@ toTransfers entity = let accounts = toAccountsWithId entity - comMapToTransfers :: forall a. - {id :: String | a} -> DateTime -> CommodityMap -> Array Transfer + comMapToTransfers + :: forall a + . { id :: String | a } + -> DateTime + -> CommodityMap + -> Array Transfer comMapToTransfers accountRec utc comMap = (values comMap) - # Array.fromFoldable - <#> (\amount -> Transfer + # Array.fromFoldable + <#> + ( \amount -> Transfer { utc: Just utc , from: accountRec.id , to: "_void_" , amount , note: Nothing - }) + } + ) accToTrans :: Account -> Array Transfer accToTrans (Account account) = (fromMaybe [] account.balances) - <#> (\(Balance utc comMap) -> - comMapToTransfers account utc comMap) - # fold + <#> + ( \(Balance utc comMap) -> + comMapToTransfers account utc comMap + ) + # fold in accounts <#> accToTrans # fold - diff --git a/src/Transity/Data/Ledger.purs b/src/Transity/Data/Ledger.purs index 9d4884d..c77a7bd 100644 --- a/src/Transity/Data/Ledger.purs +++ b/src/Transity/Data/Ledger.purs @@ -1,9 +1,25 @@ module Transity.Data.Ledger where import Prelude - ( class Eq, class Monoid, class Semigroup, class Show - , bind, compare, identity, map, pure, show - , (#), ($), (&&), (+), (/=), (<#>), (<>), (==), (||) + ( class Eq + , class Monoid + , class Semigroup + , class Show + , bind + , compare + , identity + , map + , pure + , show + , (#) + , ($) + , (&&) + , (+) + , (/=) + , (<#>) + , (<>) + , (==) + , (||) ) import Control.Alt ((<|>)) @@ -30,7 +46,13 @@ import Data.Result (Result(..), toEither, fromEither) import Data.Set as Set import Data.Show.Generic (genericShow) import Data.String - (joinWith, Pattern(..), replace, replaceAll, Replacement(..), split) + ( joinWith + , Pattern(..) + , replace + , replaceAll + , Replacement(..) + , split + ) import Data.String.Common (toLower) import Data.String.Utils (startsWith) import Data.Traversable (fold, foldr, intercalate, sequence) @@ -43,8 +65,11 @@ import Transity.Data.Account as Account import Transity.Data.Amount (Amount(..), Commodity, isZero) import Transity.Data.Amount as Amount import Transity.Data.CommodityMap - ( CommodityMap, addAmountToMap, subtractAmountFromMap - , isCommodityMapZero, isCommodityZero + ( CommodityMap + , addAmountToMap + , subtractAmountFromMap + , isCommodityMapZero + , isCommodityZero ) import Transity.Data.Config (ColorFlag(..)) import Transity.Data.Entity (Entity(..), toTransfers) @@ -65,7 +90,6 @@ import Transity.Utils , widthRecordZero ) - -- | List of all transactions newtype Ledger = Ledger { owner :: Maybe String @@ -81,8 +105,9 @@ instance showLedger :: Show Ledger where show = genericShow instance decodeLedger :: DecodeJson Ledger where - decodeJson json = toEither $ - resultWithJsonDecodeError $ decodeJsonLedger json + decodeJson json = toEither + $ resultWithJsonDecodeError + $ decodeJsonLedger json instance monoidLedger :: Monoid Ledger where mempty = Ledger @@ -99,39 +124,36 @@ instance semigroupLedger :: Semigroup Ledger where , transactions: l1.transactions <> l2.transactions } - - data BalanceFilter = BalanceOnly String | BalanceOnlyOwner | BalanceAll - - decodeJsonLedger :: Json -> Result String Ledger decodeJsonLedger json = do - object <- maybe (Error "Ledger is not an object") Ok (toObject json) - owner <- object `getFieldMaybe` "owner" - entities <- object `getFieldMaybe` "entities" + object <- maybe (Error "Ledger is not an object") Ok (toObject json) + owner <- object `getFieldMaybe` "owner" + entities <- object `getFieldMaybe` "entities" transactions <- object `getObjField` "transactions" - pure $ Ledger {owner, entities, transactions} - + pure $ Ledger { owner, entities, transactions } verifyAccounts :: Ledger -> Result String Ledger verifyAccounts wholeLedger@(Ledger ledger) = let definedAccounts = Set.fromFoldable $ concat $ (fromMaybe [] ledger.entities) <#> - (\(Entity {id, accounts}) -> [id] <> - ((fromMaybe [] accounts) <#> - (\(Account account) -> id <> ":" <> account.id)) - ) + ( \(Entity { id, accounts }) -> [ id ] <> + ( (fromMaybe [] accounts) <#> + (\(Account account) -> id <> ":" <> account.id) + ) + ) usedAccounts = - (ledger.transactions <#> \(Transaction {transfers}) -> transfers) - # concat - # map (\(Transfer {from, to}) -> [from, to]) - # concat - # Set.fromFoldable + (ledger.transactions <#> \(Transaction { transfers }) -> transfers) + # concat + # map (\(Transfer { from, to }) -> [ from, to ]) + # concat + # Set.fromFoldable + undefinedAccounts :: Array String undefinedAccounts = Set.toUnfoldable $ usedAccounts `Set.difference` definedAccounts @@ -140,13 +162,12 @@ verifyAccounts wholeLedger@(Ledger ledger) = [] -> Ok wholeLedger _ -> Error $ "Following accounts were not declared, " - <> "but still used for transfers:\n\n" - <> "entities:" - <> joinWith "" (undefinedAccounts <#> ("\n - id: " <> _)) - <> "\n\n" - <> "Please add or rename the missing accounts " - <> "to the entities section to fix this error" - + <> "but still used for transfers:\n\n" + <> "entities:" + <> joinWith "" (undefinedAccounts <#> ("\n - id: " <> _)) + <> "\n\n" + <> "Please add or rename the missing accounts " + <> "to the entities section to fix this error" isAmountInMapZero :: BalanceMap -> String -> Commodity -> Boolean isAmountInMapZero balanceMap accountId commodity = @@ -156,31 +177,30 @@ isAmountInMapZero balanceMap accountId commodity = fromMaybe false $ comMap <#> (flip isCommodityZero) commodity - verifyBalances :: BalanceMap -> Array Transfer -> Result String Unit verifyBalances balanceMap balancingTransfers = case uncons balancingTransfers of - Just {head: transfHead@(Transfer tfHeadRec), tail: transfTail} -> + Just { head: transfHead@(Transfer tfHeadRec), tail: transfTail } -> let newBal = balanceMap `addTransfer` transfHead - getCommodity {amount: Amount _ commodity} = commodity + getCommodity { amount: Amount _ commodity } = commodity targetCom = getCommodity tfHeadRec in - if tfHeadRec.note == Just "___BALANCE___" - then - if not $ isAmountInMapZero newBal tfHeadRec.from targetCom - then Error( - "Error:\nThe verification balance of account '" <> tfHeadRec.from - <> "' on '" <> (fromMaybe "" $ tfHeadRec.utc <#> dateShowPretty) - <> "'\nis off by " - <> (Map.lookup tfHeadRec.from newBal - # fromMaybe Map.empty - # Map.values - # find (\(Amount _ commodity) -> commodity == targetCom) - <#> (Amount.negate >>> Amount.showPretty) - # fromMaybe "ERROR: Amount is missing" + if tfHeadRec.note == Just "___BALANCE___" then + if not $ isAmountInMapZero newBal tfHeadRec.from targetCom then Error + ( "Error:\nThe verification balance of account '" <> tfHeadRec.from + <> "' on '" + <> (fromMaybe "" $ tfHeadRec.utc <#> dateShowPretty) + <> "'\nis off by " + <> + ( Map.lookup tfHeadRec.from newBal + # fromMaybe Map.empty + # Map.values + # find (\(Amount _ commodity) -> commodity == targetCom) + <#> (Amount.negate >>> Amount.showPretty) + # fromMaybe "ERROR: Amount is missing" ) - <> " from the calculated balance." + <> " from the calculated balance." ) else verifyBalances balanceMap transfTail else @@ -188,7 +208,6 @@ verifyBalances balanceMap balancingTransfers = Nothing -> Ok unit - entitiesToTransfers :: Maybe (Array Entity) -> Array Transfer entitiesToTransfers entities = (fromMaybe [] entities) @@ -196,36 +215,35 @@ entitiesToTransfers entities = # fold -- Label the balancing transfers to tell them apart from normal transfers -- FIXME: Really hacky and should be solved with a wrapper datatype - <#> (\(Transfer tf) -> Transfer tf {note = Just "___BALANCE___"}) - + <#> (\(Transfer tf) -> Transfer tf { note = Just "___BALANCE___" }) verifyLedgerBalances :: Ledger -> Result String Ledger -verifyLedgerBalances wholeLedger@(Ledger {transactions, entities}) = +verifyLedgerBalances wholeLedger@(Ledger { transactions, entities }) = let balancingTransfers = entitiesToTransfers entities transxTransfers = Transaction.toTransfers transactions combined = (balancingTransfers <> transxTransfers) - # sortBy (\(Transfer transfA) (Transfer transfB) -> - compare transfA.utc transfB.utc) + # sortBy + ( \(Transfer transfA) (Transfer transfB) -> + compare transfA.utc transfB.utc + ) result = verifyBalances Map.empty combined in - if entities == Nothing || entities == Just [] - then Ok wholeLedger + if entities == Nothing || entities == Just [] then Ok wholeLedger else case result of Ok _ -> Ok wholeLedger Error error -> Error error - fromJson :: String -> Result String Ledger fromJson json = do jsonObj <- fromEither $ jsonParser json ledger <- stringifyJsonDecodeError $ fromEither $ decodeJson jsonObj pure ledger - -- TODO: >>= verifyAccounts - -- TODO: >>= verifyLedgerBalances - -- TODO: >>= addInitalBalance +-- TODO: >>= verifyAccounts +-- TODO: >>= verifyLedgerBalances +-- TODO: >>= addInitalBalance fromYaml :: String -> Result String Ledger fromYaml yaml = @@ -237,30 +255,32 @@ fromYaml yaml = unverified = case result of Error error -> Error ( "Could not parse YAML: " - <> fold (map renderForeignError error) + <> fold (map renderForeignError error) ) Ok json -> stringifyJsonDecodeError $ fromEither $ decodeJson json in unverified - -- TODO: >>= verifyAccounts - -- TODO: >>= verifyLedgerBalances +-- TODO: >>= verifyAccounts +-- TODO: >>= verifyLedgerBalances showPretty :: Ledger -> String showPretty = showPrettyAligned ColorNo - showPrettyAligned :: ColorFlag -> Ledger -> String showPrettyAligned colorFlag (Ledger l) = let transactionsPretty = map (Transaction.showPrettyAligned colorFlag) l.transactions - in "" - <> "Journal for \"" <> (l.owner # fromMaybe "UNKNOWN") <> "\"\n" - <> "=" `power` 80 <> "\n" - <> fold transactionsPretty - + in + "" + <> "Journal for \"" + <> (l.owner # fromMaybe "UNKNOWN") + <> "\"\n" + <> "=" `power` 80 + <> "\n" + <> fold transactionsPretty showTransfers :: ColorFlag -> Ledger -> String showTransfers colorFlag (Ledger l) = @@ -268,28 +288,28 @@ showTransfers colorFlag (Ledger l) = transactionsPretty = l.transactions <#> Transaction.showTransfersWithDate colorFlag # fold - in "" - <> "Journal for \"" <> (l.owner # fromMaybe "UNKNOWN") <> "\"\n" - <> "=" `power` 80 <> "\n" - <> transactionsPretty - + in + "" + <> "Journal for \"" + <> (l.owner # fromMaybe "UNKNOWN") + <> "\"\n" + <> "=" `power` 80 + <> "\n" + <> transactionsPretty type BalanceMap = Map.Map Account.Id CommodityMap - isBalanceMapZero :: BalanceMap -> Boolean isBalanceMapZero balanceMap = (Map.values balanceMap) - # all isCommodityMapZero - + # all isCommodityMapZero addTransaction :: BalanceMap -> Transaction -> BalanceMap -addTransaction balanceMap (Transaction {transfers}) = +addTransaction balanceMap (Transaction { transfers }) = foldr (flip addTransfer) balanceMap transfers - addTransfer :: BalanceMap -> Transfer -> BalanceMap -addTransfer balanceMap (Transfer {to, from, amount}) = +addTransfer balanceMap (Transfer { to, from, amount }) = let receiverArray = split (Pattern ":") to receiverWithDefault = case length receiverArray of @@ -300,7 +320,7 @@ addTransfer balanceMap (Transfer {to, from, amount}) = 1 -> from <> ":_default_" _ -> from updatedFromAccount = Map.alter - (\maybeValue -> case maybeValue of + ( \maybeValue -> case maybeValue of Nothing -> Just ((Map.empty :: CommodityMap) `subtractAmountFromMap` amount) Just commodityMap -> @@ -310,7 +330,7 @@ addTransfer balanceMap (Transfer {to, from, amount}) = balanceMap in Map.alter - (\maybeValue -> case maybeValue of + ( \maybeValue -> case maybeValue of Nothing -> Just ((Map.empty :: CommodityMap) `addAmountToMap` amount) Just commodityMap -> @@ -319,12 +339,12 @@ addTransfer balanceMap (Transfer {to, from, amount}) = receiverWithDefault updatedFromAccount - subtractTransfer :: BalanceMap -> Transfer -> BalanceMap -subtractTransfer balanceMap transfer = - let transferNegated = negateTransfer transfer - in balanceMap `addTransfer` transferNegated - +subtractTransfer balanceMap transfer = + let + transferNegated = negateTransfer transfer + in + balanceMap `addTransfer` transferNegated showEntities :: SortOrder -> Ledger -> String showEntities sortOrder (Ledger ledger) = @@ -346,10 +366,13 @@ showEntities sortOrder (Ledger ledger) = " utc: " <> (utc # dateShowPrettyLong) <> "\n" showTags :: Array String -> String - showTags tags = " tags: " <> ( - -- TODO: Can tags contain quote characters? - tags # show # replaceAll (Pattern "\"") (Replacement "") - ) <> "\n" + showTags tags = " tags: " + <> + ( + -- TODO: Can tags contain quote characters? + tags # show # replaceAll (Pattern "\"") (Replacement "") + ) + <> "\n" showAccount :: Account -> String showAccount (Account acc) = @@ -362,30 +385,32 @@ showEntities sortOrder (Ledger ledger) = showEntity :: Entity -> String showEntity (Entity entity) = (entity.id # showId) - <> (entity.name <#> showName # fromMaybe "") - <> (entity.note <#> showNote # fromMaybe "") - <> (entity.utc <#> showUTC # fromMaybe "") - <> (entity.tags <#> showTags # fromMaybe "") - <> (entity.accounts <#> showAccounts # fromMaybe "") - <> "\n" + <> (entity.name <#> showName # fromMaybe "") + <> (entity.note <#> showNote # fromMaybe "") + <> (entity.utc <#> showUTC # fromMaybe "") + <> (entity.tags <#> showTags # fromMaybe "") + <> (entity.accounts <#> showAccounts # fromMaybe "") + <> "\n" in - case ledger.entities of - Nothing -> - "Journal does not contain any entities" - - Just entities -> - "entities:\n" <> (entities - # (case sortOrder of - CustomSort -> identity - Alphabetically -> - sortBy (\(Entity entityA) (Entity entityB) -> - compare (toLower entityA.id) (toLower entityB.id) + case ledger.entities of + Nothing -> + "Journal does not contain any entities" + + Just entities -> + "entities:\n" <> + ( entities + # + ( case sortOrder of + CustomSort -> identity + Alphabetically -> + sortBy + ( \(Entity entityA) (Entity entityB) -> + compare (toLower entityA.id) (toLower entityB.id) + ) ) + <#> showEntity + # fold ) - <#> showEntity - # fold - ) - showBalance :: BalanceFilter -> ColorFlag -> Ledger -> String showBalance balFilter colorFlag (Ledger ledger) = @@ -398,144 +423,173 @@ showBalance balFilter colorFlag (Ledger ledger) = -> String -> Tuple String (Map.Map Commodity Amount) mapToEmpty accTuple@(Tuple accId _) account = - if accId == account || (accId # startsWith (account <> ":")) - then accTuple + if accId == account || (accId # startsWith (account <> ":")) then accTuple else (Tuple "" Map.empty) balancesArray :: Array (Tuple String (Map.Map Commodity Amount)) balancesArray = balanceMap - # (Map.toUnfoldable :: BalanceMap -> - Array (Tuple Account.Id CommodityMap)) - <#> (\accTuple -> case balFilter of - BalanceAll -> accTuple - BalanceOnlyOwner -> - case ledger.owner of - Just owner -> mapToEmpty accTuple owner - _ -> accTuple - BalanceOnly account -> mapToEmpty accTuple account - ) + # + ( Map.toUnfoldable + :: BalanceMap + -> Array (Tuple Account.Id CommodityMap) + ) + <#> + ( \accTuple -> case balFilter of + BalanceAll -> accTuple + BalanceOnlyOwner -> + case ledger.owner of + Just owner -> mapToEmpty accTuple owner + _ -> accTuple + BalanceOnly account -> mapToEmpty accTuple account + ) -- Don't show commodities with an amount of 0 - <#> (\(Tuple accId comMap) -> - Tuple accId (comMap # Map.mapMaybe (\amount -> - if isZero amount - then Nothing - else Just amount) - ) - ) + <#> + ( \(Tuple accId comMap) -> + Tuple accId + ( comMap # Map.mapMaybe + ( \amount -> + if isZero amount then Nothing + else Just amount + ) + ) + ) # Array.filter (\(Tuple _ comMap) -> comMap /= Map.empty) normAccId accId = replace (Pattern ":_default_") (Replacement "") accId - accWidthRecs :: - Array - { account :: Int - , commodity :: Int - , fraction :: Int - , integer :: Int - } + accWidthRecs + :: Array + { account :: Int + , commodity :: Int + , fraction :: Int + , integer :: Int + } accWidthRecs = balancesArray - <#> (\(Tuple accId comMap) -> - Account.toWidthRecord (normAccId accId) comMap) - - widthRecord :: - { account :: Int - , commodity :: Int - , fraction :: Int - , integer :: Int - } + <#> + ( \(Tuple accId comMap) -> + Account.toWidthRecord (normAccId accId) comMap + ) + + widthRecord + :: { account :: Int + , commodity :: Int + , fraction :: Int + , integer :: Int + } widthRecord = foldr mergeWidthRecords widthRecordZero accWidthRecs marginLeft = 2 - showTuple (Tuple accId comMap) = (Account.showPrettyAligned - colorFlag - widthRecord { account = widthRecord.account + marginLeft } - (normAccId accId) - comMap + showTuple (Tuple accId comMap) = + ( Account.showPrettyAligned + colorFlag + widthRecord { account = widthRecord.account + marginLeft } + (normAccId accId) + comMap ) in balancesArray <#> showTuple # fold - -- | Serializes the journal to a command line printable version -- | (lines of columns). getEntries :: Ledger -> Maybe (Array (Array String)) -getEntries (Ledger {transactions, entities}) = do +getEntries (Ledger { transactions, entities }) = do let - getQunty (Amount quantity _ ) = show $ Rational.toNumber quantity - getCmdty (Amount _ commodity ) = unwrap commodity + getQunty (Amount quantity _) = show $ Rational.toNumber quantity + getCmdty (Amount _ commodity) = unwrap commodity splitTransfer :: Transfer -> Maybe (Array (Array String)) splitTransfer (Transfer tfer) = let fromAmnt = Amount.negate tfer.amount getFromAndTo date = - [ [date, tfer.from, getQunty fromAmnt, getCmdty fromAmnt] - , [date, tfer.to, getQunty tfer.amount, getCmdty tfer.amount] + [ [ date, tfer.from, getQunty fromAmnt, getCmdty fromAmnt ] + , [ date, tfer.to, getQunty tfer.amount, getCmdty tfer.amount ] ] in (tfer.utc <#> utcToIsoString) <#> getFromAndTo - splitted <- do - transactions - <#> (\(Transaction tact) -> tact.transfers - <#> (\(Transfer tfer) -> Transfer (tfer { utc = tfer.utc <|> tact.utc }))) - # concat - <#> splitTransfer - # sequence + splitted <- + do + transactions + <#> + ( \(Transaction tact) -> tact.transfers + <#> + ( \(Transfer tfer) -> Transfer + (tfer { utc = tfer.utc <|> tact.utc }) + ) + ) + # concat + <#> splitTransfer + # sequence let initialEntries = entitiesToInitialTransfers entities <#> \(Transfer t) -> - let isoString = fromMaybe "INVALID DATE" $ t.utc <#> utcToIsoString - in [[ isoString - , replace (Pattern ":_default_") (Replacement "") t.from - , getQunty t.amount - , getCmdty t.amount - ]] + let + isoString = fromMaybe "INVALID DATE" $ t.utc <#> utcToIsoString + in + [ [ isoString + , replace (Pattern ":_default_") (Replacement "") t.from + , getQunty t.amount + , getCmdty t.amount + ] + ] pure $ (splitted <> initialEntries) # concat - entitiesToInitialTransfers :: Maybe (Array Entity) -> Array Transfer entitiesToInitialTransfers entities = (fromMaybe [] entities) <#> toTransfers # fold - # Array.filter (\(Transfer tf) -> - Amount.isZero tf.amount && tf.from /= "_void_") - + # Array.filter + ( \(Transfer tf) -> + Amount.isZero tf.amount && tf.from /= "_void_" + ) maybeToArr :: forall a. Maybe a -> Array a maybeToArr m = case m of - Just val -> [val] + Just val -> [ val ] Nothing -> [] - -- | Serialize the journal to the Ledger format. entriesToLedger :: Ledger -> String entriesToLedger (Ledger { transactions }) = let - print :: DateTime -> Maybe String -> Account.Id - -> Account.Id -> Amount -> String + print + :: DateTime + -> Maybe String + -> Account.Id + -> Account.Id + -> Amount + -> String print dt maybeNote from to amount = - let date = dt # utcToIsoDateString - note = maybe "" identity maybeNote - in date <> " " <> note <> "\n" <> - " " <> to <> " " <> (Amount.showPretty amount) <> "\n" <> - " " <> from <> "\n" + let + date = dt # utcToIsoDateString + note = maybe "" identity maybeNote + in + date <> " " <> note <> "\n" + <> " " + <> to + <> " " + <> (Amount.showPretty amount) + <> "\n" + <> " " + <> from + <> "\n" result = do - Transaction { utc , note, transfers } <- transactions - xutc <- maybeToArr utc - Transfer { to, from, amount } <- transfers - pure $ print xutc note from to amount - - in result # joinWith "\n" + Transaction { utc, note, transfers } <- transactions + xutc <- maybeToArr utc + Transfer { to, from, amount } <- transfers + pure $ print xutc note from to amount + in + result # joinWith "\n" showEntries :: String -> Ledger -> Maybe String showEntries separator ledger = do @@ -546,7 +600,6 @@ showEntries separator ledger = do <#> joinWith separator # joinWith "\n" - showEntriesByAccount :: Ledger -> Maybe String showEntriesByAccount ledger = do let @@ -561,11 +614,11 @@ showEntriesByAccount ledger = do entries <- getEntries ledger pure $ entries - # sortBy compareAccComm - # groupBy isEqualAccComm - <#> Array.fromFoldable -- Convert each NonEmpty to Array - <#> sort -- Sort each entry by date - <#> (\array -> [[accCommOfGroup array]] <> array) - # intercalate [["\n"]] -- Add space between account entries - <#> joinWith " " -- Join fields for each row - # joinWith "\n" + # sortBy compareAccComm + # groupBy isEqualAccComm + <#> Array.fromFoldable -- Convert each NonEmpty to Array + <#> sort -- Sort each entry by date + <#> (\array -> [ [ accCommOfGroup array ] ] <> array) + # intercalate [ [ "\n" ] ] -- Add space between account entries + <#> joinWith " " -- Join fields for each row + # joinWith "\n" diff --git a/src/Transity/Data/Transaction.purs b/src/Transity/Data/Transaction.purs index f32baba..d228807 100644 --- a/src/Transity/Data/Transaction.purs +++ b/src/Transity/Data/Transaction.purs @@ -1,8 +1,16 @@ module Transity.Data.Transaction where import Prelude - ( class Show, class Eq, bind, map, pure - , (#), ($), (<>), (>>=), (<#>) + ( class Show + , class Eq + , bind + , map + , pure + , (#) + , ($) + , (<>) + , (>>=) + , (<#>) ) import Control.Alt ((<|>)) @@ -37,7 +45,6 @@ import Transity.Utils , resultWithJsonDecodeError ) - -- newtype FilePath = FilePath String newtype Transaction = Transaction @@ -56,19 +63,20 @@ instance showTransaction :: Show Transaction where show = genericShow instance decodeTransaction :: DecodeJson Transaction where - decodeJson json = toEither $ - resultWithJsonDecodeError $ decodeJsonTransaction json - + decodeJson json = toEither + $ resultWithJsonDecodeError + $ decodeJsonTransaction json decodeJsonTransaction :: Json -> Result String Transaction decodeJsonTransaction json = do object <- maybe (Error "Transaction is not an object") Ok (toObject json) - id <- object `getFieldMaybe` "id" - utc <- object `getFieldMaybe` "utc" - note <- object `getFieldMaybe` "note" - files <- stringifyJsonDecodeError $ - fromEither $ object `getFieldOptional` "files" `defaultField` [] + id <- object `getFieldMaybe` "id" + utc <- object `getFieldMaybe` "utc" + note <- object `getFieldMaybe` "note" + files <- stringifyJsonDecodeError + $ fromEither + $ object `getFieldOptional` "files" `defaultField` [] transfers <- object `getObjField` "transfers" pure $ Transaction @@ -79,14 +87,12 @@ decodeJsonTransaction json = do , transfers } - fromJson :: String -> Result String Transaction fromJson string = do json <- fromEither $ jsonParser string transaction <- stringifyJsonDecodeError $ fromEither $ decodeJson json pure transaction - fromYaml :: String -> Result String Transaction fromYaml yaml = let @@ -98,34 +104,32 @@ fromYaml yaml = case result of Error error -> Error ( "Could not parse YAML: " - <> foldMap renderForeignError error + <> foldMap renderForeignError error ) Ok json -> stringifyJsonDecodeError $ fromEither $ decodeJson json - toTransfers :: Array Transaction -> Array Transfer toTransfers = foldMap transactionTransfers - showTransfersWithDate :: ColorFlag -> Transaction -> String showTransfersWithDate _ transac = transac # transactionTransfers # foldMap Transfer.showPrettyColorized - transactionTransfers :: Transaction -> Array Transfer transactionTransfers (Transaction transac) = transac.transfers - <#> (\(Transfer transf) -> Transfer (transf - { utc = transf.utc <|> transac.utc } - )) - + <#> + ( \(Transfer transf) -> Transfer + ( transf + { utc = transf.utc <|> transac.utc } + ) + ) showPretty :: Transaction -> String showPretty = showPrettyAligned ColorNo - showPrettyAligned :: ColorFlag -> Transaction -> String showPrettyAligned colorFlag (Transaction tact) = let @@ -137,7 +141,8 @@ showPrettyAligned colorFlag (Transaction tact) = addId str = " | (id " <> str <> ")" in fromMaybe (" " `power` offsetDate) (map dateShowPretty tact.utc) - <> " | " <> format (width 30) (fromMaybe "NO NOTE" tact.note) - <> fromMaybe "" (map addId tact.id) - <> indentSubsequent offsetIndentation ("\n" <> transfersPretty) - <> "\n" + <> " | " + <> format (width 30) (fromMaybe "NO NOTE" tact.note) + <> fromMaybe "" (map addId tact.id) + <> indentSubsequent offsetIndentation ("\n" <> transfersPretty) + <> "\n" diff --git a/src/Transity/Data/Transfer.purs b/src/Transity/Data/Transfer.purs index 7f3018b..f763f5a 100644 --- a/src/Transity/Data/Transfer.purs +++ b/src/Transity/Data/Transfer.purs @@ -1,8 +1,18 @@ module Transity.Data.Transfer where import Prelude - ( class Eq, class Ord, class Show, bind, compare, map, pure - , (#), ($), (<>), (==), (>>=) + ( class Eq + , class Ord + , class Show + , bind + , compare + , map + , pure + , (#) + , ($) + , (<>) + , (==) + , (>>=) ) import Control.Monad.Except (runExcept) @@ -40,7 +50,6 @@ import Transity.Utils , resultWithJsonDecodeError ) - newtype Transfer = Transfer { utc :: Maybe DateTime , from :: Account.Id @@ -58,7 +67,6 @@ instance eqTransfer :: Eq Transfer where instance ordTransfer :: Ord Transfer where compare (Transfer a) (Transfer b) = compare a.utc b.utc - instance showTransfer :: Show Transfer where show = genericShow @@ -66,7 +74,6 @@ instance decodeTransfer :: DecodeJson Transfer where decodeJson json = toEither $ resultWithJsonDecodeError $ decodeJsonTransfer json - decodeJsonTransfer :: Json -> Result String Transfer decodeJsonTransfer json = do object <- maybe (Error "Transfer is not an object") Ok (toObject json) @@ -75,23 +82,25 @@ decodeJsonTransfer json = do to <- object `getFieldVerbose` "to" amount <- object `getFieldVerbose` "amount" - utc <- stringifyJsonDecodeError $ - fromEither $ object `getFieldOptional` "utc" - note <- stringifyJsonDecodeError $ - fromEither $ object `getFieldOptional` "note" - - transfer <- verifyTransfer (stringify json) (Transfer - { utc: utc >>= stringToDateTime - , from - , to - , amount - , note - } + utc <- stringifyJsonDecodeError + $ fromEither + $ object `getFieldOptional` "utc" + note <- stringifyJsonDecodeError + $ fromEither + $ object `getFieldOptional` "note" + + transfer <- verifyTransfer (stringify json) + ( Transfer + { utc: utc >>= stringToDateTime + , from + , to + , amount + , note + } ) pure transfer - transferZero :: Transfer transferZero = Transfer { utc: Nothing @@ -101,36 +110,32 @@ transferZero = Transfer , note: Nothing } - negateTransfer :: Transfer -> Transfer negateTransfer (Transfer transferRec) = let negateAmount (Amount qnt com) = Amount (negate qnt) com in - Transfer transferRec {amount = negateAmount transferRec.amount} - + Transfer transferRec { amount = negateAmount transferRec.amount } verifyTransfer :: String -> Transfer -> Result String Transfer verifyTransfer json transfer@(Transfer transRec) = let (Amount quantity _) = transRec.amount in - if (length transRec.from == 0) - then Error $ "Field 'from' in " <> json <> " must not be empty" else - if (length transRec.to == 0) - then Error $ "Field 'to' in " <> json <> " must not be empty" else - if (quantity == (fromInt 0 % fromInt 1)) - then Error $ "Field 'amount' in " <> json <> " must not be 0" + if (length transRec.from == 0) then Error $ "Field 'from' in " <> json <> + " must not be empty" + else if (length transRec.to == 0) then Error $ "Field 'to' in " <> json <> + " must not be empty" + else if (quantity == (fromInt 0 % fromInt 1)) then Error $ + "Field 'amount' in " <> json <> " must not be 0" else Ok transfer - fromJson :: String -> Result String Transfer fromJson string = do json <- fromEither $ jsonParser string transfer <- stringifyJsonDecodeError $ fromEither $ decodeJson json pure transfer - fromYaml :: String -> Result String Transfer fromYaml yaml = let @@ -142,19 +147,16 @@ fromYaml yaml = case result of Error error -> Error ( "Could not parse YAML: " - <> fold (map renderForeignError error) + <> fold (map renderForeignError error) ) Ok json -> stringifyJsonDecodeError $ fromEither $ decodeJson json - showPretty :: Transfer -> String showPretty = showPrettyAligned ColorNo 15 15 5 3 10 - showPrettyColorized :: Transfer -> String showPrettyColorized = showPrettyAligned ColorYes 15 15 5 3 10 - -- | - From account name width -- | - To account name width -- | - Integer part width @@ -171,11 +173,11 @@ showPrettyAligned colorFlag fromW toW intW fracW comW (Transfer trans) = case datePretty of Just aDate -> aDate <> " | " _ -> " " `power` offsetDate - <> format (width fromW) trans.from - <> " -> " - <> format (width toW) trans.to - <> " : " - <> Amount.showPrettyAligned colorFlag intW fracW comW trans.amount - <> " | " - <> fromMaybe "" trans.note - <> "\n" + <> format (width fromW) trans.from + <> " -> " + <> format (width toW) trans.to + <> " : " + <> Amount.showPrettyAligned colorFlag intW fracW comW trans.amount + <> " | " + <> fromMaybe "" trans.note + <> "\n" diff --git a/src/Transity/Plot.purs b/src/Transity/Plot.purs index 3bc7ff9..e58b165 100644 --- a/src/Transity/Plot.purs +++ b/src/Transity/Plot.purs @@ -1,11 +1,11 @@ module Transity.Plot where import Prelude (show, (#), (<>)) + import Data.Array ((:)) import Data.Newtype (class Newtype) import Data.String (joinWith) - newtype GplotConfig = GplotConfig { title :: String , labelY :: String @@ -18,7 +18,6 @@ newtype GplotConfig = GplotConfig derive instance newtypeGplotConfig :: Newtype GplotConfig _ - configDefault :: GplotConfig configDefault = GplotConfig { title: "Made with Transity" @@ -30,11 +29,9 @@ configDefault = GplotConfig , imgHeight: 420 } - -configSetData :: GplotConfig -> String -> GplotConfig +configSetData :: GplotConfig -> String -> GplotConfig configSetData (GplotConfig config) dataString = - GplotConfig (config { data = dataString}) - + GplotConfig (config { data = dataString }) gplotTable :: String -> String gplotTable dataString = "$data << EOD\n" @@ -43,62 +40,72 @@ gplotTable dataString = "$data << EOD\n" <> dataString <> "\nEOD\n" - -- | Code (without data) for gnuplot impulse diagram -- | to visualize transfers on one account gplotCode :: GplotConfig -> String gplotCode (GplotConfig conf) = gplotTable conf.data <> - (( - ("set terminal " <> conf.terminalType - <> " size " <> show conf.imgWidth <> ", " <> show conf.imgHeight) : - ("set title '" <> conf.title <> "'") : - "set key outside nobox" : - ("set style line 12 lc rgb'" <> conf.lineColor <> "' lt 0 lw 1") : - "set grid back ls 12" : - "set grid xtics ytics mxtics" : - "set style fill solid" : - "set xdata time" : - "set timefmt '%Y-%m-%dT%H:%M:%S'" : - "set format x '%Y-W%W'" : - "set xlabel 'ISO Week'" : - "set xtics rotate by 30 right" : - "set zeroaxis" : - ("set ylabel '" <> conf.labelY <> "'") : - "plot for [i=0:*] $data index i \ - \using 1:3 \ - \with impulses \ - \title columnhead(1)" : - "" : - [] - ) # joinWith ";") - + ( ( ( "set terminal " <> conf.terminalType + <> " size " + <> show conf.imgWidth + <> ", " + <> show conf.imgHeight + ) + : ("set title '" <> conf.title <> "'") + : "set key outside nobox" + : ("set style line 12 lc rgb'" <> conf.lineColor <> "' lt 0 lw 1") + : "set grid back ls 12" + : "set grid xtics ytics mxtics" + : "set style fill solid" + : "set xdata time" + : "set timefmt '%Y-%m-%dT%H:%M:%S'" + : "set format x '%Y-W%W'" + : "set xlabel 'ISO Week'" + : "set xtics rotate by 30 right" + : "set zeroaxis" + : ("set ylabel '" <> conf.labelY <> "'") + : + "plot for [i=0:*] $data index i \ + \using 1:3 \ + \with impulses \ + \title columnhead(1)" + : "" + : + [] + ) # joinWith ";" + ) -- | Code (without data) for cumuluative gnuplot step chart -- | to visualize balance on one account gplotCodeCumul :: GplotConfig -> String gplotCodeCumul (GplotConfig conf) = gplotTable conf.data <> - (( - ("set terminal " <> conf.terminalType - <> " size " <> show conf.imgWidth <> ", " <> show conf.imgHeight) : - ("set title '" <> conf.title <> "'") : - "set key outside nobox" : - ("set style line 12 lc rgb'" <> conf.lineColor <> "' lt 0 lw 1") : - "set grid back ls 12" : - "set grid xtics ytics mxtics" : - "set xdata time" : - "set timefmt '%Y-%m-%dT%H:%M:%S'" : - "set format x '%Y-W%W'" : - "set xlabel 'ISO Week'" : - "set xtics rotate by 30 right" : - "set zeroaxis" : - "set yrange [*<0:0<*]" : - ("set ylabel '" <> conf.labelY <> "'") : - "plot for [i=0:*] $data index i \ - \using 1:3 \ - \smooth cumulative with fillsteps \ - \title columnhead(1)" : - "" : - [] - ) # joinWith ";") + ( ( ( "set terminal " <> conf.terminalType + <> " size " + <> show conf.imgWidth + <> ", " + <> show conf.imgHeight + ) + : ("set title '" <> conf.title <> "'") + : "set key outside nobox" + : ("set style line 12 lc rgb'" <> conf.lineColor <> "' lt 0 lw 1") + : "set grid back ls 12" + : "set grid xtics ytics mxtics" + : "set xdata time" + : "set timefmt '%Y-%m-%dT%H:%M:%S'" + : "set format x '%Y-W%W'" + : "set xlabel 'ISO Week'" + : "set xtics rotate by 30 right" + : "set zeroaxis" + : "set yrange [*<0:0<*]" + : ("set ylabel '" <> conf.labelY <> "'") + : + "plot for [i=0:*] $data index i \ + \using 1:3 \ + \smooth cumulative with fillsteps \ + \title columnhead(1)" + : "" + : + [] + ) # joinWith ";" + ) diff --git a/src/Transity/Utils.purs b/src/Transity/Utils.purs index b5860b9..fe07a54 100644 --- a/src/Transity/Utils.purs +++ b/src/Transity/Utils.purs @@ -1,9 +1,26 @@ module Transity.Utils where -import Prelude ( - class Eq, bind, discard, map, max, pure, show, Unit, - (#), ($), (+), (-), (/=), (<#>), (<>), (==), (>=), (>>=), (>>>) -) +import Prelude + ( class Eq + , bind + , discard + , map + , max + , pure + , show + , Unit + , (#) + , ($) + , (+) + , (-) + , (/=) + , (<#>) + , (<>) + , (==) + , (>=) + , (>>=) + , (>>>) + ) import Ansi.Codes (Color(..)) import Ansi.Output (withGraphics, foreground) @@ -16,7 +33,7 @@ import Data.DateTime (DateTime) import Data.DateTime.Instant (instant, toDateTime) import Data.Formatter.DateTime (Formatter, FormatterCommand(..), format) as Fmt import Data.List (fromFoldable) -import Data.Maybe (Maybe(Just,Nothing), fromMaybe) +import Data.Maybe (Maybe(Just, Nothing), fromMaybe) import Data.Monoid (power) import Data.Nullable (Nullable, toMaybe) import Data.Rational (Rational, (%)) @@ -41,57 +58,65 @@ import Node.Process (setExitCode) import Transity.Data.Config - -- | Flag to switch between different ways of sorting the output data SortOrder = CustomSort | Alphabetically derive instance eqSortOrder :: Eq SortOrder - foreign import parseToUnixTimeImpl :: String -> Nullable Number parseToUnixTime :: String -> Maybe Number parseToUnixTime = parseToUnixTimeImpl >>> toMaybe - -resultWithJsonDecodeError :: forall a. - Result String a -> Result JsonDecodeError a +resultWithJsonDecodeError + :: forall a + . Result String a + -> Result JsonDecodeError a resultWithJsonDecodeError result = case result of Error str -> Error $ TypeMismatch str Ok value -> Ok value - -stringifyJsonDecodeError :: forall a. - Result JsonDecodeError a -> Result String a +stringifyJsonDecodeError + :: forall a + . Result JsonDecodeError a + -> Result String a stringifyJsonDecodeError result = case result of Error err -> Error $ printJsonDecodeError err Ok value -> Ok value - -getObjField :: forall a. DecodeJson a - => Object Json -> String -> Result String a +getObjField + :: forall a + . DecodeJson a + => Object Json + -> String + -> Result String a getObjField object name = let value = fromEither $ object `getField` name in case value of Error error -> Error $ "'" <> name - <> "' could not be parsed: \n " - <> printJsonDecodeError error + <> "' could not be parsed: \n " + <> printJsonDecodeError error Ok success -> Ok success - -getFieldMaybe :: forall a. DecodeJson a - => Object Json -> String -> Result String (Maybe a) +getFieldMaybe + :: forall a + . DecodeJson a + => Object Json + -> String + -> Result String (Maybe a) getFieldMaybe object name = stringifyJsonDecodeError $ fromEither $ getFieldOptional object name - getFieldVerbose - :: forall a. DecodeJson a - => Object Json -> String -> Result String a + :: forall a + . DecodeJson a + => Object Json + -> String + -> Result String a getFieldVerbose object name = let value = fromEither $ object `getField` name @@ -99,11 +124,10 @@ getFieldVerbose object name = case value of Error error -> Error $ "'" <> name <> "' could not be parsed in TODO " - <> {-(stringify object) <>-} " because of following error: \n " - <> printJsonDecodeError error + <> {-(stringify object) <>-} " because of following error: \n " + <> printJsonDecodeError error Ok success -> Ok success - stringToDateTime :: String -> Maybe DateTime stringToDateTime string = string # parseToUnixTime @@ -111,17 +135,21 @@ stringToDateTime string = string >>= instant <#> toDateTime - utcToIsoString :: DateTime -> String utcToIsoString utc = let formatter :: Fmt.Formatter formatter = fromFoldable - [ Fmt.YearFull, (Fmt.Placeholder "-") - , Fmt.MonthTwoDigits, (Fmt.Placeholder "-") - , Fmt.DayOfMonthTwoDigits, (Fmt.Placeholder "T") - , Fmt.Hours24, (Fmt.Placeholder ":") - , Fmt.MinutesTwoDigits, (Fmt.Placeholder ":") + [ Fmt.YearFull + , (Fmt.Placeholder "-") + , Fmt.MonthTwoDigits + , (Fmt.Placeholder "-") + , Fmt.DayOfMonthTwoDigits + , (Fmt.Placeholder "T") + , Fmt.Hours24 + , (Fmt.Placeholder ":") + , Fmt.MinutesTwoDigits + , (Fmt.Placeholder ":") , Fmt.SecondsTwoDigits ] in @@ -132,8 +160,10 @@ utcToIsoDateString utc = let formatter :: Fmt.Formatter formatter = fromFoldable - [ Fmt.YearFull, (Fmt.Placeholder "-") - , Fmt.MonthTwoDigits, (Fmt.Placeholder "-") + [ Fmt.YearFull + , (Fmt.Placeholder "-") + , Fmt.MonthTwoDigits + , (Fmt.Placeholder "-") , Fmt.DayOfMonthTwoDigits ] in @@ -144,10 +174,14 @@ dateShowPretty datetime = let formatter :: Fmt.Formatter formatter = fromFoldable - [ Fmt.YearFull, (Fmt.Placeholder "-") - , Fmt.MonthTwoDigits, (Fmt.Placeholder "-") - , Fmt.DayOfMonthTwoDigits, (Fmt.Placeholder " ") - , Fmt.Hours24, (Fmt.Placeholder ":") + [ Fmt.YearFull + , (Fmt.Placeholder "-") + , Fmt.MonthTwoDigits + , (Fmt.Placeholder "-") + , Fmt.DayOfMonthTwoDigits + , (Fmt.Placeholder " ") + , Fmt.Hours24 + , (Fmt.Placeholder ":") , Fmt.MinutesTwoDigits ] in @@ -158,80 +192,91 @@ dateShowPrettyLong datetime = let formatter :: Fmt.Formatter formatter = fromFoldable - [ Fmt.YearFull, (Fmt.Placeholder "-") - , Fmt.MonthTwoDigits, (Fmt.Placeholder "-") - , Fmt.DayOfMonthTwoDigits, (Fmt.Placeholder " ") - , Fmt.Hours24, (Fmt.Placeholder ":") - , Fmt.MinutesTwoDigits, (Fmt.Placeholder ":") + [ Fmt.YearFull + , (Fmt.Placeholder "-") + , Fmt.MonthTwoDigits + , (Fmt.Placeholder "-") + , Fmt.DayOfMonthTwoDigits + , (Fmt.Placeholder " ") + , Fmt.Hours24 + , (Fmt.Placeholder ":") + , Fmt.MinutesTwoDigits + , (Fmt.Placeholder ":") , Fmt.SecondsTwoDigits ] in Fmt.format formatter datetime - indentSubsequent :: Int -> String -> String -indentSubsequent indentation string = +indentSubsequent indentation string = replaceAll (Pattern "\n") (Replacement ("\n" <> (" " `power` indentation))) string - testNumberChar :: Char -> Boolean testNumberChar char = let digitArray = - [ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' - , '.', '-', '+' + [ '0' + , '1' + , '2' + , '3' + , '4' + , '5' + , '6' + , '7' + , '8' + , '9' + , '.' + , '-' + , '+' ] - in elem char digitArray - + in + elem char digitArray digitsToRational :: String -> Maybe Rational digitsToRational stringOfDigits = let isNumChar = all testNumberChar (toCharArray stringOfDigits) - in case isNumChar of - false -> Nothing - true -> do - let - numeratorStr = replaceAll (Pattern ".") (Replacement "") stringOfDigits - numStrLength = length numeratorStr - index = fromMaybe numStrLength (indexOf (Pattern ".") stringOfDigits) - denominator = (fromInt 10) `pow` (fromInt $ numStrLength - index) - numerator <- fromString numeratorStr - pure (numerator % denominator) - + in + case isNumChar of + false -> Nothing + true -> do + let + numeratorStr = replaceAll (Pattern ".") (Replacement "") + stringOfDigits + numStrLength = length numeratorStr + index = fromMaybe numStrLength (indexOf (Pattern ".") stringOfDigits) + denominator = (fromInt 10) `pow` (fromInt $ numStrLength - index) + numerator <- fromString numeratorStr + pure (numerator % denominator) ratioZero :: Rational ratioZero = 0 % 1 - getPadding :: Int -> String -> String getPadding targetLength string = fromCharArray $ replicate (targetLength - length string) ' ' - padStart :: Int -> String -> String padStart targetLength string = getPadding targetLength string <> string - padEnd :: Int -> String -> String padEnd targetLength string = string <> getPadding targetLength string - alignNumber :: ColorFlag -> Int -> Int -> Number -> String alignNumber colorFlag intWidth fracWidth number = let - ifSet flag color = if flag == ColorYes - then foreground color + ifSet flag color = + if flag == ColorYes then foreground color else foreground White colorMap = { positive: ifSet colorFlag Green , negative: ifSet colorFlag Red - , neutral: ifSet colorFlag BrightBlack + , neutral: ifSet colorFlag BrightBlack } fragments = split (Pattern ".") (show number) intPart = case fragments !! 0 of @@ -243,32 +288,25 @@ alignNumber colorFlag intWidth fracWidth number = _ -> emptyFrac in -- TODO: Fix after https://github.com/hdgarrood/purescript-ansi/issues/7 - if colorFlag == ColorNo - then intPart <> fracPart - else - if number >= 0.0 - then - withGraphics colorMap.positive intPart + if colorFlag == ColorNo then intPart <> fracPart + else if number >= 0.0 then + withGraphics colorMap.positive intPart <> withGraphics colorMap.neutral fracPart - else - withGraphics colorMap.negative intPart + else + withGraphics colorMap.negative intPart <> withGraphics colorMap.neutral fracPart - makeRed :: Config -> String -> String makeRed conf str = - if conf.colorState == ColorYes - then withGraphics (foreground Red) str + if conf.colorState == ColorYes then withGraphics (foreground Red) str else str - errorAndExit :: Config -> String -> Effect (Result String Unit) errorAndExit conf message = do error (makeRed conf message) setExitCode 1 pure $ Error message - -- | Decimal point is included in fraction => +1 lengthOfNumParts :: Number -> Tuple Int Int lengthOfNumParts number = @@ -281,7 +319,6 @@ lengthOfNumParts number = in Tuple first second - type WidthRecord = { account :: Int , integer :: Int @@ -289,7 +326,6 @@ type WidthRecord = , commodity :: Int } - widthRecordZero :: WidthRecord widthRecordZero = { account: 0 @@ -298,12 +334,11 @@ widthRecordZero = , commodity: 0 } - mergeWidthRecords :: WidthRecord -> WidthRecord -> WidthRecord mergeWidthRecords recA recB = recA - { account = max recA.account recB.account - , integer = max recA.integer recB.integer - , fraction = max recA.fraction recB.fraction + { account = max recA.account recB.account + , integer = max recA.integer recB.integer + , fraction = max recA.fraction recB.fraction , commodity = max recA.commodity recB.commodity } diff --git a/src/Transity/Xlsx.purs b/src/Transity/Xlsx.purs index 8078cb2..debdf69 100644 --- a/src/Transity/Xlsx.purs +++ b/src/Transity/Xlsx.purs @@ -22,13 +22,11 @@ import Transity.Data.Transaction (Transaction(..)) import Transity.Data.Ledger (Ledger(..), entitiesToInitialTransfers) import Transity.Utils (utcToIsoString) - newtype FileEntry = FileEntry { path :: String , content :: String } - foreign import writeToZipImpl :: forall a. Fn3 (Maybe a) (Maybe String) (Array FileEntry) (EffectFnAff Unit) @@ -36,7 +34,6 @@ writeToZip :: Maybe String -> Array FileEntry -> Aff Unit writeToZip outPath files = fromEffectFnAff $ runFn3 writeToZipImpl Nothing outPath files - newtype SheetRow = SheetRow { utc :: String , account :: String @@ -46,17 +43,16 @@ newtype SheetRow = SheetRow , files :: Array String } - getSheetRows :: Ledger -> Maybe (Array SheetRow) -getSheetRows (Ledger {transactions, entities}) = do +getSheetRows (Ledger { transactions, entities }) = do let - getQunty (Amount quantity _ ) = show $ Rational.toNumber quantity - getCmdty (Amount _ commodity ) = unwrap commodity + getQunty (Amount quantity _) = show $ Rational.toNumber quantity + getCmdty (Amount _ commodity) = unwrap commodity splitTransfer :: { note :: Maybe String, files :: Array String, transfer :: Transfer } -> Maybe (Array SheetRow) - splitTransfer { note: note , files: files, transfer: (Transfer tfer) } = + splitTransfer { note: note, files: files, transfer: (Transfer tfer) } = let fromAmnt = Amount.negate tfer.amount @@ -67,7 +63,7 @@ getSheetRows (Ledger {transactions, entities}) = do , account: tfer.from , amount: getQunty fromAmnt , commodity: getCmdty fromAmnt - , note: [note, tfer.note] + , note: [ note, tfer.note ] # catMaybes # intercalate ", " , files: files @@ -77,7 +73,7 @@ getSheetRows (Ledger {transactions, entities}) = do , account: tfer.to , amount: getQunty tfer.amount , commodity: getCmdty tfer.amount - , note: [note, tfer.note] + , note: [ note, tfer.note ] # catMaybes # intercalate ", " , files: files @@ -86,26 +82,30 @@ getSheetRows (Ledger {transactions, entities}) = do in (tfer.utc <#> utcToIsoString) <#> getFromAndTo - splitted <- do - transactions - <#> (\(Transaction tact) -> tact.transfers - <#> (\(Transfer tfer) -> - { note: tact.note - , files: tact.files - , transfer: Transfer (tfer { utc = tfer.utc <|> tact.utc }) - } + splitted <- + do + transactions + <#> + ( \(Transaction tact) -> tact.transfers + <#> + ( \(Transfer tfer) -> + { note: tact.note + , files: tact.files + , transfer: Transfer (tfer { utc = tfer.utc <|> tact.utc }) + } ) ) - # concat - <#> splitTransfer - # sequence + # concat + <#> splitTransfer + # sequence let initialEntries = entitiesToInitialTransfers entities <#> \(Transfer t) -> - let isoString = fromMaybe "INVALID DATE" $ t.utc <#> utcToIsoString - in - [ SheetRow + let + isoString = fromMaybe "INVALID DATE" $ t.utc <#> utcToIsoString + in + [ SheetRow { utc: isoString , account: replaceAll (Pattern ":_default_") @@ -116,20 +116,18 @@ getSheetRows (Ledger {transactions, entities}) = do , note: fromMaybe "" t.note , files: [] } - ] + ] pure $ (splitted <> initialEntries) # concat - escapeHtml :: String -> String escapeHtml unsafeStr = unsafeStr - # replaceAll (Pattern "&") (Replacement "&") - # replaceAll (Pattern "<") (Replacement "<") - # replaceAll (Pattern ">") (Replacement ">") - # replaceAll (Pattern "\"") (Replacement """) - # replaceAll (Pattern "'") (Replacement "'") - + # replaceAll (Pattern "&") (Replacement "&") + # replaceAll (Pattern "<") (Replacement "<") + # replaceAll (Pattern ">") (Replacement ">") + # replaceAll (Pattern "\"") (Replacement """) + # replaceAll (Pattern "'") (Replacement "'") entriesAsXml :: Ledger -> Maybe String entriesAsXml ledger = do @@ -140,7 +138,8 @@ entriesAsXml ledger = do -- Remove "'file://" for LibreOffice -- Should therefore work on macOS and Windows with Excel and LibreOffice -- (Apple's Numbers does not support local file links at all) - hyperlinkFormula = """ + hyperlinkFormula = + """ =HYPERLINK( SUBSTITUTE( LEFT( @@ -173,35 +172,36 @@ entriesAsXml ledger = do case dataType of "inlineStr" -> "" - <> escapeHtml val - <> "" + <> escapeHtml val + <> "" "formula" -> - "" - <> (if val == "" - then "" + "" + <> + ( if val == "" then "" else - ("" - <> (escapeHtml $ replaceAll - (Pattern "{{ filename }}") - (Replacement val ) - hyperlinkFormula) - <> "" + ( "" + <> + ( escapeHtml $ replaceAll + (Pattern "{{ filename }}") + (Replacement val) + hyperlinkFormula + ) + <> "" ) - ) + ) <> "" _ -> " dataType <> "\">" - <> escapeHtml val - <> "" + <> escapeHtml val + <> "" -- This workaround is necessary -- since there must only be one HYPERLINK per cell -- TODO: Make it work for an unlimited number of files limitTo4Files files = - take 4 (files <> ["", "", "", ""]) - + take 4 (files <> [ "", "", "", "" ]) wrapStr = wrapValue "inlineStr" @@ -222,28 +222,33 @@ entriesAsXml ledger = do dataRows :: String dataRows = sheetRows - # sortBy (\(SheetRow rowRecA) (SheetRow rowRecB) -> - compare rowRecA.utc rowRecB.utc) - <#> (\(SheetRow rowRec) -> - "\n" - <> (wrapStr (rowRec.utc <> "Z")) - <> (wrapStr rowRec.account) - <> (wrapValue "n" rowRec.amount) - <> (wrapStr rowRec.commodity) - <> (wrapStr rowRec.note) - <> (limitTo4Files rowRec.files - <#> wrapValue "formula" - # fold - ) - <> "\n" - <> "") + # sortBy + ( \(SheetRow rowRecA) (SheetRow rowRecB) -> + compare rowRecA.utc rowRecB.utc + ) + <#> + ( \(SheetRow rowRec) -> + "\n" + <> (wrapStr (rowRec.utc <> "Z")) + <> (wrapStr rowRec.account) + <> (wrapValue "n" rowRec.amount) + <> (wrapStr rowRec.commodity) + <> (wrapStr rowRec.note) + <> + ( limitTo4Files rowRec.files + <#> wrapValue "formula" + # fold + ) + <> "\n" + <> "" + ) # joinWith "\n" pure $ headerRow <> dataRows - contentTypesContent :: String -contentTypesContent = """ +contentTypesContent = + """ """ - relsContent :: String -relsContent = """ +relsContent = + """ @@ -312,9 +317,9 @@ relsContent = """ """ - appContent :: String -appContent = """ +appContent = + """ @@ -323,14 +328,13 @@ appContent = """ """ - -- TODO: Implement correct timestamp now :: String now = "2021-01-01T00:00:00Z" - coreContent :: String -coreContent = """ +coreContent = + """ All transfers of journal created with Transity """ - <> now <> - """ + <> now + <> + """ """ - <> now <> - """ + <> now + <> + """ """ - xlRelsContent :: String -xlRelsContent = """ +xlRelsContent = + """ """ - sharedStrContent :: String -sharedStrContent = """ +sharedStrContent = + """ """ - -- Mandatory (otherwise neither Excel nor Apple Numbers can open it) -- More information: https://stackoverflow.com/a/26062365/1850340 stylesContent :: String -stylesContent = """ +stylesContent = + """ @@ -431,9 +437,9 @@ stylesContent = """ """ - workbookContent :: String -workbookContent = """ +workbookContent = + """ """ - -rowsToSheet:: String -> String -rowsToSheet rows = """ +rowsToSheet :: String -> String +rowsToSheet rows = + """ zeroHeight="false" /> -""" <> rows <> """ +""" <> rows <> + """ """ - entriesAsXlsx :: Ledger -> Array FileEntry entriesAsXlsx ledger = do case entriesAsXml ledger of @@ -560,4 +566,3 @@ entriesAsXlsx ledger = do } ] - diff --git a/src/Webapp.purs b/src/Webapp.purs index e610e24..e158d1b 100644 --- a/src/Webapp.purs +++ b/src/Webapp.purs @@ -6,7 +6,6 @@ import Data.Result (Result(..)) import Transity.Data.Config (ColorFlag(..)) import Transity.Data.Ledger as Ledger - getBalance :: String -> String getBalance journal = do let diff --git a/test/CliSpec.purs b/test/CliSpec.purs index 29383e9..3091fbc 100644 --- a/test/CliSpec.purs +++ b/test/CliSpec.purs @@ -20,42 +20,40 @@ import Prelude (Unit, pure, unit, (#), ($)) import Test.Spec (Spec, describe, it) import Test.Spec.Assertions (shouldEqual, fail, shouldReturn) - tokenizeCliStr :: String -> Array CliArgToken tokenizeCliStr str = str # split (Pattern " ") # tokenizeCliArguments - tests :: Spec Unit tests = do describe "CliSpec" do describe "Tokenizer" do it "parses a CLI invocation" do (tokenizeCliStr "git") - `shouldEqual` [TextToken "git"] + `shouldEqual` [ TextToken "git" ] it "parses a standalone flag (for subcommands)" do (tokenizeCliStr "--help") - `shouldEqual` [FlagLongToken "help"] + `shouldEqual` [ FlagLongToken "help" ] it "parses a CLI with an argument" do (tokenizeCliStr "ls dir") - `shouldEqual` [TextToken "ls", TextToken "dir"] + `shouldEqual` [ TextToken "ls", TextToken "dir" ] it "parses a CLI invocation with a long flag" do (tokenizeCliStr "git --version") - `shouldEqual` [TextToken "git", FlagLongToken "version"] + `shouldEqual` [ TextToken "git", FlagLongToken "version" ] it "parses a CLI invocation with a short flag" do (tokenizeCliStr "git -a") - `shouldEqual` [TextToken "git", FlagShortToken 'a'] + `shouldEqual` [ TextToken "git", FlagShortToken 'a' ] it "parses a CLI invocation with several short flags" do (tokenizeCliStr "git -ab") `shouldEqual` - [TextToken "git", FlagShortToken 'a', FlagShortToken 'b'] + [ TextToken "git", FlagShortToken 'a', FlagShortToken 'b' ] it "parses a CLI invocation with a long flag and an argument" do (tokenizeCliStr "git --verbose dir") @@ -82,31 +80,36 @@ tests = do describe "Spec Parser" do let cliSpec :: CliSpec - cliSpec = CliSpec (emptyCliSpecRaw - { name = "git" - , description = "The git command" - , funcName = Just "runApp" - , version = Just "1.0.0" - , commands = Just - [ CliSpec (emptyCliSpecRaw - { name = "commit" - , description = "The commit sub-command" - , funcName = Just "runCommit" - , arguments = Just - [ { name: "pathspec" - , description: "File to commit" - , type: "Text" - , optional : Nothing - , default : Nothing - } - ] - }) - ] - }) + cliSpec = CliSpec + ( emptyCliSpecRaw + { name = "git" + , description = "The git command" + , funcName = Just "runApp" + , version = Just "1.0.0" + , commands = Just + [ CliSpec + ( emptyCliSpecRaw + { name = "commit" + , description = "The commit sub-command" + , funcName = Just "runCommit" + , arguments = Just + [ { name: "pathspec" + , description: "File to commit" + , type: "Text" + , optional: Nothing + , default: Nothing + } + ] + } + ) + ] + } + ) it "parses a full CLI spec" do let - cliSpecJson = """ + cliSpecJson = + """ { "name": "git", "description": "The git command", "funcName": "runApp", @@ -133,23 +136,27 @@ tests = do it "correctly detects a subcommand with one argument" do let cliSpecWithFlag :: CliSpec - cliSpecWithFlag = cliSpec # over CliSpec (\spec -> spec - { commands = Just - [ CliSpec (emptyCliSpecRaw - { name = "pull" - , description = "The pull sub-command" - , funcName = Just "runPull" - , arguments = Just - [ { name: "repository" - , description: "Name of the repository" - , type: "Text" - , optional : Nothing - , default : Nothing - } - ] - }) - ] - }) + cliSpecWithFlag = cliSpec # over CliSpec + ( \spec -> spec + { commands = Just + [ CliSpec + ( emptyCliSpecRaw + { name = "pull" + , description = "The pull sub-command" + , funcName = Just "runPull" + , arguments = Just + [ { name: "repository" + , description: "Name of the repository" + , type: "Text" + , optional: Nothing + , default: Nothing + } + ] + } + ) + ] + } + ) tokens = tokenizeCliStr "git pull origin" tokens `shouldEqual` @@ -168,32 +175,36 @@ tests = do it "correctly detects a subcommand with one long flag and one argument" do let cliSpecWithFlag :: CliSpec - cliSpecWithFlag = cliSpec # over CliSpec (\spec -> spec - { commands = Just - [ CliSpec (emptyCliSpecRaw - { name = "pull" - , description = "The pull sub-command" - , funcName = Just "runPull" - , options = Just - [ { name: Just "progress" - , shortName: Nothing - , description: "Show progress" - , argument: Nothing - , optional : Nothing - , default : Nothing - } - ] - , arguments = Just - [ { name: "repository" - , description: "Name of the repository" - , type: "Text" - , optional : Nothing - , default : Nothing - } - ] - }) - ] - }) + cliSpecWithFlag = cliSpec # over CliSpec + ( \spec -> spec + { commands = Just + [ CliSpec + ( emptyCliSpecRaw + { name = "pull" + , description = "The pull sub-command" + , funcName = Just "runPull" + , options = Just + [ { name: Just "progress" + , shortName: Nothing + , description: "Show progress" + , argument: Nothing + , optional: Nothing + , default: Nothing + } + ] + , arguments = Just + [ { name: "repository" + , description: "Name of the repository" + , type: "Text" + , optional: Nothing + , default: Nothing + } + ] + } + ) + ] + } + ) tokens = tokenizeCliStr "git pull --progress origin" tokens `shouldEqual` @@ -214,30 +225,35 @@ tests = do it "redefines a long flag with a value to a long option" do let cliSpecWithFlag :: CliSpec - cliSpecWithFlag = cliSpec # over CliSpec (\spec -> spec - { commands = Just - [ CliSpec (emptyCliSpecRaw - { name = "pull" - , description = "The pull sub-command" - , funcName = Just "runPull" - , options = Just - [ { name: Just "strategy" - , shortName: Nothing - , description: "Set the preferred merge strategy" - , argument: Just - { name: "strategy" - , description: "Strategy to use" - , type: "Text" - , optional : Just true - , default : Nothing - } - , optional : Nothing - , default : Nothing - } - ] - }) - ] - }) + cliSpecWithFlag = cliSpec # over CliSpec + ( \spec -> spec + { commands = Just + [ CliSpec + ( emptyCliSpecRaw + { name = "pull" + , description = "The pull sub-command" + , funcName = Just "runPull" + , options = Just + [ { name: Just "strategy" + , shortName: Nothing + , description: + "Set the preferred merge strategy" + , argument: Just + { name: "strategy" + , description: "Strategy to use" + , type: "Text" + , optional: Just true + , default: Nothing + } + , optional: Nothing + , default: Nothing + } + ] + } + ) + ] + } + ) tokens = tokenizeCliStr "git pull --strategy recursive" tokens `shouldEqual` @@ -257,23 +273,25 @@ tests = do it "verifies number of args for variable number of allowed args" do let cliSpecWithFlag :: CliSpec - cliSpecWithFlag = emptyCliSpec # over CliSpec (\spec -> spec - { name = "ls" - , arguments = Just - [ { name: "file" - , description: "File to list" - , type: "Text" - , optional : Just false - , default : Nothing - } - , { name: "file" - , description: "Additional files to list" - , type: "List-Text" - , optional : Just true - , default : Nothing - } - ] - }) + cliSpecWithFlag = emptyCliSpec # over CliSpec + ( \spec -> spec + { name = "ls" + , arguments = Just + [ { name: "file" + , description: "File to list" + , type: "Text" + , optional: Just false + , default: Nothing + } + , { name: "file" + , description: "Additional files to list" + , type: "List-Text" + , optional: Just true + , default: Nothing + } + ] + } + ) let tokensOne = tokenizeCliStr "ls file1" (tokensToCliArguments cliSpecWithFlag tokensOne) @@ -289,7 +307,7 @@ tests = do Ok [ CmdArg "ls" , ValArg (TextArg "file1") - , ValArgList [TextArg "file2"] + , ValArgList [ TextArg "file2" ] ] let tokensThree = tokenizeCliStr "ls file1 file2 file3" @@ -298,7 +316,7 @@ tests = do Ok [ CmdArg "ls" , ValArg (TextArg "file1") - , ValArgList [TextArg "file2", TextArg "file3"] + , ValArgList [ TextArg "file2", TextArg "file3" ] ] describe "Execution" do @@ -314,7 +332,7 @@ tests = do it "shows help output for -h" do let - toolArgs = ["git", "-h"] + toolArgs = [ "git", "-h" ] tokens = tokenizeCliArguments toolArgs case tokensToCliArguments cliSpec tokens of @@ -325,7 +343,7 @@ tests = do it "shows help output for --help" do let - toolArgs = ["git", "--help"] + toolArgs = [ "git", "--help" ] tokens = tokenizeCliArguments toolArgs case tokensToCliArguments cliSpec tokens of @@ -336,7 +354,7 @@ tests = do it "shows help output for `help`" do let - toolArgs = ["git", "help"] + toolArgs = [ "git", "help" ] tokens = tokenizeCliArguments toolArgs case tokensToCliArguments cliSpec tokens of @@ -357,7 +375,7 @@ tests = do it "shows help output for -v" do let - toolArgs = ["git", "-v"] + toolArgs = [ "git", "-v" ] tokens = tokenizeCliArguments toolArgs case tokensToCliArguments cliSpec tokens of @@ -368,7 +386,7 @@ tests = do it "shows help output for --version" do let - toolArgs = ["git", "--version"] + toolArgs = [ "git", "--version" ] tokens = tokenizeCliArguments toolArgs case tokensToCliArguments cliSpec tokens of @@ -379,7 +397,7 @@ tests = do it "shows help output for `help`" do let - toolArgs = ["git", "help"] + toolArgs = [ "git", "help" ] tokens = tokenizeCliArguments toolArgs case tokensToCliArguments cliSpec tokens of @@ -388,138 +406,150 @@ tests = do liftEffect (callCommand cliSpec usageString cliArgs executor) `shouldReturn` (Ok unit) - it "executes a sub-command with one argument" do let - cliSpec = CliSpec (emptyCliSpecRaw - { name = "git" - , description = "The git command" - , funcName = Just "runApp" - , version = Just "1.0.0" - , commands = Just - [ CliSpec (emptyCliSpecRaw - { name = "pull" - , description = "The pull sub-command" - , funcName = Just "runPull" - , arguments = Just - [ { name: "dir" - , description: "Path to a directory" - , type: "Text" - , optional : Nothing - , default : Nothing - } - ] - }) - ] - }) - toolArgs = ["git", "pull", "dir"] + cliSpec = CliSpec + ( emptyCliSpecRaw + { name = "git" + , description = "The git command" + , funcName = Just "runApp" + , version = Just "1.0.0" + , commands = Just + [ CliSpec + ( emptyCliSpecRaw + { name = "pull" + , description = "The pull sub-command" + , funcName = Just "runPull" + , arguments = Just + [ { name: "dir" + , description: "Path to a directory" + , type: "Text" + , optional: Nothing + , default: Nothing + } + ] + } + ) + ] + } + ) + toolArgs = [ "git", "pull", "dir" ] usageString = "Irrelevant" executor cmdName usageStr providedArgs = do cmdName `shouldEqual` "pull" usageStr `shouldEqual` usageString - providedArgs `shouldEqual` [(ValArg (TextArg "dir"))] + providedArgs `shouldEqual` [ (ValArg (TextArg "dir")) ] pure $ Ok unit case tokensToCliArguments cliSpec $ tokenizeCliArguments toolArgs of Error err -> fail err Ok cliArgs -> - liftEffect (callCommand - cliSpec - usageString - cliArgs - executor - ) `shouldReturn` (Ok unit) + liftEffect + ( callCommand + cliSpec + usageString + cliArgs + executor + ) `shouldReturn` (Ok unit) it "executes a sub-command with one flag" do let - cliSpec = CliSpec (emptyCliSpecRaw - { name = "git" - , description = "The git command" - , funcName = Just "runApp" - , version = Just "1.0.0" - , commands = Just - [ CliSpec (emptyCliSpecRaw - { name = "pull" - , description = "The pull sub-command" - , funcName = Just "runPull" - , options = Just - [ { name: Just "stats" - , shortName: Nothing - , description: "Statistics for pull" - , argument: Nothing - , optional : Nothing - , default : Nothing - } - ] - }) - ] - }) - args = ["git", "pull", "--stats"] + cliSpec = CliSpec + ( emptyCliSpecRaw + { name = "git" + , description = "The git command" + , funcName = Just "runApp" + , version = Just "1.0.0" + , commands = Just + [ CliSpec + ( emptyCliSpecRaw + { name = "pull" + , description = "The pull sub-command" + , funcName = Just "runPull" + , options = Just + [ { name: Just "stats" + , shortName: Nothing + , description: "Statistics for pull" + , argument: Nothing + , optional: Nothing + , default: Nothing + } + ] + } + ) + ] + } + ) + args = [ "git", "pull", "--stats" ] usageString = "Irrelevant" executor cmdName usageStr providedArgs = do cmdName `shouldEqual` "pull" usageStr `shouldEqual` usageString - providedArgs `shouldEqual` [(FlagLong "stats")] + providedArgs `shouldEqual` [ (FlagLong "stats") ] pure $ Ok unit case (tokensToCliArguments cliSpec $ tokenizeCliArguments args) of Error err -> fail err Ok cliArgs -> - liftEffect (callCommand cliSpec usageString cliArgs executor) - `shouldReturn` (Ok unit) + liftEffect (callCommand cliSpec usageString cliArgs executor) + `shouldReturn` (Ok unit) it "executes a sub-command with one option" do let - cliSpec = CliSpec (emptyCliSpecRaw - { name = "git" - , description = "The git command" - , funcName = Just "runApp" - , version = Just "1.0.0" - , commands = Just - [ CliSpec (emptyCliSpecRaw - { name = "pull" - , description = "The pull sub-command" - , funcName = Just "runPull" - , options = Just - [ { name: Just "output" - , shortName: Nothing - , description: "Output directory" - , argument: Just - { name: "dir" - , description: "Path to a directory" - , type: "Text" - , optional : Nothing - , default : Nothing - } - , optional : Nothing - , default : Nothing - } - ] - , arguments = Just - [ { name: "dir" - , description: "Path to a directory" - , type: "Text" - , optional : Nothing - , default : Nothing - } - ] - }) - ] - }) - toolArgs = ["git", "pull", "--output", "dir"] + cliSpec = CliSpec + ( emptyCliSpecRaw + { name = "git" + , description = "The git command" + , funcName = Just "runApp" + , version = Just "1.0.0" + , commands = Just + [ CliSpec + ( emptyCliSpecRaw + { name = "pull" + , description = "The pull sub-command" + , funcName = Just "runPull" + , options = Just + [ { name: Just "output" + , shortName: Nothing + , description: "Output directory" + , argument: Just + { name: "dir" + , description: "Path to a directory" + , type: "Text" + , optional: Nothing + , default: Nothing + } + , optional: Nothing + , default: Nothing + } + ] + , arguments = Just + [ { name: "dir" + , description: "Path to a directory" + , type: "Text" + , optional: Nothing + , default: Nothing + } + ] + } + ) + ] + } + ) + toolArgs = [ "git", "pull", "--output", "dir" ] usageString = "Irrelevant" executor cmdName usageStr providedArgs = do cmdName `shouldEqual` "pull" usageStr `shouldEqual` usageString - providedArgs `shouldEqual` [(OptionLong "output" (TextArg "dir"))] + providedArgs `shouldEqual` [ (OptionLong "output" (TextArg "dir")) ] pure $ Ok unit case (tokensToCliArguments cliSpec $ tokenizeCliArguments toolArgs) of Error err -> fail err Ok cliArgs -> - (liftEffect $ callCommand + ( liftEffect $ callCommand cliSpec usageString cliArgs executor - ) `shouldReturn` (Ok unit) + ) `shouldReturn` (Ok unit) diff --git a/test/Fixtures.purs b/test/Fixtures.purs index 98ef307..4e8c89e 100644 --- a/test/Fixtures.purs +++ b/test/Fixtures.purs @@ -40,7 +40,8 @@ transferSimple = Transfer } transferSimpleJson :: String -transferSimpleJson = """ +transferSimpleJson = + """ { "utc": "2014-12-24", "from": "john:giro", @@ -51,7 +52,8 @@ transferSimpleJson = """ """ transferSimpleYaml :: String -transferSimpleYaml = """ +transferSimpleYaml = + """ utc: '2014-12-24' from: john:giro to: evil-corp @@ -60,7 +62,8 @@ note: A note with special chars like < and & """ transferSimpleShowed :: String -transferSimpleShowed = """ +transferSimpleShowed = + """ (Transfer { amount: (Amount 15 % 1 (Commodity "€")) , from: "john:giro" @@ -74,7 +77,8 @@ transferSimpleShowed = """ """ transferSimplePretty :: String -transferSimplePretty = "\ +transferSimplePretty = + "\ \2014-12-24 00:00 \ \| john:giro -> evil-corp : 15 € \ \| A note with special chars like < and &\n\ @@ -90,7 +94,8 @@ transferSimpleB = Transfer } transferSimpleBShowed :: String -transferSimpleBShowed = """ +transferSimpleBShowed = + """ (Transfer { amount: (Amount 7 % 1 (Commodity "USD")) , from: "carlos:wallet" @@ -103,7 +108,6 @@ transferSimpleBShowed = """ ) """ - -- | Transaction Examples transactionZero :: Transaction @@ -115,9 +119,9 @@ transactionZero = Transaction , transfers: [] } - transactionNoAccount :: String -transactionNoAccount = """ +transactionNoAccount = + """ owner: John transactions: - transfers: @@ -128,9 +132,10 @@ transactions: transactionNoAccountPretty :: String transactionNoAccountPretty = "" - <> " " `power` 86 <> "7.00 € \n" - <> " " `power` 76 <> "John -7.00 € \n" - + <> " " `power` 86 + <> "7.00 € \n" + <> " " `power` 76 + <> "John -7.00 € \n" transactionSimple :: Transaction transactionSimple = Transaction @@ -138,39 +143,45 @@ transactionSimple = Transaction , utc: stringToDateTime "2014-12-24" , note: Just "A short note about this transaction" -- Used for testing HYPERLINKs in XLSX files - , files: ["fixtures/example.txt"] + , files: [ "fixtures/example.txt" ] , transfers: [ transferSimple ] } transactionSimpleJson :: String -transactionSimpleJson = """ +transactionSimpleJson = + """ { "id": "abcxyz", "utc": "2014-12-24", "note": "A short note about this transaction", "transfers": [ - """ <> transferSimpleJson <> """ + """ <> transferSimpleJson <> + """ ] } """ transactionSimpleYaml :: String -transactionSimpleYaml = """ +transactionSimpleYaml = + """ id: abcxyz utc: '2014-12-24' note: A short note about this transaction transfers: - - """ <> indentSubsequent 4 transferSimpleYaml <> """ + - """ <> indentSubsequent 4 transferSimpleYaml <> + """ """ transactionSimpleShowed :: String -transactionSimpleShowed = """ +transactionSimpleShowed = + """ (Transaction { files: [] , id: (Just "abcxyz") , note: (Just "A short note about this transaction") , transfers: - [ """ <> transferSimpleShowed <> """ + [ """ <> transferSimpleShowed <> + """ ] , utc: (Just (DateTime (Date (Year 2014) December (Day 24)) @@ -179,32 +190,34 @@ transactionSimpleShowed = """ ) """ - transactionSimplePretty :: String -transactionSimplePretty = "\ +transactionSimplePretty = + "\ \2014-12-24 00:00 | A short note about this transaction | (id abcxyz)\n\ - \ " <> transferSimplePretty <> "\ - \ \n\ - \" -- Fix syntax highlighting: " - + \ " <> transferSimplePretty <> + "\ + \ \n\ + \" -- Fix syntax highlighting: " transactionSimpleB :: Transaction transactionSimpleB = Transaction { id: Just "defghi" , utc: stringToDateTime "2001-05-13" , note: Just "Another note" - , files: ["filepath/to/another-receipt.pdf"] + , files: [ "filepath/to/another-receipt.pdf" ] , transfers: [ transferSimpleB ] } transactionSimpleBShowed :: String -transactionSimpleBShowed = """ +transactionSimpleBShowed = + """ (Transaction { id: (Just "defghi") , note: (Just "Another note") , files: ["filepath/to/another-receipt.pdf"] , transfers: - [ """ <> transferSimpleBShowed <> """ + [ """ <> transferSimpleBShowed <> + """ ] , utc: (Just (DateTime (Date (Year 2001) May (Day 13)) @@ -213,7 +226,6 @@ transactionSimpleBShowed = """ ) """ - accountPretty :: String accountPretty = "" <> "test 12 $\n" @@ -224,13 +236,11 @@ accountPrettyAligned = "" <> " test 12 $ \n" <> " 2 EUR \n" - commodityMapPretty :: String commodityMapPretty = "" <> "12 $\n" <> "2 EUR" - commodityMapPrettyAligned :: String commodityMapPrettyAligned = "" <> " 12 $ \n" @@ -254,7 +264,6 @@ ledger2 = Ledger [ transactionSimpleB ] } - ledgerMultiTrans :: Ledger ledgerMultiTrans = Ledger { owner: Just "John Doe" @@ -265,7 +274,6 @@ ledgerMultiTrans = Ledger ] } - ledgerEntities :: Ledger ledgerEntities = Ledger { owner: Just "John Doe" @@ -276,17 +284,17 @@ ledgerEntities = Ledger , transactions: [] } - ledgerEntitiesShowed :: String -ledgerEntitiesShowed = """ +ledgerEntitiesShowed = + """ entities: - id: Anna - id: Bob """ - ledgerJson :: String -ledgerJson = """ +ledgerJson = + """ { "entities": [ {"id": "abcxyz"}, @@ -295,14 +303,15 @@ ledgerJson = """ ], "owner": "John Doe", "transactions": [ - """ <> transactionSimpleJson <> """ + """ <> transactionSimpleJson <> + """ ] } """ - balanceJson :: String -balanceJson = """ +balanceJson = + """ { "utc": "2017-04-02 20:11:45", "amounts": ["7 €", "-8 $", "+9 BTC"] @@ -310,7 +319,8 @@ balanceJson = """ """ balanceShowed :: String -balanceShowed = """ +balanceShowed = + """ (Balance (DateTime (Date (Year 2017) April (Day 2)) @@ -322,35 +332,35 @@ balanceShowed = """ ])) """ - commodityMap :: CommodityMap commodityMap = fromFoldable - [(Tuple - (Commodity "€") - (Amount (100 % 1) (Commodity "€"))) + [ ( Tuple + (Commodity "€") + (Amount (100 % 1) (Commodity "€")) + ) ] - balanceMap :: BalanceMap balanceMap = - fromFoldable [Tuple "john" commodityMap] - + fromFoldable [ Tuple "john" commodityMap ] account :: Account account = Account { id: "wallet" , commodityMap , balances: Just - [ (Balance - (unsafePartial $ fromJust $ stringToDateTime "2017-04-02 20:11:45") - (fromFoldable - [(Tuple (Commodity "€") (Amount (100 % 1) (Commodity "€")))])) + [ ( Balance + (unsafePartial $ fromJust $ stringToDateTime "2017-04-02 20:11:45") + ( fromFoldable + [ (Tuple (Commodity "€") (Amount (100 % 1) (Commodity "€"))) ] + ) + ) ] } - accountJson :: String -accountJson = """ +accountJson = + """ { "id": "_default_", "balances": [ { "utc": "2017-04-02 20:11:45", @@ -361,9 +371,9 @@ accountJson = """ }]} """ - accountShowed :: String -accountShowed = """ +accountShowed = + """ (Account { balances: (Just [ (Balance @@ -393,9 +403,9 @@ accountShowed = """ }) """ - entityJson :: String -entityJson = """ +entityJson = + """ { "id": "john", "accounts": [ { "id": "_default_", @@ -408,7 +418,8 @@ entityJson = """ """ entityShowed :: String -entityShowed = """ +entityShowed = + """ (Entity {accounts: (Just [ (Account @@ -448,7 +459,8 @@ entityShowed = """ """ ledgerYaml :: String -ledgerYaml = """ +ledgerYaml = + """ entities: - id: abcxyz - id: evil-corp @@ -456,20 +468,24 @@ entities: owner: John Doe additional: Additional values are ignored transactions: - - """ <> indentSubsequent 4 transactionSimpleYaml <> """ + - """ <> indentSubsequent 4 transactionSimpleYaml <> + """ """ ledgerLedger :: String -ledgerLedger = """2014-12-24 A short note about this transaction +ledgerLedger = + """2014-12-24 A short note about this transaction evil-corp 15 € john:giro """ idToEntityStr :: String -> String -idToEntityStr id = """ +idToEntityStr id = + """ (Entity { accounts: Nothing - , id: """ <> "\"" <> id <> "\"" <> """ + , id: """ <> "\"" <> id <> "\"" <> + """ , name: Nothing , note: Nothing , tags: Nothing @@ -477,42 +493,50 @@ idToEntityStr id = """ }) """ - ledgerShowed :: String -ledgerShowed = """ +ledgerShowed = + """ (Ledger { entities: (Just - [ """ <> idToEntityStr "abcxyz" <> """ - , """ <> idToEntityStr "evil-corp" <> """ - , """ <> idToEntityStr "john:giro" <> """ + [ """ <> idToEntityStr "abcxyz" + <> + """ + , """ + <> idToEntityStr "evil-corp" + <> + """ + , """ + <> idToEntityStr "john:giro" + <> + """ ]) , owner: (Just "John Doe") , transactions: - [ """ <> transactionSimpleShowed <> """ + [ """ + <> transactionSimpleShowed + <> + """ ] } ) """ - ledgerPretty :: String -ledgerPretty = """Journal for "John Doe" +ledgerPretty = + """Journal for "John Doe" ================================================================================ 2014-12-24 00:00 | A short note about this transaction | (id abcxyz) """ <> transferSimplePretty <> " \n" - ledgerBalanceOwner :: String ledgerBalanceOwner = "" <> " john:giro -15 €\n" - ledgerBalanceAll :: String ledgerBalanceAll = "" <> " evil-corp 15 €\n" <> " john:giro -15 €\n" - ledgerBalanceMultiTrans :: String ledgerBalanceMultiTrans = "" <> " evil-corp 8 €\n" diff --git a/test/Main.purs b/test/Main.purs index 8270efc..2561afe 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -68,7 +68,6 @@ import Transity.Utils ) import Transity.Xlsx (entriesAsXlsx, writeToZip, FileEntry(..)) - rmWhitespace :: String -> String rmWhitespace str = let @@ -76,39 +75,35 @@ rmWhitespace str = in replace whitespace "" str - wrapWithOk :: String -> String wrapWithOk string = "(Ok " <> string <> ")" - testEqualityTo :: String -> String -> Result String String testEqualityTo actual expected = - if (actual /= expected) - then Error + if (actual /= expected) then Error $ indentSubsequent 2 - $ "=========== Actual ===========\n" - <> replaceAll (Pattern "\n") (Replacement "|\n") actual <> "|\n" - <> "========== Expected ==========\n" - <> replaceAll (Pattern "\n") (Replacement "|\n") expected <> "|\n" - <> "==============================" - <> "\n\n" + $ "=========== Actual ===========\n" + <> replaceAll (Pattern "\n") (Replacement "|\n") actual + <> "|\n" + <> "========== Expected ==========\n" + <> replaceAll (Pattern "\n") (Replacement "|\n") expected + <> "|\n" + <> "==============================" + <> "\n\n" else Ok "" - shouldBeOk :: Result String String -> Aff Unit shouldBeOk value = case value of Error error -> fail error Ok _ -> (pure unit) - shouldEqualString :: String -> String -> Aff Unit shouldEqualString v1 v2 = case v1 `testEqualityTo` v2 of Error error -> fail error Ok _ -> (pure unit) - compareChar :: String -> String -> Aff Unit compareChar actual expected = let @@ -116,14 +111,13 @@ compareChar actual expected = shouldEqual (toCharArray actual) (toCharArray expected) - in do - fold comparisonArray - (length actual) `shouldEqual` (length expected) - - + in + do + fold comparisonArray + (length actual) `shouldEqual` (length expected) main :: Effect Unit -main = launchAff_ $ runSpec [consoleReporter] do +main = launchAff_ $ runSpec [ consoleReporter ] do Test.CliSpec.tests describe "Utils" do @@ -158,7 +152,7 @@ main = launchAff_ $ runSpec [consoleReporter] do it "converts 12.3456 to 123456/10000" do (digitsToRational "12.3456") `shouldEqual` - (Just (123456 % 10000)) + (Just (123456 % 10000)) it "converts -0.3 to -3/10" do (digitsToRational "-0.3") `shouldEqual` @@ -174,15 +168,14 @@ main = launchAff_ $ runSpec [consoleReporter] do let bigIntRatio :: Maybe Rational bigIntRatio = do - a <- BigInt.fromString "3111111111" - b <- BigInt.fromString "2000000000" - pure (a % b) + a <- BigInt.fromString "3111111111" + b <- BigInt.fromString "2000000000" + pure (a % b) -- This would fail with a range overflow -- if Ints instead of BigInt were used (Just $ digitsToRational digits) `shouldEqual` (Just bigIntRatio) - describe "Xlsx" do it "writes files to a ZIP archive" do writeToZip @@ -213,7 +206,6 @@ main = launchAff_ $ runSpec [consoleReporter] do Just (FileEntry sheet) -> sheet.content `shouldContain` "special chars like < and &" - describe "Transity" do describe "Data" do describe "Amount" do @@ -235,7 +227,6 @@ main = launchAff_ $ runSpec [consoleReporter] do (Amount (37 % 1) (Commodity "EUR")) actual `shouldEqualString` " 37 EUR " - describe "Account" do it "converts a JSON string to an Account" do let @@ -253,7 +244,8 @@ main = launchAff_ $ runSpec [consoleReporter] do it "encodes an Account as JSON" do stringify (encodeJson Account.zero) `shouldEqualString` - rmWhitespace """ + rmWhitespace + """ { "id": "", "commodityMap": [], @@ -264,9 +256,11 @@ main = launchAff_ $ runSpec [consoleReporter] do it "can add an amount to a commodity map" do let expectedMap = Map.fromFoldable - [(Tuple - (Commodity "€") - (Amount (37 % 1) (Commodity "€")))] + [ ( Tuple + (Commodity "€") + (Amount (37 % 1) (Commodity "€")) + ) + ] emptyMap = Map.empty :: CommodityMap amount = Amount (37 % 1) (Commodity "€") actualMap = emptyMap `CommodityMap.addAmountToMap` amount @@ -275,44 +269,51 @@ main = launchAff_ $ runSpec [consoleReporter] do it "can subtract an amount from a commodity map" do let expectedMap = Map.fromFoldable - [(Tuple - (Commodity "€") - (Amount (37 % 1) (Commodity "€")))] + [ ( Tuple + (Commodity "€") + (Amount (37 % 1) (Commodity "€")) + ) + ] initialMap = Map.fromFoldable - [(Tuple - (Commodity "€") - (Amount (42 % 1) (Commodity "€")))] + [ ( Tuple + (Commodity "€") + (Amount (42 % 1) (Commodity "€")) + ) + ] amount = Amount (5 % 1) (Commodity "€") actualMap = initialMap `CommodityMap.subtractAmountFromMap` amount actualMap `shouldEqual` expectedMap it "can check if a commodity map as only zero of each commodity" do - let commodityMapZero = Map.fromFoldable - [ (Tuple (Commodity "€") (Amount ratioZero (Commodity "€"))) - , (Tuple (Commodity "$") (Amount ratioZero (Commodity "$"))) - ] + let + commodityMapZero = Map.fromFoldable + [ (Tuple (Commodity "€") (Amount ratioZero (Commodity "€"))) + , (Tuple (Commodity "$") (Amount ratioZero (Commodity "$"))) + ] (isCommodityMapZero commodityMapZero) `shouldEqual` true - - let commodityMap = Map.fromFoldable - [ (Tuple + let + commodityMap = Map.fromFoldable + [ ( Tuple (Commodity "EUR") - (Amount (2 % 1) (Commodity "EUR"))) - , (Tuple + (Amount (2 % 1) (Commodity "EUR")) + ) + , ( Tuple (Commodity "$") - (Amount (12 % 1) (Commodity "$"))) - ] + (Amount (12 % 1) (Commodity "$")) + ) + ] it "pretty shows a commodity map" do let actualPretty = CommodityMap.showPretty commodityMap actualPretty `shouldEqualString` commodityMapPretty it "pretty shows and aligns a commodity map" do - let actualPretty = - CommodityMap.showPrettyAligned ColorNo 7 8 9 commodityMap + let + actualPretty = + CommodityMap.showPrettyAligned ColorNo 7 8 9 commodityMap actualPretty `shouldEqualString` commodityMapPrettyAligned - it "pretty shows an account" do let actualPretty = Account.showPretty "test" commodityMap actualPretty `shouldEqualString` accountPretty @@ -332,7 +333,6 @@ main = launchAff_ $ runSpec [consoleReporter] do commodityMap actualPretty `shouldEqualString` accountPrettyAligned - describe "Transfer" do it "converts a simple JSON string to a Transfer" do let @@ -350,7 +350,6 @@ main = launchAff_ $ runSpec [consoleReporter] do actual = Transfer.showPretty transferSimple actual `shouldEqualString` transferSimplePretty - describe "Transaction" do it "converts a JSON string to a Transaction" do let @@ -363,7 +362,6 @@ main = launchAff_ $ runSpec [consoleReporter] do # rmWhitespace actual `shouldEqualString` expected - it "converts a YAML string to a Transaction" do let actual = transactionSimpleYaml @@ -375,13 +373,11 @@ main = launchAff_ $ runSpec [consoleReporter] do # rmWhitespace actual `shouldEqualString` expected - it "pretty shows a transaction" do let actual = Transaction.showPretty transactionSimple actual `shouldEqualString` transactionSimplePretty - describe "Balance" do it "converts a JSON string to a Balance" do let @@ -397,7 +393,6 @@ main = launchAff_ $ runSpec [consoleReporter] do # rmWhitespace actual `shouldEqualString` expected - describe "Entity" do it "converts a JSON string to an Entity" do let @@ -410,52 +405,65 @@ main = launchAff_ $ runSpec [consoleReporter] do # rmWhitespace actual `shouldEqualString` expected - it "converts an Entity to an array of accounts with long id" do let accountWithId = over Account.Account (_ { id = "_default_" }) Account.zero entity = over Entity.Entity - (_ { accounts = Just [account, accountWithId], id = "John" }) + (_ { accounts = Just [ account, accountWithId ], id = "John" }) Entity.zero accounts = Entity.toAccountsWithId entity - (show accounts) `shouldEqualString` (show - [ (Account - { balances: (Just [(Balance - (unsafePartial $ fromJust - $ stringToDateTime "2017-04-02 20:11:45") - (Map.fromFoldable - [(Tuple - (Commodity "€") - (Amount (100 % 1) (Commodity "€"))) - ])) - ]) - , commodityMap: (Map.fromFoldable - [(Tuple - (Commodity "€") - (Amount (100 % 1) (Commodity "€"))) - ]) - , id: "John:wallet" - }) - , (Account - { balances: Nothing - , commodityMap: (Map.fromFoldable []) - , id: "John:_default_" - }) - ] - ) - + (show accounts) `shouldEqualString` + ( show + [ ( Account + { balances: + ( Just + [ ( Balance + ( unsafePartial $ fromJust + $ stringToDateTime "2017-04-02 20:11:45" + ) + ( Map.fromFoldable + [ ( Tuple + (Commodity "€") + (Amount (100 % 1) (Commodity "€")) + ) + ] + ) + ) + ] + ) + , commodityMap: + ( Map.fromFoldable + [ ( Tuple + (Commodity "€") + (Amount (100 % 1) (Commodity "€")) + ) + ] + ) + , id: "John:wallet" + } + ) + , ( Account + { balances: Nothing + , commodityMap: (Map.fromFoldable []) + , id: "John:_default_" + } + ) + ] + ) it "converts an Entitie's balances to an array of transfers" do let entity = over Entity.Entity - (_ { accounts = Just [account], id = "John" }) + (_ { accounts = Just [ account ], id = "John" }) Entity.zero transfers = Entity.toTransfers entity - (rmWhitespace $ show transfers) `shouldEqualString` (rmWhitespace """ + (rmWhitespace $ show transfers) `shouldEqualString` + ( rmWhitespace + """ [(Transfer { amount: (Amount 100 % 1 (Commodity "€")) , from: "John:wallet" @@ -466,8 +474,8 @@ main = launchAff_ $ runSpec [consoleReporter] do (Time (Hour 20) (Minute 11) (Second 45) (Millisecond 0)))) }) ] - """) - + """ + ) describe "Ledger" do it "converts a JSON string to a Ledger" do @@ -481,7 +489,6 @@ main = launchAff_ $ runSpec [consoleReporter] do # rmWhitespace actual `shouldEqualString` expected - it "converts a YAML string to a Ledger" do let actual = ledgerYaml @@ -493,31 +500,32 @@ main = launchAff_ $ runSpec [consoleReporter] do # rmWhitespace actual `shouldEqualString` expected - it "checks if balance map is zero" do (Ledger.isBalanceMapZero balanceMap) `shouldEqual` false - it "checks if amount in balance map is zero" do let - balMap = fromFoldable [Tuple "john" $ fromFoldable - [ (Tuple - (Commodity "€") - (Amount (100 % 1) (Commodity "€"))) - , (Tuple - (Commodity "$") - (Amount ratioZero (Commodity "$"))) - ]] + balMap = fromFoldable + [ Tuple "john" $ fromFoldable + [ ( Tuple + (Commodity "€") + (Amount (100 % 1) (Commodity "€")) + ) + , ( Tuple + (Commodity "$") + (Amount ratioZero (Commodity "$")) + ) + ] + ] isZeroUSD = Ledger.isAmountInMapZero balMap "john" (Commodity "$") isZeroEUR = Ledger.isAmountInMapZero balMap "john" (Commodity "€") isZeroUSD `shouldEqual` true isZeroEUR `shouldEqual` false - it "adds a transfer to a balance map" do let - emptyMap = fromFoldable [Tuple "john" Map.empty] + emptyMap = fromFoldable [ Tuple "john" Map.empty ] transfer = Transfer { utc: stringToDateTime "2014-12-24" , from: "john:wallet" @@ -527,35 +535,36 @@ main = launchAff_ $ runSpec [consoleReporter] do } expected = fromFoldable [ Tuple "anna:_default_" $ fromFoldable - [ (Tuple - (Commodity "€") - (Amount (15 % 1) (Commodity "€"))) + [ ( Tuple + (Commodity "€") + (Amount (15 % 1) (Commodity "€")) + ) ] , Tuple "john" $ fromFoldable [] , Tuple "john:wallet" $ fromFoldable - [ (Tuple - (Commodity "€") - (Amount (-15 % 1) (Commodity "€"))) + [ ( Tuple + (Commodity "€") + (Amount (-15 % 1) (Commodity "€")) + ) ] ] actual = emptyMap `Ledger.addTransfer` transfer (show actual) `shouldEqualString` (show expected) - describe "Verification" do it "ledger without verification balances is valid" do let verification = Ledger.verifyLedgerBalances ledger (isOk verification) `shouldEqual` true - -- TODO: Use instead following with purescript-spec@v3.1.0 - -- verification `shouldSatisfy` isOk - + -- TODO: Use instead following with purescript-spec@v3.1.0 + -- verification `shouldSatisfy` isOk it "fails if verification balances are incorrect" do let - ledgerValid = Ledger.fromYaml """ + ledgerValid = Ledger.fromYaml + """ owner: John Doe entities: - id: anna @@ -579,10 +588,10 @@ main = launchAff_ $ runSpec [consoleReporter] do (isError verification) `shouldEqual` true - it "fails if verification balance has too many entries" do let - ledgerValid = Ledger.fromYaml """ + ledgerValid = Ledger.fromYaml + """ owner: John Doe entities: - id: anna @@ -609,10 +618,10 @@ main = launchAff_ $ runSpec [consoleReporter] do (show verification) `shouldContain` "off by 5 BTC" - it "passes if verification balance is correct" do let - ledgerValid = Ledger.fromYaml """ + ledgerValid = Ledger.fromYaml + """ owner: John Doe entities: - id: anna @@ -634,80 +643,116 @@ main = launchAff_ $ runSpec [consoleReporter] do """ verification = ledgerValid >>= Ledger.verifyLedgerBalances expected = Ledger - { entities: (Just - [ (Entity - { accounts: (Just - [(Account { balances: (Just - [ (Balance - (unsafePartial $ fromJust - $ stringToDateTime "2000-01-01 12:00") - (fromFoldable [])) - , (Balance - (unsafePartial $ fromJust - $ stringToDateTime "2010-01-01 12:00") - (fromFoldable - [(Tuple - (Commodity "€") - (Amount - (3 % 1) - (Commodity "€"))) - ] - ) - ) - ]) - , commodityMap: (fromFoldable []) - , id: "wallet" })]) - , id: "anna" - , name: Nothing - , note: Nothing - , tags: Nothing - , utc: Nothing - }) - , (Entity - { accounts: (Just - [(Account - { balances: Nothing - , commodityMap: (fromFoldable []) - , id: "wallet" - }) - ]) - , id: "ben" - , name: Nothing - , note: Nothing - , tags: Nothing - , utc: Nothing - }) - ]) - , owner: Just "John Doe" - , transactions: - [(Transaction - { id: Nothing - , note: Nothing - , files: [] - , transfers: - [ (Transfer - { amount: (Amount - (3 % 1) - (Commodity "€")) - , from: "ben:wallet" + { entities: + ( Just + [ ( Entity + { accounts: + ( Just + [ ( Account + { balances: + ( Just + [ ( Balance + ( unsafePartial + $ fromJust + $ stringToDateTime + "2000-01-01 12:00" + ) + (fromFoldable []) + ) + , ( Balance + ( unsafePartial + $ fromJust + $ stringToDateTime + "2010-01-01 12:00" + ) + ( fromFoldable + [ ( Tuple + ( Commodity + "€" + ) + ( Amount + (3 % 1) + ( Commodity + "€" + ) + ) + ) + ] + ) + ) + ] + ) + , commodityMap: (fromFoldable []) + , id: "wallet" + } + ) + ] + ) + , id: "anna" + , name: Nothing + , note: Nothing + , tags: Nothing + , utc: Nothing + } + ) + , ( Entity + { accounts: + ( Just + [ ( Account + { balances: Nothing + , commodityMap: (fromFoldable []) + , id: "wallet" + } + ) + ] + ) + , id: "ben" + , name: Nothing , note: Nothing - , to: "anna:wallet" + , tags: Nothing , utc: Nothing - }) - ] - , utc: (Just (unsafePartial $ fromJust - $ stringToDateTime "2005-01-01 12:00")) - }) + } + ) + ] + ) + , owner: Just "John Doe" + , transactions: + [ ( Transaction + { id: Nothing + , note: Nothing + , files: [] + , transfers: + [ ( Transfer + { amount: + ( Amount + (3 % 1) + (Commodity "€") + ) + , from: "ben:wallet" + , note: Nothing + , to: "anna:wallet" + , utc: Nothing + } + ) + ] + , utc: + ( Just + ( unsafePartial $ fromJust + $ stringToDateTime "2005-01-01 12:00" + ) + ) + } + ) ] } (show verification) `shouldEqualString` - (show (Ok expected :: Result String Ledger.Ledger) ) - + (show (Ok expected :: Result String Ledger.Ledger)) it "passes if verification balances are correct" do let - ledgerValid = Ledger.fromYaml """ + ledgerValid = Ledger.fromYaml + """ owner: John Doe entities: - id: anna @@ -734,10 +779,10 @@ main = launchAff_ $ runSpec [consoleReporter] do (isOk verification) `shouldEqual` true - it "passes if verification balances at different UTCs are correct" do let - ledgerValid = Ledger.fromYaml """ + ledgerValid = Ledger.fromYaml + """ owner: John Doe entities: - id: anna @@ -768,76 +813,76 @@ main = launchAff_ $ runSpec [consoleReporter] do (isOk verification) `shouldEqual` true - it "subtracts a transfer from a balance map" do let result = balanceMap `Ledger.subtractTransfer` transferSimple expected = Map.fromFoldable - [ (Tuple "evil-corp:_default_" - (Map.fromFoldable - [(Tuple - (Commodity "€") - (Amount (-15 % 1) (Commodity "€"))) - ])) - , (Tuple "john" - (Map.fromFoldable - [(Tuple - (Commodity "€") - (Amount (100 % 1) (Commodity "€"))) - ])) - , (Tuple "john:giro" - (Map.fromFoldable - [(Tuple - (Commodity "€") - (Amount (15 % 1) (Commodity "€"))) - ])) + [ ( Tuple "evil-corp:_default_" + ( Map.fromFoldable + [ ( Tuple + (Commodity "€") + (Amount (-15 % 1) (Commodity "€")) + ) + ] + ) + ) + , ( Tuple "john" + ( Map.fromFoldable + [ ( Tuple + (Commodity "€") + (Amount (100 % 1) (Commodity "€")) + ) + ] + ) + ) + , ( Tuple "john:giro" + ( Map.fromFoldable + [ ( Tuple + (Commodity "€") + (Amount (15 % 1) (Commodity "€")) + ) + ] + ) + ) ] (show result) `shouldEqualString` (show expected) - it "fails if a transfer contains an empty field" do expectError - (shouldBeOk do - actual <- transactionNoAccount - # Ledger.fromYaml - # map (Ledger.showBalance BalanceAll ColorNo) - expected <- Ok transactionNoAccountPretty - actual `testEqualityTo` expected + ( shouldBeOk do + actual <- transactionNoAccount + # Ledger.fromYaml + # map (Ledger.showBalance BalanceAll ColorNo) + expected <- Ok transactionNoAccountPretty + actual `testEqualityTo` expected ) - it "pretty shows a ledger" do (Ledger.showPretty ledger) `shouldEqualString` ledgerPretty - it "pretty shows all accounts" do (ledgerEntities # Ledger.showEntities CustomSort # rmWhitespace) `shouldEqualString` - (rmWhitespace ledgerEntitiesShowed) - + (rmWhitespace ledgerEntitiesShowed) it "pretty shows the balance of owner" do (Ledger.showBalance (BalanceOnly "john") ColorNo ledger) `shouldEqualString` ledgerBalanceOwner - it "pretty shows the balance of all accounts" do (Ledger.showBalance BalanceAll ColorNo ledger) `shouldEqualString` ledgerBalanceAll - it "supports multiple transactions on one account" do let actual = Ledger.showBalance BalanceAll ColorNo ledgerMultiTrans actual `shouldEqualString` ledgerBalanceMultiTrans - it "serializes to HLedger format" do (Ledger.entriesToLedger ledger) `shouldEqualString` ledgerLedger - it "keeps first owner when combining several ledgers" do let (Ledger combined) =