what I wish I could do at work

ugh.hs

{-# LANGUAGE DeriveFunctor, FlexibleInstances, OverlappingInstances #-}
module Main where

-- Standard Library imports

import Control.Applicative (Applicative, (<$>), (<*>), pure, liftA2)
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Free (Free(..), iterM, liftF)

-- The definition of the term server's API
--
--     Get Int (String -> next)
--
-- defines a command called `Get` (to be implemented later) which takes as
-- argument an Int and returns a String. Note that we define it from the Term
-- Server's perspective so the return type is the argument to a "callback"

data TermServerCommF next = Get Int (String -> next)
                          | GetMulti [Int] ([String] -> next)
                          deriving (Functor)
-- technically the "free monad on TermServerCommF", but doesn't really matter
type TermServerComm = Free TermServerCommF

-- boilerplate functions for manipulating lists and then passing the result to
-- callbacks

onlyThen :: Int -> (String -> a) -> [String] -> a
onlyThen i n l = n $ l !! i

dropThen :: Int -> ([String] -> a) -> [String] -> a
dropThen i n l = n $ drop i l

takeThen :: Int -> ([String] -> a) -> [String] -> a
takeThen i n l = n $ take i l

combineGet :: [Int]
           -> ([String] -> TermServerComm (a1 -> a))
           -> ([String] -> TermServerComm a1)
           -> TermServerComm a
combineGet ids f g = Free $ GetMulti ids $ \m -> f m <*> g m

-- This is where we can define the optimizations!

-- Technically we're defining how 

instance Applicative (Free TermServerCommF) where
  pure = Pure

  Pure a <*> Pure b = Pure $ a b
  Pure f <*> Free mb = Free $ fmap f <$> mb
  Free (Get i n) <*> Free (Get i' n') = combineGet s m m'
    where s = [i, i']
          m  = onlyThen 0 n
          m' = onlyThen 1 n'
  Free (Get i n) <*> Free (GetMulti is' n') = combineGet s m m'
    where s = i:is'
          m  = onlyThen 0 n
          m' = dropThen 1 n'
  Free (GetMulti is n) <*> Free (Get i' n') = combineGet s m m'
    where s = i':is
          m  = dropThen 1 n
          m' = onlyThen 0 n'
  Free (GetMulti is n) <*> Free (GetMulti is' n') = combineGet s m m'
    where s = mappend is is'
          m  = takeThen (length is) n
          m' = dropThen (length is) n'
  Free ma <*> b = Free $ (<*> b) <$> ma

-- Convenience functions for Get and GetMulti

get :: Int -> TermServerComm String
get i = liftF $ Get i id

getMulti :: [Int] -> TermServerComm [String]
getMulti ids = liftF $ GetMulti ids id

-- A fake TermServer, which maps integers to terms

termServerLookup :: Int -> String
termServerLookup 1 = "Asthma"
termServerLookup 2 = "Diabetes"
termServerLookup 3 = "Breast Cancer"
termServerLookup 4 = "Hodgkins Lymphoma"
termServerLookup 5 = "Basal Cell Carcinoma"
termServerLookup _ = "Else"

fastTermServerLookup :: [Int] -> [String]
fastTermServerLookup = map termServerLookup

-- This is where we define what `Get` and `GetMulti` means. This is where we
-- could make network calls.

interpret :: TermServerComm a -> [String] -> a
interpret = (iterM run)
  where
    run (GetMulti ids next) =
      next (fastTermServerLookup ids)
    run (Get i next) = do
      next (termServerLookup i)

-------------------------------------------------------------------------------
-- Below here is the tree walking algorithm that converts from a Boolean Tree of
-- ints to a Boolean Tree of strings
--
-- This algorithm is cleanly separated from the details of how to contact the
-- Term Server. In particular, we could choose to implement `TermServerComm` in
-- a silly way by making lots of individual calls instead of making one big call

data BT x = And (BT x) (BT x)
          | Or  (BT x) (BT x)
          | Leaf x
          deriving Show

compile :: BT Int -> TermServerComm (BT String)
compile (And l r) = (And  <$> (compile l) <*> (compile r))
compile (Or l r)  = (Or   <$> (compile l) <*> (compile r))
compile (Leaf i)  = (Leaf <$> (get i))


foo :: BT Int
foo = (And (Or (Leaf 1)
               (And (Leaf 2) (Leaf 3)))
           (Or (And (Leaf 3) (Leaf 5))
               (Leaf 4)))

main :: IO ()
main = do
  putStrLn $ show $ interpret (compile $ foo) []

Prints:

And (Or (Leaf "Asthma") (And (Leaf "Diabetes") (Leaf "Breast Cancer")))
    (Or (And (Leaf "Breast Cancer") (Leaf "Basal Cell Carcinoma")) (Leaf "Hodgkins Lymphoma"))