Experiment - Redefining Functor to work with both curried and uncurried functions

Main.purs

module Main where

import Prelude hiding (pure)

import Data.Function.Uncurried (Fn2, mkFn2, runFn2)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, wrap)
import Effect (Effect)
import Effect.Console (log)
import Prelude as Prelude
import Safe.Coerce (coerce)

import TryPureScript as TryPureScript

{-
## Idea of this experiment

Question:
What if the Monad type class hierarchy was redefined
so as to enable either curried or uncurried functions?

Answer:
- Applicative doesn't play well when we can only define an
  uncurried version or curried version but not both.
  If we define both in the same type class, 
  then everything does continue to work.
- PureScript's inliner for uncurried functions breaks
  when we use code in this way. However,
  if it was updated for this, I believe we'd pay 
  for one less closure allocation for most `bind`s
  and `apply`s in our code
  (note: this is an unverified claim)
-}

{-
class Functor :: (Type -> Type) -> Constraint
class Functor f where
  map :: forall a b. (a -> b) -> f a -> f b

  map :: forall a b. (a -> b) -> (f a -> f b)

  -- Note: pseudo-syntax, backticks don't work at the type-level
  map :: forall a b. (a -> b) `Function` (f a -> f b)

  map :: forall a b. Function (a -> b) (f a -> f b)

-- Hm....
data Function a b :: Type -> Type -> Type

class FunctorIsh :: (Type -> Type -> Type) -> (Type -> Type) -> Constraint
class FunctorIsh function f where
  map :: forall a b. function (a -> b) (f a -> f b)

  -- Note: pseudo-syntax, backticks don't work at the type-level
  map :: forall a b. function (a -> b) ((f a) `Function` (f b))

  map :: forall a b. function (a -> b) (Function (f a) (f b))

  -- Hm... now what do we need to do to get rid of that `Function`
  -- and get something more like this...
  map :: forall a b. function (a -> b) (f a) (f b)
-}

-- | Functor, but where the function used, `fn`, is either
-- | an uncurried function (e.g. `gmap(aToB, fa)`)
-- | or a curried function (e.g. `gmap(aToB)(fa)`).
class GFunctor :: (Type -> Type -> Type -> Type) -> (Type -> Type) -> Constraint
class GFunctor fn f where
  gmap :: forall a b. fn (a -> b) (f a) (f b)

-- Normally, we would write a type alias here.
-- However, the newtype is necessary because defining
-- it as a type alias and then writing
-- `forall a b. GFunctor CurriedFn2 f =>`
-- is rejected by the compiler because
-- "Type synonym `CurriedFn2` is partially applied.
--  Type synonyms must be applied to all of their type arguments."
newtype CurriedFn2 a b c = CurriedFn2 (a -> b -> c)
derive instance Newtype (CurriedFn2 a b c) _

-- Choose your curried/uncurried `map`
--  `c` prefix = curried   function (aka normal     `map`)
-- `uc` prefix = uncurried function (aka performant `map`)
cMap :: forall f a b. GFunctor CurriedFn2 f => (a -> b) -> f a -> f b
cMap = coerce (gmap :: CurriedFn2 (a -> b) (f a) (f b))

ucMap :: forall f a b. GFunctor Fn2 f => Fn2 (a -> b) (f a) (f b)
ucMap = gmap

{-
-- or maybe...?
ucMap :: forall f a b. GFunctor Fn2 f => (a -> b) -> f a -> f b
ucMap = runFn2 gmap
-}

class GApply :: (Type -> Type -> Type -> Type) -> (Type -> Type) -> Constraint
class GFunctor fn f <= GApply fn f where
  gapply :: forall a b. fn (f (a -> b)) (f a) (f b)

cApply :: forall f a b. GApply CurriedFn2 f => f (a -> b) -> f a -> f b
cApply =  coerce (gapply :: CurriedFn2 (f (a -> b)) (f a) (f b))

ucApply :: forall f a b. GApply Fn2 f => Fn2 (f (a -> b)) (f a) (f b)
ucApply = gapply

{-
-- Ugh, Applicative... Why does `pure` take only one argument rather than two!?

-- We can't have a superclass relationship with `Apply fn f`
-- because then the `fn` type variable is unknowable with only
-- the `a` and `f a` types in `gpure`'s type signature:

class GApply fn f <= GApplicative f where ...
  gpure :: forall a. a -> f a

-- Moreover, we don't want to push the `fn` type variable into `GApplicative`
-- because then we need to add a useless arg since the `fn`
-- takes two arguments, not one.
-- This doesn't affect the uncurried function because we can
-- just pass in `Unit`, but it does incur another closure
-- allocation for the curried function.

class GApply fn f <= GApplicative fn f where
  gpure :: forall a. fn Unit a (f a)

  -- uncurried: no issue, just ignore the argument
  gpure :: forall a. Fn2 Unit a (f a) -- `gpure(unit, a)`

  -- curried: unit is a waste!
  gpure :: forall a. Unit -> a -> f a -- `gpure(unit)(a)`
-}

-- So, here's a workaround/hack
-- 1. `fn` not mentioned below but `gpure` is still defined...
class GApplicativeHack f where
  gpure :: forall a. a -> f a

-- 2. Define `Applicative` by extending both `GApply` and `GApplicative'`
class GApplicative :: (Type -> Type -> Type -> Type) -> (Type -> Type) -> Constraint
class (GApply fn f, GApplicativeHack f) <= GApplicative fn f

-- 3. Define a global instance. Any other instance is an orphan instance.
instance (GApply fn f, GApplicativeHack f) => GApplicative fn f

-- Solution:
-- Developer implements a `GApplicativeHack` instance, but uses the
-- `GApplicative` type class for constraints.

-- Moving on to `Bind`!

class GBind :: (Type -> Type -> Type -> Type) -> (Type -> Type) -> Constraint
class GApply fn f <= GBind fn f where
  gbind :: forall a b. fn (f a) (a -> f b) (f b)

cBind :: forall f a b. GBind CurriedFn2 f => f a -> (a -> f b) -> f b
cBind =  coerce (gbind :: CurriedFn2 (f a) (a -> f b) (f b))

ucBind :: forall f a b. GBind Fn2 f => Fn2 (f a) (a -> f b) (f b)
ucBind = gbind

-- And finally `Monad`

class
  ( GApplicative fn f
  , GBind fn f
  ) <= GMonad fn f

-- Let's do an easy type, `Maybe`.

instance GFunctor Fn2 Maybe where
  gmap = mkFn2 \f -> case _ of
    Nothing -> Nothing
    Just a -> Just (f a)

instance GFunctor CurriedFn2 Maybe where
  gmap = wrap Prelude.map

instance GApply Fn2 Maybe where
  gapply = mkFn2 case _, _ of
    Just f, Just a -> Just (f a)
    _, _ -> Nothing

instance GApply CurriedFn2 Maybe where
  gapply = wrap Prelude.apply

instance GApplicativeHack Maybe where
  gpure = Just

instance GBind Fn2 Maybe where
  gbind = mkFn2 \mb f -> case mb of
    Nothing -> Nothing
    Just a -> f a

instance GBind CurriedFn2 Maybe where
  gbind = wrap Prelude.bind

instance GMonad Fn2 Maybe
instance GMonad CurriedFn2 Maybe

-- Alright! Let's test it out and see if it works!
-- Be sure to check out the outputted JavaScript at the end.

main :: Effect Unit
main = TryPureScript.render =<< TryPureScript.withConsole do
  log $ show curriedWorks
  log $ show uncurriedInlinerWorks
  log $ show uncurriedInlinerFails1
  log $ show uncurriedInlinerFails2

  answerLastQuestion

  where
  curriedWorks :: Maybe Int
  curriedWorks = let bind = cBind in do
    a <- Just 1
    b <- Just 2
    c <- Just 3
    gpure (a + b + c)

  uncurriedInlinerWorks :: Maybe Int
  uncurriedInlinerWorks =
    runFn2 ucBind (Just 1) \a ->
      runFn2 ucBind (Just 2) \b ->
        runFn2 ucBind (Just 3) \c ->
          gpure (a + b + c)

  uncurriedInlinerFails1 :: Maybe Int
  uncurriedInlinerFails1 = let bind = runFn2 ucBind in
    bind (Just 1) \a ->
      bind (Just 2) \b ->
        bind (Just 3) \c ->
          gpure (a + b + c)

  uncurriedInlinerFails2 :: Maybe Int
  uncurriedInlinerFails2 = let bind = runFn2 ucBind in do
    a <- Just 1
    b <- Just 2
    c <- Just 3
    gpure (a + b + c)

{-
Last Question:
Is there ever a time where a type CAN implement the curried monad type class hierarchy
  but CANNOT implement the uncurried one? In other words, what if we defined
  both the curried and uncurried versions in the same type class?

  If PureScript had default implementations natively (rather than the 'default' functions
  demonstrated for only `Functor2` below), this would be trivial to support.
-}

class Functor2 f where
  cMap2 :: forall a b. (a -> b) -> f a -> f b

  ucMap2 :: forall a b. Fn2 (a -> b) (f a) (f b)

-- Example of PureScript's current "default" implementations.
-- These either produce a runtime exception or loop forever
-- (I can't recall which) if both are used in the same
-- type class instance. In short, define one of the members
-- and the second one can be implemented using the first.
cMap2Default :: forall f a b. Functor2 f => (a -> b) -> f a -> f b
cMap2Default = runFn2 ucMap2

ucMap2Default :: forall f a b. Functor2 f => Fn2 (a -> b) (f a) (f b)
ucMap2Default = mkFn2 cMap2

{-
-- For example...
instance Functor2 Identity where
  ucMap2 = mkFn2 \f (Identity a) -> Identity (f a)

  cMap2 = cMap2Default
-}

class Functor2 f <= Apply2 f where
  cApply2 :: forall a b. f (a -> b) -> f a -> f b

  ucApply2 :: forall a b. Fn2 (f (a -> b)) (f a) (f b)

-- Hey! We solved the ApplicativeHack issue!
class Apply2 f <= Applicative2 f where
  pure2 :: forall a. a -> f a

class Apply2 f <= Bind2 f where
  cBind2 :: forall a b. f a -> (a -> f b) -> f b

  ucBind2 :: forall a b. Fn2 (f a) (a -> f b) (f b)

class (Applicative2 f, Bind2 f) <= Monad2 f

{-
Now, rather than using the curried version of bind
we could hypothetically used the uncurried version of bind
for our do notations
-}

answerLastQuestion :: Effect Unit
answerLastQuestion = do
  log $ show curriedVsUncurriedBindUsage
  where
  -- Maybe's instances are defined at bottom of this file
  curriedVsUncurriedBindUsage :: Maybe Int
  curriedVsUncurriedBindUsage =
    -- For our main do notation, we use uncurried bind
    -- because the second argument is ALWAYS known
    -- (assuming the inliner was updated to handle this...)
    let bind = runFn2 ucBind2 in do
      a <- Just 1
      b <- Just 2

          -- but for any binds that happen on the right side
          -- of the `<-`, we have the OPTION of using
          -- either one.
      c <- (Just 3) `cBind` \three -> Just (three + 0)
      d <- (Just 0) `runFn2 ucBind2` \zero -> Just (zero + 0)
      pure2 (a + b + c + d)


instance Functor2 Maybe where
  cMap2 = Prelude.map

  ucMap2 = ucMap

instance Apply2 Maybe where
  cApply2 = Prelude.apply

  ucApply2 = ucApply

instance Applicative2 Maybe where
  pure2 = Prelude.pure

instance Bind2 Maybe where
  cBind2 = Prelude.bind

  ucBind2 = ucBind

instance Monad2 Maybe