1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
|
{-# 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), ())
|
