Hdoc/Utils.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Hdoc.Utils where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Control.Monad (Monad(..))
   8 import Data.Bool
   9 import Data.Default.Class (Default(..))
  10 import Data.Eq (Eq(..))
  11 import Data.Foldable (Foldable(..))
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Hashable (Hashable(..))
  15 import Data.Int (Int)
  16 import Data.List.NonEmpty (NonEmpty(..))
  17 import Data.Maybe (Maybe(..))
  18 import Data.Monoid (Monoid(..))
  19 import Data.Ord (Ord(..))
  20 import Data.Sequence (Seq)
  21 import Data.Text (Text)
  22 import Prelude (pred, succ)
  23 import System.IO (IO, FilePath)
  24 import Text.Show (Show(..))
  25 import qualified Data.ByteString.Lazy as BSL
  26 import qualified Data.HashMap.Strict as HM
  27 import qualified Data.HashSet as HS
  28 import qualified Data.Text.Lazy as TL
  29 import qualified Data.Text.Lazy.Encoding as TL
  30 import qualified System.Directory as IO
  31 import qualified System.IO as IO
  32 import qualified System.IO.Error as IO
  33
  34 instance Default Text where
  35         def = ""
  36 instance Default TL.Text where
  37         def = ""
  38 instance Default a => Default (NonEmpty a) where
  39         def = def:|[]
  40 instance Hashable a => Hashable (Seq a) where
  41         hashWithSalt s = hashWithSalt s . toList
  42 instance Default (HM.HashMap k a) where
  43         def = HM.empty
  44 instance Default (HS.HashSet a) where
  45         def = HS.empty
  46 {-
  47 instance Hashable a => Hashable (TS.Tree a) where
  48         hashWithSalt s (TS.Tree a ts) =
  49                 s`hashWithSalt`a
  50                  `hashWithSalt`ts
  51 -}
  52
  53 -- * Monad utilities
  54 unless :: (Applicative f, Monoid a) => Bool -> f a -> f a
  55 unless b fa = if b then pure mempty else fa
  56 {-# INLINABLE unless #-}
  57
  58 when :: (Applicative f, Monoid a) => Bool -> f a -> f a
  59 when b fa = if b then fa else pure mempty
  60 {-# INLINABLE when #-}
  61
  62 -- * Filesystem utilities
  63 readFile :: FilePath -> IO TL.Text
  64 readFile fp = TL.decodeUtf8 <$> BSL.readFile fp
  65
  66 writeFile :: FilePath -> TL.Text -> IO ()
  67 writeFile fp s = BSL.writeFile fp $ TL.encodeUtf8 s
  68
  69 withFile :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
  70 withFile = IO.withFile
  71
  72 removeFile :: FilePath -> IO ()
  73 removeFile f =
  74         IO.removeFile f `IO.catchIOError` \e ->
  75                 if IO.isDoesNotExistError e
  76                 then return ()
  77                 else IO.ioError e
  78
  79 -- | Lazy in the monoidal accumulator.
  80 foldlMapA :: (Foldable f, Monoid b, Applicative m) => (a -> m b) -> f a -> m b
  81 foldlMapA f = foldr (liftA2 mappend . f) (pure mempty)
  82
  83 -- | Strict in the monoidal accumulator.
  84 -- For monads strict in the left argument of bind ('>>='),
  85 -- this will run in constant space.
  86 foldlMapM :: (Foldable f, Monoid b, Monad m) => (a -> m b) -> f a -> m b
  87 foldlMapM f xs = foldr go pure xs mempty
  88         where
  89         -- go :: a -> (b -> m b) -> b -> m b
  90         go x k lb = f x >>= \rb -> let !b = lb`mappend`rb in k b
  91
  92 -- * Arithmetical utilities
  93 -- ** Type 'Nat'
  94 newtype Nat = Nat { unNat :: Int }
  95  deriving (Eq,Ord,Hashable)
  96 instance Show Nat where
  97         showsPrec p = showsPrec p . unNat
  98 instance Default Nat where
  99         def = Nat 0
 100
 101 succNat :: Nat -> Nat
 102 succNat (Nat n) = Nat $ succ n
 103
 104 predNat :: Nat -> Maybe Nat
 105 predNat (Nat n) | n <= 0    = Nothing
 106                 | otherwise = Just $ Nat $ pred n
 107
 108 -- ** Type 'Nat1'
 109 newtype Nat1 = Nat1 { unNat1 :: Int }
 110  deriving (Eq,Ord,Hashable)
 111 instance Show Nat1 where
 112         showsPrec p = showsPrec p . unNat1
 113 instance Default Nat1 where
 114         def = Nat1 1
 115
 116 succNat1 :: Nat1 -> Nat1
 117 succNat1 (Nat1 n) = Nat1 $ succ n
 118 predNat1 :: Nat1 -> Maybe Nat1
 119 predNat1 (Nat1 n) | n <= 1    = Nothing
 120                   | otherwise = Just $ Nat1 $ pred n