From d90eaf6f1c8c22afc76c986e56c27588d0f16449 Mon Sep 17 00:00:00 2001
From: Tissevert <tissevert+devel@marvid.fr>
Date: Thu, 27 Feb 2020 17:22:12 +0100
Subject: [PATCH] Add Box instances to allow handling some exceptions in monad
 and converting them to Traversable accessible from the data part of the type

---
 src/PDF/Box.hs | 41 ++++++++++++++++++++++++++++-------------
 1 file changed, 28 insertions(+), 13 deletions(-)

diff --git a/src/PDF/Box.hs b/src/PDF/Box.hs
index 23a711f..39a1548 100644
--- a/src/PDF/Box.hs
+++ b/src/PDF/Box.hs
@@ -3,21 +3,27 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module PDF.Box (
       Box(..)
-    , I(..)
+    , Index(..)
+    , Maybe_(..)
+    , Either_(..)
     , at
     , atAll
     , edit
   ) where
 
+import Control.Monad.Except (ExceptT(..), runExceptT)
 import Control.Monad.Fail (MonadFail(..))
 import Control.Monad.State (MonadState(..))
 import Data.Map (Map)
 import qualified Data.Map as Map (insert, lookup, member)
 import Prelude hiding (fail)
 
-newtype I = I Int
+newtype Index = Index Int
+newtype Maybe_ x = Maybe_ x
+newtype Either_ b x = Either_ x
 
 class Monad m => Box m i a b | m a i -> b where
   r :: i -> a -> m b
@@ -32,17 +38,14 @@ atAll i f = at i $ (mapM f)
 edit :: MonadState a m => (a -> m a) -> m ()
 edit f = get >>= f >>= put
 
-instance MonadFail m => Box m I [a] a where
-  r (I i) = getAt i
-    where
-      getAt _ [] = fail $ "Index out of bounds " ++ show i
-      getAt 0 (x:_) = return x
-      getAt k (_:xs) = getAt (k+1) xs
-  w (I i) newX = setAt i
-    where
-      setAt _ [] = fail $ "Index out of bounds " ++ show i
-      setAt 0 (_:xs) = return (newX:xs)
-      setAt k (x:xs) = (x:)<$>(setAt (k-1) xs)
+instance MonadFail m => Box m Index [a] a where
+  r (Index i) [] = fail $ "Index out of bounds " ++ show i
+  r (Index 0) (x:_) = return x
+  r (Index i) (_:xs) = r (Index (i-1)) xs
+
+  w (Index i) _ [] = fail $ "Index out of bounds " ++ show i
+  w (Index 0) newX (_:xs) = return (newX:xs)
+  w (Index i) newX (x:xs) = (x:) <$> w (Index (i-1)) newX xs
 
 instance (Ord k, MonadFail m) => Box m k (Map k a) a where
   r k = maybe (fail "Unknown key") return . Map.lookup k
@@ -50,3 +53,15 @@ instance (Ord k, MonadFail m) => Box m k (Map k a) a where
     | Map.member k aMap =
         return $ Map.insert k a aMap
     | otherwise = fail "Unknown key"
+
+instance (Monad m, Box Maybe i a b) => Box m (Maybe_ i) a (Maybe b) where
+  r (Maybe_ i) = return . r i
+  w (Maybe_ i) (Just b) a =
+    return . maybe a id $ w i b a
+  w _ _ obj = return obj
+
+instance (Monad m, Box (ExceptT e m) i a b) => Box m (Either_ e i) a (Either e b) where
+  r (Either_ i) a = runExceptT (r i a)
+  w (Either_ i) (Right b) a =
+    either (const a) id <$> runExceptT (w i b a :: ExceptT e m a)
+  w _ _ a = return a