1 {-|
    2 
    3 Standard imports and utilities which are useful everywhere, or needed low
    4 in the module hierarchy. This is the bottom of hledger's module graph.
    5 
    6 -}
    7 
    8 module Hledger.Utils (---- provide these frequently used modules - or not, for clearer api:
    9                           -- module Control.Monad,
   10                           -- module Data.List,
   11                           -- module Data.Maybe,
   12                           -- module Data.Time.Calendar,
   13                           -- module Data.Time.Clock,
   14                           -- module Data.Time.LocalTime,
   15                           -- module Data.Tree,
   16                           -- module Debug.Trace,
   17                           -- module Text.RegexPR,
   18                           -- module Test.HUnit,
   19                           -- module Text.Printf,
   20                           ---- all of this one:
   21                           module Hledger.Utils,
   22                           Debug.Trace.trace
   23                           ---- and this for i18n - needs to be done in each module I think:
   24                           -- module Hledger.Utils.UTF8
   25                           )
   26 where
   27 import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded)
   28 import Data.Char
   29 import Data.List
   30 import Data.Maybe
   31 import Data.Time.Clock
   32 import Data.Time.LocalTime
   33 import Data.Tree
   34 import Debug.Trace
   35 import System.Info (os)
   36 import Test.HUnit
   37 import Text.ParserCombinators.Parsec
   38 import Text.Printf
   39 import Text.RegexPR
   40 -- import qualified Data.Map as Map
   41 -- 
   42 -- import Prelude hiding (readFile,writeFile,getContents,putStr,putStrLn)
   43 -- import Hledger.Utils.UTF8
   44 
   45 -- strings
   46 
   47 lowercase = map toLower
   48 uppercase = map toUpper
   49 
   50 strip = lstrip . rstrip
   51 lstrip = dropWhile (`elem` " \t")
   52 rstrip = reverse . lstrip . reverse
   53 
   54 elideLeft width s =
   55     if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s
   56 
   57 elideRight width s =
   58     if length s > width then take (width - 2) s ++ ".." else s
   59 
   60 underline :: String -> String
   61 underline s = s' ++ replicate (length s) '-' ++ "\n"
   62     where s'
   63             | last s == '\n' = s
   64             | otherwise = s ++ "\n"
   65 
   66 -- | Wrap a string in single quotes, and \-prefix any embedded single
   67 -- quotes, if it contains whitespace and is not already single- or
   68 -- double-quoted.
   69 quoteIfSpaced :: String -> String
   70 quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s
   71                 | not $ any (`elem` s) whitespacechars = s
   72                 | otherwise = "'"++escapeSingleQuotes s++"'"
   73                   where escapeSingleQuotes = regexReplace "'" "\'"
   74 
   75 -- | Quote-aware version of words - don't split on spaces which are inside quotes.
   76 -- NB correctly handles "a'b" but not "''a''".
   77 words' :: String -> [String]
   78 words' = map stripquotes . fromparse . parsewith p
   79     where
   80       p = do ss <- (quotedPattern <|> pattern) `sepBy` many1 spacenonewline
   81              -- eof
   82              return ss
   83       pattern = many (noneOf whitespacechars)
   84       quotedPattern = between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\""
   85 
   86 -- | Quote-aware version of unwords - single-quote strings which contain whitespace
   87 unwords' :: [String] -> String
   88 unwords' = unwords . map singleQuoteIfNeeded
   89 
   90 singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"
   91                       | otherwise = s
   92 
   93 whitespacechars = " \t\n\r"
   94 
   95 -- | Strip one matching pair of single or double quotes on the ends of a string.
   96 stripquotes :: String -> String
   97 stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s
   98 
   99 isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\''
  100 isSingleQuoted _ = False
  101 
  102 isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"'
  103 isDoubleQuoted _ = False
  104 
  105 unbracket :: String -> String
  106 unbracket s
  107     | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s
  108     | otherwise = s
  109 
  110 -- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded.
  111 concatTopPadded :: [String] -> String
  112 concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded
  113     where
  114       lss = map lines strs
  115       h = maximum $ map length lss
  116       ypad ls = replicate (difforzero h (length ls)) "" ++ ls
  117       xpad ls = map (padleft w) ls where w | null ls = 0
  118                                            | otherwise = maximum $ map length ls
  119       padded = map (xpad . ypad) lss
  120 
  121 -- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.
  122 concatBottomPadded :: [String] -> String
  123 concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded
  124     where
  125       lss = map lines strs
  126       h = maximum $ map length lss
  127       ypad ls = ls ++ replicate (difforzero h (length ls)) ""
  128       xpad ls = map (padleft w) ls where w | null ls = 0
  129                                            | otherwise = maximum $ map length ls
  130       padded = map (xpad . ypad) lss
  131 
  132 -- | Compose strings vertically and right-aligned.
  133 vConcatRightAligned :: [String] -> String
  134 vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss
  135     where
  136       showfixedwidth = printf (printf "%%%ds" width)
  137       width = maximum $ map length ss
  138 
  139 -- | Convert a multi-line string to a rectangular string top-padded to the specified height.
  140 padtop :: Int -> String -> String
  141 padtop h s = intercalate "\n" xpadded
  142     where
  143       ls = lines s
  144       sh = length ls
  145       sw | null ls = 0
  146          | otherwise = maximum $ map length ls
  147       ypadded = replicate (difforzero h sh) "" ++ ls
  148       xpadded = map (padleft sw) ypadded
  149 
  150 -- | Convert a multi-line string to a rectangular string bottom-padded to the specified height.
  151 padbottom :: Int -> String -> String
  152 padbottom h s = intercalate "\n" xpadded
  153     where
  154       ls = lines s
  155       sh = length ls
  156       sw | null ls = 0
  157          | otherwise = maximum $ map length ls
  158       ypadded = ls ++ replicate (difforzero h sh) ""
  159       xpadded = map (padleft sw) ypadded
  160 
  161 -- | Convert a multi-line string to a rectangular string left-padded to the specified width.
  162 padleft :: Int -> String -> String
  163 padleft w "" = concat $ replicate w " "
  164 padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s
  165 
  166 -- | Convert a multi-line string to a rectangular string right-padded to the specified width.
  167 padright :: Int -> String -> String
  168 padright w "" = concat $ replicate w " "
  169 padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s
  170 
  171 -- | Clip a multi-line string to the specified width and height from the top left.
  172 cliptopleft :: Int -> Int -> String -> String
  173 cliptopleft w h = intercalate "\n" . take h . map (take w) . lines
  174 
  175 -- | Clip and pad a multi-line string to fill the specified width and height.
  176 fitto :: Int -> Int -> String -> String
  177 fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline
  178     where
  179       rows = map (fit w) $ lines s
  180       fit w = take w . (++ repeat ' ')
  181       blankline = replicate w ' '
  182 
  183 -- encoded platform strings
  184 
  185 -- | A platform string is a string value from or for the operating system,
  186 -- such as a file path or command-line argument (or environment variable's
  187 -- name or value ?). On some platforms (such as unix) these are not real
  188 -- unicode strings but have some encoding such as UTF-8. This alias does
  189 -- no type enforcement but aids code clarity.
  190 type PlatformString = String
  191 
  192 -- | Convert a possibly encoded platform string to a real unicode string.
  193 -- We decode the UTF-8 encoding recommended for unix systems
  194 -- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)
  195 -- and leave anything else unchanged.
  196 fromPlatformString :: PlatformString -> String
  197 fromPlatformString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s
  198 
  199 -- | Convert a unicode string to a possibly encoded platform string.
  200 -- On unix we encode with the recommended UTF-8
  201 -- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)
  202 -- and elsewhere we leave it unchanged.
  203 toPlatformString :: String -> PlatformString
  204 toPlatformString = case os of
  205                      "unix" -> UTF8.encodeString
  206                      "linux" -> UTF8.encodeString
  207                      "darwin" -> UTF8.encodeString
  208                      _ -> id
  209 
  210 -- | A version of error that's better at displaying unicode.
  211 error' :: String -> a
  212 error' = error . toPlatformString
  213 
  214 -- | A version of userError that's better at displaying unicode.
  215 userError' :: String -> IOError
  216 userError' = userError . toPlatformString
  217 
  218 -- math
  219 
  220 difforzero :: (Num a, Ord a) => a -> a -> a
  221 difforzero a b = maximum [(a - b), 0]
  222 
  223 -- regexps
  224 
  225 -- regexMatch :: String -> String -> MatchFun Maybe
  226 regexMatch r s = matchRegexPR r s
  227 
  228 -- regexMatchCI :: String -> String -> MatchFun Maybe
  229 regexMatchCI r s = regexMatch (regexToCaseInsensitive r) s
  230 
  231 regexMatches :: String -> String -> Bool
  232 regexMatches r s = isJust $ matchRegexPR r s
  233 
  234 regexMatchesCI :: String -> String -> Bool
  235 regexMatchesCI r s = regexMatches (regexToCaseInsensitive r) s
  236 
  237 containsRegex = regexMatchesCI
  238 
  239 regexReplace :: String -> String -> String -> String
  240 regexReplace r repl s = gsubRegexPR r repl s
  241 
  242 regexReplaceCI :: String -> String -> String -> String
  243 regexReplaceCI r s = regexReplace (regexToCaseInsensitive r) s
  244 
  245 regexReplaceBy :: String -> (String -> String) -> String -> String
  246 regexReplaceBy r replfn s = gsubRegexPRBy r replfn s
  247 
  248 regexToCaseInsensitive :: String -> String
  249 regexToCaseInsensitive r = "(?i)"++ r
  250 
  251 -- lists
  252 
  253 splitAtElement :: Eq a => a -> [a] -> [[a]]
  254 splitAtElement e l = 
  255     case dropWhile (e==) l of
  256       [] -> []
  257       l' -> first : splitAtElement e rest
  258         where
  259           (first,rest) = break (e==) l'
  260 
  261 -- trees
  262 
  263 root = rootLabel
  264 subs = subForest
  265 branches = subForest
  266 
  267 -- | List just the leaf nodes of a tree
  268 leaves :: Tree a -> [a]
  269 leaves (Node v []) = [v]
  270 leaves (Node _ branches) = concatMap leaves branches
  271 
  272 -- | get the sub-tree rooted at the first (left-most, depth-first) occurrence
  273 -- of the specified node value
  274 subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a)
  275 subtreeat v t
  276     | root t == v = Just t
  277     | otherwise = subtreeinforest v $ subs t
  278 
  279 -- | get the sub-tree for the specified node value in the first tree in
  280 -- forest in which it occurs.
  281 subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a)
  282 subtreeinforest _ [] = Nothing
  283 subtreeinforest v (t:ts) = case (subtreeat v t) of
  284                              Just t' -> Just t'
  285                              Nothing -> subtreeinforest v ts
  286           
  287 -- | remove all nodes past a certain depth
  288 treeprune :: Int -> Tree a -> Tree a
  289 treeprune 0 t = Node (root t) []
  290 treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t)
  291 
  292 -- | apply f to all tree nodes
  293 treemap :: (a -> b) -> Tree a -> Tree b
  294 treemap f t = Node (f $ root t) (map (treemap f) $ branches t)
  295 
  296 -- | remove all subtrees whose nodes do not fulfill predicate
  297 treefilter :: (a -> Bool) -> Tree a -> Tree a
  298 treefilter f t = Node 
  299                  (root t) 
  300                  (map (treefilter f) $ filter (treeany f) $ branches t)
  301     
  302 -- | is predicate true in any node of tree ?
  303 treeany :: (a -> Bool) -> Tree a -> Bool
  304 treeany f t = f (root t) || any (treeany f) (branches t)
  305     
  306 -- treedrop -- remove the leaves which do fulfill predicate. 
  307 -- treedropall -- do this repeatedly.
  308 
  309 -- | show a compact ascii representation of a tree
  310 showtree :: Show a => Tree a -> String
  311 showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show
  312 
  313 -- | show a compact ascii representation of a forest
  314 showforest :: Show a => Forest a -> String
  315 showforest = concatMap showtree
  316 
  317 -- debugging
  318 
  319 -- | trace (print on stdout at runtime) a showable expression
  320 -- (for easily tracing in the middle of a complex expression)
  321 strace :: Show a => a -> a
  322 strace a = trace (show a) a
  323 
  324 -- | labelled trace - like strace, with a label prepended
  325 ltrace :: Show a => String -> a -> a
  326 ltrace l a = trace (l ++ ": " ++ show a) a
  327 
  328 -- | monadic trace - like strace, but works as a standalone line in a monad
  329 mtrace :: (Monad m, Show a) => a -> m a
  330 mtrace a = strace a `seq` return a
  331 
  332 -- | trace an expression using a custom show function
  333 tracewith :: (a -> String) -> a -> a
  334 tracewith f e = trace (f e) e
  335 
  336 -- parsing
  337 
  338 -- | Backtracking choice, use this when alternatives share a prefix.
  339 -- Consumes no input if all choices fail.
  340 choice' :: [GenParser tok st a] -> GenParser tok st a
  341 choice' = choice . map Text.ParserCombinators.Parsec.try
  342 
  343 parsewith :: Parser a -> String -> Either ParseError a
  344 parsewith p = parse p ""
  345 
  346 parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a
  347 parseWithCtx ctx p = runParser p ctx ""
  348 
  349 fromparse :: Either ParseError a -> a
  350 fromparse = either parseerror id
  351 
  352 parseerror :: ParseError -> a
  353 parseerror e = error' $ showParseError e
  354 
  355 showParseError :: ParseError -> String
  356 showParseError e = "parse error at " ++ show e
  357 
  358 showDateParseError :: ParseError -> String
  359 showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)
  360 
  361 nonspace :: GenParser Char st Char
  362 nonspace = satisfy (not . isSpace)
  363 
  364 spacenonewline :: GenParser Char st Char
  365 spacenonewline = satisfy (`elem` " \v\f\t")
  366 
  367 restofline :: GenParser Char st String
  368 restofline = anyChar `manyTill` newline
  369 
  370 -- time
  371 
  372 getCurrentLocalTime :: IO LocalTime
  373 getCurrentLocalTime = do
  374   t <- getCurrentTime
  375   tz <- getCurrentTimeZone
  376   return $ utcToLocalTime tz t
  377 
  378 -- testing
  379 
  380 -- | Get a Test's label, or the empty string.
  381 tname :: Test -> String
  382 tname (TestLabel n _) = n
  383 tname _ = ""
  384 
  385 -- | Flatten a Test containing TestLists into a list of single tests.
  386 tflatten :: Test -> [Test]
  387 tflatten (TestLabel _ t@(TestList _)) = tflatten t
  388 tflatten (TestList ts) = concatMap tflatten ts
  389 tflatten t = [t]
  390 
  391 -- | Filter TestLists in a Test, recursively, preserving the structure.
  392 tfilter :: (Test -> Bool) -> Test -> Test
  393 tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)
  394 tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts
  395 tfilter _ t = t
  396 
  397 -- | Simple way to assert something is some expected value, with no label.
  398 is :: (Eq a, Show a) => a -> a -> Assertion
  399 a `is` e = assertEqual "" e a
  400 
  401 -- | Assert a parse result is successful, printing the parse error on failure.
  402 assertParse :: (Either ParseError a) -> Assertion
  403 assertParse parse = either (assertFailure.show) (const (return ())) parse
  404 
  405 -- | Assert a parse result is successful, printing the parse error on failure.
  406 assertParseFailure :: (Either ParseError a) -> Assertion
  407 assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse
  408 
  409 -- | Assert a parse result is some expected value, printing the parse error on failure.
  410 assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
  411 assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse
  412 
  413 printParseError :: (Show a) => a -> IO ()
  414 printParseError e = do putStr "parse error at "; print e
  415 
  416 -- misc
  417 
  418 isLeft :: Either a b -> Bool
  419 isLeft (Left _) = True
  420 isLeft _        = False
  421 
  422 isRight :: Either a b -> Bool
  423 isRight = not . isLeft
  424 
  425 -- | Apply a function the specified number of times. Possibly uses O(n) stack ?
  426 applyN :: Int -> (a -> a) -> a -> a
  427 applyN n f = (!! n) . iterate f