{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE ScopedTypeVariables, FlexibleInstances  #-}

-- This test has a deep nest of join points, which led to
-- an exponential blow-up in GHC.Core.Opt.SpecConstr

module T3831(setAttributes)  where

import Data.Monoid
import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))
import Control.Monad

class (Monoid s, OutputCap s) => TermStr s

class OutputCap f where
    outputCap :: ([Int] -> String) -> [Int] -> f
    outputCap = error "urk"

instance OutputCap [Char] where
instance (Enum p, OutputCap f) => OutputCap (p -> f) where


instance Functor Capability where
    fmap = liftM

instance Applicative Capability where
    pure = Capability . const . return . Just
    (<*>) = ap

instance Monad Capability where
    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

instance Alternative Capability where
    empty = mzero
    (<|>) = mplus

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

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

