module Hledger.Data.Utils (
module Data.Char,
module Control.Monad,
module Data.List,
module Data.Maybe,
module Data.Ord,
module Data.Tree,
module Data.Time.Clock,
module Data.Time.Calendar,
module Data.Time.LocalTime,
module Debug.Trace,
module Hledger.Data.Utils,
module Text.Printf,
module Text.RegexPR,
module Test.HUnit,
)
where
import Data.Char
import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded)
import Control.Monad
import Data.List
import Data.Maybe
import Data.Ord
import Data.Tree
import Data.Time.Clock
import Data.Time.Calendar
import Data.Time.LocalTime
import Debug.Trace
#if __GLASGOW_HASKELL__ <= 610
import Prelude hiding (readFile,putStr,print)
import System.IO.UTF8
#endif
import Test.HUnit
import Text.Printf
import Text.RegexPR
import Text.ParserCombinators.Parsec
import System.Info (os)
lowercase = map toLower
uppercase = map toUpper
strip = lstrip . rstrip
lstrip = dropws
rstrip = reverse . dropws . reverse
dropws = dropWhile (`elem` " \t")
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"
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 ' '
type PlatformString = String
fromPlatformString :: PlatformString -> String
fromPlatformString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s
toPlatformString :: String -> PlatformString
toPlatformString = case os of
"unix" -> UTF8.encodeString
"linux" -> UTF8.encodeString
"darwin" -> UTF8.encodeString
_ -> id
error' :: String -> a
error' = error . toPlatformString
userError' :: String -> IOError
userError' = userError . toPlatformString
difforzero :: (Num a, Ord a) => a -> a -> a
difforzero a b = maximum [(a b), 0]
containsRegex :: String -> String -> Bool
containsRegex r s = case matchRegexPR ("(?i)"++r) s of
Just _ -> True
_ -> False
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 (containsRegex "[^ \\|]") . 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 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 e = error' $ showParseError e
showParseError e = "parse error at " ++ show e
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
tname :: Test -> String
tname (TestLabel n _) = n
tname _ = ""
tflatten :: Test -> [Test]
tflatten (TestLabel _ t@(TestList _)) = tflatten t
tflatten (TestList ts) = concatMap tflatten ts
tflatten t = [t]
tfilter :: (Test -> Bool) -> Test -> Test
tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)
tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts
tfilter _ 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
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