A category of type morphisms (functors, monads, etc.)

TypeMorphMorph.hs

{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

import           Prelude hiding (id, (.))

import           Control.Category
import           Control.Monad.Except
import           Control.Monad.Trans.Maybe
import           Data.Aeson
import           Data.ByteString.Char8 as BS
import           Data.Maybe
import           Data.Yaml as Yaml

newtype TypeMorphMorph f g = TypeMorphMorph (forall x . f x -> g x)

runTypeMorphMorph :: TypeMorphMorph f g -> f x -> g x
runTypeMorphMorph (TypeMorphMorph f) = f

-- | Category of type morphisms is defined by a type morphism morphism.
instance Category TypeMorphMorph where
    id = TypeMorphMorph id
    TypeMorphMorph bc . TypeMorphMorph ab = TypeMorphMorph (bc . ab)

main :: IO ()
main =
    yprint
        ( runTypeMorphMorph (right . just) [1 :: Int]
        , runTypeMorphMorph (just . right) [2 :: Int]
        , runTypeMorphMorph (maybeToList' . listToMaybe') [3 :: Int]
        , runTypeMorphMorph (listToMaybe' . maybeToList') $ Just (3 :: Int)
        )

listToMaybe' :: TypeMorphMorph [] Maybe
listToMaybe' = TypeMorphMorph listToMaybe

maybeToList' :: TypeMorphMorph Maybe []
maybeToList' = TypeMorphMorph maybeToList

just :: Functor f => TypeMorphMorph f (MaybeT f)
just = TypeMorphMorph (MaybeT . fmap Just)

right :: Functor f => TypeMorphMorph f (ExceptT () f)
right = TypeMorphMorph (ExceptT . fmap Right)

--------------------------------------------------------------------------------

yprint :: ToJSON a => a -> IO ()
yprint = BS.putStrLn . Yaml.encode

instance ToJSON1 m => ToJSON1 (MaybeT m) where
    liftToJSON tj tjl (MaybeT m) = object
        ["MaybeT" .= liftToJSON (liftToJSON tj tjl) (liftToJSONList tj tjl) m]
    liftToEncoding = undefined

instance (ToJSON e, ToJSON1 m) => ToJSON1 (ExceptT e m) where
    liftToJSON tj tjl (ExceptT m) = object
        ["ExceptT" .= liftToJSON (liftToJSON tj tjl) (liftToJSONList tj tjl) m]
    liftToEncoding = undefined

instance (ToJSON1 m, ToJSON a) => ToJSON (MaybeT m a) where
    toJSON = liftToJSON toJSON toJSONList

instance (ToJSON1 m, ToJSON e, ToJSON a) => ToJSON (ExceptT e m a) where
    toJSON = liftToJSON toJSON toJSONList