Merge branch 'master' into atomics
[ghc.git] / testsuite / tests / simplCore / should_compile / T3831.hs
1 {-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}
2
3 -- This test has a deep nest of join points, which led to
4 -- an exponential blow-up in SpecConstr
5
6 module T3831(setAttributes) where
7
8 import Data.Monoid
9 import Control.Monad
10
11 class (Monoid s, OutputCap s) => TermStr s
12
13 class OutputCap f where
14 outputCap :: ([Int] -> String) -> [Int] -> f
15 outputCap = error "urk"
16
17 instance OutputCap [Char] where
18 instance (Enum p, OutputCap f) => OutputCap (p -> f) where
19
20 instance MonadPlus Capability where
21 mzero = Capability (const $ return Nothing)
22 Capability f `mplus` Capability g = Capability $ \t -> do
23 mx <- f t
24 case mx of
25 Nothing -> g t
26 _ -> return mx
27
28 instance Monad Capability where
29 return = Capability . const . return . Just
30 Capability f >>= g = Capability $ \t -> do
31 mx <- f t
32 case mx of
33 Nothing -> return Nothing
34 Just x -> let Capability g' = g x in g' t
35
36 newtype Capability a = Capability (() -> IO (Maybe a))
37
38 tiGetOutput1 :: forall f . OutputCap f => String -> Capability f
39 {-# NOINLINE tiGetOutput1 #-}
40 tiGetOutput1 _ = return (outputCap (const "") [])
41
42 enterStandoutMode :: TermStr s => Capability s
43 enterStandoutMode = tiGetOutput1 "smso"
44
45 enterUnderlineMode :: TermStr s => Capability s
46 enterUnderlineMode = tiGetOutput1 "smul"
47
48 reverseOn :: TermStr s => Capability s
49 reverseOn = tiGetOutput1 "rev"
50
51 blinkOn:: TermStr s => Capability s
52 blinkOn = tiGetOutput1 "blink"
53
54 boldOn :: TermStr s => Capability s
55 boldOn = tiGetOutput1 "bold"
56
57 dimOn :: TermStr s => Capability s
58 dimOn = tiGetOutput1 "dim"
59
60 invisibleOn :: TermStr s => Capability s
61 invisibleOn = tiGetOutput1 "invis"
62
63 protectedOn :: TermStr s => Capability s
64 protectedOn = tiGetOutput1 "prot"
65
66 data Attributes = Attributes {
67 standoutAttr,
68 underlineAttr,
69 reverseAttr,
70 blinkAttr,
71 dimAttr,
72 boldAttr,
73 invisibleAttr,
74 protectedAttr :: Bool
75 }
76
77 setAttributes :: TermStr s => Capability (Attributes -> s)
78 setAttributes = usingSGR0 `mplus` manualSets
79 where
80 usingSGR0 = do
81 sgr <- tiGetOutput1 "sgr"
82 return $ \a -> let mkAttr f = if f a then 1 else 0 :: Int
83 in sgr (mkAttr standoutAttr)
84 (mkAttr underlineAttr)
85 (mkAttr reverseAttr)
86 (mkAttr blinkAttr)
87 (mkAttr dimAttr)
88 (mkAttr boldAttr)
89 (mkAttr invisibleAttr)
90 (mkAttr protectedAttr)
91 (0::Int)
92 attrCap :: TermStr s => (Attributes -> Bool) -> Capability s
93 -> Capability (Attributes -> s)
94 attrCap f cap = do {to <- cap; return $ \a -> if f a then to else mempty}
95 `mplus` return (const mempty)
96 manualSets = do
97 cs <- sequence [attrCap standoutAttr enterStandoutMode
98 , attrCap underlineAttr enterUnderlineMode
99 , attrCap reverseAttr reverseOn
100 , attrCap blinkAttr blinkOn
101 , attrCap boldAttr boldOn
102 , attrCap dimAttr dimOn
103 , attrCap invisibleAttr invisibleOn
104 , attrCap protectedAttr protectedOn
105 ]
106 return $ \a -> mconcat $ map ($ a) cs
107