{-# OPTIONS_GHC -fno-warn-orphans #-}
module Prolog
    (
    -- * Modules
      module Control.Applicative
    , module Control.Monad
    , module Control.Monad.Except
    , module Control.Monad.Identity
    , module Control.Monad.IO.Class
    , module Control.Monad.Reader
    , module Data.Bifunctor
    , module Data.Bifoldable
    , module Data.Bitraversable
    , module Data.Bool
    , module Data.Either
    , module Data.Foldable
    , module Data.Function
    , module Data.Functor
    , module Data.Functor.Contravariant
    , module Data.Maybe
    -- * Types
    , Comonad (..)
    , Binary
    , Generic
    , Generic1
    , Typeable
    , Generically (..)
    , MonadThrow (..)
    , Exception (..)
    , SomeException (..)
    , B.StrictByteString
    , BL.LazyByteString
    , StrictText
    , LazyText
    , Set
    , Map
    -- * Strings
    , IsString (..)
    , StringConv (..)
    , toS
    , toSL
    , convS
    , convSL
    , renderTo
    , fromStringlike
    -- * Utils
    , ffmap
    , (<<$>>)
    , fffmap
    , (<<<$>>>)
    , (<<&>>)
    , (-->)
    , (-/>)
    , (>>=?)
    , foreach
    , liftMaybe
    , squashMaybe
    , throwEither
    , squashEither
    , rebase
    , rebaseWith
    , rebaseWithM
    ) where

import Control.Applicative
import Control.Comonad
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Aeson qualified as A
import Data.Bifunctor
import Data.Bifoldable
import Data.Binary
import Data.Bitraversable
import Data.Bool
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as BL
import Data.Char qualified as C
import Data.Either
import Data.Foldable
import Data.Function
import Data.Functor
import Data.Functor.Contravariant
import Data.List qualified as L
import Data.Map.Strict (Map)
import Data.Maybe
import Data.Set (Set)
import Data.String
import Data.String.Conv
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Time qualified as Time
import Data.Typeable (Typeable)
import GHC.Generics
import Network.URI

import Hakyll qualified as H
import Text.Blaze
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Pretty as BS
import Text.Blaze.Html.Renderer.Text as BT
import Text.Blaze.Html.Renderer.Utf8 as BB
import Text.LaTeX.Base qualified as L
import Text.LaTeX.Base.Syntax qualified as L
import Text.LaTeX.Packages.Hyperref qualified as LH

type StrictText = T.Text
type LazyText = TL.Text

-- | 'fmap' over nested functors
ffmap :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
ffmap = fmap fmap fmap
{-# INLINE ffmap #-}

-- | Infix version of 'ffmap'
(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
infixl 4 <<$>>
(<<$>>) = ffmap
{-# INLINE (<<$>>) #-}

-- | 'fmap' over nested functors
fffmap ::  (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))
fffmap = fmap . fmap . fmap
{-# INLINE fffmap #-}

-- | Infix version of 'fffmap'
(<<<$>>>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))
infixl 4 <<<$>>>
(<<<$>>>) = fffmap
{-# INLINE (<<<$>>>) #-}

(<<&>>) :: (Functor f, Functor g) => f (g a) -> (a -> b) -> f (g b)
infixl 1 <<&>>
(<<&>>) = flip (<<$>>)
{-# INLINE (<<&>>) #-}

foreach :: Functor f => f a -> (a -> b) -> f b
foreach = flip fmap
{-# INLINE foreach #-}


(-->) :: (Monad m, Monoid w) => m Bool -> m w -> m w
infixr 0 -->
b --> a = b >>= bool (pure mempty) a
{-# INLINE (-->) #-}

(-/>) :: (Monad m, Monoid w) => m Bool -> m w -> m w
infixr 0 -/>
(-/>) = (-->) . fmap not
{-# INLINE (-/>) #-}

(>>=?) :: (Monad m, Monoid w) => m (Maybe a) -> (a -> m w) -> m w
infixl 1 >>=?
x >>=? f = x >>= maybe (pure mempty) f
{-# INLINE (>>=?) #-}


liftMaybe :: Alternative m => Maybe a -> m a
liftMaybe = maybe empty pure
{-# INLINE liftMaybe #-}

squashMaybe :: (Alternative m, Monad m) => m (Maybe a) -> m a
squashMaybe = (>>= liftMaybe)
{-# INLINE squashMaybe #-}

throwEither :: (Exception e, MonadThrow m) => Either e a -> m a
throwEither = either throwM pure
{-# INLINE throwEither #-}

squashEither :: (Exception e, MonadThrow m) => m (Either e a) -> m a
squashEither = (>>= throwEither)
{-# INLINE squashEither #-}

renderTo :: (StringConv T.Text s, L.Render r) => r -> s
renderTo = toSL . L.render
{-# INLINE renderTo #-}

fromStringlike :: (IsString s, StringConv t String) => t -> s
fromStringlike = fromString . toSL
{-# INLINE fromStringlike #-}


rebase :: (Applicative m, Comonad w) => w a -> m a
rebase = rebaseWith id
{-# INLINE rebase #-}

rebaseWith :: (Applicative m, Comonad w) => (a -> b) -> w a -> m b
rebaseWith f = rebaseWithM $ pure . f
{-# INLINE rebaseWith #-}

rebaseWithM :: (Comonad w) => (a -> m b) -> w a -> m b
rebaseWithM f = f . extract
{-# INLINE rebaseWithM #-}

-- Orphan instances


instance Binary L.MathType
instance Binary L.Measure
instance Binary L.TeXArg
instance Binary L.LaTeX
instance Binary URIAuth
instance Binary URI

instance H.Writable L.LaTeX where
    write p = L.renderFile p . H.itemBody


instance Contravariant H.Context where
    contramap f (H.Context c) = H.Context $ \x xs -> c x xs . fmap f

instance Comonad H.Item where
    extract = H.itemBody
    duplicate = join (<$)

instance StringConv L.LaTeX T.Text where
    strConv _ = L.render

instance StringConv L.LaTeX TL.Text where
    strConv l = strConv l . L.render

instance StringConv L.LaTeX B.ByteString where
    strConv l = strConv l . L.render

instance StringConv L.LaTeX BL.ByteString where
    strConv l = strConv l . L.render

instance StringConv L.LaTeX String where
    strConv l = strConv l . L.render

instance StringConv Html T.Text where
    strConv l = strConv l . BT.renderHtml

instance StringConv Html TL.Text where
    strConv _ = TL.strip . BT.renderHtml

instance StringConv Html String where
    strConv _ = strip . BS.renderHtml
      where
        strip :: String -> String
        strip = 
          let d = L.dropWhile C.isSpace
           in L.reverse . d . L.reverse . d


instance StringConv Html B.ByteString where
    strConv l = strConv l . BB.renderHtml

instance StringConv Html BL.ByteString where
    strConv _ = BB.renderHtml

instance StringConv URI String where
    strConv _ = show

instance StringConv URI T.Text where
    strConv l = strConv l . show

instance StringConv URI TL.Text where
    strConv l = strConv l . show

instance StringConv URI B.ByteString where
    strConv l = strConv l . show

instance StringConv URI BL.ByteString where
    strConv l = strConv l . show

instance StringConv URI LH.URL where
    strConv _ = fromString . show

instance StringConv String LH.URL where
    strConv _ = fromString

instance StringConv T.Text LH.URL where
    strConv l = fromString . strConv l

instance StringConv TL.Text LH.URL where
    strConv l = fromString . strConv l

instance StringConv B.ByteString LH.URL where
    strConv l = fromString . strConv l

instance StringConv BL.ByteString LH.URL where
    strConv l = fromString . strConv l

instance StringConv LH.URL T.Text where
    strConv _ = L.render

instance StringConv LH.URL TL.Text where
    strConv l = strConv l . L.render

instance StringConv LH.URL String where
    strConv l = strConv l . L.render

instance StringConv LH.URL B.ByteString where
    strConv l = strConv l . L.render

instance StringConv LH.URL BL.ByteString where
    strConv l = strConv l . L.render

instance ToMarkup LH.URL where
    toMarkup = toMarkup . L.render
    preEscapedToMarkup = preEscapedToMarkup . L.render

instance ToValue LH.URL where
    toValue = toValue . L.render
    preEscapedToValue = preEscapedToValue . L.render

instance ToMarkup URI where
    toMarkup = toMarkup . show
    preEscapedToMarkup = preEscapedToMarkup . show

instance ToValue URI where
    toValue = toValue . show
    preEscapedToValue = preEscapedToValue . show

instance MonadThrow H.Compiler where
    throwM = throwError . pure . displayException

-- | Huh, I guess I need a version bump for this guy?
instance A.FromJSON URI where
    parseJSON = A.withText "URI" $ maybe (fail "Invalid URI") pure . parseURI . toSL

deriving instance Generic Time.Day
deriving newtype instance Binary Time.Day