diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ryan Daniels (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ryan Daniels nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/escape-artist.cabal b/escape-artist.cabal new file mode 100644 --- /dev/null +++ b/escape-artist.cabal @@ -0,0 +1,86 @@ +name: escape-artist +version: 1.0.0 +synopsis: ANSI Escape Sequence Text Decoration Made Easy +description: + A library for text decoration with ANSI escape sequences made easy. Decorate your terminal text easily and expressively. + Any complex data type, existing or custom, can be simply colorized by implementing the class 'ToEscapable', then + output to terminal or converted to 'String' using the provided functions. + . + Simple Example + . + @ + import Data.Monoid ((\<\>)) + import Text.EscapeArtist + . + underlines = Underline $ FgCyan \"I am underlined\" \<\> UnderlineOff \" but I am not \" \<\> FgMagenta \"and I am over here\" + . + putEscLn underlines + @ + . + <> + . + Implementing 'ToEscapable' + . + @ + import Data.Monoid ((\<\>)) + import Text.EscapeArtist + . + data ABC = A | B deriving (Show, Eq) + . + instance ToEscapable ABC where + toEscapable (A) = FgRed $ show A + toEscapable (B) = FgGreen $ show B + . + instance (ToEscapable a) => ToEscapable (Maybe a) where + toEscapable (Just a) = FgGreen \"Just\" \<\> Inherit \" \" \<\> FgYellow a + toEscapable a = FgRed $ show a + @ + . + Comprehensive Documentation + . + See comprehensive documentation with many examples here: + . + + +homepage: https://github.com/EarthCitizen/escape-artist#readme +license: BSD3 +license-file: LICENSE +author: Ryan Daniels +maintainer: rd.github@gmail.com +copyright: 2016 Ryan Daniels +category: Text +build-type: Simple +cabal-version: >= 1.10 + +library + hs-source-dirs: src + exposed-modules: Text.EscapeArtist + , Text.EscapeArtist.Internal + , Text.EscapeArtist.Internal.Constants + default-extensions: ExistentialQuantification, ExtendedDefaultRules, FlexibleInstances, NoMonomorphismRestriction + build-depends: base >= 4.7 && < 5 + , bytestring >= 0.10.8.1 && < 0.11 + , text >= 1.2.2.1 && < 1.3 + ghc-options: + default-language: Haskell2010 + +test-suite escape-artist-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + other-modules: Text.EscapeArtistSpec + , Text.EscapeArtistSpec.TestData + main-is: Spec.hs + build-depends: base >= 4.7 && < 5 + , bytestring >= 0.10.8.1 && < 0.11 + , escape-artist + , hspec >= 2.2.4 && < 2.3 + , silently >= 1.2.5 && < 1.3 + , text >= 1.2.2.1 && < 1.3 + , QuickCheck >= 2.9.2 && < 2.10 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-extensions: ExistentialQuantification, ExtendedDefaultRules, FlexibleInstances, NoMonomorphismRestriction + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/EarthCitizen/escape-artist diff --git a/src/Text/EscapeArtist.hs b/src/Text/EscapeArtist.hs new file mode 100644 --- /dev/null +++ b/src/Text/EscapeArtist.hs @@ -0,0 +1,55 @@ +{-| +Module : Text.EscapeArtist +Description : ANSI Escape Sequence Text Decoration Made Easy +Copyright : (c) Ryan Daniels 2016 +License : BSD3 +Maintainer : rd.github@gmail.com +Stability : stable +Portability : Terminal supporting ANSI escape sequences + +A library for text decoration with ANSI escape sequences made easy. Decorate your terminal text easily and expressively. +Any complex data type, existing or custom, can be simply colorized by implementing the class 'ToEscapable', then +output to terminal or converted to 'String' using the provided functions. + +=== Simple Example + +@ +import Data.Monoid ((<>)) +import Text.EscapeArtist + +underlines = Underline $ FgCyan \"I am underlined\" <> UnderlineOff \" but I am not \" <> FgMagenta \"and I am over here\" + +putEscLn underlines +@ + +<> + +=== Implementing 'ToEscapable' + +@ +import Data.Monoid ((<>)) +import Text.EscapeArtist + +data ABC = A | B deriving (Show, Eq) + +instance ToEscapable ABC where + toEscapable (A) = FgRed $ show A + toEscapable (B) = FgGreen $ show B + +instance (ToEscapable a) => ToEscapable (Maybe a) where + toEscapable (Just a) = FgGreen \"Just\" <> Inherit \" \" <> FgYellow a + toEscapable a = FgRed $ show a +@ + +=== Notes + +See the documentation on 'ToEscapable' below for a more advanced example. + +See comprehensive documentation with many examples here: + + +-} + +module Text.EscapeArtist (Escapable(..), ToEscapable(..), putEscLn, putEsc, escToString, (^$)) where + +import Text.EscapeArtist.Internal hiding (Atom, Sum) diff --git a/src/Text/EscapeArtist/Internal.hs b/src/Text/EscapeArtist/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/EscapeArtist/Internal.hs @@ -0,0 +1,349 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Text.EscapeArtist.Internal (Escapable(..), ToEscapable(..), putEscLn, putEsc, escToString, (^$)) where + +import Control.Applicative ((<|>)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Typeable (Typeable, cast) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Text.EscapeArtist.Internal.Constants + +infixr 7 ^$ + +-- | The same as '$', but with higher precedence. One level of precedence higher than 'Data.Monoid.<>'. This allows +-- avoiding parentheses when using '$' and 'Data.Monoid.<>' in the same expression. For example: +-- +-- @ +-- Underline $ (Bright $ FgGreen \"GREEN\") <> Default \" \" <> FgYellow \"YELLOW\" +-- @ +-- +-- can be written as: +-- +-- @ +-- Underline $ Bright ^$ FgGreen \"GREEN\" <> Default \" \" <> FgYellow \"YELLOW\" +-- @ +-- +-- In this example, 'Bright' is applied only to the 'String' \"GREEN\", that is concatenated +-- with a space and the yellow text \"YELLOW\", then 'Underline' is applied to the entire +-- expression. +-- +(^$) :: (a -> b) -> a -> b +(^$) = ($) + +-- | The constructors used to apply attributes to values +-- for terminal output +data Escapable = forall a. (ToEscapable a) => FgBlack a -- ^ Foreground color black + | forall a. (ToEscapable a) => FgRed a -- ^ Foreground color red + | forall a. (ToEscapable a) => FgGreen a -- ^ Foreground color green + | forall a. (ToEscapable a) => FgYellow a -- ^ Foreground color yellow + | forall a. (ToEscapable a) => FgBlue a -- ^ Foreground color blue + | forall a. (ToEscapable a) => FgMagenta a -- ^ Foreground color magenta + | forall a. (ToEscapable a) => FgCyan a -- ^ Foreground color cyan + | forall a. (ToEscapable a) => FgWhite a -- ^ Foreground color white + + | forall a. (ToEscapable a) => BgBlack a -- ^ Background color black + | forall a. (ToEscapable a) => BgRed a -- ^ Background color red + | forall a. (ToEscapable a) => BgGreen a -- ^ Background color green + | forall a. (ToEscapable a) => BgYellow a -- ^ Background color yellow + | forall a. (ToEscapable a) => BgBlue a -- ^ Background color blue + | forall a. (ToEscapable a) => BgMagenta a -- ^ Background color magenta + | forall a. (ToEscapable a) => BgCyan a -- ^ Background color cyan + | forall a. (ToEscapable a) => BgWhite a -- ^ Background color white + + | forall a. (ToEscapable a) => FgDefault a -- ^ Applies default terminal foreground color + | forall a. (ToEscapable a) => BgDefault a -- ^ Applies default terminal background color + | forall a. (ToEscapable a) => Inherit a -- ^ Inherit attributes from the parent, but apply none directly + | forall a. (ToEscapable a) => Default a -- ^ Applied value will have defaults of terminal + + | forall a. (ToEscapable a) => Blink a -- ^ Blinking text + | forall a. (ToEscapable a) => BlinkOff a -- ^ Will not inherit blink attribute from parent + | forall a. (ToEscapable a) => Bright a -- ^ Color mode to bright + | forall a. (ToEscapable a) => BrightOff a -- ^ Will not inherit bright attribute from parent + | forall a. (ToEscapable a) => Underline a -- ^ Underlined text + | forall a. (ToEscapable a) => UnderlineOff a -- ^ Will not inherit underline attribute from parent + | forall a. (ToEscapable a) => Inverse a -- ^ Swap the background and foreground colors + | forall a. (ToEscapable a) => InverseOff a -- ^ Will not inherit inverse attribute from parent + | Sum [Escapable] + | Atom String + +instance Show Escapable where + show (FgBlack a) = "FgBlack (" ++ show a ++ ")" + show (FgRed a) = "FgRed (" ++ show a ++ ")" + show (FgGreen a) = "FgGreen (" ++ show a ++ ")" + show (FgYellow a) = "FgYellow (" ++ show a ++ ")" + show (FgBlue a) = "FgBlue (" ++ show a ++ ")" + show (FgMagenta a) = "FgMagenta (" ++ show a ++ ")" + show (FgCyan a) = "FgCyan (" ++ show a ++ ")" + show (FgWhite a) = "FgWhite (" ++ show a ++ ")" + + show (BgBlack a) = "BgBlack (" ++ show a ++ ")" + show (BgRed a) = "BgRed (" ++ show a ++ ")" + show (BgGreen a) = "BgGreen (" ++ show a ++ ")" + show (BgYellow a) = "BgYellow (" ++ show a ++ ")" + show (BgBlue a) = "BgBlue (" ++ show a ++ ")" + show (BgMagenta a) = "BgMagenta (" ++ show a ++ ")" + show (BgCyan a) = "BgCyan (" ++ show a ++ ")" + show (BgWhite a) = "BgWhite (" ++ show a ++ ")" + + show (FgDefault a) = "FgDefault (" ++ show a ++ ")" + show (BgDefault a) = "BgDefault (" ++ show a ++ ")" + show (Inherit a) = "Inherit (" ++ show a ++ ")" + show (Default a) = "Default (" ++ show a ++ ")" + + show (Blink a) = "Blink (" ++ show a ++ ")" + show (BlinkOff a) = "BlinkOff (" ++ show a ++ ")" + show (Bright a) = "Bright (" ++ show a ++ ")" + show (BrightOff a) = "BrightOff (" ++ show a ++ ")" + show (Underline a) = "Underline (" ++ show a ++ ")" + show (UnderlineOff a) = "UnderlineOff (" ++ show a ++ ")" + show (Inverse a) = "Inverse (" ++ show a ++ ")" + show (InverseOff a) = "InverseOff (" ++ show a ++ ")" + + show (Sum a) = "Sum " ++ show a + show (Atom a) = "Atom " ++ show a + +tryCast :: forall a b. (Show b, Typeable a, Typeable b) => a -> (b -> String) -> Maybe String +tryCast a f = case cast a of + (Just s) -> Just $ f s + _ -> Nothing + +tryString, tryChar, tryBS, tryBSL, tryT, tryTL :: Typeable a => a -> Maybe String + +tryString a = tryCast a id +tryChar a = tryCast a (\b -> [b :: Char] ) +tryBS a = tryCast a (\b -> BSC.unpack b) +tryBSL a = tryCast a (\b -> BSLC.unpack b) +tryT a = tryCast a (\b -> T.unpack b) +tryTL a = tryCast a (\b -> TL.unpack b) + +toCompStr :: forall a. (Show a, Typeable a) => a -> String +toCompStr a = case options of + (Just s) -> s + _ -> show a + where options = tryString a + <|> tryChar a + <|> tryBS a + <|> tryBSL a + <|> tryT a + <|> tryTL a + +instance Eq Escapable where + (FgBlack a) == (FgBlack b) = toCompStr a == toCompStr b + (FgRed a) == (FgRed b) = toCompStr a == toCompStr b + (FgGreen a) == (FgGreen b) = toCompStr a == toCompStr b + (FgYellow a) == (FgYellow b) = toCompStr a == toCompStr b + (FgBlue a) == (FgBlue b) = toCompStr a == toCompStr b + (FgMagenta a) == (FgMagenta b) = toCompStr a == toCompStr b + (FgCyan a) == (FgCyan b) = toCompStr a == toCompStr b + (FgWhite a) == (FgWhite b) = toCompStr a == toCompStr b + + (BgBlack a) == (BgBlack b) = toCompStr a == toCompStr b + (BgRed a) == (BgRed b) = toCompStr a == toCompStr b + (BgGreen a) == (BgGreen b) = toCompStr a == toCompStr b + (BgYellow a) == (BgYellow b) = toCompStr a == toCompStr b + (BgBlue a) == (BgBlue b) = toCompStr a == toCompStr b + (BgMagenta a) == (BgMagenta b) = toCompStr a == toCompStr b + (BgCyan a) == (BgCyan b) = toCompStr a == toCompStr b + (BgWhite a) == (BgWhite b) = toCompStr a == toCompStr b + + (FgDefault a) == (FgDefault b) = toCompStr a == toCompStr b + (BgDefault a) == (BgDefault b) = toCompStr a == toCompStr b + (Inherit a) == (Inherit b) = toCompStr a == toCompStr b + (Default a) == (Default b) = toCompStr a == toCompStr b + + (Blink a) == (Blink b) = toCompStr a == toCompStr b + (BlinkOff a) == (BlinkOff b) = toCompStr a == toCompStr b + (Bright a) == (Bright b) = toCompStr a == toCompStr b + (BrightOff a) == (BrightOff b) = toCompStr a == toCompStr b + (Underline a) == (Underline b) = toCompStr a == toCompStr b + (UnderlineOff a) == (UnderlineOff b) = toCompStr a == toCompStr b + (Inverse a) == (Inverse b) = toCompStr a == toCompStr b + (InverseOff a) == (InverseOff b) = toCompStr a == toCompStr b + + (Sum a) == (Sum b) = toCompStr a == toCompStr b + (Atom a) == (Atom b) = toCompStr a == toCompStr b + _ == _ = False + +{-| +Implement 'ToEscapable' by composing constructors of the type 'Escapable'. +This can be done for any data type with the exception of the following, which +already come with an implementation which renders directly to 'String': + +* 'Char' +* 'Data.ByteString.ByteString' +* 'Data.ByteString.Lazy.ByteString' (Lazy) +* 'Data.Text.Text' +* 'Data.Text.Lazy.Text' (Lazy) +* 'Double' +* 'Float' +* 'Int' +* 'Integer' +* 'String' +* 'Word' +* 'Word8' +* 'Word16' +* 'Word32' +* 'Word64' + +@ +\{\-\# LANGUAGE FlexibleInstances \#\-\} + +import Data.Monoid ((<>)) +import Text.EscapeArtist + +type FileName = String +type LineNumber = Integer +type ColumnNumber = Integer + +data ErrorType = SyntaxError FileName LineNumber ColumnNumber deriving (Show) + +instance ToEscapable ErrorType where + toEscapable (SyntaxError fn ln cn) = Default "Syntax error in file " + <> FgYellow ^$ Underline fn + <> Default " at " + <> FgRed (show ln ++ ":" ++ show cn) + +instance ToEscapable (Either ErrorType String) where + toEscapable (Left e) = toEscapable e + toEscapable (Right m) = FgGreen m + +mkSyntaxError :: FileName -> LineNumber -> ColumnNumber -> Either ErrorType String +mkSyntaxError fn ln cn = Left $ SyntaxError fn ln cn + +mkStatusOK :: Either ErrorType String +mkStatusOK = Right "Status OK" + +putEscLn $ mkSyntaxError "some/File.hs" 1 23 +putEscLn mkStatusOK +@ + +<> +-} +class (Show a, Typeable a) => ToEscapable a where + -- | Convert the given type to an Escapable + toEscapable :: a -> Escapable + +instance ToEscapable String where + toEscapable = Atom + +instance ToEscapable Char where + toEscapable a = Atom [a] + +instance ToEscapable BS.ByteString where + toEscapable a = Atom $ BSC.unpack a + +instance ToEscapable BSL.ByteString where + toEscapable a = Atom $ BSLC.unpack a + +instance ToEscapable T.Text where + toEscapable a = Atom $ T.unpack a + +instance ToEscapable TL.Text where + toEscapable a = Atom $ TL.unpack a + +instance ToEscapable Int where + toEscapable a = Atom $ show a + +instance ToEscapable Integer where + toEscapable a = Atom $ show a + +instance ToEscapable Word where + toEscapable a = Atom $ show a + +instance ToEscapable Word8 where + toEscapable a = Atom $ show a + +instance ToEscapable Word16 where + toEscapable a = Atom $ show a + +instance ToEscapable Word32 where + toEscapable a = Atom $ show a + +instance ToEscapable Word64 where + toEscapable a = Atom $ show a + +instance ToEscapable Float where + toEscapable a = Atom $ show a + +instance ToEscapable Double where + toEscapable a = Atom $ show a + +instance ToEscapable Escapable where + toEscapable = id + +-- | Convert any instance of 'ToEscapable' to a 'String' +escToString :: (ToEscapable a) => a -> String +escToString esc = escToStrEncl "" "" $ toEscapable esc + +recur :: String -> String -> Escapable -> String +recur = escToStrEncl + +dc :: String +dc = defaultFgColor + +dbc :: String +dbc = defaultBgColor + +def :: String +def = defaultAll + +te :: (ToEscapable a) => a -> Escapable +te = toEscapable + +escToStrEncl :: String -> String -> Escapable -> String +escToStrEncl pref suff (FgBlack a) = recur (pref ++ fgBlack ) (dc ++ suff) (te a) +escToStrEncl pref suff (FgRed a) = recur (pref ++ fgRed ) (dc ++ suff) (te a) +escToStrEncl pref suff (FgGreen a) = recur (pref ++ fgGreen ) (dc ++ suff) (te a) +escToStrEncl pref suff (FgYellow a) = recur (pref ++ fgYellow ) (dc ++ suff) (te a) +escToStrEncl pref suff (FgBlue a) = recur (pref ++ fgBlue ) (dc ++ suff) (te a) +escToStrEncl pref suff (FgMagenta a) = recur (pref ++ fgMagenta) (dc ++ suff) (te a) +escToStrEncl pref suff (FgCyan a) = recur (pref ++ fgCyan ) (dc ++ suff) (te a) +escToStrEncl pref suff (FgWhite a) = recur (pref ++ fgWhite ) (dc ++ suff) (te a) + +escToStrEncl pref suff (BgBlack a) = recur (pref ++ bgBlack ) (dbc ++ suff) (te a) +escToStrEncl pref suff (BgRed a) = recur (pref ++ bgRed ) (dbc ++ suff) (te a) +escToStrEncl pref suff (BgGreen a) = recur (pref ++ bgGreen ) (dbc ++ suff) (te a) +escToStrEncl pref suff (BgYellow a) = recur (pref ++ bgYellow ) (dbc ++ suff) (te a) +escToStrEncl pref suff (BgBlue a) = recur (pref ++ bgBlue ) (dbc ++ suff) (te a) +escToStrEncl pref suff (BgMagenta a) = recur (pref ++ bgMagenta) (dbc ++ suff) (te a) +escToStrEncl pref suff (BgCyan a) = recur (pref ++ bgCyan ) (dbc ++ suff) (te a) +escToStrEncl pref suff (BgWhite a) = recur (pref ++ bgWhite ) (dbc ++ suff) (te a) + +escToStrEncl pref suff (FgDefault a) = recur (pref ++ dc ) suff (te a) +escToStrEncl pref suff (BgDefault a) = recur (pref ++ dbc) suff (te a) +escToStrEncl pref suff (Inherit a) = recur pref suff (te a) +escToStrEncl pref suff (Default a) = recur (pref ++ def) suff (te a) + +escToStrEncl pref suff (Blink a) = recur (pref ++ blinkOn ) (blinkOff ++ suff) (te a) +escToStrEncl pref suff (BlinkOff a) = recur (pref ++ blinkOff ) suff (te a) +escToStrEncl pref suff (Bright a) = recur (pref ++ brightOn ) (brightOff ++ suff) (te a) +escToStrEncl pref suff (BrightOff a) = recur (pref ++ brightOff ) suff (te a) +escToStrEncl pref suff (Underline a) = recur (pref ++ underlineOn ) (underlineOff ++ suff) (te a) +escToStrEncl pref suff (UnderlineOff a) = recur (pref ++ underlineOff) suff (te a) +escToStrEncl pref suff (Inverse a) = recur (pref ++ inverseOn ) (inverseOff ++ suff) (te a) +escToStrEncl pref suff (InverseOff a) = recur (pref ++ inverseOff ) suff (te a) + +escToStrEncl pref suff (Sum a) = concatMap (recur pref suff) a +escToStrEncl pref suff (Atom a) = concat [pref, a, suff] + +instance Monoid Escapable where + mempty = Sum [] + mappend (Sum []) b = b + mappend a (Sum []) = a + mappend (Sum as) (Sum bs) = Sum $ mconcat [as, bs ] + mappend (Sum as) b = Sum $ mconcat [as, [b]] + mappend a (Sum bs) = Sum $ mconcat [[a], bs ] + mappend a b = Sum [a, b] + +-- | Convert any instance of 'ToEscapable' to a 'String' and output it to the terminal followed by a newline +putEscLn :: (ToEscapable a) => a -> IO () +putEscLn = putStrLn . escToString + +-- | Convert any instance of 'ToEscapable' to a 'String' and output it to the terminal +putEsc :: (ToEscapable a) => a -> IO () +putEsc = putStr . escToString diff --git a/src/Text/EscapeArtist/Internal/Constants.hs b/src/Text/EscapeArtist/Internal/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Text/EscapeArtist/Internal/Constants.hs @@ -0,0 +1,52 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Text.EscapeArtist.Internal.Constants where + +fgBlack, fgRed, fgGreen, fgYellow, fgBlue, fgMagenta, fgCyan, fgWhite :: String + +fgBlack = "\ESC[30m" +fgRed = "\ESC[31m" +fgGreen = "\ESC[32m" +fgYellow = "\ESC[33m" +fgBlue = "\ESC[34m" +fgMagenta = "\ESC[35m" +fgCyan = "\ESC[36m" +fgWhite = "\ESC[37m" + +bgBlack, bgRed, bgGreen, bgYellow, bgBlue, bgMagenta, bgCyan, bgWhite :: String + +bgBlack = "\ESC[40m" +bgRed = "\ESC[41m" +bgGreen = "\ESC[42m" +bgYellow = "\ESC[43m" +bgBlue = "\ESC[44m" +bgMagenta = "\ESC[45m" +bgCyan = "\ESC[46m" +bgWhite = "\ESC[47m" + +defaultAll, defaultFgColor, defaultBgColor :: String + +defaultAll = "\ESC[0m" + +defaultFgColor = "\ESC[39m" + +defaultBgColor = "\ESC[49m" + +blinkOn, blinkOff, brightOn, brightOff :: String + +blinkOn = "\ESC[5m" +blinkOff = "\ESC[25m" + +brightOn = "\ESC[1m" +brightOff = "\ESC[22m" + +underlineOn, underlineOff, inverseOn, inverseOff :: String + +underlineOn = "\ESC[4m" +underlineOff = "\ESC[24m" + +inverseOn = "\ESC[7m" +inverseOff = "\ESC[27m" + +-- strikeOn = "\ESC[9m" +-- strikeOff = "\ESC[29m" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,4 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} + +-- main :: IO () +-- main = putStrLn "Test suite not yet implemented" diff --git a/test/Text/EscapeArtistSpec.hs b/test/Text/EscapeArtistSpec.hs new file mode 100644 --- /dev/null +++ b/test/Text/EscapeArtistSpec.hs @@ -0,0 +1,74 @@ +module Text.EscapeArtistSpec (spec) where + +import Control.Monad (forM_) +import Data.Monoid ((<>), mempty) +import Text.EscapeArtist.Internal +import Text.EscapeArtistSpec.TestData +import System.IO.Silently (capture) +import Test.QuickCheck +import Test.Hspec (context, describe, it, shouldBe, shouldNotBe, Spec) + +spec :: Spec +spec = do + describe "escToString" $ do + context "when passed any instance of ToEscapable" $ do + it "outputs contained valued with corresponding escape codes" $ forM_ escSingleTestCases $ + \(TestCaseVE escapable expectation) -> do + escToString escapable `shouldBe` expectation + context "when passed an Inherit" $ do + it "outputs contained value with only parent escape codes" $ forM_ inheritTestCases $ do + \(TestCaseVE escapable expectation) -> do + escToString escapable `shouldBe` expectation + context "when passed a Sum" $ do + it "outputs all contained values with the corresponding escape codes" $ forM_ sumTestCases $ + \(TestCaseVE escapable expectation) -> do + escToString escapable `shouldBe` expectation + it "outputs parent escape codes around each nested sum element" $ forM_ nestedSumTestCases $ do + \(TestCaseVE escapable expectation) -> do + escToString escapable `shouldBe` expectation + + describe "putEsc" $ do + context "when passed any instance of ToEscapable" $ do + it "outputs contained values with corresponding escape codes" $ forM_ allEscTestCases $ + \(TestCaseVE escapable expectation) -> do + (out, result) <- capture $ putEsc $ escapable + out `shouldBe` expectation + result `shouldBe` () + + describe "putEscLn" $ do + context "when passed any instance of ToEscapable" $ do + it "outputs contained values with corresponding escape codes and newline" $ forM_ allEscTestCases $ + \(TestCaseVE escapable expectation) -> do + (out, result) <- capture $ putEscLn $ escapable + out `shouldBe` (expectation ++ ['\n']) + result `shouldBe` () + + describe "^$" $ do + it "produces the same result as $" $ do + (FgRed ^$ Underline ^$ Blink 6) `shouldBe` (FgRed $ Underline $ Blink 6) + it "gets processed before <>" $ do + (FgRed ^$ Underline 5 <> FgBlue 3 <> FgYellow 9) `shouldBe` (Sum [FgRed (Underline 5), FgBlue 3, FgYellow 9]) + + describe "Eq Escapable" $ do + it "considers escapables equal when constructors and strings of contained values are same" $ forM_ eqTestCases $ do + \(a, b) -> a `shouldBe` b + it "considers escapables not equal when constructors or strings of contained values are not same" $ forM_ notEqTestCases $ do + \(a, b) -> a `shouldNotBe` b + + describe "Monoid Escapable" $ do + it "obeys left identity" $ forM_ monoidArgs $ + -- left identity + -- mempty <> x = x + \x -> mempty <> x `shouldBe` (x :: Escapable) + it "obeys right identify" $ forM_ monoidArgs $ + -- right identity + -- x <> mempty = x + \x -> x <> mempty `shouldBe` (x :: Escapable) + it "obeys associativity" $ forM_ monoidTestCases $ + -- associativity + -- (x <> y) <> z = x <> (y <> z) + \(x, y, z) -> (x <> y) <> z `shouldBe` (x :: Escapable) <> ((y :: Escapable) <> (z :: Escapable)) + + describe "Show Escapable" $ do + it "returns the String representation of the given value" $ forM_ showTestCases $ do + \(TestCaseVE escapable expectation) -> show escapable `shouldBe` expectation diff --git a/test/Text/EscapeArtistSpec/TestData.hs b/test/Text/EscapeArtistSpec/TestData.hs new file mode 100644 --- /dev/null +++ b/test/Text/EscapeArtistSpec/TestData.hs @@ -0,0 +1,336 @@ +module Text.EscapeArtistSpec.TestData ( + TestCaseVE(..) + , allEscTestCases + , inheritTestCases + , escSingleTestCases + , nestedSumTestCases + , sumTestCases + , eqTestCases + , notEqTestCases + , monoidArgs + , monoidTestCases + , showTestCases + ) where + +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy.Char8 as BSLC +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Word +import Text.EscapeArtist.Internal +import Text.EscapeArtist.Internal.Constants +import Test.QuickCheck + +data TestCaseVE = forall a. (ToEscapable a) => TestCaseVE a String + +----------------------------------------------------------- + +openCloseCons = [ + (fgBlack, defaultFgColor, FgBlack ), + (fgRed, defaultFgColor, FgRed ), + (fgGreen, defaultFgColor, FgGreen ), + (fgYellow, defaultFgColor, FgYellow ), + (fgBlue, defaultFgColor, FgBlue ), + (fgMagenta, defaultFgColor, FgMagenta), + (fgCyan, defaultFgColor, FgCyan ), + (fgWhite, defaultFgColor, FgWhite ), + + (bgBlack, defaultBgColor, BgBlack ), + (bgRed, defaultBgColor, BgRed ), + (bgGreen, defaultBgColor, BgGreen ), + (bgYellow, defaultBgColor, BgYellow ), + (bgBlue, defaultBgColor, BgBlue ), + (bgMagenta, defaultBgColor, BgMagenta), + (bgCyan, defaultBgColor, BgCyan ), + (bgWhite, defaultBgColor, BgWhite ), + + (defaultFgColor, "", FgDefault ), + (defaultBgColor, "", BgDefault), + ("", "", Inherit ), + (defaultAll, "", Default ), + + (blinkOn, blinkOff, Blink ), + (blinkOff, "", BlinkOff ), + (brightOn, brightOff, Bright ), + (brightOff, "", BrightOff ), + (underlineOn, underlineOff, Underline ), + (underlineOff, "", UnderlineOff), + (inverseOn, inverseOff, Inverse ), + (inverseOff, "", InverseOff ) + ] + +genTestCases valueList = [ + TestCaseVE (cons v) e | + (open, close, cons) <- openCloseCons, + (v, vs) <- valueList, + let e = open ++ vs ++ close + ] + +-- Atom terminating type tests + +charValueExp = [('5', "5"), ('X', "X"), ('@', "@")] :: [(Char, String)] +charTestCases = genTestCases charValueExp + +bsValueExp = [(BSC.pack "ASDASDASD", "ASDASDASD"), (BSC.pack "%%$\":98^tug'kjgh\"", "%%$\":98^tug'kjgh\""), (BSC.pack "aaa\nggg\thhh\n", "aaa\nggg\thhh\n")] +bsTestCases = genTestCases bsValueExp + +bslValueExp = [(BSLC.pack "ASDASDASD", "ASDASDASD"), (BSLC.pack "%%$\":98^tug'kjgh\"", "%%$\":98^tug'kjgh\""), (BSLC.pack "aaa\nggg\thhh\n", "aaa\nggg\thhh\n")] +bslTestCases = genTestCases bslValueExp + +stringValueExp = [("ASDASDASD", "ASDASDASD"), ("%%$\":98^tug'kjgh\"", "%%$\":98^tug'kjgh\""), ("aaa\nggg\thhh\n", "aaa\nggg\thhh\n")] +stringTestCases = genTestCases stringValueExp + +textValueExp = [(T.pack "ASDASDASD", "ASDASDASD"), (T.pack "%%$\":98^tug'kjgh\"", "%%$\":98^tug'kjgh\""), (T.pack "aaa\nggg\thhh\n", "aaa\nggg\thhh\n")] +textTestCases = genTestCases textValueExp + +textLazyValueExp = [(TL.pack "ASDASDASD", "ASDASDASD"), (TL.pack "%%$\":98^tug'kjgh\"", "%%$\":98^tug'kjgh\""), (TL.pack "aaa\nggg\thhh\n", "aaa\nggg\thhh\n")] +textLazyTestCases = genTestCases textLazyValueExp + +intValueExp = [(500, "500"), ((-4000), "-4000"), (9999999, "9999999")] :: [(Int, String)] +intTestCases = genTestCases intValueExp + +integerValueExp = [(500, "500"), ((-4000), "-4000"), (9999999, "9999999")] :: [(Integer, String)] +integerTestCases = genTestCases integerValueExp + +wValueExp = [(500, "500"), ((4), "4"), (999, "999")] :: [(Word, String)] +wTestCases = genTestCases wValueExp + +w8ValueExp = [(200, "200"), (4, "4"), (99, "99")] :: [(Word8, String)] +w8TestCases = genTestCases w8ValueExp + +w16ValueExp = [(500, "500"), ((4), "4"), (999, "999")] :: [(Word16, String)] +w16TestCases = genTestCases w16ValueExp + +w32ValueExp = [(500, "500"), ((400), "400"), (99999, "99999")] :: [(Word32, String)] +w32TestCases = genTestCases w32ValueExp + +w64ValueExp = [(500, "500"), ((400), "400"), (99999, "99999")] :: [(Word64, String)] +w64TestCases = genTestCases w64ValueExp + +floatValueExp = [(4.5, "4.5"), (0.0001, "1.0e-4"), (-0.003, "-3.0e-3")] :: [(Float, String)] +floatTestCases = genTestCases floatValueExp + +doubleValueExp = [(4.5, "4.5"), (0.0001, "1.0e-4"), (-0.003, "-3.0e-3")] :: [(Double, String)] +doubleTestCases = genTestCases doubleValueExp + +-- Atom tests + +atomTestCases = [TestCaseVE (Atom v) e | (v, e) <- stringValueExp] + +-- Other types of ToEscapable tests + +data SomeToEscapable = A deriving (Show) + +instance ToEscapable SomeToEscapable where + toEscapable (A) = FgRed $ "A" + +toEscTestCases = [TestCaseVE 5 "5", TestCaseVE "Some String" "Some String", TestCaseVE A (fgRed ++ "A" ++ defaultFgColor)] + +-- Put them all together to run through the same test + +escSingleTestCases = charTestCases + ++ bsTestCases + ++ bslTestCases + ++ stringTestCases + ++ textTestCases + ++ textLazyTestCases + ++ atomTestCases + ++ toEscTestCases + ++ intTestCases + ++ integerTestCases + ++ wTestCases + ++ w8TestCases + ++ w16TestCases + ++ w32TestCases + ++ w64TestCases + ++ floatTestCases + ++ doubleTestCases + +----------------------------------------------------------- + +-- Inherit tests + +inheritTestCases = [TestCaseVE (Underline $ Bright 6) (underlineOn ++ brightOn ++ "6" ++ brightOff ++ underlineOff)] + +----------------------------------------------------------- + +-- Sum tests + +singleSum = Sum [FgRed 6, FgBlue "Color", FgYellow "Hello"] +singleSumExp = concat [fgRed, "6", defaultFgColor, fgBlue, "Color", defaultFgColor, fgYellow, "Hello", defaultFgColor] +sumTestCases = [TestCaseVE singleSum singleSumExp] + +oneNestedSum = Bright $ FgRed $ Underline $ Sum [Underline $ FgYellow "Hello", FgGreen 1000 ] +oneNestedSumExp = concat [ + brightOn, fgRed, underlineOn, underlineOn, fgYellow, "Hello", defaultFgColor, underlineOff, underlineOff, defaultFgColor, brightOff, + brightOn, fgRed, underlineOn, fgGreen, "1000", defaultFgColor, underlineOff, defaultFgColor, brightOff + ] + +twoNestedSum = Underline $ Sum [Underline $ FgYellow "Hello", Bright $ Sum [FgGreen 1000, FgBlue 999]] +twoNestedSumExp = concat [ + underlineOn, underlineOn, fgYellow, "Hello", defaultFgColor, underlineOff, underlineOff, + underlineOn, brightOn, fgGreen, "1000", defaultFgColor, brightOff, underlineOff, + underlineOn, brightOn, fgBlue, "999", defaultFgColor, brightOff, underlineOff + ] + +threeNestedSum = Inverse $ Sum [Underline $ FgYellow "Hello", Bright $ Sum [Inverse $ Sum [FgGreen 1000, FgCyan "C"], FgBlue 999]] +threeNestedSumExp = concat [ + inverseOn, underlineOn, fgYellow, "Hello", defaultFgColor, underlineOff, inverseOff, + inverseOn, brightOn, inverseOn, fgGreen, "1000", defaultFgColor, inverseOff, brightOff, inverseOff, + inverseOn, brightOn, inverseOn, fgCyan, "C", defaultFgColor, inverseOff, brightOff, inverseOff, + inverseOn, brightOn, fgBlue, "999", defaultFgColor, brightOff, inverseOff + ] + +nestedSumTestCases = [ + TestCaseVE oneNestedSum oneNestedSumExp, + TestCaseVE twoNestedSum twoNestedSumExp, + TestCaseVE threeNestedSum threeNestedSumExp + ] + +----------------------------------------------------------- + +-- Tests for putEsc and putEscLn + +allEscTestCases = inheritTestCases ++ escSingleTestCases ++ sumTestCases ++ nestedSumTestCases + +----------------------------------------------------------- + +-- Equality tests + +forAllCons = [ + FgBlack, + FgRed, + FgGreen, + FgYellow, + FgBlue, + FgMagenta, + FgCyan, + FgWhite, + BgBlack, + BgRed, + BgGreen, + BgYellow, + BgBlue, + BgMagenta, + BgCyan, + BgWhite, + FgDefault, + BgDefault, + Inherit, + Default, + Blink, + BlinkOff, + Bright, + BrightOff, + Underline, + UnderlineOff, + Inverse, + InverseOff + ] + +fnConsSameValSame = (\v -> zipWith (\c v -> (c v, c v)) forAllCons $ repeat v) +fnCVCyc = (zipWith (\c v -> c v) forAllCons) . cycle +fnCVRep = (zipWith (\c v -> c v) forAllCons) . repeat + +eqTestCases = fnConsSameValSame 'Z' + ++ fnConsSameValSame "@%^&*&^%$#$%" + ++ (fnConsSameValSame $ BSC.pack "4") + ++ (fnConsSameValSame $ BSLC.pack "7") + ++ (fnConsSameValSame $ T.pack "999") + ++ (fnConsSameValSame $ TL.pack "Some Text") + ++ fnConsSameValSame 6 + -- This case hadles different values which are the + -- same when strings + ++ zip (fnCVRep (3.5 :: Float)) (fnCVRep (3.5 :: Double)) + ++ [(Atom "6", Atom "6")] + ++ [(Sum [FgRed 6], Sum [FgRed 6])] + +li1 = fnCVCyc [1, 10, 5] +li2 = fnCVCyc [1000, 10000, 5000] + +ls1 = fnCVCyc ["asdf", "@@#$%", "+_)(+_)(+_)(+_)()"] +ls2 = fnCVCyc ["99999", "^&*(9876(*&^9876))", "************"] + +lc1 = fnCVCyc "QWERTY" +lc2 = fnCVCyc "ZXCVBN" + +notEqConsSameValueNotTestCases = zip (li1 ++ ls1 ++ lc1) (li2 ++ ls2 ++ lc2) + ++ [(Atom "not", Atom "same")] + ++ [(Sum [FgBlue "not"], Sum [FgBlue "same"])] + +forAllConsEnum = zip [1..] forAllCons + +notEqConsNotValueSameTestCases = [(c1 v, c2 v) | (c1e, c1) <- forAllConsEnum, + (c2e, c2) <- forAllConsEnum, + let v = "Any Value", + c1e /= c2e + ] + ++ [(Atom "same", FgRed "same")] + ++ [(Sum [FgWhite "same"], FgRed "same")] + +notEqTestCases = notEqConsSameValueNotTestCases + ++ notEqConsNotValueSameTestCases + +----------------------------------------------------------- + +-- Monoid law test data + +instance Arbitrary Escapable where + arbitrary = oneof $ map return [ + FgRed 6, + Underline $ Inverse $ FgGreen 10, + oneNestedSum, + twoNestedSum, + threeNestedSum + ] + +monoidArgs = [ + FgRed 6, + Underline $ Inverse $ FgGreen 10, + singleSum, + oneNestedSum, + twoNestedSum, + threeNestedSum + ] + +monoidTestCases = [(a, b, c) | a <- monoidArgs, b <- monoidArgs, c <- monoidArgs] + +----------------------------------------------------------- + +-- Show test data + +showValueExp = [ + (FgBlack 1, "FgBlack (1)"), + (FgRed 2, "FgRed (2)"), + (FgGreen 3, "FgGreen (3)"), + (FgYellow 4, "FgYellow (4)"), + (FgBlue 5, "FgBlue (5)"), + (FgMagenta 6, "FgMagenta (6)"), + (FgCyan 7, "FgCyan (7)"), + (FgWhite 8, "FgWhite (8)"), + (BgBlack 9, "BgBlack (9)"), + (BgRed 10, "BgRed (10)"), + (BgGreen 11, "BgGreen (11)"), + (BgYellow 12, "BgYellow (12)"), + (BgBlue 13, "BgBlue (13)"), + (BgMagenta 14, "BgMagenta (14)"), + (BgCyan 15, "BgCyan (15)"), + (BgWhite 16, "BgWhite (16)"), + (FgDefault 17, "FgDefault (17)"), + (BgDefault 18, "BgDefault (18)"), + (Inherit 19, "Inherit (19)"), + (Default 20, "Default (20)"), + (Blink 21, "Blink (21)"), + (BlinkOff 22, "BlinkOff (22)"), + (Bright 23, "Bright (23)"), + (BrightOff 24, "BrightOff (24)"), + (Underline 25, "Underline (25)"), + (UnderlineOff 26, "UnderlineOff (26)"), + (Inverse 27, "Inverse (27)"), + (InverseOff 28, "InverseOff (28)"), + + (Sum [FgRed 6, FgBlue 3], "Sum [FgRed (6),FgBlue (3)]"), + + (Atom "text", "Atom \"text\"") + ] +showTestCases = [TestCaseVE v e | (v, e) <- showValueExp]