1 {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo #-}
2 {-# OPTIONS_GHC -foptimal-applicative-do #-}
3 module Main where
5 import Control.Applicative
6 import Text.PrettyPrint as PP
8 (a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..]
10 -- This one requires -foptimal-applicative-do to find the best solution
11 -- ((a; b) | (c; d)); e
12 test1 :: M ()
13 test1 = do
14 x1 <- a
15 x2 <- const b x1
16 x3 <- c
17 x4 <- const d x3
18 x5 <- const e (x1,x4)
19 return (const () x5)
21 -- (a | c); (b | d); e
22 test2 :: M ()
23 test2 = do
24 x1 <- a
25 x3 <- c
26 x2 <- const b x1
27 x4 <- const d x3
28 x5 <- const e (x1,x4)
29 return (const () x5)
31 main = mapM_ run
32 [ test1
33 , test2
34 ]
36 -- Testing code, prints out the structure of a monad/applicative expression
38 newtype M a = M (Bool -> (Maybe Doc, a))
40 maybeParen True d = parens d
41 maybeParen _ d = d
43 run :: M a -> IO ()
44 run (M m) = print d where (Just d,_) = m False
46 instance Functor M where
47 fmap f m = m >>= return . f
49 instance Applicative M where
50 pure a = M \$ \_ -> (Nothing, a)
51 M f <*> M a = M \$ \p ->
52 let (Just d1, f') = f True
53 (Just d2, a') = a True
54 in
55 (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a')