module Data.Yall.Iso (
Iso(..)
, inverseI
, (:<->)
, iso
, ($-), (-$)
, IsoPure(..), ifmap, fromPure
, wordsI, showI, linesI, curryI, enumI, integerI, rationalI, zipI
, incrementI, incrementByI, consI
, distributeI, factorI
, (:<~>)
) where
import Prelude hiding ((.),id)
import Control.Category
import Data.Functor.Identity
import Control.Monad
import qualified Control.Categorical.Functor as C
import Control.Categorical.Bifunctor
import Control.Category.Associative
import Control.Category.Braided
import Control.Category.Monoidal
import Control.Category.Distributive
data Iso w m a b = Iso { apply :: a -> m b
, unapply :: b -> w a }
instance (Monad m, Monad w)=> Category (Iso w m) where
id = iso id id
g . f = Iso (apply f >=> apply g) (unapply g >=> unapply f)
newtype IsoPure a b = IsoPure { isoPure :: Iso Identity Identity a b }
deriving (Category)
pureWrapped :: (Iso Identity Identity a1 b1 -> Iso Identity Identity a b)
-> IsoPure a1 b1
-> IsoPure a b
pureWrapped2 :: (Iso Identity Identity a1 b1
-> Iso Identity Identity a2 b2
-> Iso Identity Identity a b)
-> IsoPure a1 b1
-> IsoPure a2 b2
-> IsoPure a b
pureWrapped2 f a b = IsoPure $ f (isoPure a) (isoPure b)
pureWrapped f = IsoPure . f . isoPure
instance PFunctor (,) IsoPure IsoPure where
first = pureWrapped first
instance QFunctor (,) IsoPure IsoPure where
second = pureWrapped second
instance Bifunctor (,) IsoPure IsoPure IsoPure where
bimap = pureWrapped2 bimap
instance PFunctor Either IsoPure IsoPure where
first = pureWrapped first
instance QFunctor Either IsoPure IsoPure where
second = pureWrapped second
instance Bifunctor Either IsoPure IsoPure IsoPure where
bimap = pureWrapped2 bimap
instance Associative IsoPure (,) where
associate = IsoPure associate
disassociate = IsoPure disassociate
instance Associative IsoPure Either where
associate = IsoPure associate
disassociate = IsoPure disassociate
instance Braided IsoPure (,) where
braid = IsoPure braid
instance Braided IsoPure Either where
braid = IsoPure braid
instance Symmetric IsoPure Either where
instance Symmetric IsoPure (,) where
instance Monoidal IsoPure (,) where
type Id IsoPure (,) = ()
idl = IsoPure idl
idr = IsoPure idr
coidl = IsoPure coidl
coidr = IsoPure coidr
ifmap :: (Monad w, Monad m, C.Functor f IsoPure IsoPure)=> Iso Identity Identity a b -> Iso w m (f a) (f b)
ifmap = fromPure . C.fmap . IsoPure
fromPure :: (Monad w, Monad m)=> IsoPure a b -> Iso w m a b
fromPure (IsoPure (Iso f g)) = iso (fmap runIdentity f) (fmap runIdentity g)
instance (Functor f)=> C.Functor f IsoPure IsoPure where
fmap (IsoPure (Iso f g)) =
IsoPure $ iso (fmap $ fmap runIdentity f) (fmap $ fmap runIdentity g)
instance (Monad m)=> C.Functor m (Iso m m) (Iso Identity Identity) where
fmap (Iso f g) = iso (>>= f) (>>= g)
instance (Monad m, Monad w)=> PFunctor (,) (Iso w m) (Iso w m) where
first f = bimap f id
instance (Monad m, Monad w)=> QFunctor (,) (Iso w m) (Iso w m) where
second = bimap id
instance (Monad m, Monad w)=> Bifunctor (,) (Iso w m) (Iso w m) (Iso w m) where
bimap (Iso f g) (Iso f' g') = Iso (bimapM f f') (bimapM' g g')
where bimapM x = fmap extractJoinT . bimap x
bimapM' x = fmap extractJoinT . bimap x
instance (Monad m, Monad w)=> PFunctor Either (Iso w m) (Iso w m) where
first f = bimap f id
instance (Monad m, Monad w)=> QFunctor Either (Iso w m) (Iso w m) where
second = bimap id
instance (Monad m, Monad w)=> Bifunctor Either (Iso w m) (Iso w m) (Iso w m) where
bimap (Iso f g) (Iso f' g') = Iso (bimapM f f') (bimapM' g g')
where bimapM x = fmap extractJoinE . bimap x
bimapM' x = fmap extractJoinE . bimap x
extractJoinE :: (Monad m)=> Either (m a) (m b) -> m (Either a b)
extractJoinE = either (liftM Left) (liftM Right)
extractJoinT :: (Monad m)=> (m a, m b) -> m (a,b)
extractJoinT = uncurry $ liftM2 (,)
instance (Monad m, Monad w)=> Associative (Iso w m) (,) where
associate = iso associate disassociate
disassociate = iso disassociate associate
instance (Monad m, Monad w)=> Associative (Iso w m) Either where
associate = iso associate disassociate
disassociate = iso disassociate associate
instance (Monad m, Monad w)=> Braided (Iso w m) (,) where
braid = iso braid braid
instance (Monad m, Monad w)=> Braided (Iso w m) Either where
braid = iso braid braid
instance (Monad m, Monad w)=> Symmetric (Iso w m) (,) where
instance (Monad m, Monad w)=> Symmetric (Iso w m) Either where
distributeI :: (Monad m, Monad w)=> Iso w m (a, Either b c) (Either (a,b) (a,c))
distributeI = iso distribute factor
factorI :: (Monad m, Monad w)=> Iso w m (Either (a,b) (a,c)) (a, Either b c)
factorI = iso factor distribute
instance (Monad m, Monad w)=> Monoidal (Iso w m) (,) where
type Id (Iso w m) (,) = ()
idl = iso idl coidl
idr = iso idr coidr
coidl = iso coidl idl
coidr = iso coidr idr
inverseI :: (Monad m, Monad w)=> Iso w m a b -> Iso m w b a
inverseI (Iso f g) = Iso g f
type a :<~> b = Iso Maybe Maybe a b
type a :<-> b = Iso Identity Identity a b
iso :: (Monad m, Monad w)=> (a -> b) -> (b -> a) -> Iso w m a b
iso f g = Iso (fmap return f) (fmap return g)
($-) :: (a :<-> b) -> a -> b
i $- a = runIdentity $ apply i a
(-$) :: (a :<-> b) -> b -> a
i -$ b = runIdentity $ unapply i b
wordsI :: (Monad m, Monad w)=> Iso w m String [String]
wordsI = iso words unwords
linesI :: (Monad m, Monad w)=> Iso w m String [String]
linesI = iso lines unlines
showI :: (Read s, Show s, Monad w, Monad m)=> Iso w m s String
showI = iso show read
curryI :: (Monad m, Monad w)=> Iso w m ((a,b) -> c) (a -> b -> c)
curryI = iso curry uncurry
enumI :: (Enum a, Monad m, Monad w)=> Iso w m Int a
enumI = iso toEnum fromEnum
integerI :: (Integral a, Monad m, Monad w)=> Iso w m a Integer
integerI = iso toInteger fromInteger
rationalI :: (Real a, Fractional a, Monad m, Monad w)=> Iso w m a Rational
rationalI = iso toRational fromRational
zipI :: (Monad m, Monad w)=> Iso w m ([a],[b]) [(a,b)]
zipI = iso (uncurry zip) unzip
incrementI :: (Monad m, Monad w, Num a)=> Iso w m a a
incrementI = incrementByI 1
incrementByI :: (Monad m, Monad w, Num a)=> a -> Iso w m a a
incrementByI n = iso (+n) (subtract n)
consI :: (Monad m, Monad w)=> Iso w m (a,[a]) [a]
consI = Iso (\(a,as)-> return (a:as)) unconsI
where unconsI [] = fail "empty list"
unconsI (a:as) = return (a,as)