ft-compose.purs

module Main where

import Prelude

import Control.Apply ((*>))
import Data.Either (Either(..), either)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Console (log, error, CONSOLE())
import Unsafe.Coerce (unsafeCoerce)
import Text.Chalk

class (Monad m) <= DSL m where
  command :: String -> m Unit
  sample :: m String

newtype Logger e a = Logger (Eff e a)
runLogger :: forall e a. Logger e a -> Eff e a
runLogger (Logger ea) = ea

instance functorLogger :: Functor (Logger e) where
  map fn (Logger ea) = Logger $ map fn ea

instance applyLogger :: Apply (Logger e) where
  apply (Logger fn) (Logger ea) = Logger $ apply fn ea

instance applicativeLogger :: Applicative (Logger e) where
  pure a = Logger $ pure a

instance bindLogger :: Bind (Logger e) where
  bind (Logger ea) mfn = Logger $ ea >>= mfn >>> runLogger

instance monadLogger :: Monad (Logger e)

instance dslLogger :: DSL (Logger e) where
  command = unsafeCoerce <<< log <<< green
  sample = Logger $ pure "Logger"

newtype Errorer e a = Errorer (Eff e a)
runErrorer :: forall e a. Errorer e a -> Eff e a
runErrorer (Errorer ea) = ea

instance functorErrorer :: Functor (Errorer e) where
  map fn (Errorer ea) = Errorer $ map fn ea

instance applyErrorer :: Apply (Errorer e) where
  apply (Errorer fn) (Errorer ea) = Errorer $ apply fn ea

instance applicativeErrorer :: Applicative (Errorer e) where
  pure a = Errorer $ pure a

instance bindErrorer :: Bind (Errorer e) where
  bind (Errorer ea) mfn = Errorer $ ea >>= mfn >>> runErrorer

instance monadErrorer :: Monad (Errorer e)

instance dslErrorer :: DSL (Errorer e) where
  command = unsafeCoerce <<< error <<< red
  sample = pure "Errorer"

newtype Both e a = Both (Eff e a)
runBoth :: forall e a. Both e a -> Eff e a
runBoth (Both ea) = ea

toLogger :: forall e a. Both e a -> Logger e a
toLogger = unsafeCoerce

toErrorer :: forall e a. Both e a -> Errorer e a
toErrorer = unsafeCoerce

instance functorBoth :: Functor (Both e) where
  map fn (Both ea) = Both $ map fn ea

instance applyBoth :: Apply (Both e) where
  apply (Both fn) (Both ea) = Both $ apply fn ea

instance applicativeBoth :: Applicative (Both e) where
  pure a = Both $ pure a

instance bindBoth :: Bind (Both e) where
  bind (Both ea) mfn = Both $ ea >>= mfn >>> runBoth

instance monadBoth :: Monad (Both e)

instance dslBoth :: DSL (Both e) where
  command s = Both do
    runLogger $ command s
    runErrorer $ command s
  sample = pure "Both"


-- The question is: What do we want to combine in dsls?
-- And probably : How do we want to combine them?

{-
If we have 2 dsls implemented as typeclasses. Then we in fact
have all superclass constraints. And we must decide how all these
constraints shall be combined in composed dsl. I.e. if we want
values from first dsl be processed by functions only from first dsl
then we have one approach. If we want values from both dsls be processed
by both dsl functions then we have other approach.
-}


data Weaver f g a = Weaver (f a) (g a)

--type WBoth e a = Weaver (Logger e a) (Errorer e a)

instance functorWeaver :: (Functor f, Functor g) => Functor (Weaver f g) where
  map fn (Weaver fa ga) = Weaver (map fn fa) (map fn ga)

instance applyWeaver :: (Apply f, Apply g) => Apply (Weaver f g) where
  apply (Weaver ffn gfn) (Weaver fa ga) = Weaver (ffn <*> fa) (gfn <*> ga)

instance applicativeWeaver :: (Applicative f, Applicative g) => Applicative (Weaver f g) where
  pure a = Weaver (pure a) (pure a)

instance bindWeaver :: (Bind f, Bind g) => Bind (Weaver f g) where
  bind (Weaver fa ga) mfn = Weaver (fa >>= mfn >>> (\(Weaver fb _) -> fb)) (ga >>= mfn >>> (\(Weaver _ gb) -> gb))

instance monadWeaver :: (Monad f, Monad g) => Monad (Weaver f g)

instance dslWeaver :: (DSL f, DSL g) => DSL (Weaver f g) where
  command s = Weaver (command s) (command s)
  sample = Weaver sample sample

type WBoth e a = Weaver (Logger e) (Errorer e) a
runWBoth :: forall e a. WBoth e a -> Eff e a
runWBoth (Weaver l e) = do
  runLogger l
  runErrorer e




main :: Eff _ Unit
main = runWBoth do
  o <- sample
  command o
  q <- pure "Foo"
  command q