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

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Hashable (Hashable(..))
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Sequence (Seq)
import Data.Text (Text)
import Prelude (pred, succ)
import System.IO (IO, FilePath)
import Text.Show (Show(..))
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

instance Default Text where
	def = ""
instance Default TL.Text where
	def = ""
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

-- * Arithmetical utilities
-- ** Type 'Nat'
newtype Nat = Nat { unNat :: Int }
 deriving (Eq,Ord,Hashable)
instance Show Nat where
	showsPrec p = showsPrec p . unNat
instance Default Nat where
	def = Nat 0

succNat :: Nat -> Nat
succNat (Nat n) = Nat $ succ n

predNat :: Nat -> Maybe Nat
predNat (Nat n) | n <= 0    = Nothing
                | otherwise = Just $ Nat $ pred n

-- ** Type 'Nat1'
newtype Nat1 = Nat1 { unNat1 :: Int }
 deriving (Eq,Ord,Hashable)
instance Show Nat1 where
	showsPrec p = showsPrec p . unNat1
instance Default Nat1 where
	def = Nat1 1

succNat1 :: Nat1 -> Nat1
succNat1 (Nat1 n) = Nat1 $ succ n
predNat1 :: Nat1 -> Maybe Nat1
predNat1 (Nat1 n) | n <= 1    = Nothing
                  | otherwise = Just $ Nat1 $ pred n