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