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