Prismの再実装中・・・色々整理しないと頭がパーン

gistfile1.hs

{-# LANGUAGE RankNTypes #-}
module Main where
import Unsafe.Coerce
import Control.Applicative
import Control.Category (Category)
import Control.Lens
import Control.Monad.Identity
import Data.Either
import Data.Monoid
import Numeric.Natural

main :: IO ()
main = do
  putStrLn "Hello, World!"

----------
-- Bifunctor

class Bifunctor p where
  bimap :: (a -> b) -> (c -> d) -> p a c -> p b d

  first :: (a -> b) -> p a c -> p b c
  first f = bimap f id
  
  second :: (b -> c) -> p a b -> p a c
  second f = bimap id f

----------
-- Profunctor

infixr 9 #.
infixl 8 .#

class Profunctor f where
  dimap :: (c -> a) -> (b -> d) -> f a b -> f c d

  lmap :: (a -> b) -> f b c -> f a c
  lmap f = dimap f id
  
  rmap :: (b -> c) -> f a b -> f a c
  rmap = dimap id

  (#.) :: (b -> c) -> f a b -> f a c
  (#.) = \f -> \p -> p `seq` rmap f p
  
  (.#) :: f b c -> (a -> b) -> f a c
  (.#) = \p -> p `seq` \f -> lmap f p

instance Profunctor (->) where
  dimap f g h = g . h . f

----------
-- Choice 

class Profunctor f => Choice f where
  left' :: f a b -> f (Either a c) (Either b c)
  right' :: f a b -> f (Either c a) (Either c b)

instance Choice (->) where
  left'  f = lr f id
  right' g = lr id g

lr :: (a -> b) -> (c -> d) -> Either a c -> Either b d
lr f _ (Left x)  = Left  $ f x
lr _ g (Right y) = Right $ g y

----------
-- re function

--type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
type LensLike f s t a b =                    (a -> f b) -> s -> f t
type LensLike' f s a = LensLike f s s a a

type Optic p f s t a b = p a (f b) -> p s (f t)
type Optic' p f s a = Optic p f s s a a
newtype Tagged s b = Tagged { unTagged :: b }
type AReview t b = Optic' Tagged Identity t b

----

class Contravariant f where
  contramap :: (a -> b) -> f b -> f a 

--re :: Contravariant f => AReview t b -> LensLike' f b t
re :: AReview t b -> LensLike' (Accessor r) b t
re p = to (runIdentity #. unTagged #. p .# Tagged .# Identity)

instance Profunctor Tagged where
  dimap _ f = Tagged . f . unTagged

instance Choice Tagged where
  left'  = unsafeCoerce
  right' = Tagged . Right . unTagged

----------
-- Prism

--type Lens s t a b = forall f. Functor f =>                  (->) a (f b) -> (->) s (f t)
type Prism s t a b =  forall p f. (Choice p, Applicative f) => p   a (f b) -> p    s (f t)
type Prism' s a = Prism s s a a

--type Getter s a = forall r. Getting r s a
--type Getting r s a = (a -> Accessor r a) -> s -> Accessor r s

--foldOf :: Getter s a -> s -> a

prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism f g = dimap g (either pure $ fmap f) . right'

----------
-- sample

nat :: Prism' Integer Natural
nat = prism toInteger 
  $ \i -> if i < 0 then Left i else Right (fromInteger i)