lib: split up Utils more
This commit is contained in:
Simon Michael
parent
69c870c6f0
commit
7aecbac851
@ -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
|
||||
|
||||
45
hledger-lib/Hledger/Utils/Parse.hs
Normal file
45
hledger-lib/Hledger/Utils/Parse.hs
Normal file
@ -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
|
||||
|
||||
227
hledger-lib/Hledger/Utils/String.hs
Normal file
227
hledger-lib/Hledger/Utils/String.hs
Normal file
@ -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 ' '
|
||||
|
||||
41
hledger-lib/Hledger/Utils/Test.hs
Normal file
41
hledger-lib/Hledger/Utils/Test.hs
Normal file
@ -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
|
||||
|
||||
87
hledger-lib/Hledger/Utils/Tree.hs
Normal file
87
hledger-lib/Hledger/Utils/Tree.hs
Normal file
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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:
|
||||
|
||||
Loading…
Reference in New Issue
Block a user