path: root/src/Prolog.hs

{-# 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.Either
import Data.Foldable
import Data.Function
import Data.Functor
import Data.Functor.Contravariant
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 _ = BT.renderHtml

instance StringConv Html String where
    strConv _ = BS.renderHtml

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