module Hledger.Utils (
module Hledger.Utils,
Debug.Trace.trace,
SystemString,fromSystemString,toSystemString,error',userError'
)
where
import Control.Monad.Error
import Data.Char
import Data.List
import Data.Maybe
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Tree
import Debug.Trace
import System.Directory (getHomeDirectory)
import System.FilePath(takeDirectory,combine)
import Test.HUnit
import Text.ParserCombinators.Parsec
import Text.Printf
import Text.RegexPR
import Hledger.Utils.UTF8IOCompat (SystemString,fromSystemString,toSystemString,error',userError')
lowercase = map toLower
uppercase = map toUpper
strip = lstrip . rstrip
lstrip = dropWhile (`elem` " \t")
rstrip = reverse . lstrip . reverse
elideLeft width s =
if length s > width then ".." ++ reverse (take (width 2) $ reverse s) else s
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"
quoteIfSpaced :: String -> String
quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s
| not $ any (`elem` s) whitespacechars = s
| otherwise = "'"++escapeSingleQuotes s++"'"
escapeSingleQuotes :: String -> String
escapeSingleQuotes = regexReplace "'" "\'"
escapeQuotes :: String -> String
escapeQuotes = regexReplace "([\"'])" "\\1"
words' :: String -> [String]
words' = map stripquotes . fromparse . parsewith p
where
p = do ss <- (quotedPattern <|> pattern) `sepBy` many1 spacenonewline
return ss
pattern = many (noneOf whitespacechars)
quotedPattern = between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\""
unwords' :: [String] -> String
unwords' = unwords . map singleQuoteIfNeeded
singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"
| otherwise = s
whitespacechars = " \t\n\r"
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
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
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 (padleft w) ls where w | null ls = 0
| otherwise = maximum $ map length ls
padded = map (xpad . ypad) lss
vConcatRightAligned :: [String] -> String
vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss
where
showfixedwidth = printf (printf "%%%ds" width)
width = maximum $ map length ss
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
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
padleft :: Int -> String -> String
padleft w "" = concat $ replicate w " "
padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s
padright :: Int -> String -> String
padright w "" = concat $ replicate w " "
padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s
cliptopleft :: Int -> Int -> String -> String
cliptopleft w h = intercalate "\n" . take h . map (take w) . lines
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 ' '
difforzero :: (Num a, Ord a) => a -> a -> a
difforzero a b = maximum [(a b), 0]
regexMatch r s = matchRegexPR r s
regexMatchCI r s = regexMatch (regexToCaseInsensitive r) s
regexMatches :: String -> String -> Bool
regexMatches r s = isJust $ matchRegexPR r s
regexMatchesCI :: String -> String -> Bool
regexMatchesCI r s = regexMatches (regexToCaseInsensitive r) s
containsRegex = regexMatchesCI
regexReplace :: String -> String -> String -> String
regexReplace r repl s = gsubRegexPR r repl s
regexReplaceCI :: String -> String -> String -> String
regexReplaceCI r s = regexReplace (regexToCaseInsensitive r) s
regexReplaceBy :: String -> (String -> String) -> String -> String
regexReplaceBy r replfn s = gsubRegexPRBy r replfn s
regexToCaseInsensitive :: String -> String
regexToCaseInsensitive r = "(?i)"++ r
splitAtElement :: Eq a => a -> [a] -> [[a]]
splitAtElement e l =
case dropWhile (e==) l of
[] -> []
l' -> first : splitAtElement e rest
where
(first,rest) = break (e==) l'
root = rootLabel
subs = subForest
branches = subForest
leaves :: Tree a -> [a]
leaves (Node v []) = [v]
leaves (Node _ branches) = concatMap leaves branches
subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a)
subtreeat v t
| root t == v = Just t
| otherwise = subtreeinforest v $ subs t
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
treeprune :: Int -> Tree a -> Tree a
treeprune 0 t = Node (root t) []
treeprune d t = Node (root t) (map (treeprune $ d1) $ branches t)
treemap :: (a -> b) -> Tree a -> Tree b
treemap f t = Node (f $ root t) (map (treemap f) $ branches t)
treefilter :: (a -> Bool) -> Tree a -> Tree a
treefilter f t = Node
(root t)
(map (treefilter f) $ filter (treeany f) $ branches t)
treeany :: (a -> Bool) -> Tree a -> Bool
treeany f t = f (root t) || any (treeany f) (branches t)
showtree :: Show a => Tree a -> String
showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show
showforest :: Show a => Forest a -> String
showforest = concatMap showtree
strace :: Show a => a -> a
strace a = trace (show a) a
ltrace :: Show a => String -> a -> a
ltrace l a = trace (l ++ ": " ++ show a) a
mtrace :: (Monad m, Show a) => a -> m a
mtrace a = strace a `seq` return a
tracewith :: (a -> String) -> a -> a
tracewith f e = trace (f e) e
choice' :: [GenParser tok st a] -> GenParser tok st a
choice' = choice . map Text.ParserCombinators.Parsec.try
parsewith :: Parser a -> String -> Either ParseError a
parsewith p = parse p ""
parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a
parseWithCtx ctx p = runParser 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 :: GenParser Char st Char
nonspace = satisfy (not . isSpace)
spacenonewline :: GenParser Char st Char
spacenonewline = satisfy (`elem` " \v\f\t")
restofline :: GenParser Char st String
restofline = anyChar `manyTill` newline
getCurrentLocalTime :: IO LocalTime
getCurrentLocalTime = do
t <- getCurrentTime
tz <- getCurrentTimeZone
return $ utcToLocalTime tz t
testName :: Test -> String
testName (TestLabel n _) = n
testName _ = ""
flattenTests :: Test -> [Test]
flattenTests (TestLabel _ t@(TestList _)) = flattenTests t
flattenTests (TestList ts) = concatMap flattenTests ts
flattenTests t = [t]
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
is :: (Eq a, Show a) => a -> a -> Assertion
a `is` e = assertEqual "" e a
assertParse :: (Either ParseError a) -> Assertion
assertParse parse = either (assertFailure.show) (const (return ())) parse
assertParseFailure :: (Either ParseError a) -> Assertion
assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse
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
isLeft :: Either a b -> Bool
isLeft (Left _) = True
isLeft _ = False
isRight :: Either a b -> Bool
isRight = not . isLeft
applyN :: Int -> (a -> a) -> a -> a
applyN n f = (!! n) . iterate f
expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath
expandPath pos fp = liftM mkAbsolute (expandHome fp)
where
mkAbsolute = combine (takeDirectory (sourceName pos))
expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory
return $ homedir ++ drop 1 inname
| otherwise = return inname
firstJust ms = case dropWhile (==Nothing) ms of
[] -> Nothing
(md:_) -> md