escape-artist (empty) → 1.0.0
raw patch · 9 files changed
+988/−0 lines, 9 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, escape-artist, hspec, silently, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- escape-artist.cabal +86/−0
- src/Text/EscapeArtist.hs +55/−0
- src/Text/EscapeArtist/Internal.hs +349/−0
- src/Text/EscapeArtist/Internal/Constants.hs +52/−0
- test/Spec.hs +4/−0
- test/Text/EscapeArtistSpec.hs +74/−0
- test/Text/EscapeArtistSpec/TestData.hs +336/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ escape-artist.cabal view
@@ -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+ @+ .+ <<https://raw.githubusercontent.com/EarthCitizen/escape-artist/master/images/underline_off.png>>+ .+ 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:+ .+ <https://github.com/EarthCitizen/escape-artist#readme>++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
+ src/Text/EscapeArtist.hs view
@@ -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+@++<<https://raw.githubusercontent.com/EarthCitizen/escape-artist/master/images/underline_off.png>>++=== 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:++<https://github.com/EarthCitizen/escape-artist#readme>+-}++module Text.EscapeArtist (Escapable(..), ToEscapable(..), putEscLn, putEsc, escToString, (^$)) where++import Text.EscapeArtist.Internal hiding (Atom, Sum)
+ src/Text/EscapeArtist/Internal.hs view
@@ -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+@++<<https://raw.githubusercontent.com/EarthCitizen/escape-artist/master/images/either_error.png>>+-}+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
+ src/Text/EscapeArtist/Internal/Constants.hs view
@@ -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"
+ test/Spec.hs view
@@ -0,0 +1,4 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}++-- main :: IO ()+-- main = putStrLn "Test suite not yet implemented"
+ test/Text/EscapeArtistSpec.hs view
@@ -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
+ test/Text/EscapeArtistSpec/TestData.hs view
@@ -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]