{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.Utils where

import Data.Bool
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Default.Class (Default(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Monoid (Monoid(..))
import Data.Hashable (Hashable(..))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Sequence (Seq)
import System.IO (IO, FilePath)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified System.Directory as IO
import qualified System.IO as IO
import qualified System.IO.Error as IO
-- import qualified Data.Text.Lazy.IO as TL
-- import qualified System.Environment as Env
-- import qualified Data.TreeSeq.Strict as TS

instance Default a => Default (NonEmpty a) where
	def = def:|[]
instance Hashable a => Hashable (Seq a) where
	hashWithSalt s = hashWithSalt s . toList
instance Default (HM.HashMap k a) where
	def = HM.empty
instance Default (HS.HashSet a) where
	def = HS.empty
{-
instance Hashable a => Hashable (TS.Tree a) where
	hashWithSalt s (TS.Tree a ts) =
		s`hashWithSalt`a
		 `hashWithSalt`ts
-}

-- * Monad utilities
unless :: (Applicative f, Monoid a) => Bool -> f a -> f a
unless b fa = if b then pure mempty else fa
{-# INLINABLE unless #-}

when :: (Applicative f, Monoid a) => Bool -> f a -> f a
when b fa = if b then fa else pure mempty
{-# INLINABLE when #-}

-- * Filesystem utilities
readFile :: FilePath -> IO TL.Text
readFile fp = TL.decodeUtf8 <$> BSL.readFile fp

writeFile :: FilePath -> TL.Text -> IO ()
writeFile fp s = BSL.writeFile fp $ TL.encodeUtf8 s

withFile :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
withFile = IO.withFile

removeFile :: FilePath -> IO ()
removeFile f =
	IO.removeFile f `IO.catchIOError` \e ->
		if IO.isDoesNotExistError e
		then return ()
		else IO.ioError e

-- | Lazy in the monoidal accumulator.
foldlMapA :: (Foldable f, Monoid b, Applicative m) => (a -> m b) -> f a -> m b
foldlMapA f = foldr (liftA2 mappend . f) (pure mempty)

-- | Strict in the monoidal accumulator.
-- For monads strict in the left argument of bind ('>>='),
-- this will run in constant space.
foldlMapM :: (Foldable f, Monoid b, Monad m) => (a -> m b) -> f a -> m b
foldlMapM f xs = foldr go pure xs mempty
	where
	-- go :: a -> (b -> m b) -> b -> m b
	go x k lb = f x >>= \rb -> let !b = lb`mappend`rb in k b