A lot of work on aliases and the like

1 files changed, 57 insertions, 0 deletions

diff --git a/src/Prolog.hs b/src/Prolog.hs
index df4a772..145f2d3 100644
--- a/src/Prolog.hs
+++ b/src/Prolog.hs
@@ -52,6 +52,8 @@ module Prolog
     , foreach
     , liftMaybe
     , squashMaybe
+    , throwEither
+    , squashEither
     ) where
 
 import Control.Applicative
@@ -62,6 +64,7 @@ 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
@@ -92,6 +95,7 @@ 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
@@ -140,6 +144,14 @@ 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 #-}
@@ -214,6 +226,47 @@ instance StringConv URI B.ByteString where
 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
@@ -224,3 +277,7 @@ instance ToValue URI where
 
 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