1 {-|
    2 
    3 Provide standard imports and utilities which are useful everywhere, or
    4 needed low in the module hierarchy. This is the bottom of the dependency graph.
    5 
    6 -}
    7 
    8 module Ledger.Utils (
    9 module Char,
   10 module Control.Monad,
   11 module Data.List,
   12 --module Data.Map,
   13 module Data.Maybe,
   14 module Data.Ord,
   15 module Data.Tree,
   16 module Data.Time.Clock,
   17 module Data.Time.Calendar,
   18 module Data.Time.LocalTime,
   19 module Debug.Trace,
   20 module Ledger.Utils,
   21 module Text.Printf,
   22 module Text.RegexPR,
   23 module Test.HUnit,
   24 )
   25 where
   26 import Prelude hiding (readFile)
   27 import Char
   28 import Control.Exception
   29 import Control.Monad
   30 import Data.List
   31 --import qualified Data.Map as Map
   32 import Data.Maybe
   33 import Data.Ord
   34 import Data.Tree
   35 import Data.Time.Clock
   36 import Data.Time.Calendar
   37 import Data.Time.LocalTime
   38 import Debug.Trace
   39 import System.IO.UTF8
   40 import Test.HUnit
   41 import Text.Printf
   42 import Text.RegexPR
   43 import Text.ParserCombinators.Parsec
   44 
   45 
   46 -- strings
   47 
   48 lowercase = map toLower
   49 uppercase = map toUpper
   50 
   51 strip = lstrip . rstrip
   52 lstrip = dropws
   53 rstrip = reverse . dropws . reverse
   54 dropws = dropWhile (`elem` " \t")
   55 
   56 elideLeft width s =
   57     case length s > width of
   58       True -> ".." ++ (reverse $ take (width - 2) $ reverse s)
   59       False -> s
   60 
   61 elideRight width s =
   62     case length s > width of
   63       True -> take (width - 2) s ++ ".."
   64       False -> s
   65 
   66 underline :: String -> String
   67 underline s = s' ++ replicate (length s) '-' ++ "\n"
   68     where s'
   69             | last s == '\n' = s
   70             | otherwise = s ++ "\n"
   71 
   72 unbracket :: String -> String
   73 unbracket s
   74     | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s
   75     | otherwise = s
   76 
   77 -- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded.
   78 concatTopPadded :: [String] -> String
   79 concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded
   80     where
   81       lss = map lines strs
   82       h = maximum $ map length lss
   83       ypad ls = replicate (difforzero h (length ls)) "" ++ ls
   84       xpad ls = map (padleft w) ls where w | null ls = 0
   85                                            | otherwise = maximum $ map length ls
   86       padded = map (xpad . ypad) lss
   87 
   88 -- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.
   89 concatBottomPadded :: [String] -> String
   90 concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded
   91     where
   92       lss = map lines strs
   93       h = maximum $ map length lss
   94       ypad ls = ls ++ replicate (difforzero h (length ls)) ""
   95       xpad ls = map (padleft w) ls where w | null ls = 0
   96                                            | otherwise = maximum $ map length ls
   97       padded = map (xpad . ypad) lss
   98 
   99 -- | Convert a multi-line string to a rectangular string top-padded to the specified height.
  100 padtop :: Int -> String -> String
  101 padtop h s = intercalate "\n" xpadded
  102     where
  103       ls = lines s
  104       sh = length ls
  105       sw | null ls = 0
  106          | otherwise = maximum $ map length ls
  107       ypadded = replicate (difforzero h sh) "" ++ ls
  108       xpadded = map (padleft sw) ypadded
  109 
  110 -- | Convert a multi-line string to a rectangular string bottom-padded to the specified height.
  111 padbottom :: Int -> String -> String
  112 padbottom h s = intercalate "\n" xpadded
  113     where
  114       ls = lines s
  115       sh = length ls
  116       sw | null ls = 0
  117          | otherwise = maximum $ map length ls
  118       ypadded = ls ++ replicate (difforzero h sh) ""
  119       xpadded = map (padleft sw) ypadded
  120 
  121 -- | Convert a multi-line string to a rectangular string left-padded to the specified width.
  122 padleft :: Int -> String -> String
  123 padleft w "" = concat $ replicate w " "
  124 padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s
  125 
  126 -- | Convert a multi-line string to a rectangular string right-padded to the specified width.
  127 padright :: Int -> String -> String
  128 padright w "" = concat $ replicate w " "
  129 padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s
  130 
  131 -- | Clip a multi-line string to the specified width and height from the top left.
  132 cliptopleft :: Int -> Int -> String -> String
  133 cliptopleft w h s = intercalate "\n" $ take h $ map (take w) $ lines s
  134 
  135 -- | Clip and pad a multi-line string to fill the specified width and height.
  136 fitto :: Int -> Int -> String -> String
  137 fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline
  138     where
  139       rows = map (fit w) $ lines s
  140       fit w s = take w $ s ++ repeat ' '
  141       blankline = replicate w ' '
  142 
  143 -- math
  144 
  145 difforzero :: (Num a, Ord a) => a -> a -> a
  146 difforzero a b = maximum [(a - b), 0]
  147 
  148 -- regexps
  149 
  150 containsRegex :: String -> String -> Bool
  151 containsRegex r s = case matchRegexPR ("(?i)"++r) s of
  152                       Just _ -> True
  153                       otherwise -> False
  154 
  155 
  156 -- lists
  157 
  158 splitAtElement :: Eq a => a -> [a] -> [[a]]
  159 splitAtElement e l = 
  160     case dropWhile (e==) l of
  161       [] -> []
  162       l' -> first : splitAtElement e rest
  163         where
  164           (first,rest) = break (e==) l'
  165 
  166 -- trees
  167 
  168 root = rootLabel
  169 subs = subForest
  170 branches = subForest
  171 
  172 -- | List just the leaf nodes of a tree
  173 leaves :: Tree a -> [a]
  174 leaves (Node v []) = [v]
  175 leaves (Node _ branches) = concatMap leaves branches
  176 
  177 -- | get the sub-tree rooted at the first (left-most, depth-first) occurrence
  178 -- of the specified node value
  179 subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a)
  180 subtreeat v t
  181     | root t == v = Just t
  182     | otherwise = subtreeinforest v $ subs t
  183 
  184 -- | get the sub-tree for the specified node value in the first tree in
  185 -- forest in which it occurs.
  186 subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a)
  187 subtreeinforest v [] = Nothing
  188 subtreeinforest v (t:ts) = case (subtreeat v t) of
  189                              Just t' -> Just t'
  190                              Nothing -> subtreeinforest v ts
  191           
  192 -- | remove all nodes past a certain depth
  193 treeprune :: Int -> Tree a -> Tree a
  194 treeprune 0 t = Node (root t) []
  195 treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t)
  196 
  197 -- | apply f to all tree nodes
  198 treemap :: (a -> b) -> Tree a -> Tree b
  199 treemap f t = Node (f $ root t) (map (treemap f) $ branches t)
  200 
  201 -- | remove all subtrees whose nodes do not fulfill predicate
  202 treefilter :: (a -> Bool) -> Tree a -> Tree a
  203 treefilter f t = Node 
  204                  (root t) 
  205                  (map (treefilter f) $ filter (treeany f) $ branches t)
  206     
  207 -- | is predicate true in any node of tree ?
  208 treeany :: (a -> Bool) -> Tree a -> Bool
  209 treeany f t = (f $ root t) || (any (treeany f) $ branches t)
  210     
  211 -- treedrop -- remove the leaves which do fulfill predicate. 
  212 -- treedropall -- do this repeatedly.
  213 
  214 -- | show a compact ascii representation of a tree
  215 showtree :: Show a => Tree a -> String
  216 showtree = unlines . filter (containsRegex "[^ |]") . lines . drawTree . treemap show
  217 
  218 -- | show a compact ascii representation of a forest
  219 showforest :: Show a => Forest a -> String
  220 showforest = concatMap showtree
  221 
  222 -- debugging
  223 
  224 -- | trace (print on stdout at runtime) a showable expression
  225 -- (for easily tracing in the middle of a complex expression)
  226 strace :: Show a => a -> a
  227 strace a = trace (show a) a
  228 
  229 -- | labelled trace - like strace, with a newline and a label prepended
  230 ltrace :: Show a => String -> a -> a
  231 ltrace l a = trace (l ++ ": " ++ show a) a
  232 
  233 -- parsing
  234 
  235 parsewith :: Parser a -> String -> Either ParseError a
  236 parsewith p ts = parse p "" ts
  237 
  238 fromparse :: Either ParseError a -> a
  239 fromparse = either (\e -> error $ "parse error at "++(show e)) id
  240 
  241 nonspace :: GenParser Char st Char
  242 nonspace = satisfy (not . isSpace)
  243 
  244 spacenonewline :: GenParser Char st Char
  245 spacenonewline = satisfy (\c -> c `elem` " \v\f\t")
  246 
  247 restofline :: GenParser Char st String
  248 restofline = anyChar `manyTill` newline
  249 
  250 -- time
  251 
  252 getCurrentLocalTime :: IO LocalTime
  253 getCurrentLocalTime = do
  254   t <- getCurrentTime
  255   tz <- getCurrentTimeZone
  256   return $ utcToLocalTime tz t
  257 
  258 -- misc
  259 
  260 isLeft :: Either a b -> Bool
  261 isLeft (Left _) = True
  262 isLeft _        = False
  263 
  264 isRight :: Either a b -> Bool
  265 isRight = not . isLeft
  266 
  267 strictReadFile :: FilePath -> IO String
  268 strictReadFile f = readFile f >>= \s -> Control.Exception.evaluate (length s) >> return s