Permalink
Switch branches/tags
hledger-web-1.10 hledger-web-1.9.2 hledger-web-1.9.1 hledger-web-1.9 hledger-web-1.5.1 hledger-web-1.5 hledger-web-1.4 hledger-web-1.3.2 hledger-web-1.3.1 hledger-web-1.3 hledger-web-1.2 hledger-web-1.1 hledger-web-1.0.1 hledger-web-1.0 hledger-web-0.27 hledger-web-0.26 hledger-web-0.25.1 hledger-web-0.25 hledger-web-0.24.1 hledger-web-0.24 hledger-web-0.23.3 hledger-web-0.23.2 hledger-web-0.23.1 hledger-web-0.23 hledger-web-0.21.3 hledger-web-0_19 hledger-web-0_17_1 hledger-web-0_16_5 hledger-web-0_16_4 hledger-web-0_16_3 hledger-web-0_16_2 hledger-web-0_15_3 hledger-web-0_15_1 hledger{,-vty,-chart}-0_15_1,_hledger-web-0_15_2 hledger-ui-1.10.1 hledger-ui-1.10 hledger-ui-1.9.1 hledger-ui-1.9 hledger-ui-1.5 hledger-ui-1.4 hledger-ui-1.3.1 hledger-ui-1.3 hledger-ui-1.2 hledger-ui-1.1.2 hledger-ui-1.1.1 hledger-ui-1.1 hledger-ui-1.0.5 hledger-ui-1.0.4 hledger-ui-1.0.3 hledger-ui-1.0.2 hledger-ui-1.0.1 hledger-ui-1.0 hledger-ui-0.27.5 hledger-ui-0.27.4 hledger-ui-0.27.3 hledger-ui-0.27.2 hledger-ui-0.27.1 hledger-ui-0.27 hledger-lib-1.10 hledger-lib-1.9.1 hledger-lib-1.9 hledger-lib-1.5.1 hledger-lib-1.5 hledger-lib-1.4 hledger-lib-1.3.2 hledger-lib-1.3.1 hledger-lib-1.3 hledger-lib-1.2 hledger-lib-1.1 hledger-lib-1.0.1 hledger-lib-1.0 hledger-lib-0.27.1 hledger-lib-0.27 hledger-lib-0.26 hledger-lib-0.25.1 hledger-lib-0.25 hledger-lib-0.24.1 hledger-lib-0.24 hledger-lib-0.23.3 hledger-lib-0.23.2 hledger-lib-0.23.1 hledger-lib-0.23 hledger-irr-0.1.1.4 hledger-irr-0.1.1.3 hledger-irr-0.1.1.2 hledger-irr-0.1.1.1 hledger-irr-0.1.1 hledger-api-1.10 hledger-api-1.9.1 hledger-api-1.9 hledger-api-1.5 hledger-api-1.4 hledger-api-1.3.1 hledger-api-1.3 hledger-api-1.2 hledger-api-1.1 hledger-api-1.0 hledger-1.10 hledger-1.9.1 hledger-1.9
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 88 lines (74 sloc) 2.71 KB
#!/usr/bin/env runhaskell
{-
generatejournal.hs NUMTXNS NUMACCTS ACCTDEPTH [--chinese|--mixed]
Outputs a dummy journal file with the specified number of
transactions, number of accounts, and account tree depth. By default
it uses only ascii characters, with --chinese it uses wide chinese
characters, or with --mixed it uses both. These files are used for
testing, benchmarking, profiling, etc.
-}
module Main
where
import Data.Char
import Data.List
import Data.Time.Calendar
import Data.Time.LocalTime
import Numeric
import System.Environment
import Text.Printf
-- import Hledger.Utils.Debug
main = do
rawargs <- getArgs
let (opts,args) = partition (isPrefixOf "-") rawargs
let [numtxns, numaccts, acctdepth] = map read args :: [Int]
today <- getCurrentDay
let (year,_,_) = toGregorian today
let d = fromGregorian (year-1) 1 1
let dates = iterate (addDays 1) d
let accts = pair $ cycle $ take numaccts $ uniqueAccountNames opts acctdepth
mapM_ (\(n,d,(a,b)) -> putStr $ showtxn n d a b) $ take numtxns $ zip3 [1..] dates accts
return ()
showtxn :: Int -> Day -> String -> String -> String
showtxn txnno date acct1 acct2 =
printf "%s transaction %d\n %-40s %2d\n %-40s %2d\n\n" d txnno acct1 amt acct2 (-amt)
where
d = show date
amt = 1::Int
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 [] = []
go l' = s : go (tail l')
where
s' = take n l'
s | length s' == n = s'
| otherwise = take n (l' ++ cycle l)
wideChars = map chr [0x3400..0x4db0]
pair :: [a] -> [(a,a)]
pair [] = []
pair [a] = [(a,a)]
pair (a:b:rest) = (a,b):pair rest
getCurrentDay :: IO Day
getCurrentDay = do
t <- getZonedTime
return $ localDay (zonedTimeToLocalTime t)