2023-12-16 08:27:41 +03:00
#!/ usr / bin / env stack
-- stack runghc
2014-09-11 00:07:53 +04:00
{-
2015-10-10 21:51:07 +03:00
generatejournal . hs NUMTXNS NUMACCTS ACCTDEPTH [ --chinese|--mixed]
2009-05-29 12:23:59 +04:00
2019-04-20 18:30:56 +03:00
This generates synthetic journal data for benchmarking & profiling . It
prints a dummy journal on stdout , with NUMTXNS transactions , one per
day , using NUMACCTS account names with depths up to ACCTDEPTH . It will
also contain NUMACCTS P records , one per day . By default it uses only
ascii characters , with --chinese it uses wide chinese characters, or
with --mixed it uses both.
2009-05-29 12:23:59 +04:00
- }
module Main
where
2015-10-10 21:51:07 +03:00
import Data.Char
2021-03-05 14:59:21 +03:00
import Data.Decimal
2015-10-10 21:51:07 +03:00
import Data.List
2009-05-29 12:23:59 +04:00
import Data.Time.Calendar
2015-10-10 21:51:07 +03:00
import Data.Time.LocalTime
2009-05-29 12:23:59 +04:00
import Numeric
2024-02-29 04:36:20 +03:00
import Safe ( tailErr )
2015-10-10 21:51:07 +03:00
import System.Environment
import Text.Printf
-- import Hledger.Utils.Debug
2009-05-29 12:23:59 +04:00
main = do
2015-10-10 21:51:07 +03:00
rawargs <- getArgs
let ( opts , args ) = partition ( isPrefixOf " - " ) rawargs
2009-05-29 12:23:59 +04:00
let [ numtxns , numaccts , acctdepth ] = map read args :: [ Int ]
2019-04-20 18:30:56 +03:00
-- today <- getCurrentDay
-- let (year,_,_) = toGregorian today
let d = fromGregorian 2000 1 1
2009-05-29 12:23:59 +04:00
let dates = iterate ( addDays 1 ) d
2015-10-10 21:51:07 +03:00
let accts = pair $ cycle $ take numaccts $ uniqueAccountNames opts acctdepth
2021-03-05 14:59:21 +03:00
let comms = cycle [ 'A' .. 'Z' ]
2019-04-20 01:44:25 +03:00
let rates = [ 0.70 , 0.71 .. 1.3 ]
2021-03-05 14:59:21 +03:00
mapM_ ( \ ( n , d , ( a , b ) , c , p ) -> putStr $ showtxn n d a b c p ) $ take numtxns $ zip5 [ 1 .. ] dates accts comms ( drop 1 comms )
2024-02-29 04:36:20 +03:00
mapM_ ( \ ( d , rate ) -> putStr $ showmarketprice d rate ) $ take numtxns $ zip dates ( cycle $ rates ++ init ( tailErr ( reverse rates ) ) ) -- PARTIAL tailErr succeeds because non-null rates list
2009-05-29 12:23:59 +04:00
2021-03-05 14:59:21 +03:00
showtxn :: Int -> Day -> String -> String -> Char -> Char -> String
showtxn txnno date acct1 acct2 comm pricecomm =
printf " %s transaction %d \ n %-40s %2d %c%s \ n %-40s %s %c \ n \ n " d txnno acct1 amt comm pricesymbol acct2 ( show amt2 ) amt2comm
2009-05-29 12:23:59 +04:00
where
d = show date
2019-04-24 17:56:45 +03:00
amt = txnno
2021-03-05 14:59:21 +03:00
( amt2 , amt2comm , pricesymbol )
| txnno ` rem ` 3 == 0 = ( fromIntegral ( - amt ) :: Decimal , comm , " " )
| txnno ` rem ` 3 == 1 = ( fromIntegral ( - amt ) * rate , pricecomm , printf " @ %s %c " ( show rate ) pricecomm )
| otherwise = ( fromIntegral ( - amt ) , pricecomm , printf " @@ %s %c " ( show amt ) pricecomm )
rate = 0.70 + 0.01 * fromIntegral ( txnno ` rem ` 60 ) :: Decimal
2009-05-29 12:23:59 +04:00
2019-04-20 01:44:25 +03:00
showmarketprice :: Day -> Double -> String
2021-08-16 08:32:12 +03:00
showmarketprice date = printf " P %s A %.2f B \ n " ( show date )
2019-04-20 01:44:25 +03:00
2015-10-10 21:51:07 +03:00
uniqueAccountNames :: [ String ] -> Int -> [ String ]
uniqueAccountNames opts depth =
mkacctnames uniquenames
where
mkacctnames names = mkacctnamestodepth some ++ mkacctnames rest
where
( some , rest ) = splitAt depth names
-- mkacctnamestodepth ["a", "b", "c"] = ["a","a:b","a:b:c"]
mkacctnamestodepth :: [ String ] -> [ String ]
mkacctnamestodepth [] = []
mkacctnamestodepth ( a : as ) = a : map ( ( a ++ " : " ) ++ ) ( mkacctnamestodepth as )
uniquenames
| " --mixed " ` elem ` opts = concat $ zipWith ( \ a b -> [ a , b ] ) uniqueNamesHex uniqueNamesWide
| " --chinese " ` elem ` opts = uniqueNamesWide
| otherwise = uniqueNamesHex
uniqueNamesHex = map hex [ 1 .. ] where hex = flip showHex " "
uniqueNamesWide = concat [ sequences n wideChars | n <- [ 1 .. ] ]
-- Get the sequences of specified size starting at each element of a list,
-- cycling it if needed to fill the last sequence. If the list's elements
-- are unique, then the sequences will be too.
sequences :: Show a => Int -> [ a ] -> [ [ a ] ]
sequences n l = go l
where
go [] = []
2024-02-29 04:36:20 +03:00
go l' = s : go ( tailErr l' ) -- PARTIAL tailErr succeeds because of pattern
2015-10-10 21:51:07 +03:00
where
s' = take n l'
s | length s' == n = s'
| otherwise = take n ( l' ++ cycle l )
2009-05-29 12:23:59 +04:00
2015-10-10 21:51:07 +03:00
wideChars = map chr [ 0x3400 .. 0x4db0 ]
2009-05-29 12:23:59 +04:00
pair :: [ a ] -> [ ( a , a ) ]
pair [] = []
pair [ a ] = [ ( a , a ) ]
2009-09-22 20:51:27 +04:00
pair ( a : b : rest ) = ( a , b ) : pair rest
2009-05-29 12:23:59 +04:00
2019-04-20 18:30:56 +03:00
-- getCurrentDay :: IO Day
-- getCurrentDay = do
-- t <- getZonedTime
-- return $ localDay (zonedTimeToLocalTime t)
2009-05-29 12:23:59 +04:00