Task.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}

module Task where

import Prelude hiding (id, (.))

import Control.Applicative
import Control.Category
import Control.Arrow

-- classification of computation is done by a sanity check on which type of analysis is possible
-- Monad = running the task
-- Applicative = calculate all dependencies upfront
-- Arrow = calculate the amount of operations
-- (Arrow)Choice = give all possible dependencies
-- Static/Dynamic = retrieve all static information upfront

-------------------------------------
-- Original Task
-------------------------------------

type Task c k v = forall f. c f => (k -> f v) -> f v

-- Monad Task

testTM :: Task Monad String Integer
testTM = \fetch -> do
  c1 <- fetch "C1"
  if c1 == 1
    then fetch "A1"
    else fetch "A2"

runTestTM = testTM
  (\cell -> do print ("cell: " ++ cell); readLn)

-- Applicative Task

testTI :: Task Applicative String Integer
testTI = \fetch -> do
  a1 <- fetch "A1"
  a2 <- fetch "A2"
  return $ a1 + a2

depTestTI = getConst $ testTI
  (\cell -> Const [cell])

runTestTI = testTI
  (\cell -> do print ("cell: " ++ cell); readLn)

-------------------------------------
-- Generalization 1
-------------------------------------

type Task1 c i o = forall p. c p => p i o -> p () o

-- Arrow Task1

testA1 :: Task1 Arrow String Integer
testA1 = \fetch -> proc () -> do
  c1 <- fetch -< "C1"
  ax <- fetch -< "A" ++ show c1
  returnA -< ax

tickTestA1 = unConstArr $ testA1
  (ConstArr [1 :: Int])

-------------------------------------
-- Generalization 2
-------------------------------------

type Task2 c i o = forall p. c p => (i -> p () o) -> p () o

-- Applicative Task2

testI2 :: Task2 Arrow String Integer
testI2 = \fetch -> proc () -> do
  a1 <- fetch "A1" -< ()
  a2 <- fetch "A2" -< ()
  returnA -< (a1 + a2)

depTestI2 = unConstArr $ testI2
  (\cell -> ConstArr [cell])

-------------------------------------
-- Generalization 3
-------------------------------------

type Task3 c i o = forall p. c p => p () (i -> o) -> p () o

-- Arrow Task3

testA3 :: Task3 Arrow String Integer
testA3 = \fetch -> proc () -> do
  c1 <- fetch -< ()
  ax <- fetch -< ()
  returnA -< ax ("A" ++ show (c1 "C1"))

tickTestA3 = unConstArr $ testA3
  (ConstArr [1 :: Int])

-------------------------------------
-- Combination 1 and 2
-------------------------------------

type Task12 c si di o = forall p. c p => (si -> p di o) -> p () o

-- Applicative = Arrow Constraint, Only Static Input

testI12 :: Task12 Arrow String () Integer
testI12 = \fetch -> proc () -> do
  a1 <- fetch "A1" -< ()
  a2 <- fetch "A2" -< ()
  returnA -< a1 + a2

depTestI12 = unConstArr $ testI12
  (\cell -> ConstArr [cell])

runTestI12 = runKleisli_ $ testI12
  (\cell -> Kleisli (\_ -> do print ("cell: " ++ cell); readLn))

-- Arrow = Arrow Constraint, Only Dynamic Input

testA12 :: Task12 Arrow () String Integer
testA12 = \fetch -> proc () -> do
  c1 <- fetch () -< "C1"
  fetch () -< "A" ++ show c1

tickTestA12 = unConstArr $ testA12
  (\_ -> ConstArr [1])

runTestA12 = runKleisli_ $ testA12
  (toDynamic (\cell -> Kleisli (\_ -> do print ("cell: " ++ cell); readLn)))

toDynamic :: (si -> Kleisli f () o) -> () -> Kleisli f si o
toDynamic f _ = Kleisli (\si -> runKleisli (f si) ())

-- Mix Static and Dynamic Input

testSD12 :: Task12 Arrow String String Integer
testSD12 = \fetch -> proc () -> do
  c1 <- fetch "C" -< "1"
  fetch "A" -< show c1

-- calculate all columns, which is static information
depTestSD12 = unConstArr $ testSD12
  (\col -> ConstArr [col])

runTestSD12 = runKleisli_ $ testSD12
  (\col -> Kleisli (\row -> do print ("cell: " ++ col ++ row); readLn))

-- ArrowChoice

testC12_1 :: Task12 ArrowChoice String () Integer
testC12_1 = \fetch -> proc () -> do
  c1 <- fetch "C1" -< ()
  if c1 == 1
    then fetch "A1" -< ()
    else fetch "A2" -< ()

-- overestimation of dependencies
apprDepTestC12_1 = unConstArr $ testC12_1
  (\cell -> ConstArr [cell])

testC12_2 :: Task12 ArrowChoice () String Integer
testC12_2 = \fetch -> proc () -> do
  c1 <- fetch () -< "C1"
  if c1 == 1
    then fetch () -< "A" ++ show c1
    else fetch () -< "Z" ++ show c1

tickTestC12_2 = unMaxConstArr $ testC12_2
  (\_ -> MaxConstArr [1])

--

runKleisli_ e = runKleisli e ()

-- ConstArr

newtype ConstArr c i o = ConstArr { unConstArr :: c }

instance (Monoid c) => Category (ConstArr c) where
  id = ConstArr mempty
  (ConstArr a) . (ConstArr b) = ConstArr (a `mappend` b)

instance (Monoid c) => Arrow (ConstArr c) where
  arr f = ConstArr mempty
  first (ConstArr c) = ConstArr c

instance (Monoid c) => ArrowChoice (ConstArr c) where
  left (ConstArr c) = ConstArr c

-- MaxConstArr

newtype MaxConstArr c i o = MaxConstArr { unMaxConstArr :: c }

instance (Monoid c) => Category (MaxConstArr c) where
  id = MaxConstArr mempty
  (MaxConstArr a) . (MaxConstArr b) = MaxConstArr (a `mappend` b)

instance (Monoid c) => Arrow (MaxConstArr c) where
  arr f = MaxConstArr mempty
  first (MaxConstArr c) = MaxConstArr c

instance (Ord c, Monoid c) => ArrowChoice (MaxConstArr c) where
  (MaxConstArr c1) +++ (MaxConstArr c2) = MaxConstArr (max c1 c2)