diff --git a/hledger-lib/Hledger/Utils.hs b/hledger-lib/Hledger/Utils.hs index 9477dfb02..aebb4c617 100644 --- a/hledger-lib/Hledger/Utils.hs +++ b/hledger-lib/Hledger/Utils.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} {-| Standard imports and utilities which are useful everywhere, or needed low @@ -20,7 +19,11 @@ module Hledger.Utils (---- provide these frequently used modules - or not, for c ---- all of this one: module Hledger.Utils, module Hledger.Utils.Debug, + module Hledger.Utils.Parse, module Hledger.Utils.Regex, + module Hledger.Utils.String, + module Hledger.Utils.Test, + module Hledger.Utils.Tree, -- Debug.Trace.trace, -- module Data.PPrint, -- module Hledger.Utils.UTF8IOCompat @@ -30,204 +33,28 @@ module Hledger.Utils (---- provide these frequently used modules - or not, for c where import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Char -import Data.List -import qualified Data.Map as M +-- import Data.Char +-- import Data.List -- import Data.Maybe -- import Data.PPrint import Data.Time.Clock import Data.Time.LocalTime -import Data.Tree import System.Directory (getHomeDirectory) import System.FilePath((), isRelative) import System.IO -import Test.HUnit -import Text.Parsec -import Text.Printf +-- import Text.Printf -- import qualified Data.Map as Map import Hledger.Utils.Debug +import Hledger.Utils.Parse import Hledger.Utils.Regex +import Hledger.Utils.String +import Hledger.Utils.Test +import Hledger.Utils.Tree -- import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn) -- import Hledger.Utils.UTF8IOCompat (readFile,writeFile,appendFile,getContents,putStr,putStrLn) import Hledger.Utils.UTF8IOCompat (SystemString,fromSystemString,toSystemString,error',userError') --- strings - -lowercase, uppercase :: String -> String -lowercase = map toLower -uppercase = map toUpper - --- | Remove leading and trailing whitespace. -strip :: String -> String -strip = lstrip . rstrip - --- | Remove leading whitespace. -lstrip :: String -> String -lstrip = dropWhile (`elem` " \t") :: String -> String -- XXX isSpace ? - --- | Remove trailing whitespace. -rstrip :: String -> String -rstrip = reverse . lstrip . reverse - --- | Remove trailing newlines/carriage returns. -chomp :: String -> String -chomp = reverse . dropWhile (`elem` "\r\n") . reverse - -stripbrackets :: String -> String -stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String - -elideLeft :: Int -> String -> String -elideLeft width s = - if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s - -elideRight :: Int -> String -> String -elideRight width s = - if length s > width then take (width - 2) s ++ ".." else s - -underline :: String -> String -underline s = s' ++ replicate (length s) '-' ++ "\n" - where s' - | last s == '\n' = s - | otherwise = s ++ "\n" - --- | Wrap a string in double quotes, and \-prefix any embedded single --- quotes, if it contains whitespace and is not already single- or --- double-quoted. -quoteIfSpaced :: String -> String -quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s - | not $ any (`elem` s) whitespacechars = s - | otherwise = "'"++escapeSingleQuotes s++"'" - --- | Double-quote this string if it contains whitespace, single quotes --- or double-quotes, escaping the quotes as needed. -quoteIfNeeded :: String -> String -quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\"" - | otherwise = s - --- | Single-quote this string if it contains whitespace or double-quotes. --- No good for strings containing single quotes. -singleQuoteIfNeeded :: String -> String -singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'" - | otherwise = s - -quotechars, whitespacechars :: [Char] -quotechars = "'\"" -whitespacechars = " \t\n\r" - -escapeDoubleQuotes :: String -> String -escapeDoubleQuotes = regexReplace "\"" "\"" - -escapeSingleQuotes :: String -> String -escapeSingleQuotes = regexReplace "'" "\'" - -escapeQuotes :: String -> String -escapeQuotes = regexReplace "([\"'])" "\\1" - --- | Quote-aware version of words - don't split on spaces which are inside quotes. --- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails. -words' :: String -> [String] -words' "" = [] -words' s = map stripquotes $ fromparse $ parsewith p s - where - p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline - -- eof - return ss - pattern = many (noneOf whitespacechars) - singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") - doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") - --- | Quote-aware version of unwords - single-quote strings which contain whitespace -unwords' :: [String] -> String -unwords' = unwords . map quoteIfNeeded - --- | Strip one matching pair of single or double quotes on the ends of a string. -stripquotes :: String -> String -stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s - -isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\'' -isSingleQuoted _ = False - -isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"' -isDoubleQuoted _ = False - -unbracket :: String -> String -unbracket s - | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s - | otherwise = s - --- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded. -concatTopPadded :: [String] -> String -concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded - where - lss = map lines strs - h = maximum $ map length lss - ypad ls = replicate (difforzero h (length ls)) "" ++ ls - xpad ls = map (padleft w) ls where w | null ls = 0 - | otherwise = maximum $ map length ls - padded = map (xpad . ypad) lss - --- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded. -concatBottomPadded :: [String] -> String -concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded - where - lss = map lines strs - h = maximum $ map length lss - ypad ls = ls ++ replicate (difforzero h (length ls)) "" - xpad ls = map (padright w) ls where w | null ls = 0 - | otherwise = maximum $ map length ls - padded = map (xpad . ypad) lss - --- | Compose strings vertically and right-aligned. -vConcatRightAligned :: [String] -> String -vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss - where - showfixedwidth = printf (printf "%%%ds" width) - width = maximum $ map length ss - --- | Convert a multi-line string to a rectangular string top-padded to the specified height. -padtop :: Int -> String -> String -padtop h s = intercalate "\n" xpadded - where - ls = lines s - sh = length ls - sw | null ls = 0 - | otherwise = maximum $ map length ls - ypadded = replicate (difforzero h sh) "" ++ ls - xpadded = map (padleft sw) ypadded - --- | Convert a multi-line string to a rectangular string bottom-padded to the specified height. -padbottom :: Int -> String -> String -padbottom h s = intercalate "\n" xpadded - where - ls = lines s - sh = length ls - sw | null ls = 0 - | otherwise = maximum $ map length ls - ypadded = ls ++ replicate (difforzero h sh) "" - xpadded = map (padleft sw) ypadded - --- | Convert a multi-line string to a rectangular string left-padded to the specified width. -padleft :: Int -> String -> String -padleft w "" = concat $ replicate w " " -padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s - --- | Convert a multi-line string to a rectangular string right-padded to the specified width. -padright :: Int -> String -> String -padright w "" = concat $ replicate w " " -padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s - --- | Clip a multi-line string to the specified width and height from the top left. -cliptopleft :: Int -> Int -> String -> String -cliptopleft w h = intercalate "\n" . take h . map (take w) . lines - --- | Clip and pad a multi-line string to fill the specified width and height. -fitto :: Int -> Int -> String -> String -fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline - where - rows = map (fit w) $ lines s - fit w = take w . (++ repeat ' ') - blankline = replicate w ' ' -- tuples @@ -246,11 +73,6 @@ third5 (_,_,x,_,_) = x fourth5 (_,_,_,x,_) = x fifth5 (_,_,_,_,x) = x --- math - -difforzero :: (Num a, Ord a) => a -> a -> a -difforzero a b = maximum [(a - b), 0] - -- lists splitAtElement :: Eq a => a -> [a] -> [[a]] @@ -263,120 +85,6 @@ splitAtElement x l = split es = let (first,rest) = break (x==) es in first : splitAtElement x rest --- trees - --- standard tree helpers - -root = rootLabel -subs = subForest -branches = subForest - --- | List just the leaf nodes of a tree -leaves :: Tree a -> [a] -leaves (Node v []) = [v] -leaves (Node _ branches) = concatMap leaves branches - --- | get the sub-tree rooted at the first (left-most, depth-first) occurrence --- of the specified node value -subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a) -subtreeat v t - | root t == v = Just t - | otherwise = subtreeinforest v $ subs t - --- | get the sub-tree for the specified node value in the first tree in --- forest in which it occurs. -subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a) -subtreeinforest _ [] = Nothing -subtreeinforest v (t:ts) = case (subtreeat v t) of - Just t' -> Just t' - Nothing -> subtreeinforest v ts - --- | remove all nodes past a certain depth -treeprune :: Int -> Tree a -> Tree a -treeprune 0 t = Node (root t) [] -treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t) - --- | apply f to all tree nodes -treemap :: (a -> b) -> Tree a -> Tree b -treemap f t = Node (f $ root t) (map (treemap f) $ branches t) - --- | remove all subtrees whose nodes do not fulfill predicate -treefilter :: (a -> Bool) -> Tree a -> Tree a -treefilter f t = Node - (root t) - (map (treefilter f) $ filter (treeany f) $ branches t) - --- | is predicate true in any node of tree ? -treeany :: (a -> Bool) -> Tree a -> Bool -treeany f t = f (root t) || any (treeany f) (branches t) - --- treedrop -- remove the leaves which do fulfill predicate. --- treedropall -- do this repeatedly. - --- | show a compact ascii representation of a tree -showtree :: Show a => Tree a -> String -showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show - --- | show a compact ascii representation of a forest -showforest :: Show a => Forest a -> String -showforest = concatMap showtree - - --- | An efficient-to-build tree suggested by Cale Gibbard, probably --- better than accountNameTreeFrom. -newtype FastTree a = T (M.Map a (FastTree a)) - deriving (Show, Eq, Ord) - -emptyTree = T M.empty - -mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a -mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m') - -treeFromPath :: [a] -> FastTree a -treeFromPath [] = T M.empty -treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs)) - -treeFromPaths :: (Ord a) => [[a]] -> FastTree a -treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath - - --- parsing - --- | Backtracking choice, use this when alternatives share a prefix. --- Consumes no input if all choices fail. -choice' :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a -choice' = choice . map Text.Parsec.try - -parsewith :: Parsec [Char] () a -> String -> Either ParseError a -parsewith p = runParser p () "" - -parseWithCtx :: Stream s m t => u -> ParsecT s u m a -> s -> m (Either ParseError a) -parseWithCtx ctx p = runParserT p ctx "" - -fromparse :: Either ParseError a -> a -fromparse = either parseerror id - -parseerror :: ParseError -> a -parseerror e = error' $ showParseError e - -showParseError :: ParseError -> String -showParseError e = "parse error at " ++ show e - -showDateParseError :: ParseError -> String -showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) - -nonspace :: (Stream [Char] m Char) => ParsecT [Char] st m Char -nonspace = satisfy (not . isSpace) - -spacenonewline :: (Stream [Char] m Char) => ParsecT [Char] st m Char -spacenonewline = satisfy (`elem` " \v\f\t") - -restofline :: (Stream [Char] m Char) => ParsecT [Char] st m String -restofline = anyChar `manyTill` newline - -eolof :: (Stream [Char] m Char) => ParsecT [Char] st m () -eolof = (newline >> return ()) <|> eof - -- time getCurrentLocalTime :: IO LocalTime @@ -385,44 +93,6 @@ getCurrentLocalTime = do tz <- getCurrentTimeZone return $ utcToLocalTime tz t --- testing - --- | Get a Test's label, or the empty string. -testName :: Test -> String -testName (TestLabel n _) = n -testName _ = "" - --- | Flatten a Test containing TestLists into a list of single tests. -flattenTests :: Test -> [Test] -flattenTests (TestLabel _ t@(TestList _)) = flattenTests t -flattenTests (TestList ts) = concatMap flattenTests ts -flattenTests t = [t] - --- | Filter TestLists in a Test, recursively, preserving the structure. -filterTests :: (Test -> Bool) -> Test -> Test -filterTests p (TestLabel l ts) = TestLabel l (filterTests p ts) -filterTests p (TestList ts) = TestList $ filter (any p . flattenTests) $ map (filterTests p) ts -filterTests _ t = t - --- | Simple way to assert something is some expected value, with no label. -is :: (Eq a, Show a) => a -> a -> Assertion -a `is` e = assertEqual "" e a - --- | Assert a parse result is successful, printing the parse error on failure. -assertParse :: (Either ParseError a) -> Assertion -assertParse parse = either (assertFailure.show) (const (return ())) parse - --- | Assert a parse result is successful, printing the parse error on failure. -assertParseFailure :: (Either ParseError a) -> Assertion -assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse - --- | Assert a parse result is some expected value, printing the parse error on failure. -assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion -assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse - -printParseError :: (Show a) => a -> IO () -printParseError e = do putStr "parse error at "; print e - -- misc isLeft :: Either a b -> Bool diff --git a/hledger-lib/Hledger/Utils/Parse.hs b/hledger-lib/Hledger/Utils/Parse.hs new file mode 100644 index 000000000..b1fbd6e80 --- /dev/null +++ b/hledger-lib/Hledger/Utils/Parse.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} +module Hledger.Utils.Parse where + +import Data.Char +import Data.List +import Text.Parsec +import Text.Printf + +import Hledger.Utils.UTF8IOCompat (error') + +-- | Backtracking choice, use this when alternatives share a prefix. +-- Consumes no input if all choices fail. +choice' :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a +choice' = choice . map Text.Parsec.try + +parsewith :: Parsec [Char] () a -> String -> Either ParseError a +parsewith p = runParser p () "" + +parseWithCtx :: Stream s m t => u -> ParsecT s u m a -> s -> m (Either ParseError a) +parseWithCtx ctx p = runParserT p ctx "" + +fromparse :: Either ParseError a -> a +fromparse = either parseerror id + +parseerror :: ParseError -> a +parseerror e = error' $ showParseError e + +showParseError :: ParseError -> String +showParseError e = "parse error at " ++ show e + +showDateParseError :: ParseError -> String +showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) + +nonspace :: (Stream [Char] m Char) => ParsecT [Char] st m Char +nonspace = satisfy (not . isSpace) + +spacenonewline :: (Stream [Char] m Char) => ParsecT [Char] st m Char +spacenonewline = satisfy (`elem` " \v\f\t") + +restofline :: (Stream [Char] m Char) => ParsecT [Char] st m String +restofline = anyChar `manyTill` newline + +eolof :: (Stream [Char] m Char) => ParsecT [Char] st m () +eolof = (newline >> return ()) <|> eof + diff --git a/hledger-lib/Hledger/Utils/String.hs b/hledger-lib/Hledger/Utils/String.hs new file mode 100644 index 000000000..8efce1b0b --- /dev/null +++ b/hledger-lib/Hledger/Utils/String.hs @@ -0,0 +1,227 @@ +module Hledger.Utils.String ( + -- * misc + lowercase, + uppercase, + underline, + stripbrackets, + unbracket, + -- quoting + quoteIfSpaced, + quoteIfNeeded, + singleQuoteIfNeeded, + -- quotechars, + -- whitespacechars, + escapeDoubleQuotes, + escapeSingleQuotes, + escapeQuotes, + words', + unwords', + stripquotes, + isSingleQuoted, + isDoubleQuoted, + -- * single-line layout + strip, + lstrip, + rstrip, + chomp, + elideLeft, + elideRight, + -- * multi-line layout + concatTopPadded, + concatBottomPadded, + vConcatRightAligned, + padtop, + padbottom, + padleft, + padright, + cliptopleft, + fitto + ) where + + +import Data.Char +import Data.List +import Text.Parsec +import Text.Printf + +import Hledger.Utils.Parse +import Hledger.Utils.Regex + +lowercase, uppercase :: String -> String +lowercase = map toLower +uppercase = map toUpper + +-- | Remove leading and trailing whitespace. +strip :: String -> String +strip = lstrip . rstrip + +-- | Remove leading whitespace. +lstrip :: String -> String +lstrip = dropWhile (`elem` " \t") :: String -> String -- XXX isSpace ? + +-- | Remove trailing whitespace. +rstrip :: String -> String +rstrip = reverse . lstrip . reverse + +-- | Remove trailing newlines/carriage returns. +chomp :: String -> String +chomp = reverse . dropWhile (`elem` "\r\n") . reverse + +stripbrackets :: String -> String +stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String + +elideLeft :: Int -> String -> String +elideLeft width s = + if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s + +elideRight :: Int -> String -> String +elideRight width s = + if length s > width then take (width - 2) s ++ ".." else s + +underline :: String -> String +underline s = s' ++ replicate (length s) '-' ++ "\n" + where s' + | last s == '\n' = s + | otherwise = s ++ "\n" + +-- | Wrap a string in double quotes, and \-prefix any embedded single +-- quotes, if it contains whitespace and is not already single- or +-- double-quoted. +quoteIfSpaced :: String -> String +quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s + | not $ any (`elem` s) whitespacechars = s + | otherwise = "'"++escapeSingleQuotes s++"'" + +-- | Double-quote this string if it contains whitespace, single quotes +-- or double-quotes, escaping the quotes as needed. +quoteIfNeeded :: String -> String +quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\"" + | otherwise = s + +-- | Single-quote this string if it contains whitespace or double-quotes. +-- No good for strings containing single quotes. +singleQuoteIfNeeded :: String -> String +singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'" + | otherwise = s + +quotechars, whitespacechars :: [Char] +quotechars = "'\"" +whitespacechars = " \t\n\r" + +escapeDoubleQuotes :: String -> String +escapeDoubleQuotes = regexReplace "\"" "\"" + +escapeSingleQuotes :: String -> String +escapeSingleQuotes = regexReplace "'" "\'" + +escapeQuotes :: String -> String +escapeQuotes = regexReplace "([\"'])" "\\1" + +-- | Quote-aware version of words - don't split on spaces which are inside quotes. +-- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails. +words' :: String -> [String] +words' "" = [] +words' s = map stripquotes $ fromparse $ parsewith p s + where + p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline + -- eof + return ss + pattern = many (noneOf whitespacechars) + singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") + doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") + +-- | Quote-aware version of unwords - single-quote strings which contain whitespace +unwords' :: [String] -> String +unwords' = unwords . map quoteIfNeeded + +-- | Strip one matching pair of single or double quotes on the ends of a string. +stripquotes :: String -> String +stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s + +isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\'' +isSingleQuoted _ = False + +isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"' +isDoubleQuoted _ = False + +unbracket :: String -> String +unbracket s + | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s + | otherwise = s + +-- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded. +concatTopPadded :: [String] -> String +concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded + where + lss = map lines strs + h = maximum $ map length lss + ypad ls = replicate (difforzero h (length ls)) "" ++ ls + xpad ls = map (padleft w) ls where w | null ls = 0 + | otherwise = maximum $ map length ls + padded = map (xpad . ypad) lss + +-- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded. +concatBottomPadded :: [String] -> String +concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded + where + lss = map lines strs + h = maximum $ map length lss + ypad ls = ls ++ replicate (difforzero h (length ls)) "" + xpad ls = map (padright w) ls where w | null ls = 0 + | otherwise = maximum $ map length ls + padded = map (xpad . ypad) lss + +-- | Compose strings vertically and right-aligned. +vConcatRightAligned :: [String] -> String +vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss + where + showfixedwidth = printf (printf "%%%ds" width) + width = maximum $ map length ss + +-- | Convert a multi-line string to a rectangular string top-padded to the specified height. +padtop :: Int -> String -> String +padtop h s = intercalate "\n" xpadded + where + ls = lines s + sh = length ls + sw | null ls = 0 + | otherwise = maximum $ map length ls + ypadded = replicate (difforzero h sh) "" ++ ls + xpadded = map (padleft sw) ypadded + +-- | Convert a multi-line string to a rectangular string bottom-padded to the specified height. +padbottom :: Int -> String -> String +padbottom h s = intercalate "\n" xpadded + where + ls = lines s + sh = length ls + sw | null ls = 0 + | otherwise = maximum $ map length ls + ypadded = ls ++ replicate (difforzero h sh) "" + xpadded = map (padleft sw) ypadded + +difforzero :: (Num a, Ord a) => a -> a -> a +difforzero a b = maximum [(a - b), 0] + +-- | Convert a multi-line string to a rectangular string left-padded to the specified width. +padleft :: Int -> String -> String +padleft w "" = concat $ replicate w " " +padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s + +-- | Convert a multi-line string to a rectangular string right-padded to the specified width. +padright :: Int -> String -> String +padright w "" = concat $ replicate w " " +padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s + +-- | Clip a multi-line string to the specified width and height from the top left. +cliptopleft :: Int -> Int -> String -> String +cliptopleft w h = intercalate "\n" . take h . map (take w) . lines + +-- | Clip and pad a multi-line string to fill the specified width and height. +fitto :: Int -> Int -> String -> String +fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline + where + rows = map (fit w) $ lines s + fit w = take w . (++ repeat ' ') + blankline = replicate w ' ' + diff --git a/hledger-lib/Hledger/Utils/Test.hs b/hledger-lib/Hledger/Utils/Test.hs new file mode 100644 index 000000000..215b8b6bb --- /dev/null +++ b/hledger-lib/Hledger/Utils/Test.hs @@ -0,0 +1,41 @@ +module Hledger.Utils.Test where + +import Test.HUnit +import Text.Parsec + +-- | Get a Test's label, or the empty string. +testName :: Test -> String +testName (TestLabel n _) = n +testName _ = "" + +-- | Flatten a Test containing TestLists into a list of single tests. +flattenTests :: Test -> [Test] +flattenTests (TestLabel _ t@(TestList _)) = flattenTests t +flattenTests (TestList ts) = concatMap flattenTests ts +flattenTests t = [t] + +-- | Filter TestLists in a Test, recursively, preserving the structure. +filterTests :: (Test -> Bool) -> Test -> Test +filterTests p (TestLabel l ts) = TestLabel l (filterTests p ts) +filterTests p (TestList ts) = TestList $ filter (any p . flattenTests) $ map (filterTests p) ts +filterTests _ t = t + +-- | Simple way to assert something is some expected value, with no label. +is :: (Eq a, Show a) => a -> a -> Assertion +a `is` e = assertEqual "" e a + +-- | Assert a parse result is successful, printing the parse error on failure. +assertParse :: (Either ParseError a) -> Assertion +assertParse parse = either (assertFailure.show) (const (return ())) parse + +-- | Assert a parse result is successful, printing the parse error on failure. +assertParseFailure :: (Either ParseError a) -> Assertion +assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse + +-- | Assert a parse result is some expected value, printing the parse error on failure. +assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion +assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse + +printParseError :: (Show a) => a -> IO () +printParseError e = do putStr "parse error at "; print e + diff --git a/hledger-lib/Hledger/Utils/Tree.hs b/hledger-lib/Hledger/Utils/Tree.hs new file mode 100644 index 000000000..23d3c30f5 --- /dev/null +++ b/hledger-lib/Hledger/Utils/Tree.hs @@ -0,0 +1,87 @@ +module Hledger.Utils.Tree where + +-- import Data.Char +import Data.List (foldl') +import qualified Data.Map as M +import Data.Tree +-- import Text.Parsec +-- import Text.Printf + +import Hledger.Utils.Regex +-- import Hledger.Utils.UTF8IOCompat (error') + +-- standard tree helpers + +root = rootLabel +subs = subForest +branches = subForest + +-- | List just the leaf nodes of a tree +leaves :: Tree a -> [a] +leaves (Node v []) = [v] +leaves (Node _ branches) = concatMap leaves branches + +-- | get the sub-tree rooted at the first (left-most, depth-first) occurrence +-- of the specified node value +subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a) +subtreeat v t + | root t == v = Just t + | otherwise = subtreeinforest v $ subs t + +-- | get the sub-tree for the specified node value in the first tree in +-- forest in which it occurs. +subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a) +subtreeinforest _ [] = Nothing +subtreeinforest v (t:ts) = case (subtreeat v t) of + Just t' -> Just t' + Nothing -> subtreeinforest v ts + +-- | remove all nodes past a certain depth +treeprune :: Int -> Tree a -> Tree a +treeprune 0 t = Node (root t) [] +treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t) + +-- | apply f to all tree nodes +treemap :: (a -> b) -> Tree a -> Tree b +treemap f t = Node (f $ root t) (map (treemap f) $ branches t) + +-- | remove all subtrees whose nodes do not fulfill predicate +treefilter :: (a -> Bool) -> Tree a -> Tree a +treefilter f t = Node + (root t) + (map (treefilter f) $ filter (treeany f) $ branches t) + +-- | is predicate true in any node of tree ? +treeany :: (a -> Bool) -> Tree a -> Bool +treeany f t = f (root t) || any (treeany f) (branches t) + +-- treedrop -- remove the leaves which do fulfill predicate. +-- treedropall -- do this repeatedly. + +-- | show a compact ascii representation of a tree +showtree :: Show a => Tree a -> String +showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show + +-- | show a compact ascii representation of a forest +showforest :: Show a => Forest a -> String +showforest = concatMap showtree + + +-- | An efficient-to-build tree suggested by Cale Gibbard, probably +-- better than accountNameTreeFrom. +newtype FastTree a = T (M.Map a (FastTree a)) + deriving (Show, Eq, Ord) + +emptyTree = T M.empty + +mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a +mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m') + +treeFromPath :: [a] -> FastTree a +treeFromPath [] = T M.empty +treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs)) + +treeFromPaths :: (Ord a) => [[a]] -> FastTree a +treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath + + diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index f4611a7b4..d9cf1e0a8 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -109,7 +109,11 @@ library Hledger.Reports.TransactionsReports Hledger.Utils Hledger.Utils.Debug + Hledger.Utils.Parse Hledger.Utils.Regex + Hledger.Utils.String + Hledger.Utils.Test + Hledger.Utils.Tree Hledger.Utils.UTF8IOCompat default-language: Haskell2010 diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index ac6bb6403..edabcd668 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -122,7 +122,11 @@ library: - Hledger.Reports.TransactionsReports - Hledger.Utils - Hledger.Utils.Debug + - Hledger.Utils.Parse - Hledger.Utils.Regex + - Hledger.Utils.String + - Hledger.Utils.Test + - Hledger.Utils.Tree - Hledger.Utils.UTF8IOCompat tests: