diff options
| -rw-r--r-- | testsuite/tests/ghc-regress/simplCore/should_compile/T3831.hs | 107 | ||||
| -rw-r--r-- | testsuite/tests/ghc-regress/simplCore/should_compile/all.T | 1 |
2 files changed, 108 insertions, 0 deletions
diff --git a/testsuite/tests/ghc-regress/simplCore/should_compile/T3831.hs b/testsuite/tests/ghc-regress/simplCore/should_compile/T3831.hs new file mode 100644 index 0000000000..718fe190a1 --- /dev/null +++ b/testsuite/tests/ghc-regress/simplCore/should_compile/T3831.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}
+
+-- This test has a deep nest of join points, which led to
+-- an exponential blow-up in SpecConstr
+
+module T3831(setAttributes) where
+
+import Data.Monoid
+import Control.Monad
+
+class (Monoid s, OutputCap s) => TermStr s
+
+class OutputCap f where
+ outputCap :: ([Int] -> String) -> [Int] -> f
+ optputCap = error "urk"
+
+instance OutputCap [Char] where
+instance (Enum p, OutputCap f) => OutputCap (p -> f) where
+
+instance MonadPlus Capability where
+ mzero = Capability (const $ return Nothing)
+ Capability f `mplus` Capability g = Capability $ \t -> do
+ mx <- f t
+ case mx of
+ Nothing -> g t
+ _ -> return mx
+
+instance Monad Capability where
+ return = Capability . const . return . Just
+ Capability f >>= g = Capability $ \t -> do
+ mx <- f t
+ case mx of
+ Nothing -> return Nothing
+ Just x -> let Capability g' = g x in g' t
+
+newtype Capability a = Capability (() -> IO (Maybe a))
+
+tiGetOutput1 :: forall f . OutputCap f => String -> Capability f
+{-# NOINLINE tiGetOutput1 #-}
+tiGetOutput1 _ = return (outputCap (const "") [])
+
+enterStandoutMode :: TermStr s => Capability s
+enterStandoutMode = tiGetOutput1 "smso"
+
+enterUnderlineMode :: TermStr s => Capability s
+enterUnderlineMode = tiGetOutput1 "smul"
+
+reverseOn :: TermStr s => Capability s
+reverseOn = tiGetOutput1 "rev"
+
+blinkOn:: TermStr s => Capability s
+blinkOn = tiGetOutput1 "blink"
+
+boldOn :: TermStr s => Capability s
+boldOn = tiGetOutput1 "bold"
+
+dimOn :: TermStr s => Capability s
+dimOn = tiGetOutput1 "dim"
+
+invisibleOn :: TermStr s => Capability s
+invisibleOn = tiGetOutput1 "invis"
+
+protectedOn :: TermStr s => Capability s
+protectedOn = tiGetOutput1 "prot"
+
+data Attributes = Attributes {
+ standoutAttr,
+ underlineAttr,
+ reverseAttr,
+ blinkAttr,
+ dimAttr,
+ boldAttr,
+ invisibleAttr,
+ protectedAttr :: Bool
+ }
+
+setAttributes :: TermStr s => Capability (Attributes -> s)
+setAttributes = usingSGR0 `mplus` manualSets
+ where
+ usingSGR0 = do
+ sgr <- tiGetOutput1 "sgr"
+ return $ \a -> let mkAttr f = if f a then 1 else 0 :: Int
+ in sgr (mkAttr standoutAttr)
+ (mkAttr underlineAttr)
+ (mkAttr reverseAttr)
+ (mkAttr blinkAttr)
+ (mkAttr dimAttr)
+ (mkAttr boldAttr)
+ (mkAttr invisibleAttr)
+ (mkAttr protectedAttr)
+ (0::Int)
+ attrCap :: TermStr s => (Attributes -> Bool) -> Capability s
+ -> Capability (Attributes -> s)
+ attrCap f cap = do {to <- cap; return $ \a -> if f a then to else mempty}
+ `mplus` return (const mempty)
+ manualSets = do
+ cs <- sequence [attrCap standoutAttr enterStandoutMode
+ , attrCap underlineAttr enterUnderlineMode
+ , attrCap reverseAttr reverseOn
+ , attrCap blinkAttr blinkOn
+ , attrCap boldAttr boldOn
+ , attrCap dimAttr dimOn
+ , attrCap invisibleAttr invisibleOn
+ , attrCap protectedAttr protectedOn
+ ]
+ return $ \a -> mconcat $ map ($ a) cs
+
diff --git a/testsuite/tests/ghc-regress/simplCore/should_compile/all.T b/testsuite/tests/ghc-regress/simplCore/should_compile/all.T index 0efb89b073..1245247bc9 100644 --- a/testsuite/tests/ghc-regress/simplCore/should_compile/all.T +++ b/testsuite/tests/ghc-regress/simplCore/should_compile/all.T @@ -72,3 +72,4 @@ test('T3772', extra_clean(['T3772_A.hi', 'T3772_A.o']), run_command, ['$MAKE -s --no-print-directory T3772']) +test('T3831', normal, compile, ['']) |