simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-12-28 04:46:31 +03:00
Code Issues Projects Releases Wiki Activity

web: Switch to Data.Text, instead of unpacking to String

Browse Source
This commit is contained in:
Jakub Zárybnický 2018-06-08 23:10:05 +02:00
parent 50e97e05fd
commit ee97e476c8
6 changed files with 63 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
hledger-web/Foundation.hs
View File

@ -8,7 +8,6 @@ import Data.IORef (IORef, readIORef, writeIORef)
import Data.List (isPrefixOf, sort, nub)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import Network.HTTP.Conduit (Manager)
import Text.Blaze (Markup)
@ -149,10 +148,10 @@ data ViewData = VD {
,msg :: Maybe Html -- ^ the current UI message if any, possibly from the current request
,today :: Day -- ^ today's date (for queries containing relative dates)
,j :: Journal -- ^ the up-to-date parsed unfiltered journal
,q :: String -- ^ the current q parameter, the main query expression
,m :: Query -- ^ a query parsed from the q parameter
,q :: Text -- ^ the current q parameter, the main query expression
,m :: Query -- ^ a query parsed from the q parameter
,qopts :: [QueryOpt] -- ^ query options parsed from the q parameter
,am :: Query -- ^ a query parsed from the accounts sidebar query expr ("a" parameter)
,am :: Query -- ^ a query parsed from the accounts sidebar query expr ("a" parameter)
,aopts :: [QueryOpt] -- ^ query options parsed from the accounts sidebar query expr
,showpostings :: Bool -- ^ current p parameter, 1 or 0 shows/hides all postings where applicable
,showsidebar :: Bool -- ^ current showsidebar cookie value
@ -165,10 +164,10 @@ nullviewdata :: ViewData
nullviewdata = viewdataWithDateAndParams nulldate "" "" ""
-- | Make a ViewData using the given date and request parameters, and defaults elsewhere.
viewdataWithDateAndParams :: Day -> String -> String -> String -> ViewData
viewdataWithDateAndParams :: Day -> Text -> Text -> Text -> ViewData
viewdataWithDateAndParams d q a p =
let (querymatcher,queryopts) = parseQuery d (T.pack q)
(acctsmatcher,acctsopts) = parseQuery d (T.pack a)
let (querymatcher,queryopts) = parseQuery d q
(acctsmatcher,acctsopts) = parseQuery d a
in VD {
opts = defwebopts
,j = nulljournal
@ -235,8 +234,8 @@ getViewData = do
return (j, Just e)
-- | Get the named request parameter, or the empty string if not present.
getParameterOrNull :: String -> Handler String
getParameterOrNull p = T.unpack `fmap` fromMaybe "" <$> lookupGetParam (T.pack p)
getParameterOrNull :: Text -> Handler Text
getParameterOrNull = fmap (fromMaybe "") . lookupGetParam
-- | Get the message that was set by the last request, in a
-- referentially transparent manner (allowing multiple reads).

17
hledger-web/Handler/AddForm.hs
View File

@ -8,9 +8,10 @@ module Handler.AddForm where
import Import
import Control.Monad.State.Strict (evalStateT)
import Data.List (sort)
import Data.Either (lefts, rights)
import Data.List (sort)
import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Time.Calendar
import Data.Void (Void)
@ -24,9 +25,9 @@ import Hledger.Cli.Commands.Add (appendToJournalFileOrStdout)
-- Don't know how to handle the variable posting fields with yesod-form yet.
data AddForm = AddForm
{ addFormDate :: Day
, addFormDescription :: Maybe Text -- String
, addFormDescription :: Maybe Text
-- , addFormPostings :: [(AccountName, String)]
, addFormJournalFile :: Maybe Text -- FilePath
, addFormJournalFile :: Maybe Text
}
deriving Show
@ -46,11 +47,11 @@ postAddForm = do
validateJournalFile :: Text -> Either FormMessage Text
validateJournalFile f
| T.unpack f `elem` journalFilePaths j = Right f
| otherwise = Left $ MsgInvalidEntry $ T.pack "the selected journal file \"" <> f <> "\"is unknown"
| otherwise = Left $ MsgInvalidEntry $ "the selected journal file \"" <> f <> "\"is unknown"
validateDate :: Text -> Handler (Either FormMessage Day)
validateDate s = return $
case fixSmartDateStrEither' today $ T.pack $ strip $ T.unpack s of
case fixSmartDateStrEither' today (T.strip s) of
Right d -> Right d
Left _ -> Left $ MsgInvalidEntry $ "could not parse date \"" <> s <> "\":"
@ -60,7 +61,7 @@ postAddForm = do
<*> iopt (check validateJournalFile textField) "journal"
ok <- case formresult of
FormMissing -> showErrors ["there is no form data"::String] >> return False
FormMissing -> showErrors ["there is no form data" :: Text] >> return False
FormFailure errs -> showErrors errs >> return False
FormSuccess dat -> do
let AddForm{
@ -68,7 +69,7 @@ postAddForm = do
,addFormDescription=mdesc
,addFormJournalFile=mjournalfile
} = dat
desc = maybe "" T.unpack mdesc
desc = fromMaybe "" mdesc
journalfile = maybe (journalFilePath j) T.unpack mjournalfile
-- 2. the fixed fields look good; now process the posting fields adhocly,
@ -101,7 +102,7 @@ postAddForm = do
| otherwise = either (\e -> Left [L.head $ lines e]) Right
(balanceTransaction Nothing $ nulltransaction {
tdate=date
,tdescription=T.pack desc
,tdescription=desc
,tpostings=[nullposting{paccount=acct, pamount=Mixed [amt]} | (acct,amt) <- zip accts amts]
})
case etxn of

54
hledger-web/Handler/Common.hs
View File

@ -24,13 +24,13 @@ import Hledger.Web.WebOptions
-- | Standard hledger-web page layout.
#if MIN_VERSION_yesod(1,6,0)
hledgerLayout :: ViewData -> String -> HtmlUrl AppRoute -> HandlerFor App Html
hledgerLayout :: ViewData -> Text -> HtmlUrl AppRoute -> HandlerFor App Html
#else
hledgerLayout :: ViewData -> String -> HtmlUrl AppRoute -> HandlerT App IO Html
hledgerLayout :: ViewData -> Text -> HtmlUrl AppRoute -> HandlerT App IO Html
#endif
hledgerLayout vd title content = do
defaultLayout $ do
setTitle $ toHtml $ title ++ " - hledger-web"
setTitle $ toHtml $ title <> " - hledger-web"
toWidget [hamlet|
^{topbar vd}
^{sidebar vd}
@ -39,8 +39,8 @@ hledgerLayout vd title content = do
^{content}
|]
where
showmd = if showsidebar vd then "col-md-8" else "col-md-12" :: String
showsm = if showsidebar vd then "col-sm-8" else "col-sm-12" :: String
showmd = if showsidebar vd then "col-md-8" else "col-md-12" :: Text
showsm = if showsidebar vd then "col-sm-8" else "col-sm-12" :: Text
-- | Global toolbar/heading area.
topbar :: ViewData -> HtmlUrl AppRoute
@ -55,8 +55,8 @@ topbar VD{..} = [hamlet|
|]
where
title = takeFileName $ journalFilePath j
showmd = if showsidebar then "col-md-4" else "col-any-0" :: String
showsm = if showsidebar then "col-sm-4" else "" :: String
showmd = if showsidebar then "col-md-4" else "col-any-0" :: Text
showsm = if showsidebar then "col-sm-4" else "" :: Text
-- | The sidebar used on most views.
sidebar :: ViewData -> HtmlUrl AppRoute
@ -71,13 +71,13 @@ sidebar vd@VD{..} =
^{accounts}
|]
where
journalcurrent = if here == JournalR then "inacct" else "" :: String
journalcurrent = if here == JournalR then "inacct" else "" :: Text
ropts = reportopts_ $ cliopts_ opts
-- flip the default for items with zero amounts, show them by default
ropts' = ropts{empty_=not $ empty_ ropts}
accounts = balanceReportAsHtml opts vd $ balanceReport ropts' am j
showmd = if showsidebar then "col-md-4" else "col-any-0" :: String
showsm = if showsidebar then "col-sm-4" else "" :: String
showmd = if showsidebar then "col-md-4" else "col-any-0" :: Text
showsm = if showsidebar then "col-sm-4" else "" :: Text
-- -- | Navigation link, preserving parameters and possibly highlighted.
-- navlink :: ViewData -> String -> AppRoute -> String -> HtmlUrl AppRoute
@ -114,7 +114,7 @@ searchform VD{..} = [hamlet|
<button .btn .btn-default type=button data-toggle="modal" data-target="#helpmodal" title="Show search and general help">?
|]
where
filtering = not $ null q
filtering = not $ T.null q
-- -- | Edit journal form.
-- editform :: ViewData -> HtmlUrl AppRoute
@ -163,11 +163,11 @@ searchform VD{..} = [hamlet|
-- |]
-- | Link to a topic in the manual.
helplink :: String -> String -> HtmlUrl AppRoute
helplink :: Text -> Text -> HtmlUrl AppRoute
helplink topic label = [hamlet|
<a href=#{u} target=hledgerhelp>#{label}
|]
where u = manualurl ++ if null topic then "" else '#':topic
where u = manualurl <> if T.null topic then "" else T.cons '#' topic
nulltemplate :: HtmlUrl AppRoute
nulltemplate = [hamlet||]
@ -206,23 +206,20 @@ balanceReportAsHtml _ vd@VD{..} (items',total) =
where
hassubs = not $ maybe False (null.asubs) $ ledgerAccount l acct
inacctclass = case inacctmatcher of
Just m' -> if m' `matchesAccount` acct then "inacct" else ""
Nothing -> "" :: String
Just m' -> if m' `matchesAccount` acct then "inacct" else ""
Nothing -> "" :: Text
indent = preEscapedString $ concat $ replicate (2 * (1+aindent)) "&nbsp;"
acctquery = (RegisterR, [("q", T.pack $ accountQuery acct)])
acctonlyquery = (RegisterR, [("q", T.pack $ accountOnlyQuery acct)])
acctquery = (RegisterR, [("q", accountQuery acct)])
acctonlyquery = (RegisterR, [("q", accountOnlyQuery acct)])
accountQuery :: AccountName -> String
accountQuery a = "inacct:" ++ T.unpack (quoteIfSpaced a) -- (accountNameToAccountRegex a)
accountQuery :: AccountName -> Text
accountQuery = ("inacct:" <>) . quoteIfSpaced
accountOnlyQuery :: AccountName -> String
accountOnlyQuery a = "inacctonly:" ++ T.unpack (quoteIfSpaced a ) -- (accountNameToAccountRegex a)
accountOnlyQuery :: AccountName -> Text
accountOnlyQuery = ("inacctonly:" <>) . quoteIfSpaced
accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])
accountUrl r a = (r, [("q", T.pack $ accountQuery a)])
-- stringIfLongerThan :: Int -> String -> String
-- stringIfLongerThan n s = if length s > n then s else ""
accountUrl r a = (r, [("q", accountQuery a)])
numberTransactionsReportItems :: [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]
numberTransactionsReportItems [] = []
@ -240,7 +237,8 @@ numberTransactionsReportItems items = number 0 nulldate items
mixedAmountAsHtml :: MixedAmount -> Html
mixedAmountAsHtml b = preEscapedString $ unlines $ map addclass $ lines $ showMixedAmountWithoutPrice b
where addclass = printf "<span class=\"%s\">%s</span><br/>" (c :: String)
c = case isNegativeMixedAmount b of Just True -> "negative amount"
_ -> "positive amount"
where addclass = printf "<span class=\"%s\">%s</span><br/>" (c :: Text)
c = case isNegativeMixedAmount b of
Just True -> "negative amount"
_ -> "positive amount"

14
hledger-web/Handler/JournalR.hs
View File

@ -5,8 +5,6 @@ module Handler.JournalR where
import Import
import qualified Data.Text as T
import Handler.AddForm
import Handler.Common
@ -27,9 +25,9 @@ getJournalR = do
filtering = m /= Any
-- showlastcolumn = if injournal && not filtering then False else True
title = case inacct of
Nothing -> "General Journal"++s2
Just (a,inclsubs) -> "Transactions in "++T.unpack a++s1++s2
where s1 = if inclsubs then "" else " (excluding subaccounts)"
Nothing -> "General Journal" <> s2
Just (a,inclsubs) -> "Transactions in " <> a <> s1 <> s2
where s1 = if inclsubs then "" else " (excluding subaccounts)"
where
s2 = if filtering then ", filtered" else ""
maincontent = journalTransactionsReportAsHtml opts vd $ journalTransactionsReport (reportopts_ $ cliopts_ opts) j m
@ -78,11 +76,7 @@ $forall p' <- tpostings torig
<td .amount .nonhead style="text-align:right;">#{mixedAmountAsHtml $ pamount p'}
|]
where
acctlink a = (RegisterR, [("q", T.pack $ accountQuery a)])
-- datetransition | newm = "newmonth"
-- | newd = "newday"
-- | otherwise = "" :: String
acctlink a = (RegisterR, [("q", accountQuery a)])
(date, desc) = (show $ tdate torig, tdescription torig)
-- acctquery = (here, [("q", T.pack $ accountQuery acct)])
showamt = not split || not (isZeroMixedAmount amt)

21
hledger-web/Handler/RegisterR.hs
View File

@ -28,12 +28,11 @@ getRegisterR = do
-- staticRootUrl <- (staticRoot . settings) <$> getYesod
let -- injournal = isNothing inacct
filtering = m /= Any
-- title = "Transactions in "++a++s1++s2
title = T.unpack a++s1++s2
where
(a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts
s1 = if inclsubs then "" else " (excluding subaccounts)"
s2 = if filtering then ", filtered" else ""
title = a <> s1 <> s2
where
(a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts
s1 = if inclsubs then "" else " (excluding subaccounts)"
s2 = if filtering then ", filtered" else ""
maincontent = registerReportHtml opts vd $ accountTransactionsReport (reportopts_ $ cliopts_ opts) j m $ fromMaybe Any $ inAccountQuery qopts
hledgerLayout vd "register" [hamlet|
<h2 #contenttitle>#{title}
@ -89,10 +88,10 @@ registerItemsHtml _ vd (balancelabel,items) = [hamlet|
|]
where
evenodd = if even n then "even" else "odd" :: String
evenodd = if even n then "even" else "odd" :: Text
datetransition | newm = "newmonth"
| newd = "newday"
| otherwise = "" :: String
| otherwise = "" :: Text
(firstposting, date, desc) = (False, show $ tdate tacct, tdescription tacct)
-- acctquery = (here, [("q", pack $ accountQuery acct)])
showamt = not split || not (isZeroMixedAmount amt)
@ -171,9 +170,9 @@ registerChartHtml percommoditytxnreports =
|]
-- [#{dayToJsTimestamp $ ltrace "\ndate" $ triDate i}, #{ltrace "balancequantity" $ simpleMixedAmountQuantity $ triCommodityBalance c i}, '#{ltrace "balance" $ show $ triCommodityBalance c i}, '#{ltrace "amount" $ show $ triCommodityAmount c i}''],
where
charttitle = case maybe "" (fst.snd) $ headMay percommoditytxnreports
of "" -> ""
s -> s++":"
charttitle = case maybe "" (fst.snd) $ headMay percommoditytxnreports of
"" -> ""
s -> s <> ":"
colorForCommodity = fromMaybe 0 . flip lookup commoditiesIndex
commoditiesIndex = zip (map fst percommoditytxnreports) [0..] :: [(CommoditySymbol,Int)]
simpleMixedAmountQuantity = maybe 0 aquantity . headMay . amounts

9
hledger-web/Settings.hs
View File

@ -7,6 +7,7 @@
module Settings where
import Data.Default (def)
import Data.Semigroup ((<>))
import Data.Text (Text)
import Data.Yaml
import Language.Haskell.TH.Syntax (Q, Exp)
@ -18,9 +19,11 @@ import Yesod.Default.Util
import Settings.Development
hledgerorgurl, manualurl :: String
hledgerorgurl = "http://hledger.org"
manualurl = hledgerorgurl++"/manual"
hledgerorgurl :: Text
hledgerorgurl = "http://hledger.org"
manualurl :: Text
manualurl = hledgerorgurl <> "/manual"
-- | The default IP address to listen on. May be overridden with --host.
defhost :: String