Monadicity Polymorphism

Nonad.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

import Data.Functor.Identity
import Prelude hiding (Functor(..), Applicative(..), Monad(..), map)
import qualified Prelude as P

type family f $ a = r where
  Identity $ a = a
  f $ a = f a

class Functor (f :: * -> *) where
  fmap :: (a -> b) -> f $ a -> f $ b

class Functor f => Applicative f where
  pure :: a -> f $ a
  (<*>) :: f $ (a -> b) -> f $ a -> f $ b

class Applicative f => Monad f where
  (>>=) :: f $ a -> (a -> f $ b) -> f $ b

instance Functor Identity where
  fmap f x = f x

instance Functor Maybe where
  fmap _ Nothing = Nothing
  fmap f (Just x) = Just (f x)

instance Functor IO where
  fmap = P.fmap

instance Applicative Identity where
  pure x = x
  f <*> x = f x

instance Applicative Maybe where
  pure x = Just x
  Nothing <*> x = Nothing
  _ <*> Nothing = Nothing
  Just f <*> Just x = Just (f x)

instance Applicative IO where
  pure = P.pure
  (<*>) = (P.<*>)

instance Monad Identity where
  x >>= f = f x

instance Monad Maybe where
  Nothing >>= _ = Nothing
  Just x >>= f = f x

instance Monad IO where
  (>>=) = (P.>>=)

map :: forall m a b. Monad m => (a -> m $ b) -> [a] -> m $ [b]
map f = go
  where
    go [] = pure @m ([] :: [b])
    go (x : xs) = (>>=) @m @b @[b] (f x)
      $ \ y -> (>>=) @m @[b] @[b] (go xs)
      $ \ ys -> pure @m (y : ys)

main :: IO ()
main = do
  print $ map @Identity (+ 1) [1, 2, 3]
  print $ map @Maybe (\ x -> if odd x then Nothing else Just x) [1, 2, 3]
  print $ map @Maybe (\ x -> if odd x then Just (x * 2) else Just x) [1, 2, 3]
  _ <- map @IO putStrLn ["one", "two", "three"]
  pure @IO ()