slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages 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.List (isPrefixOf, sort, nub)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
import Text.Blaze (Markup) 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 ,msg :: Maybe Html -- ^ the current UI message if any, possibly from the current request
,today :: Day -- ^ today's date (for queries containing relative dates) ,today :: Day -- ^ today's date (for queries containing relative dates)
,j :: Journal -- ^ the up-to-date parsed unfiltered journal ,j :: Journal -- ^ the up-to-date parsed unfiltered journal
,q :: String -- ^ the current q parameter, the main query expression ,q :: Text -- ^ the current q parameter, the main query expression
,m :: Query -- ^ a query parsed from the q parameter ,m :: Query -- ^ a query parsed from the q parameter
,qopts :: [QueryOpt] -- ^ query options 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 ,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 ,showpostings :: Bool -- ^ current p parameter, 1 or 0 shows/hides all postings where applicable
,showsidebar :: Bool -- ^ current showsidebar cookie value ,showsidebar :: Bool -- ^ current showsidebar cookie value
@ -165,10 +164,10 @@ nullviewdata :: ViewData
nullviewdata = viewdataWithDateAndParams nulldate "" "" "" nullviewdata = viewdataWithDateAndParams nulldate "" "" ""
-- | Make a ViewData using the given date and request parameters, and defaults elsewhere. -- | 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 = viewdataWithDateAndParams d q a p =
let (querymatcher,queryopts) = parseQuery d (T.pack q) let (querymatcher,queryopts) = parseQuery d q
(acctsmatcher,acctsopts) = parseQuery d (T.pack a) (acctsmatcher,acctsopts) = parseQuery d a
in VD { in VD {
opts = defwebopts opts = defwebopts
,j = nulljournal ,j = nulljournal
@ -235,8 +234,8 @@ getViewData = do
return (j, Just e) return (j, Just e)
-- | Get the named request parameter, or the empty string if not present. -- | Get the named request parameter, or the empty string if not present.
getParameterOrNull :: String -> Handler String getParameterOrNull :: Text -> Handler Text
getParameterOrNull p = T.unpack `fmap` fromMaybe "" <$> lookupGetParam (T.pack p) getParameterOrNull = fmap (fromMaybe "") . lookupGetParam
-- | Get the message that was set by the last request, in a -- | Get the message that was set by the last request, in a
-- referentially transparent manner (allowing multiple reads). -- 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 Import
import Control.Monad.State.Strict (evalStateT) import Control.Monad.State.Strict (evalStateT)
import Data.List (sort)
import Data.Either (lefts, rights) import Data.Either (lefts, rights)
import Data.List (sort)
import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free 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 qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar
import Data.Void (Void) 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. -- Don't know how to handle the variable posting fields with yesod-form yet.
data AddForm = AddForm data AddForm = AddForm
{ addFormDate :: Day { addFormDate :: Day
, addFormDescription :: Maybe Text -- String , addFormDescription :: Maybe Text
-- , addFormPostings :: [(AccountName, String)] -- , addFormPostings :: [(AccountName, String)]
, addFormJournalFile :: Maybe Text -- FilePath , addFormJournalFile :: Maybe Text
} }
deriving Show deriving Show
@ -46,11 +47,11 @@ postAddForm = do
validateJournalFile :: Text -> Either FormMessage Text validateJournalFile :: Text -> Either FormMessage Text
validateJournalFile f validateJournalFile f
| T.unpack f `elem` journalFilePaths j = Right 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 :: Text -> Handler (Either FormMessage Day)
validateDate s = return $ validateDate s = return $
case fixSmartDateStrEither' today $ T.pack $ strip $ T.unpack s of case fixSmartDateStrEither' today (T.strip s) of
Right d -> Right d Right d -> Right d
Left _ -> Left $ MsgInvalidEntry $ "could not parse date \"" <> s <> "\":" Left _ -> Left $ MsgInvalidEntry $ "could not parse date \"" <> s <> "\":"
@ -60,7 +61,7 @@ postAddForm = do
<*> iopt (check validateJournalFile textField) "journal" <*> iopt (check validateJournalFile textField) "journal"
ok <- case formresult of 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 FormFailure errs -> showErrors errs >> return False
FormSuccess dat -> do FormSuccess dat -> do
let AddForm{ let AddForm{
@ -68,7 +69,7 @@ postAddForm = do
,addFormDescription=mdesc ,addFormDescription=mdesc
,addFormJournalFile=mjournalfile ,addFormJournalFile=mjournalfile
} = dat } = dat
desc = maybe "" T.unpack mdesc desc = fromMaybe "" mdesc
journalfile = maybe (journalFilePath j) T.unpack mjournalfile journalfile = maybe (journalFilePath j) T.unpack mjournalfile
-- 2. the fixed fields look good; now process the posting fields adhocly, -- 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 | otherwise = either (\e -> Left [L.head $ lines e]) Right
(balanceTransaction Nothing $ nulltransaction { (balanceTransaction Nothing $ nulltransaction {
tdate=date tdate=date
,tdescription=T.pack desc ,tdescription=desc
,tpostings=[nullposting{paccount=acct, pamount=Mixed [amt]} | (acct,amt) <- zip accts amts] ,tpostings=[nullposting{paccount=acct, pamount=Mixed [amt]} | (acct,amt) <- zip accts amts]
}) })
case etxn of case etxn of

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

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

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

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

9
hledger-web/Settings.hs
View File

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