extra: update, stackify hledger-check-dates
This commit is contained in:
		
							parent
							
								
									7f5e09096f
								
							
						
					
					
						commit
						e7c457f970
					
				| @ -1,4 +1,9 @@ | |||||||
| #!/usr/bin/env runhaskell | #!/usr/bin/env stack | ||||||
|  | {- stack runghc --verbosity info | ||||||
|  |    --package hledger-lib | ||||||
|  |    --package hledger | ||||||
|  | -} | ||||||
|  | 
 | ||||||
| {-| | {-| | ||||||
| hledger-check-dates [--strict] [--date2] [-f JOURNALFILE] | hledger-check-dates [--strict] [--date2] [-f JOURNALFILE] | ||||||
| 
 | 
 | ||||||
| @ -12,19 +17,19 @@ import Text.Printf | |||||||
| 
 | 
 | ||||||
| argsmode :: Mode RawOpts | argsmode :: Mode RawOpts | ||||||
| argsmode = (defCommandMode ["check-dates"]) | argsmode = (defCommandMode ["check-dates"]) | ||||||
| 	{ modeHelp = "check that transactions' date are monotonically increasing" |   { modeHelp = "check that transactions' date are monotonically increasing" | ||||||
| 	, modeGroupFlags = Group |   , modeGroupFlags = Group | ||||||
| 		{ groupNamed = |     { groupNamed = | ||||||
| 			[ ("Input",inputflags) |       [ ("Input",inputflags) | ||||||
| 			, ("Reporting",reportflags) |       , ("Reporting",reportflags) | ||||||
| 			, ("Misc",helpflags) |       , ("Misc",helpflags) | ||||||
| 			] |       ] | ||||||
| 		,groupUnnamed = [ |     ,groupUnnamed = [ | ||||||
| 			flagNone ["strict"] (\opts -> setboolopt "strict" opts) "makes date comparing strict" |       flagNone ["strict"] (\opts -> setboolopt "strict" opts) "makes date comparing strict" | ||||||
| 		 ] |      ] | ||||||
| 		, groupHidden = [] |     , groupHidden = [] | ||||||
| 		} |     } | ||||||
| 	} |   } | ||||||
| 
 | 
 | ||||||
| data FoldAcc a b = FoldAcc | data FoldAcc a b = FoldAcc | ||||||
|  { fa_error    :: Maybe a |  { fa_error    :: Maybe a | ||||||
| @ -32,50 +37,50 @@ data FoldAcc a b = FoldAcc | |||||||
|  } |  } | ||||||
| 
 | 
 | ||||||
| foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b | foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b | ||||||
| foldWhile fold acc [] = acc | foldWhile _ acc [] = acc | ||||||
| foldWhile fold acc (a:as) = | foldWhile fold acc (a:as) = | ||||||
| 	case fold a acc of |   case fold a acc of | ||||||
| 	 acc@FoldAcc{fa_error=Just a} -> acc |    acc@FoldAcc{fa_error=Just _} -> acc | ||||||
| 	 acc -> foldWhile fold acc as |    acc -> foldWhile fold acc as | ||||||
| 
 | 
 | ||||||
| checkTransactions :: (Transaction -> Transaction -> Bool) | checkTransactions :: (Transaction -> Transaction -> Bool) | ||||||
|  -> [Transaction] -> FoldAcc Transaction Transaction |  -> [Transaction] -> FoldAcc Transaction Transaction | ||||||
| checkTransactions compare ts = | checkTransactions compare ts = | ||||||
| 	foldWhile fold FoldAcc{fa_error=Nothing, fa_previous=Nothing} ts |   foldWhile fold FoldAcc{fa_error=Nothing, fa_previous=Nothing} ts | ||||||
| 	where |   where | ||||||
| 		fold current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current} |     fold current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current} | ||||||
| 		fold current acc@FoldAcc{fa_previous=Just previous} = |     fold current acc@FoldAcc{fa_previous=Just previous} = | ||||||
| 			if compare previous current |       if compare previous current | ||||||
| 			then acc{fa_previous=Just current} |       then acc{fa_previous=Just current} | ||||||
| 			else acc{fa_error=Just current} |       else acc{fa_error=Just current} | ||||||
| 
 | 
 | ||||||
| main :: IO () | main :: IO () | ||||||
| main = do | main = do | ||||||
| 	opts <- getCliOpts argsmode |   opts <- getCliOpts argsmode | ||||||
| 	withJournalDo opts $ |   withJournalDo opts $ | ||||||
| 	 \cliopts@CliOpts{rawopts_=opts,reportopts_=ropts} j -> do |    \CliOpts{rawopts_=opts,reportopts_=ropts} j -> do | ||||||
| 		d <- getCurrentDay |     d <- getCurrentDay | ||||||
| 		let ropts_ = ropts{flat_=True} |     let ropts_ = ropts{accountlistmode_=ALFlat} | ||||||
| 		let q = queryFromOpts d ropts_ |     let q = queryFromOpts d ropts_ | ||||||
| 		let ts = filter (q `matchesTransaction`) $ |     let ts = filter (q `matchesTransaction`) $ | ||||||
| 			jtxns $ journalSelectingAmountFromOpts ropts j |              jtxns $ journalSelectingAmountFromOpts ropts j | ||||||
| 		let strict = boolopt "strict" opts |     let strict = boolopt "strict" opts | ||||||
| 		let date = transactionDateFn ropts |     let date = transactionDateFn ropts | ||||||
| 		let compare a b = |     let compare a b = | ||||||
| 			if strict |           if strict | ||||||
| 			then date a <  date b |           then date a <  date b | ||||||
| 			else date a <= date b |           else date a <= date b | ||||||
| 		case checkTransactions compare ts of |     case checkTransactions compare ts of | ||||||
| 		 FoldAcc{fa_previous=Nothing} -> putStrLn "ok (empty journal)" |      FoldAcc{fa_previous=Nothing} -> putStrLn "ok (empty journal)" | ||||||
| 		 FoldAcc{fa_error=Nothing}    -> putStrLn "ok" |      FoldAcc{fa_error=Nothing}    -> putStrLn "ok" | ||||||
| 		 FoldAcc{fa_error=Just error, fa_previous=Just previous} -> |      FoldAcc{fa_error=Just error, fa_previous=Just previous} -> | ||||||
| 			putStrLn $ printf ("ERROR: transaction out of%s date order" |       putStrLn $ printf ("ERROR: transaction out of%s date order" | ||||||
| 			 ++ "\nPrevious date: %s" |        ++ "\nPrevious date: %s" | ||||||
| 			 ++ "\nDate: %s" |        ++ "\nDate: %s" | ||||||
| 			 ++ "\nLocation: %s" |        ++ "\nLocation: %s" | ||||||
| 			 ++ "\nTransaction:\n\n%s") |        ++ "\nTransaction:\n\n%s") | ||||||
| 			 (if strict then " STRICT" else "") |        (if strict then " STRICT" else "") | ||||||
| 			 (show $ date previous) |        (show $ date previous) | ||||||
| 			 (show $ date error) |        (show $ date error) | ||||||
| 			 (show $ tsourcepos error) |        (show $ tsourcepos error) | ||||||
| 			 (showTransactionUnelided error) |        (showTransactionUnelided error) | ||||||
|  | |||||||
		Loading…
	
		Reference in New Issue
	
	Block a user