module Data.Iso.Core (
Iso(..), convert, inverse, many,
(:-)(..), stack, unstack, swap, duck,
lit, inverseLit, matchWithDefault, ignoreWithDefault
) where
import Prelude hiding (id, (.), head)
import Data.Monoid
import Data.Semigroup
import Control.Applicative hiding (many)
import Control.Monad
import Control.Category
data Iso a b = Iso (a -> Maybe b) (b -> Maybe a)
instance Category Iso where
id = Iso Just Just
~(Iso f1 g1) . ~(Iso f2 g2) = Iso (f1 <=< f2) (g1 >=> g2)
instance Monoid (Iso a b) where
mempty = Iso (const Nothing) (const Nothing)
~(Iso f1 g1) `mappend` ~(Iso f2 g2) =
Iso
((<|>) <$> f1 <*> f2)
((<|>) <$> g1 <*> g2)
instance Semigroup (Iso a b) where
(<>) = mappend
convert :: Iso a b -> a -> Maybe b
convert (Iso f _) = f
inverse :: Iso a b -> Iso b a
inverse (Iso f g) = Iso g f
many :: Iso a a -> Iso a a
many (Iso f g) = Iso manyF manyG
where
manyF = ((<|>) <$> (f >=> manyF) <*> Just)
manyG = ((<|>) <$> (g >=> manyG) <*> Just)
data h :- t = h :- t
deriving (Eq, Show)
infixr 5 :-
head :: (h :- t) -> h
head (h :- _) = h
stack :: Iso a b -> Iso (a :- t) (b :- t)
stack (Iso f g) = Iso (lift f) (lift g)
where
lift k (x :- t) = (:- t) <$> k x
unstack :: Iso (a :- ()) (b :- ()) -> Iso a b
unstack (Iso f g) = Iso (lift f) (lift g)
where
lift k = fmap head . k . (:- ())
swap :: Iso (a :- b :- t) (b :- a :- t)
swap = Iso f f
where
f (x :- y :- t) = Just (y :- x :- t)
duck :: Iso t1 t2 -> Iso (h :- t1) (h :- t2)
duck (Iso f g) = Iso (lift f) (lift g)
where
lift k (h :- t) = (h :-) <$> k t
lit :: Eq a => a -> Iso t (a :- t)
lit x = Iso f g
where
f t = Just (x :- t)
g (x' :- t) = do
guard (x' == x)
Just t
inverseLit :: Eq a => a -> Iso (a :- t) t
inverseLit = inverse . lit
matchWithDefault :: (a -> Bool) -> a -> Iso t (a :- t)
matchWithDefault p x = Iso f g
where
f t = Just (x :- t)
g (x' :- t) = do
guard (p x')
return t
ignoreWithDefault :: a -> Iso t (a :- t)
ignoreWithDefault = matchWithDefault (const True)