Hdoc/Utils.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Hdoc.Utils where
   3
   4 import Data.Bool
   5 import Control.Applicative (Applicative(..))
   6 import Control.Monad (Monad(..))
   7 import Data.Default.Class (Default(..))
   8 import Data.Foldable (Foldable(..))
   9 import Data.Function (($), (.))
  10 import Data.Functor ((<$>))
  11 import Data.Monoid (Monoid(..))
  12 import Data.Hashable (Hashable(..))
  13 import Data.List.NonEmpty (NonEmpty(..))
  14 import Data.Sequence (Seq)
  15 import System.IO (IO, FilePath)
  16 import qualified Data.ByteString.Lazy as BSL
  17 import qualified Data.HashMap.Strict as HM
  18 import qualified Data.HashSet as HS
  19 import qualified Data.Text.Lazy as TL
  20 import qualified Data.Text.Lazy.Encoding as TL
  21 import qualified System.Directory as IO
  22 import qualified System.IO as IO
  23 import qualified System.IO.Error as IO
  24 -- import qualified Data.Text.Lazy.IO as TL
  25 -- import qualified System.Environment as Env
  26 -- import qualified Data.TreeSeq.Strict as TS
  27
  28 instance Default a => Default (NonEmpty a) where
  29         def = def:|[]
  30 instance Hashable a => Hashable (Seq a) where
  31         hashWithSalt s = hashWithSalt s . toList
  32 instance Default (HM.HashMap k a) where
  33         def = HM.empty
  34 instance Default (HS.HashSet a) where
  35         def = HS.empty
  36 {-
  37 instance Hashable a => Hashable (TS.Tree a) where
  38         hashWithSalt s (TS.Tree a ts) =
  39                 s`hashWithSalt`a
  40                  `hashWithSalt`ts
  41 -}
  42
  43 -- * Monad utilities
  44 unless :: (Applicative f, Monoid a) => Bool -> f a -> f a
  45 unless b fa = if b then pure mempty else fa
  46 {-# INLINABLE unless #-}
  47
  48 when :: (Applicative f, Monoid a) => Bool -> f a -> f a
  49 when b fa = if b then fa else pure mempty
  50 {-# INLINABLE when #-}
  51
  52 -- * Filesystem utilities
  53 readFile :: FilePath -> IO TL.Text
  54 readFile fp = TL.decodeUtf8 <$> BSL.readFile fp
  55
  56 writeFile :: FilePath -> TL.Text -> IO ()
  57 writeFile fp s = BSL.writeFile fp $ TL.encodeUtf8 s
  58
  59 withFile :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
  60 withFile = IO.withFile
  61
  62 removeFile :: FilePath -> IO ()
  63 removeFile f =
  64         IO.removeFile f `IO.catchIOError` \e ->
  65                 if IO.isDoesNotExistError e
  66                 then return ()
  67                 else IO.ioError e
  68
  69 -- | Lazy in the monoidal accumulator.
  70 foldlMapA :: (Foldable f, Monoid b, Applicative m) => (a -> m b) -> f a -> m b
  71 foldlMapA f = foldr (liftA2 mappend . f) (pure mempty)
  72
  73 -- | Strict in the monoidal accumulator.
  74 -- For monads strict in the left argument of bind ('>>='),
  75 -- this will run in constant space.
  76 foldlMapM :: (Foldable f, Monoid b, Monad m) => (a -> m b) -> f a -> m b
  77 foldlMapM f xs = foldr go pure xs mempty
  78         where
  79         -- go :: a -> (b -> m b) -> b -> m b
  80         go x k lb = f x >>= \rb -> let !b = lb`mappend`rb in k b
  81