{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo #-}
{-# OPTIONS_GHC -foptimal-applicative-do #-}
module Main where

import Control.Applicative
import Text.PrettyPrint as PP

(a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..]

-- This one requires -foptimal-applicative-do to find the best solution
-- ((a; b) | (c; d)); e
test1 :: M ()
test1 = do
  x1 <- a
  x2 <- const b x1
  x3 <- c
  x4 <- const d x3
  x5 <- const e (x1,x4)
  return (const () x5)

-- (a | c); (b | d); e
test2 :: M ()
test2 = do
  x1 <- a
  x3 <- c
  x2 <- const b x1
  x4 <- const d x3
  x5 <- const e (x1,x4)
  return (const () x5)

main = mapM_ run
 [ test1
 , test2
 ]

-- Testing code, prints out the structure of a monad/applicative expression

newtype M a = M (Bool -> (Maybe Doc, a))

maybeParen True d = parens d
maybeParen _ d = d

run :: M a -> IO ()
run (M m) = print d where (Just d,_) = m False

instance Functor M where
  fmap f m = m >>= return . f

instance Applicative M where
  pure a = M $ \_ -> (Nothing, a)
  M f <*> M a = M $ \p ->
    let (Just d1, f') = f True
        (Just d2, a') = a True
    in
        (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a')

instance Monad M where
  return = pure
  M m >>= k = M $ \p ->
    let (d1, a) = m True
        (d2, b) = case k a of M f -> f True
    in
    case (d1,d2) of
      (Nothing,Nothing) -> (Nothing, b)
      (Just d, Nothing) -> (Just d, b)
      (Nothing, Just d) -> (Just d, b)
      (Just d1, Just d2) -> (Just (maybeParen p (d1 PP.<> semi <+> d2)), b)

doc :: String -> M ()
doc d = M $ \_ -> (Just (text d), ())