Skip to content
Permalink
Browse files

refactor: lib: hlint cleanups

  • Loading branch information...
simonmichael committed Feb 14, 2019
1 parent 0387705 commit bc7a1476ed99dd309b1ee3ef68d2f456dccd613f
@@ -47,10 +47,11 @@
# - ignore: {name: Use let}
# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules

- ignore: {name: Use camelCase}
- ignore: {name: Reduce duplication}
- ignore: {name: Redundant $}
- ignore: {name: Redundant bracket}
- ignore: {name: Redundant do}
- ignore: {name: Use camelCase}


# Define some custom infix operators
@@ -242,7 +242,7 @@ sortAccountTreeByDeclaration :: Account -> Account
sortAccountTreeByDeclaration a
| null $ asubs a = a
| otherwise = a{asubs=
sortBy (comparing accountDeclarationOrderAndName) $
sortOn accountDeclarationOrderAndName $
map sortAccountTreeByDeclaration $ asubs a
}

@@ -132,7 +132,6 @@ import Data.List
import Data.Map (findWithDefault)
import Data.Maybe
import Data.Time.Calendar (Day)
import Data.Ord (comparing)
-- import Data.Text (Text)
import qualified Data.Text as T
import Safe (maximumDef)
@@ -469,7 +468,7 @@ commodityValue j valuationdate c
where
dbg = dbg8 ("using market price for "++T.unpack c)
applicableprices =
[p | p <- sortBy (comparing mpdate) $ jmarketprices j
[p | p <- sortOn mpdate $ jmarketprices j
, mpcommodity p == c
, mpdate p <= valuationdate
]
@@ -26,7 +26,7 @@ import Hledger.Utils


-- characters that may not be used in a non-quoted commodity symbol
nonsimplecommoditychars = "0123456789-+.@*;\n \"{}=" :: [Char]
nonsimplecommoditychars = "0123456789-+.@*;\n \"{}=" :: String

isNonsimpleCommodityChar :: Char -> Bool
isNonsimpleCommodityChar c = isDigit c || c `textElem` otherChars
@@ -126,21 +126,15 @@ showDateSpanMonthAbbrev = showPeriodMonthAbbrev . dateSpanAsPeriod

-- | Get the current local date.
getCurrentDay :: IO Day
getCurrentDay = do
t <- getZonedTime
return $ localDay (zonedTimeToLocalTime t)
getCurrentDay = localDay . zonedTimeToLocalTime <$> getZonedTime

-- | Get the current local month number.
getCurrentMonth :: IO Int
getCurrentMonth = do
(_,m,_) <- toGregorian `fmap` getCurrentDay
return m
getCurrentMonth = second3 . toGregorian <$> getCurrentDay

-- | Get the current local year.
getCurrentYear :: IO Integer
getCurrentYear = do
(y,_,_) <- toGregorian `fmap` getCurrentDay
return y
getCurrentYear = first3 . toGregorian <$> getCurrentDay

elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a
elapsedSeconds t1 = realToFrac . diffUTCTime t1
@@ -380,14 +374,13 @@ spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)
-- | Convert a smart date string to an explicit yyyy\/mm\/dd string using
-- the provided reference date, or raise an error.
fixSmartDateStr :: Day -> Text -> String
fixSmartDateStr d s = either
(\e->error' $ printf "could not parse date %s %s" (show s) (show e))
id
$ (fixSmartDateStrEither d s :: Either (ParseErrorBundle Text CustomErr) String)
fixSmartDateStr d s =
either (error' . printf "could not parse date %s %s" (show s) . show) id $
(fixSmartDateStrEither d s :: Either (ParseErrorBundle Text CustomErr) String)

-- | A safe version of fixSmartDateStr.
fixSmartDateStrEither :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) String
fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d
fixSmartDateStrEither d = fmap showDate . fixSmartDateStrEither' d

fixSmartDateStrEither'
:: Day -> Text -> Either (ParseErrorBundle Text CustomErr) Day
@@ -469,34 +462,34 @@ fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of
-- "2009/01/01"
--
fixSmartDate :: Day -> SmartDate -> Day
fixSmartDate refdate sdate = fix sdate
where
fix :: SmartDate -> Day
fix ("","","today") = fromGregorian ry rm rd
fix ("","this","day") = fromGregorian ry rm rd
fix ("","","yesterday") = prevday refdate
fix ("","last","day") = prevday refdate
fix ("","","tomorrow") = nextday refdate
fix ("","next","day") = nextday refdate
fix ("","last","week") = prevweek refdate
fix ("","this","week") = thisweek refdate
fix ("","next","week") = nextweek refdate
fix ("","last","month") = prevmonth refdate
fix ("","this","month") = thismonth refdate
fix ("","next","month") = nextmonth refdate
fix ("","last","quarter") = prevquarter refdate
fix ("","this","quarter") = thisquarter refdate
fix ("","next","quarter") = nextquarter refdate
fix ("","last","year") = prevyear refdate
fix ("","this","year") = thisyear refdate
fix ("","next","year") = nextyear refdate
fix ("","",d) = fromGregorian ry rm (read d)
fix ("",m,"") = fromGregorian ry (read m) 1
fix ("",m,d) = fromGregorian ry (read m) (read d)
fix (y,"","") = fromGregorian (read y) 1 1
fix (y,m,"") = fromGregorian (read y) (read m) 1
fix (y,m,d) = fromGregorian (read y) (read m) (read d)
(ry,rm,rd) = toGregorian refdate
fixSmartDate refdate = fix
where
fix :: SmartDate -> Day
fix ("", "", "today") = fromGregorian ry rm rd
fix ("", "this", "day") = fromGregorian ry rm rd
fix ("", "", "yesterday") = prevday refdate
fix ("", "last", "day") = prevday refdate
fix ("", "", "tomorrow") = nextday refdate
fix ("", "next", "day") = nextday refdate
fix ("", "last", "week") = prevweek refdate
fix ("", "this", "week") = thisweek refdate
fix ("", "next", "week") = nextweek refdate
fix ("", "last", "month") = prevmonth refdate
fix ("", "this", "month") = thismonth refdate
fix ("", "next", "month") = nextmonth refdate
fix ("", "last", "quarter") = prevquarter refdate
fix ("", "this", "quarter") = thisquarter refdate
fix ("", "next", "quarter") = nextquarter refdate
fix ("", "last", "year") = prevyear refdate
fix ("", "this", "year") = thisyear refdate
fix ("", "next", "year") = nextyear refdate
fix ("", "", d) = fromGregorian ry rm (read d)
fix ("", m, "") = fromGregorian ry (read m) 1
fix ("", m, d) = fromGregorian ry (read m) (read d)
fix (y, "", "") = fromGregorian (read y) 1 1
fix (y, m, "") = fromGregorian (read y) (read m) 1
fix (y, m, d) = fromGregorian (read y) (read m) (read d)
(ry, rm, rd) = toGregorian refdate

prevday :: Day -> Day
prevday = addDays (-1)
@@ -764,7 +757,7 @@ smartdateonly = do
eof
return d

datesepchars :: [Char]
datesepchars :: String
datesepchars = "/-."

datesepchar :: TextParser m Char
@@ -980,8 +973,7 @@ reportingintervalp = choice' [
return $ DayOfWeek n,
do string' "every"
skipMany spacenonewline
n <- weekday
return $ DayOfWeek n,
DayOfWeek <$> weekday,
do string' "every"
skipMany spacenonewline
n <- nth
@@ -1034,7 +1026,7 @@ reportingintervalp = choice' [
return $ intcons 1,
do string' "every"
skipMany spacenonewline
n <- fmap read $ some digitChar
n <- read <$> some digitChar
skipMany spacenonewline
string' plural'
return $ intcons n
@@ -1061,8 +1053,7 @@ doubledatespanp rdate = do
b <- smartdate
skipMany spacenonewline
optional (choice [string' "to", string' "-"] >> skipMany spacenonewline)
e <- smartdate
return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)
DateSpan (Just $ fixSmartDate rdate b) . Just . fixSmartDate rdate <$> smartdate

fromdatespanp :: Day -> TextParser m DateSpan
fromdatespanp rdate = do
@@ -1081,14 +1072,12 @@ fromdatespanp rdate = do
todatespanp :: Day -> TextParser m DateSpan
todatespanp rdate = do
choice [string' "to", string' "-"] >> skipMany spacenonewline
e <- smartdate
return $ DateSpan Nothing (Just $ fixSmartDate rdate e)
DateSpan Nothing . Just . fixSmartDate rdate <$> smartdate

justdatespanp :: Day -> TextParser m DateSpan
justdatespanp rdate = do
optional (string' "in" >> skipMany spacenonewline)
d <- smartdate
return $ spanFromSmartDate rdate d
spanFromSmartDate rdate <$> smartdate

-- | Make a datespan from two valid date strings parseable by parsedate
-- (or raise an error). Eg: mkdatespan \"2011/1/1\" \"2011/12/31\".
@@ -90,7 +90,6 @@ import Data.Maybe
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid
#endif
import Data.Ord
import qualified Data.Semigroup as Sem
import Data.Text (Text)
import qualified Data.Text as T
@@ -672,7 +671,7 @@ journalBalanceTransactionsST assrt j createStore storeIn extract =
(Just $ journalCommodityStyles j)
(getModifierAccountNames j)
flip R.runReaderT env $ do
dated <- fmap snd . sortBy (comparing fst) . concat
dated <- fmap snd . sortOn fst . concat
<$> mapM' discriminateByDate (jtxns j)
mapM' checkInferAndRegisterAmounts dated
lift $ extract txStore
@@ -714,33 +713,33 @@ discriminateByDate :: Transaction
-> CurrentBalancesModifier s [(Day, Either Posting Transaction)]
discriminateByDate tx
| null (assignmentPostings tx) = do
styles <- R.reader $ eStyles
balanced <- lift $ ExceptT $ return $ balanceTransaction styles tx
storeTransaction balanced
return $
fmap (postingDate &&& (Left . removePrices)) $ tpostings $ balanced
| True = do
when (any (isJust . pdate) $ tpostings tx) $
throwError $ unlines $
["postings may not have both a custom date and a balance assignment."
,"Write the posting amount explicitly, or remove the posting date:\n"
, showTransaction tx]
return
[(tdate tx, Right $ tx { tpostings = removePrices <$> tpostings tx })]
styles <- R.reader $ eStyles
balanced <- lift $ ExceptT $ return $ balanceTransaction styles tx
storeTransaction balanced
return $ fmap (postingDate &&& (Left . removePrices)) $ tpostings $ balanced
| otherwise = do
when (any (isJust . pdate) $ tpostings tx) $
throwError $
unlines $
[ "postings may not have both a custom date and a balance assignment."
, "Write the posting amount explicitly, or remove the posting date:\n"
, showTransaction tx
]
return [(tdate tx, Right $ tx {tpostings = removePrices <$> tpostings tx})]

-- | Throw an error if a posting is in the unassignable set.
checkUnassignablePosting :: Posting -> CurrentBalancesModifier s ()
checkUnassignablePosting p = do
unassignable <- R.asks eUnassignable
if (isAssignment p && paccount p `S.member` unassignable)
then throwError $ unlines $
[ "cannot assign amount to account "
, ""
, " " ++ (T.unpack $ paccount p)
, ""
, "because it is also included in transaction modifiers."
]
else return ()
when (isAssignment p && paccount p `S.member` unassignable) $
throwError $
unlines $
[ "cannot assign amount to account "
, ""
, " " ++ T.unpack (paccount p)
, ""
, "because it is also included in transaction modifiers."
]


-- | This function takes an object describing changes to
@@ -789,7 +788,7 @@ checkInferAndRegisterAmounts (Right oldTx) = do
Just ba | baexact ba -> do
diff <- setMixedBalance acc $ Mixed [baamount ba]
fullPosting diff p
Just ba | otherwise -> do
Just ba -> do
old <- liftModifier $ \Env{ eBalances = bals } -> HT.lookup bals acc
let amt = baamount ba
assertedcomm = acommodity amt
@@ -884,13 +883,12 @@ commodityStylesFromAmounts amts = M.fromList commstyles
-- That is: the style of the first, and the maximum precision of all.
canonicalStyleFrom :: [AmountStyle] -> AmountStyle
canonicalStyleFrom [] = amountstyle
canonicalStyleFrom ss@(first:_) =
first{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
canonicalStyleFrom ss@(first:_) = first {asprecision = prec, asdecimalpoint = mdec, asdigitgroups = mgrps}
where
mgrps = maybe Nothing Just $ headMay $ catMaybes $ map asdigitgroups ss
mgrps = headMay $ mapMaybe asdigitgroups ss
-- precision is maximum of all precisions
prec = maximumStrict $ map asprecision ss
mdec = Just $ headDef '.' $ catMaybes $ map asdecimalpoint ss
mdec = Just $ headDef '.' $ mapMaybe asdecimalpoint ss
-- precision is that of first amount with a decimal point
-- (mdec, prec) =
-- case filter (isJust . asdecimalpoint) ss of
@@ -993,7 +991,7 @@ journalDateSpan secondary j
latest = maximumStrict dates
dates = pdates ++ tdates
tdates = map (if secondary then transactionDate2 else tdate) ts
pdates = concatMap (catMaybes . map (if secondary then (Just . postingDate2) else pdate) . tpostings) ts
pdates = concatMap (mapMaybe (if secondary then (Just . postingDate2) else pdate) . tpostings) ts
ts = jtxns j

-- | Apply the pivot transformation to all postings in a journal,
@@ -107,12 +107,13 @@ ledgerCommodities = M.keys . jinferredcommodities . ljournal

-- tests

tests_Ledger = tests "Ledger" [

tests "ledgerFromJournal" [
(length $ ledgerPostings $ ledgerFromJournal Any nulljournal) `is` 0
,(length $ ledgerPostings $ ledgerFromJournal Any samplejournal) `is` 13
,(length $ ledgerPostings $ ledgerFromJournal (Depth 2) samplejournal) `is` 7
]

]
tests_Ledger =
tests
"Ledger"
[ tests
"ledgerFromJournal"
[ length (ledgerPostings $ ledgerFromJournal Any nulljournal) `is` 0
, length (ledgerPostings $ ledgerFromJournal Any samplejournal) `is` 13
, length (ledgerPostings $ ledgerFromJournal (Depth 2) samplejournal) `is` 7
]
]
@@ -8,8 +8,6 @@ value of things at a given date.
-}

{-# LANGUAGE OverloadedStrings, LambdaCase #-}

module Hledger.Data.MarketPrice
where
import qualified Data.Text as T
@@ -1,7 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-|
A 'PeriodicTransaction' is a rule describing recurring transactions.
@@ -66,7 +66,6 @@ import Data.MemoUgly (memo)
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid
#endif
import Data.Ord
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
@@ -176,7 +175,7 @@ postingDate2 p = headDef nulldate $ catMaybes dates
where dates = [pdate2 p
,maybe Nothing tdate2 $ ptransaction p
,pdate p
,maybe Nothing (Just . tdate) $ ptransaction p
,fmap tdate (ptransaction p)
]

-- | Get a posting's status. This is cleared or pending if those are
@@ -237,14 +236,14 @@ isEmptyPosting = isZeroMixedAmount . pamount
postingsDateSpan :: [Posting] -> DateSpan
postingsDateSpan [] = DateSpan Nothing Nothing
postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps')
where ps' = sortBy (comparing postingDate) ps
where ps' = sortOn postingDate ps

-- --date2-sensitive version, as above.
postingsDateSpan' :: WhichDate -> [Posting] -> DateSpan
postingsDateSpan' _ [] = DateSpan Nothing Nothing
postingsDateSpan' wd ps = DateSpan (Just $ postingdate $ head ps') (Just $ addDays 1 $ postingdate $ last ps')
where
ps' = sortBy (comparing postingdate) ps
ps' = sortOn postingdate ps
postingdate = if wd == PrimaryDate then postingDate else postingDate2

-- AccountName stuff that depends on PostingType
Oops, something went wrong.

0 comments on commit bc7a147

Please sign in to comment.
You can’t perform that action at this time.