1{-|
2
3Standard imports and utilities which are useful everywhere, or needed low
4in the module hierarchy. This is the bottom of hledger's module graph.
5
6-}
7{-# LANGUAGE OverloadedStrings, LambdaCase #-}
8
9module Hledger.Utils (---- provide these frequently used modules - or not, for clearer api:
10                          -- module Control.Monad,
11                          -- module Data.List,
12                          -- module Data.Maybe,
13                          -- module Data.Time.Calendar,
14                          -- module Data.Time.Clock,
15                          -- module Data.Time.LocalTime,
16                          -- module Data.Tree,
17                          -- module Text.RegexPR,
18                          -- module Text.Printf,
19                          ---- all of this one:
20                          module Hledger.Utils,
21                          module Hledger.Utils.Debug,
22                          module Hledger.Utils.Parse,
23                          module Hledger.Utils.Regex,
24                          module Hledger.Utils.String,
25                          module Hledger.Utils.Text,
26                          module Hledger.Utils.Test,
27                          module Hledger.Utils.Color,
28                          module Hledger.Utils.Tree,
29                          -- Debug.Trace.trace,
30                          -- module Data.PPrint,
31                          -- module Hledger.Utils.UTF8IOCompat
32                          error',userError',usageError,
33                          -- the rest need to be done in each module I think
34                          )
35where
36
37import Control.Monad (liftM, when)
38-- import Data.Char
39import Data.Default
40import Data.FileEmbed (makeRelativeToProject, embedStringFile)
41import Data.List
42-- import Data.Maybe
43-- import Data.PPrint
44-- import Data.String.Here (hereFile)
45import Data.Text (Text)
46import qualified Data.Text.IO as T
47import Data.Time.Clock
48import Data.Time.LocalTime
49-- import Data.Text (Text)
50-- import qualified Data.Text as T
51-- import Language.Haskell.TH.Quote (QuasiQuoter(..))
52import Language.Haskell.TH.Syntax (Q, Exp)
53import System.Directory (getHomeDirectory)
54import System.FilePath((</>), isRelative)
55import System.IO
56-- import Text.Printf
57-- import qualified Data.Map as Map
58
59import Hledger.Utils.Debug
60import Hledger.Utils.Parse
61import Hledger.Utils.Regex
62import Hledger.Utils.String
63import Hledger.Utils.Text
64import Hledger.Utils.Test
65import Hledger.Utils.Color
66import Hledger.Utils.Tree
67-- import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn)
68-- import Hledger.Utils.UTF8IOCompat   (readFile,writeFile,appendFile,getContents,putStr,putStrLn)
69import Hledger.Utils.UTF8IOCompat (error',userError',usageError)
70
71
72-- tuples
73
74first3  (x,_,_) = x
75second3 (_,x,_) = x
76third3  (_,_,x) = x
77
78first4  (x,_,_,_) = x
79second4 (_,x,_,_) = x
80third4  (_,_,x,_) = x
81fourth4 (_,_,_,x) = x
82
83first5  (x,_,_,_,_) = x
84second5 (_,x,_,_,_) = x
85third5  (_,_,x,_,_) = x
86fourth5 (_,_,_,x,_) = x
87fifth5  (_,_,_,_,x) = x
88
89first6  (x,_,_,_,_,_) = x
90second6 (_,x,_,_,_,_) = x
91third6  (_,_,x,_,_,_) = x
92fourth6 (_,_,_,x,_,_) = x
93fifth6  (_,_,_,_,x,_) = x
94sixth6  (_,_,_,_,_,x) = x
95
96-- currying
97
98
99curry2 :: ((a, b) -> c) -> a -> b -> c
100curry2 f x y = f (x, y)
101
102uncurry2 :: (a -> b -> c) -> (a, b) -> c
103uncurry2 f (x, y) = f x y
104
105curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d
106curry3 f x y z = f (x, y, z)
107
108uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
109uncurry3 f (x, y, z) = f x y z
110
111curry4 :: ((a, b, c, d) -> e) -> a -> b -> c -> d -> e
112curry4 f w x y z = f (w, x, y, z)
113
114uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
115uncurry4 f (w, x, y, z) = f w x y z
116
117-- lists
118
119splitAtElement :: Eq a => a -> [a] -> [[a]]
120splitAtElement x l =
121  case l of
122    []          -> []
123    e:es | e==x -> split es
124    es          -> split es
125  where
126    split es = let (first,rest) = break (x==) es
127               in first : splitAtElement x rest
128
129-- text
130
131-- time
132
133getCurrentLocalTime :: IO LocalTime
134getCurrentLocalTime = do
135  t <- getCurrentTime
136  tz <- getCurrentTimeZone
137  return $ utcToLocalTime tz t
138
139getCurrentZonedTime :: IO ZonedTime
140getCurrentZonedTime = do
141  t <- getCurrentTime
142  tz <- getCurrentTimeZone
143  return $ utcToZonedTime tz t
144
145-- misc
146
147instance Default Bool where def = False
148
149-- | Apply a function the specified number of times,
150-- which should be > 0 (otherwise does nothing).
151-- Possibly uses O(n) stack ?
152applyN :: Int -> (a -> a) -> a -> a
153applyN n f | n < 1     = id
154           | otherwise = (!! n) . iterate f
155-- from protolude, compare
156-- applyN :: Int -> (a -> a) -> a -> a
157-- applyN n f = X.foldr (.) identity (X.replicate n f)
158
159-- | Convert a possibly relative, possibly tilde-containing file path to an absolute one,
160-- given the current directory. ~username is not supported. Leave "-" unchanged.
161-- Can raise an error.
162expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers
163expandPath _ "-" = return "-"
164expandPath curdir p = (if isRelative p then (curdir </>) else id) `liftM` expandHomePath p
165-- PARTIAL:
166
167-- | Expand user home path indicated by tilde prefix
168expandHomePath :: FilePath -> IO FilePath
169expandHomePath = \case
170    ('~':'/':p)  -> (</> p) <$> getHomeDirectory
171    ('~':'\\':p) -> (</> p) <$> getHomeDirectory
172    ('~':_)      -> ioError $ userError "~USERNAME in paths is not supported"
173    p            -> return p
174
175-- | Read text from a file,
176-- converting any \r\n line endings to \n,,
177-- using the system locale's text encoding,
178-- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.
179readFilePortably :: FilePath -> IO Text
180readFilePortably f =  openFile f ReadMode >>= readHandlePortably
181
182-- | Like readFilePortably, but read from standard input if the path is "-".
183readFileOrStdinPortably :: String -> IO Text
184readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably
185  where
186    openFileOrStdin :: String -> IOMode -> IO Handle
187    openFileOrStdin "-" _ = return stdin
188    openFileOrStdin f m   = openFile f m
189
190readHandlePortably :: Handle -> IO Text
191readHandlePortably h = do
192  hSetNewlineMode h universalNewlineMode
193  menc <- hGetEncoding h
194  when (fmap show menc == Just "UTF-8") $  -- XXX no Eq instance, rely on Show
195    hSetEncoding h utf8_bom
196  T.hGetContents h
197
198-- | Total version of maximum, for integral types, giving 0 for an empty list.
199maximum' :: Integral a => [a] -> a
200maximum' [] = 0
201maximum' xs = maximumStrict xs
202
203-- | Strict version of sum that doesn’t leak space
204{-# INLINABLE sumStrict #-}
205sumStrict :: Num a => [a] -> a
206sumStrict = foldl' (+) 0
207
208-- | Strict version of maximum that doesn’t leak space
209{-# INLINABLE maximumStrict #-}
210maximumStrict :: Ord a => [a] -> a
211maximumStrict = foldl1' max
212
213-- | Strict version of minimum that doesn’t leak space
214{-# INLINABLE minimumStrict #-}
215minimumStrict :: Ord a => [a] -> a
216minimumStrict = foldl1' min
217
218-- | This is a version of sequence based on difference lists. It is
219-- slightly faster but we mostly use it because it uses the heap
220-- instead of the stack. This has the advantage that Neil Mitchell’s
221-- trick of limiting the stack size to discover space leaks doesn’t
222-- show this as a false positive.
223{-# INLINABLE sequence' #-}
224sequence' :: Monad f => [f a] -> f [a]
225sequence' ms = do
226  h <- go id ms
227  return (h [])
228  where
229    go h [] = return h
230    go h (m:ms) = do
231      x <- m
232      go (h . (x :)) ms
233
234-- | Like mapM but uses sequence'.
235{-# INLINABLE mapM' #-}
236mapM' :: Monad f => (a -> f b) -> [a] -> f [b]
237mapM' f = sequence' . map f
238
239-- | Like embedFile, but takes a path relative to the package directory.
240-- Similar to embedFileRelative ?
241embedFileRelative :: FilePath -> Q Exp
242embedFileRelative f = makeRelativeToProject f >>= embedStringFile
243
244-- -- | Like hereFile, but takes a path relative to the package directory.
245-- -- Similar to embedFileRelative ?
246-- hereFileRelative :: FilePath -> Q Exp
247-- hereFileRelative f = makeRelativeToProject f >>= hereFileExp
248--   where
249--     QuasiQuoter{quoteExp=hereFileExp} = hereFile
250
251tests_Utils = tests "Utils" [
252  tests_Text
253  ]
254