An Applicative that records the instructions of underlying computations.

RecordingApplicative.hs

{-# LANGUAGE DeriveFunctor #-}

import Control.Applicative
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.Identity
import Data.Map (Map, (!))
import qualified Data.Map as Map
import Data.List (groupBy, intercalate, nub)
import Data.Function (on)

newtype Payload = Payload String deriving (Eq, Show, Ord)
payload :: Payload -> String
payload (Payload s) = s

newtype Response = Response String deriving (Eq, Show)
response :: Response -> String
response (Response s) = s

payloadA = Payload "A"
payloadB1 = Payload "B.1"
payloadB2 = Payload "B.2"

-- The typeclass based on which we write our domain-specific "scripts".
-- It produces a Tree because we'd like to have a result that mirrors
-- the structure of the Haskell code that describes the computation.
class DSL m where
  upload :: Payload -> m (Tree String)
  finish :: Payload -> m (Tree String)

data Tree a
  = Node a (Tree a) (Tree a)
  | Leaf

showStringTree :: Tree String -> String
showStringTree tree = loop tree 0
  where
    indent level =
      "\n" ++ (concat . take (level * 2) . repeat $ " ")

    loop (Leaf) _ = ""

    loop (Node a Leaf Leaf) level =
      concat [indent level, " - ", a]

    loop (Node a l r) level =
      concat [
        indent level, " - ", a,
        loop l (level + 1),
        loop r (level + 1)
      ]

-- ----------------------------------------------------------------------------
-- Sample "scripts" using the DSL.
--
-- The Applicative constraint allows us to traverse the whole "script" AST,
-- without actually executing it. Monad would be too much of a constraint.
-- ----------------------------------------------------------------------------
computationA :: (Applicative m, DSL m) => m (Tree String)
computationA =
  markCompleted "A" <$> upload payloadA <*> finish payloadA

computationB :: (Applicative m, DSL m) => m (Tree String)
computationB =
  markCompleted "B"
    <$> (markCompleted "B.1" <$> upload payloadB1 <*> finish payloadB1)
    <*> (markCompleted "B.2" <$> upload payloadB2 <*> finish payloadB2)

computationC :: (Applicative m, DSL m) => m (Tree String)
computationC =
  markCompleted "C"
    <$> (markCompleted "C.1" <$> computationA <*> computationB)
    <*> (markCompleted "C.2" <$> computationA <*> computationB)

markCompleted :: String -> Tree String -> Tree String -> Tree String
markCompleted name =
  Node ("computing " ++ name ++ " from: ")

optimizeInstructions :: [Instr] -> [Instr]
optimizeInstructions = nub . filter isUploadInstr

executeInstructions :: [Instr] -> IO (Map Instr Response)
executeInstructions instrs =
  let
    response instr = Response ("response of: " ++ payload (instrPayload instr))
    respondTo instr =
      -- This `return` is supposed to mimic the network access.
      return (instr, response instr)
  in
    fmap Map.fromList (mapM respondTo instrs)

-- We can now use the "scripts" in a recording manner — we first traverse
-- them and log/record all emitted instructions, we obtain that list of
-- instructions from a Writer (which acts as the log implementation), but
-- we also obtain a distributing Reader. This reader expects a result based
-- on the instructions emitted by the writer, which will be available once
-- we optimize and actually execute all logged instructions.
main =
  let
    -- Define a composed applicative computation.
    composed = markCompleted "ALL" <$> computationA <*> computationC

    -- Time to traverse the applicative computation tree, recording the
    -- instructions present in it and building a big reader that will accept
    -- the result of executing the optimized query, which optimized query
    -- will result from processing the logged instructions.
    --
    -- The final reader is called `distribute` because it distributes results
    -- back to the original computations.
    recorded = runRecorder (composed :: Recorder (Tree String))
    (distribute, instructions) = runIdentity . runWriterT $ recorded

    optimized = optimizeInstructions instructions
  in do
    printInstrs "COLLECTED INSTRUCTIONS:" instructions
    printInstrs "OPTIMIZED INSTRUCTIONS:" optimized
    putStrLn "EXECUTING INSTRUCTIONS..."
    executed <- executeInstructions optimized
    printGlobalResult executed

    putStrLn "DISTRIBUTING RESULTS BACK TO COMPUTATIONS...\n"
    let finalResult = runReader distribute (GlobalResult executed)

    putStrLn "FINAL RESULT:"
    putStrLn $ showStringTree finalResult
  where
    printInstrs header instrs = do
      putStrLn header
      printList instrs

    printGlobalResult executed = do
      putStrLn ""
      putStrLn "GLOBAL RESULT:"
      printList (Map.toList executed)

    printList list = do
      putStrLn ""
      putStrLn $ intercalate "\n" (map ((" - " ++) . show) list)
      putStrLn ""

-- ----------------------------------------------------------------------------
-- The Instruction-Recording Interpreter
-- ----------------------------------------------------------------------------

-- First, we need an ADT representing the operations of the DSL.
data Instr
  = Upload Payload
  | Finish Payload
  deriving (Eq, Show, Ord)

instrPayload (Upload a) = a
instrPayload (Finish a) = a

isUploadInstr (Upload _) = True
isUploadInstr (Finish _) = False

-- This is the result of the global computation, i.e., the computation of
-- all the script instructions, merged together and, probably, optimized in
-- some way. It's "global" to denote the global optimizations that we can
-- perform on the DSL "scripts" seen as a whole.
newtype GlobalResult = GlobalResult { result :: Map Instr Response }

-- The datatype backing our smart Applicative and DSL instances.
newtype Recorder a =
  Recorder { runRecorder :: Writer [Instr] (Reader GlobalResult a) }
  deriving Functor

-- This is the tricky part. Our Recorder is a Writer which accumulates
-- instructions and *computes a Reader*, which Reader takes a result and
-- gives it back to the original recorded computation, finally producing
-- the result of the computation.
instance Applicative Recorder where
  -- A pure value is one that doesn't use the global result, nor logs anything.
  pure a = Recorder (writer (reader (\_ -> a), []))

  -- Applying a recorded computation to another recorded computation means
  -- obtaining the final reader of the first computation and applying it to
  -- the final reader of the second computation. The writers are sequenced
  -- using monadic bind.
  (Recorder recordedF) <*> (Recorder recordedA) =
    Recorder (recordedF >>= (\f -> fmap (\a -> f <*> a) recordedA))

instance DSL Recorder where
  -- This is a pretty basic implementation which just logs the instruction
  -- associtated with a DSL operation AND forwards the global result back to
  -- the underlying computations. In a real-world scenario, you'll probably
  -- want to send down just parts of the global result, based on arguments of
  -- the `upload` or `finish` methods, which will be closed over.
  --
  -- For exampe, if `upload` takes a `host` parameter, you'd lookup a value
  -- associated with that host in the global result.
  upload payload =
    Recorder (writer (reader extractResponse, [instr]))
    where
      instr = Upload payload
      extractResponse r = Node ("upload " ++ (response ((result r) ! instr))) Leaf Leaf

  finish payload =
    Recorder (writer (reader extractResponse, [Finish payload]))
    where
      extractResponse r =
        Node ("finish " ++ (response ((result r) ! (Upload payload)))) Leaf Leaf

Execution output:

COLLECTED INSTRUCTIONS:

 - Upload (Payload "A")
 - Finish (Payload "A")
 - Upload (Payload "A")
 - Finish (Payload "A")
 - Upload (Payload "B.1")
 - Finish (Payload "B.1")
 - Upload (Payload "B.2")
 - Finish (Payload "B.2")
 - Upload (Payload "A")
 - Finish (Payload "A")
 - Upload (Payload "B.1")
 - Finish (Payload "B.1")
 - Upload (Payload "B.2")
 - Finish (Payload "B.2")

OPTIMIZED INSTRUCTIONS:

 - Upload (Payload "A")
 - Upload (Payload "B.1")
 - Upload (Payload "B.2")

EXECUTING INSTRUCTIONS...

GLOBAL RESULT:

 - (Upload (Payload "A"),Response "response of: A")
 - (Upload (Payload "B.1"),Response "response of: B.1")
 - (Upload (Payload "B.2"),Response "response of: B.2")

DISTRIBUTING RESULTS BACK TO COMPUTATIONS...

FINAL RESULT:

 - computing ALL from: 
   - computing A from: 
     - upload response of: A
     - finish response of: A
   - computing C from: 
     - computing C.1 from: 
       - computing A from: 
         - upload response of: A
         - finish response of: A
       - computing B from: 
         - computing B.1 from: 
           - upload response of: B.1
           - finish response of: B.1
         - computing B.2 from: 
           - upload response of: B.2
           - finish response of: B.2
     - computing C.2 from: 
       - computing A from: 
         - upload response of: A
         - finish response of: A
       - computing B from: 
         - computing B.1 from: 
           - upload response of: B.1
           - finish response of: B.1
         - computing B.2 from: 
           - upload response of: B.2
           - finish response of: B.2