diff --git a/NEWS b/NEWS deleted file mode 100644 --- a/NEWS +++ /dev/null @@ -1,49 +0,0 @@ -This file lists the user-visible interesting changes between releases. For a -full list of changes to the source, see the ChangeLog. - - - -irc-fun-color 0.1.0.1 -- 2015-09-10 -=================================== - -General, build and documentation changes: - -* (None) - -New APIs, features and enhancements: - -* (None) - -Bug fixes: - -* When a message starting with a digit is assigned a color, it may be - interpreted as part of the color code. This has been fixed by inserting some - dummy codes between the code and the message text. - -Dependency changes: - -* (None) - - - - - -irc-fun-color 0.1.0.0 -- 2015-07-18 -=================================== - -General, build and documentation changes: - -* This library hasn't been tested much yet in actual IRC clients. If you find - any issues, please report them and they'll be fixed :-) - -New APIs, features and enhancements: - -* (This is the first release, so everything is a new feature) - -Bug fixes: - -* (This is just the first release) - -Dependency changes: - -* (This is the first release) diff --git a/NEWS.md b/NEWS.md new file mode 100644 --- /dev/null +++ b/NEWS.md @@ -0,0 +1,79 @@ +This file lists the user-visible interesting changes between releases. For a +full list of changes to the source, see the ChangeLog. + + + +irc-fun-color 0.2.0.0 -- unreleased +=================================== + +General, build and documentation changes: + +* (None) + +New APIs, features and enhancements: + +* Move from `String` to strict `Text` +* Make some of the types abstract +* Use `DList` instead of `[]`, I can't stand the `++ [c]` anti-pattern +* Integration with `Formatting` + +Bug fixes: + +* (None) + +Dependency changes: + +* Add dlist >= 0.7 + formatting >= 6.2 + irc-fun-types + text >= 1 + text-show >= 2 + + + + + +irc-fun-color 0.1.0.1 -- 2015-09-10 +=================================== + +General, build and documentation changes: + +* (None) + +New APIs, features and enhancements: + +* (None) + +Bug fixes: + +* When a message starting with a digit is assigned a color, it may be + interpreted as part of the color code. This has been fixed by inserting some + dummy codes between the code and the message text. + +Dependency changes: + +* (None) + + + + + +irc-fun-color 0.1.0.0 -- 2015-07-18 +=================================== + +General, build and documentation changes: + +* This library hasn't been tested much yet in actual IRC clients. If you find + any issues, please report them and they'll be fixed :-) + +New APIs, features and enhancements: + +* (This is the first release, so everything is a new feature) + +Bug fixes: + +* (This is just the first release) + +Dependency changes: + +* (This is the first release) diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,14 +0,0 @@ -See the .cabal file for more info and link to project website the version -control. - -The official download location is Hackage: - - - -This library is free software, and is committed to software freedom. It is -released to the public domain using the CC0 Public Domain Dedication. For the -boring "legal" details see the file 'COPYING'. - -See the file 'INSTALL' for hints on installation. The file 'ChangeLog' explains -how to see the history log of the changes done in the code. 'NEWS' provides a -friendly overview of the changes for each release. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +See the .cabal file for more info and link to project website the version +control. + +The official download location is Hackage: + + + +This library is free software, and is committed to software freedom. It is +released to the public domain using the CC0 Public Domain Dedication. For the +boring "legal" details see the file 'COPYING'. + +See the file 'INSTALL' for hints on installation. The file 'ChangeLog' explains +how to see the history log of the changes done in the code. 'NEWS' provides a +friendly overview of the changes for each release. diff --git a/irc-fun-color.cabal b/irc-fun-color.cabal --- a/irc-fun-color.cabal +++ b/irc-fun-color.cabal @@ -1,10 +1,12 @@ name: irc-fun-color -version: 0.1.0.1 +version: 0.2.0.0 synopsis: Add color and style decorations to IRC messages. description: An extension to IRC allows text formatting to be encoded into a message. Colors and decorations (e.g. bold) are available. This library can encode - this formatting into a plain text message. + this formatting into a plain text message. It also provides integration with + "Formatting" for flexible mixing of styling, formatting and IRC-specific + types. homepage: http://rel4tion.org/projects/irc-fun-color/ bug-reports: http://rel4tion.org/projects/irc-fun-color/tickets/ license: PublicDomain @@ -14,20 +16,30 @@ copyright: ♡ Copying is an act of love. Please copy, reuse and share. category: Network build-type: Simple -extra-source-files: AUTHORS ChangeLog COPYING INSTALL NEWS README +extra-source-files: AUTHORS ChangeLog COPYING INSTALL NEWS.md README.md cabal-version: >=1.10 source-repository head type: darcs - location: http://darcs.rel4tion.org/repos/irc-fun-color/ + location: http://hub.darcs.net/fr33domlover/irc-fun-color library exposed-modules: Network.IRC.Fun.Color + , Network.IRC.Fun.Color.Format + , Network.IRC.Fun.Color.Format.Long + , Network.IRC.Fun.Color.Format.Short + , Network.IRC.Fun.Color.Style -- other-modules: -- other-extensions: - build-depends: base >=4.7 && <5 + build-depends: base >=4.7 && <5 + , dlist >=0.7 + , formatting >=6.2 + , irc-fun-types + , text >=1 + , text-show >=2 hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall test-suite test default-language: Haskell2010 @@ -36,3 +48,4 @@ main-is: test.hs build-depends: base , irc-fun-color + , text diff --git a/src/Network/IRC/Fun/Color.hs b/src/Network/IRC/Fun/Color.hs --- a/src/Network/IRC/Fun/Color.hs +++ b/src/Network/IRC/Fun/Color.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-color. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -13,324 +13,16 @@ - . -} --- | This module allows you to add color and style to IRC text messages. --- Decoding style-encoded messages isn't implemented currently. --- --- Building styled strings is done in two steps: --- --- (1) Construct the string using combinators --- (2) Encode it into the IRC message styling format --- --- The result you get is a style-encoded 'String' which you can send as an IRC --- message (e.g. using PRIVMSG). --- --- The combinators are: --- --- * '#>', '<#' : Apply a style to a styled string --- * '<>' : Styles strings are monoids, use '<>' to concatenate them --- --- The tools for choosing styles for application are: --- --- * 'Color' : Choose a (foreground) color --- * 'Decoration' : Choose a decoration style, e.g. bold or underline --- * 'fg' : Choose a foreground color, you can use the 'Color' itself directly --- * 'bg' : Choose background color --- * 'fgBg' : Choose both colors --- --- Once you build the styled string, use 'encode' to obtain an encoded 'String' --- for use in IRC. --- --- Here are some examples. I assume here the @OverloadedStrings@ extension is --- enabled. If you prefer not to use it, you'll need to directly apply --- 'Pure' or 'fromString' to 'String's before styling (e.g. with '#>'). --- --- Green text: --- --- > Green #> "hello beautiful world" --- --- The same, but without the extension mentioned above: --- --- > Green #> Pure "hello beautiful world" --- --- Bold text: --- --- > Bold #> "hello beautiful world" --- --- Green text with some underlined text in the middle: --- --- > Green #> ("hello " <> Underline #> "beautiful" <> " world") --- --- Red text on gray background: --- --- > Red `fgBg` Gray #> "hello beautiful world" --- --- Text with a red underlined part in the middle, and the whole string with --- blue background: --- --- > ("hello " <> Red #> Underline #> "beaufitul" <> " world") <# bg Blue --- --- Three letters. The first is lime-on-black and bold. The second is --- black-on-line. The third is again lime-on-black, and italicized: --- --- > Lime `fgBg` Black #> (Bold #> "A" <> Reverse #> "B" <> Italic #> "C") --- --- Bold, underlined purple-on-white text: --- --- > Bold #> Underline #> Purple `fgBg` White #> "hello beautiful world" module Network.IRC.Fun.Color - ( -- * Primary Toolkit - Color (..) - , Decoration (..) - , (#>) - , (<#) - , fg - , bg - , fgBg - , encode - -- * Underlying Types - , Style (..) - , StyledString (..) - , FgBg (..) - -- * Utilities - , RGB (..) - , toIrcRGB - , toTangoRGB - , strip + ( -- * Styling + module Network.IRC.Fun.Color.Style + -- * Formatting + , module Network.IRC.Fun.Color.Format + -- * Formatters + , module Network.IRC.Fun.Color.Format.Long ) where -import Data.Char (isDigit) -import Data.List (nub) -import Data.Monoid -import Data.String (IsString (..)) - -{- -TODO check out packages irc-colors, rainbow, colour, palette, color --} - -------------------------------------------------------------------------------- --- Classes -------------------------------------------------------------------------------- - --- | A class for types which add style formatting to a string. This is what --- makes '(#>)' and '(<#)' work. -class Style s where - style :: s -> StyledString -> StyledString - -------------------------------------------------------------------------------- --- Types -------------------------------------------------------------------------------- - --- | One of the 16 available color codes. -data Color - = White - | Black - | Navy - | Green - | Red - | Maroon - | Purple - | Orange - | Yellow - | Lime - | Teal - | Cyan - | Blue - | Magenta - | Gray - | Silver - deriving (Enum, Eq, Show) - --- | A color specified by its red, green and blue components. -data RGB a = RGB a a a deriving (Eq, Show) - --- | A text decoration style. -data Decoration - = Bold - | Italic - | Underline - | Reverse ---x | Plain - deriving (Eq, Show) - --- | A string tagged with style attributes. -data StyledString - = Pure String - | Colored (Maybe Color) (Maybe Color) StyledString - | Decorated Decoration StyledString - | Concat [StyledString] - deriving Show - --- A string with all styling applied to it specified explicitly. -data StyledChunk = StyledChunk FgBg [Decoration] String deriving Show - --- | A color decoration, specifying text foreground and background colors. -data FgBg = FgBg (Maybe Color) (Maybe Color) deriving (Eq, Show) - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -mappend' :: StyledString -> StyledString -> StyledString -mappend' (Concat l) (Concat m) = Concat $ l ++ m -mappend' str (Concat l) = Concat $ str : l -mappend' (Concat l) str = Concat $ l ++ [str] -mappend' s t = Concat [s, t] - -instance Monoid StyledString where - mempty = Pure "" - mappend = mappend' - -instance IsString StyledString where - fromString = Pure - -instance Style Color where - style color = Colored (Just color) Nothing - -instance Style FgBg where - style (FgBg f b) = Colored f b - -instance Style Decoration where - style = Decorated - -------------------------------------------------------------------------------- --- Functions -------------------------------------------------------------------------------- - --- | Apply a style to a given string. -(#>) :: Style s => s -> StyledString -> StyledString -(#>) = style -infixr 7 #> - --- | Apply a style to a given string. -(<#) :: Style s => StyledString -> s -> StyledString -(<#) = flip style -infixl 7 <# - --- | Create a foreground color style with a given color. -fg :: Color -> FgBg -fg color = FgBg (Just color) Nothing - --- | Create a background color style with a given color. -bg :: Color -> FgBg -bg color = FgBg Nothing (Just color) - --- | Create a color style with a given foreground and background colors. -fgBg :: Color -> Color -> FgBg -fgBg f b = FgBg (Just f) (Just b) - --- | The IRC color number (between 0 and 15 inclusive) of a given color. -colorNumber :: Color -> Int -colorNumber = fromEnum - --- | Return the default RGB values of IRC colors. Client often allow the user --- to change the values, but these are the defaults. -toIrcRGB :: Num a => Color -> RGB a -toIrcRGB White = RGB 0xff 0xff 0xff -toIrcRGB Black = RGB 0x00 0x00 0x00 -toIrcRGB Navy = RGB 0x00 0x00 0x7f -toIrcRGB Green = RGB 0x00 0x93 0x00 -toIrcRGB Red = RGB 0xff 0x00 0x00 -toIrcRGB Maroon = RGB 0x7f 0x00 0x00 -toIrcRGB Purple = RGB 0x9c 0x00 0x9c -toIrcRGB Orange = RGB 0xfc 0x7f 0x00 -toIrcRGB Yellow = RGB 0xff 0xff 0x00 -toIrcRGB Lime = RGB 0x00 0xfc 0x00 -toIrcRGB Teal = RGB 0x00 0x93 0x93 -toIrcRGB Cyan = RGB 0x00 0xff 0xff -toIrcRGB Blue = RGB 0x00 0x00 0xfc -toIrcRGB Magenta = RGB 0xff 0x00 0xff -toIrcRGB Gray = RGB 0x7f 0x7f 0x7f -toIrcRGB Silver = RGB 0xd2 0xd2 0xd2 - --- | Return RGB values for color codes, using the Tango color scheme. It is a --- rough mapping between IRC color names and the 16 terminal colors. -toTangoRGB :: Num a => Color -> RGB a -toTangoRGB White = RGB 0xee 0xee 0xec -toTangoRGB Black = RGB 0x00 0x00 0x00 -toTangoRGB Navy = RGB 0x34 0x65 0xa4 -toTangoRGB Green = RGB 0x4e 0x9a 0x06 -toTangoRGB Red = RGB 0xef 0x29 0x29 -toTangoRGB Maroon = RGB 0xcc 0x00 0x00 -toTangoRGB Purple = RGB 0x75 0x50 0x7b -toTangoRGB Orange = RGB 0xc4 0xa0 0x00 -toTangoRGB Yellow = RGB 0xfc 0xe9 0x4f -toTangoRGB Lime = RGB 0x8a 0xe2 0x34 -toTangoRGB Teal = RGB 0x06 0x98 0x9a -toTangoRGB Cyan = RGB 0x34 0xe2 0xe2 -toTangoRGB Blue = RGB 0x73 0x9f 0xcf -toTangoRGB Magenta = RGB 0xad 0x7f 0xa8 -toTangoRGB Gray = RGB 0x55 0x57 0x53 -toTangoRGB Silver = RGB 0xd3 0xd7 0xcf - -decoCode :: Decoration -> Char -decoCode Bold = '\x02' -decoCode Italic = '\x1d' -decoCode Underline = '\x1f' -decoCode Reverse = '\x16' ---decorationCode Plain = '\x0f' - -colorChar = '\x03' - -colorCode :: Maybe Color -> Maybe Color -> String -colorCode Nothing Nothing = "" -colorCode (Just f) Nothing = colorChar : show (colorNumber f) -colorCode Nothing (Just b) = colorChar : ',' : show (colorNumber b) -colorCode (Just f) (Just b) = - colorChar : show (colorNumber f) ++ ',' : show (colorNumber b) - --- Apply color to a flat styled string -applyColor :: Maybe Color -> Maybe Color -> [StyledChunk] -> [StyledChunk] -applyColor f' b' = map h - where - g Nothing (Just c) = Just c - g curr _ = curr - h (StyledChunk (FgBg f b) d s) = StyledChunk (FgBg (g f f') (g b b')) d s - --- Apply decoration to a flat styled string -applyDeco :: Decoration -> [StyledChunk] -> [StyledChunk] -applyDeco d = map h - where - g ds d = if {-Plain `elem` ds ||-} d `elem` ds then ds else d : ds - h (StyledChunk c ds s) = StyledChunk c (g ds d) s - --- Tag the actual strings with all the hierarchically attached styles -flatten :: StyledString -> [StyledChunk] -flatten (Pure s) = [StyledChunk (FgBg Nothing Nothing) [] s] -flatten (Colored f b s) = applyColor f b $ flatten s -flatten (Decorated d s) = applyDeco d $ flatten s -flatten (Concat ss) = concatMap flatten ss - --- If a message to be colored starts with a digit, insert dummy codes to --- separate the text from the color code number -protect :: String -> String -protect [] = [] -protect s@(d:r) = - if isDigit d - then decoCode Bold : decoCode Bold : s - else s - -encodeColor :: Maybe Color -> Maybe Color -> String -> String -encodeColor Nothing Nothing s = s -encodeColor f b s = colorCode f b ++ protect s ++ [colorChar] - -encodeDeco :: [Decoration] -> String -> String -encodeDeco ds s = foldl f s $ nub ds - where - f s' d = let c = decoCode d in c : s' ++ [c] - --- | Convert a styled string value into an IRC style-coded text message. -encode :: StyledString -> String -encode = concatMap f . flatten - where - f (StyledChunk (FgBg f b) ds s) = encodeDeco ds $ encodeColor f b s - --- | Remove style from a string, returning just the content. -strip :: StyledString -> String -strip (Pure s) = s -strip (Colored _ _ s) = strip s -strip (Decorated _ s) = strip s -strip (Concat l) = concatMap strip l - --- this is cool, but only do this if it doesn't take too much time... ---decode ::String -> StyledString +import Network.IRC.Fun.Color.Style +import Network.IRC.Fun.Color.Format +import Network.IRC.Fun.Color.Format.Long diff --git a/src/Network/IRC/Fun/Color/Format.hs b/src/Network/IRC/Fun/Color/Format.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Color/Format.hs @@ -0,0 +1,47 @@ +{- This file is part of irc-fun-color. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Network.IRC.Fun.Color.Format + ( format + , lformat + ) +where + +{- +components: + +- Format type +- format, lformat +- text, ltext +- printing into stdout or handle or connection? perhaps the latter should be + in irc-fun-client, will also save the annoying MsgContent ctor everywhere, + maybe also make MsgContent a Monoid instance? +- long formatters +- short formatters +- irc specific long formatters +- irc specific short formatters +-} + +import qualified Data.Text as T (Text) +import qualified Data.Text.Lazy as TL (Text) +import qualified Formatting as F + +-- | Run the formatter and return a strict 'T.Text' value. +format :: F.Format T.Text a -> a +format = F.sformat + +-- | Run the formatter and return a lazy 'LT.Text' value. +lformat :: F.Format TL.Text a -> a +lformat = F.format diff --git a/src/Network/IRC/Fun/Color/Format/Long.hs b/src/Network/IRC/Fun/Color/Format/Long.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Color/Format/Long.hs @@ -0,0 +1,56 @@ +{- This file is part of irc-fun-color. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Network.IRC.Fun.Color.Format.Long + ( text + , ltext + , styled + , nickname + , channel + , message + ) +where + +import Data.Text.Lazy.Builder (fromText) +import Network.IRC.Fun.Color.Style (StyledText, encode) +import Network.IRC.Fun.Types + +import qualified Data.Text as T (Text) +import qualified Data.Text.Lazy as TL (Text) +import qualified Formatting as F + +-- | Output a strict 'T.Text'. +text :: F.Format r (T.Text -> r) +text = F.stext + +-- | Output a lazy 'TL.Text'. +ltext :: F.Format r (TL.Text -> r) +ltext = F.text + +-- | Render an IRC styled message. +styled :: F.Format r (StyledText -> r) +styled = F.later $ fromText . encode + +-- | Output an IRC nickname as plain text. +nickname :: F.Format r (Nickname -> r) +nickname = F.later $ fromText . unNickname + +-- | Output an IRC channel name as plain text. +channel :: F.Format r (Channel -> r) +channel = F.later $ fromText . unChannel + +-- | Output IRC message content as plain text. +message :: F.Format r (MsgContent -> r) +message = F.later $ fromText . unMsgContent diff --git a/src/Network/IRC/Fun/Color/Format/Short.hs b/src/Network/IRC/Fun/Color/Format/Short.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Color/Format/Short.hs @@ -0,0 +1,56 @@ +{- This file is part of irc-fun-color. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Network.IRC.Fun.Color.Format.Short + ( t + , lt + , stl + , nick + , chan + , msg + ) +where + +import Formatting (Format) +import Network.IRC.Fun.Color.Format.Long +import Network.IRC.Fun.Color.Style (StyledText) +import Network.IRC.Fun.Types + +import qualified Data.Text as T (Text) +import qualified Data.Text.Lazy as TL (Text) + +-- | Output a strict 'T.Text'. +t :: Format r (T.Text -> r) +t = text + +-- | Output a lazy 'TL.Text'. +lt :: Format r (TL.Text -> r) +lt = ltext + +-- | Render an IRC styled message. +stl :: Format r (StyledText -> r) +stl = styled + +-- | Output an IRC nickname as plain text. +nick :: Format r (Nickname -> r) +nick = nickname + +-- | Output an IRC channel name as plain text. +chan :: Format r (Channel -> r) +chan = channel + +-- | Output IRC message content as plain text. +msg :: Format r (MsgContent -> r) +msg = message diff --git a/src/Network/IRC/Fun/Color/Style.hs b/src/Network/IRC/Fun/Color/Style.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Color/Style.hs @@ -0,0 +1,369 @@ +{- This file is part of irc-fun-color. + - + - Written in 2015, 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +-- | This module allows you to add color and style to IRC text messages. +-- Decoding style-encoded messages isn't implemented currently. +-- +-- Building styled strings is done in two steps: +-- +-- (1) Construct the string using combinators +-- (2) Encode it into the IRC message styling format +-- +-- The result you get is a style-encoded 'T.Text' which you can send as an IRC +-- message (e.g. using PRIVMSG). +-- +-- The combinators are: +-- +-- * '#>', '<#' : Apply a style to a styled string +-- * '<>' : Styles strings are monoids, use '<>' to concatenate them +-- +-- The tools for choosing styles for application are: +-- +-- * 'Color' : Choose a (foreground) color +-- * 'Decoration' : Choose a decoration style, e.g. bold or underline +-- * 'fg' : Choose a foreground color, you can use the 'Color' itself directly +-- * 'bg' : Choose background color +-- * 'fgBg' : Choose both colors +-- +-- Once you build the styled string, use 'encode' to obtain an encoded 'String' +-- for use in IRC. +-- +-- Here are some examples. I assume here the @OverloadedStrings@ extension is +-- enabled. If you prefer not to use it, you'll need to directly apply 'plain' +-- to 'Text's before styling (e.g. with '#>'). +-- +-- Green text: +-- +-- > Green #> "hello beautiful world" +-- +-- The same, but without the extension mentioned above: +-- +-- > Green #> plain "hello beautiful world" +-- +-- Bold text: +-- +-- > Bold #> "hello beautiful world" +-- +-- Green text with some underlined text in the middle: +-- +-- > Green #> ("hello " <> Underline #> "beautiful" <> " world") +-- +-- Red text on gray background: +-- +-- > Red `fgBg` Gray #> "hello beautiful world" +-- +-- Text with a red underlined part in the middle, and the whole string with +-- blue background: +-- +-- > ("hello " <> Red #> Underline #> "beaufitul" <> " world") <# bg Blue +-- +-- Three letters. The first is lime-on-black and bold. The second is +-- black-on-line. The third is again lime-on-black, and italicized: +-- +-- > Lime `fgBg` Black #> (Bold #> "A" <> Reverse #> "B" <> Italic #> "C") +-- +-- Bold, underlined purple-on-white text: +-- +-- > Bold #> Underline #> Purple `fgBg` White #> "hello beautiful world" +module Network.IRC.Fun.Color.Style + ( -- * Primary Toolkit + Color (..) + , Decoration (..) + , (#>) + , (<#) + , plain + , fmt + , fg + , bg + , fgBg + , encode + -- * Underlying Types + , Style (..) + , StyledText () + , FgBg () + -- * Utilities + , RGB (..) + , toIrcRGB + , toTangoRGB + , strip + ) +where + +import Data.Char (isDigit) +import Data.Foldable (foldr) +import Data.List (intercalate, nub, sort) +import Data.Monoid +import Data.String (IsString (..)) +import Formatting.Internal (Format (..)) +import Prelude hiding (foldr) +import TextShow (showt) + +import qualified Data.DList as D +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL (toStrict) +import qualified Data.Text.Lazy.Builder as TLB (toLazyText) + +{- +TODO check out packages irc-colors, rainbow, colour, palette, color +-} + +------------------------------------------------------------------------------- +-- Classes +------------------------------------------------------------------------------- + +-- | A class for types which add style formatting to a string. This is what +-- makes '(#>)' and '(<#)' work. +class Style s where + style :: s -> StyledText -> StyledText + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- | One of the 16 available color codes. +data Color + = White + | Black + | Navy + | Green + | Red + | Maroon + | Purple + | Orange + | Yellow + | Lime + | Teal + | Cyan + | Blue + | Magenta + | Gray + | Silver + deriving (Enum, Eq, Show) + +-- | A color specified by its red, green and blue components. +data RGB a = RGB a a a deriving (Eq, Show) + +-- | A text decoration style. +data Decoration + = Bold + | Italic + | Underline + | Reverse +--x | Plain + deriving (Eq, Show) + +-- | A string tagged with style attributes. +data StyledText + = Pure T.Text + | Colored (Maybe Color) (Maybe Color) StyledText + | Decorated Decoration StyledText + | Concat (D.DList StyledText) + deriving Show + +-- A string with all styling applied to it specified explicitly. +data StyledChunk = StyledChunk FgBg [Decoration] T.Text deriving Show + +-- | A color decoration, specifying text foreground and background colors. +data FgBg = FgBg (Maybe Color) (Maybe Color) deriving (Eq, Show) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +mappend' :: StyledText -> StyledText -> StyledText +mappend' (Concat l) (Concat m) = Concat $ l <> m +mappend' str (Concat l) = Concat $ str `D.cons` l +mappend' (Concat l) str = Concat $ l `D.snoc` str +mappend' s t = Concat $ D.singleton s `D.snoc` t + +instance Monoid StyledText where + mempty = Pure mempty + mappend = mappend' + +instance IsString StyledText where + fromString = Pure . fromString + +instance Style Color where + style color = Colored (Just color) Nothing + +instance Style FgBg where + style (FgBg f b) = Colored f b + +instance Style Decoration where + style = Decorated + +------------------------------------------------------------------------------- +-- Functions +------------------------------------------------------------------------------- + +-- | Apply a style to a given string. +(#>) :: Style s => s -> StyledText -> StyledText +(#>) = style +infixr 7 #> + +-- | Apply a style to a given string. +(<#) :: Style s => StyledText -> s -> StyledText +(<#) = flip style +infixl 7 <# + +-- | Create a plain-text styled text. +plain :: T.Text -> StyledText +plain = Pure + +-- | Create plain text using formatting. This is simply a shortcut that is +-- equivalent to using 'Network.IRC.Fun.Color.Format.format' to get a strict +-- 'T.Text' and applying 'plain' to that. +fmt :: Format StyledText a -> a +fmt m = runFormat m (Pure . TL.toStrict . TLB.toLazyText) + +-- | Create a foreground color style with a given color. +fg :: Color -> FgBg +fg color = FgBg (Just color) Nothing + +-- | Create a background color style with a given color. +bg :: Color -> FgBg +bg color = FgBg Nothing (Just color) + +-- | Create a color style with a given foreground and background colors. +fgBg :: Color -> Color -> FgBg +fgBg f b = FgBg (Just f) (Just b) + +-- | The IRC color number (between 0 and 15 inclusive) of a given color. +colorNumber :: Color -> Int +colorNumber = fromEnum + +-- | Return the default RGB values of IRC colors. Client often allow the user +-- to change the values, but these are the defaults. +toIrcRGB :: Num a => Color -> RGB a +toIrcRGB White = RGB 0xff 0xff 0xff +toIrcRGB Black = RGB 0x00 0x00 0x00 +toIrcRGB Navy = RGB 0x00 0x00 0x7f +toIrcRGB Green = RGB 0x00 0x93 0x00 +toIrcRGB Red = RGB 0xff 0x00 0x00 +toIrcRGB Maroon = RGB 0x7f 0x00 0x00 +toIrcRGB Purple = RGB 0x9c 0x00 0x9c +toIrcRGB Orange = RGB 0xfc 0x7f 0x00 +toIrcRGB Yellow = RGB 0xff 0xff 0x00 +toIrcRGB Lime = RGB 0x00 0xfc 0x00 +toIrcRGB Teal = RGB 0x00 0x93 0x93 +toIrcRGB Cyan = RGB 0x00 0xff 0xff +toIrcRGB Blue = RGB 0x00 0x00 0xfc +toIrcRGB Magenta = RGB 0xff 0x00 0xff +toIrcRGB Gray = RGB 0x7f 0x7f 0x7f +toIrcRGB Silver = RGB 0xd2 0xd2 0xd2 + +-- | Return RGB values for color codes, using the Tango color scheme. It is a +-- rough mapping between IRC color names and the 16 terminal colors. +toTangoRGB :: Num a => Color -> RGB a +toTangoRGB White = RGB 0xee 0xee 0xec +toTangoRGB Black = RGB 0x00 0x00 0x00 +toTangoRGB Navy = RGB 0x34 0x65 0xa4 +toTangoRGB Green = RGB 0x4e 0x9a 0x06 +toTangoRGB Red = RGB 0xef 0x29 0x29 +toTangoRGB Maroon = RGB 0xcc 0x00 0x00 +toTangoRGB Purple = RGB 0x75 0x50 0x7b +toTangoRGB Orange = RGB 0xc4 0xa0 0x00 +toTangoRGB Yellow = RGB 0xfc 0xe9 0x4f +toTangoRGB Lime = RGB 0x8a 0xe2 0x34 +toTangoRGB Teal = RGB 0x06 0x98 0x9a +toTangoRGB Cyan = RGB 0x34 0xe2 0xe2 +toTangoRGB Blue = RGB 0x73 0x9f 0xcf +toTangoRGB Magenta = RGB 0xad 0x7f 0xa8 +toTangoRGB Gray = RGB 0x55 0x57 0x53 +toTangoRGB Silver = RGB 0xd3 0xd7 0xcf + +decoCode :: Decoration -> Char +decoCode Bold = '\x02' +decoCode Italic = '\x1d' +decoCode Underline = '\x1f' +decoCode Reverse = '\x16' +--decorationCode Plain = '\x0f' + +colorChar :: Char +colorChar = '\x03' + +colorCode :: Maybe Color -> Maybe Color -> T.Text +colorCode Nothing Nothing = T.empty +colorCode (Just f) Nothing = colorChar `T.cons` showt (colorNumber f) +colorCode Nothing (Just b) = + colorChar `T.cons` ',' `T.cons` showt (colorNumber b) +colorCode (Just f) (Just b) = T.concat + [ T.singleton colorChar + , showt (colorNumber f) + , T.singleton ',' + , showt (colorNumber b) + ] + +-- Apply color to a flat styled string +applyColor + :: Maybe Color + -> Maybe Color + -> D.DList StyledChunk + -> D.DList StyledChunk +applyColor f' b' = fmap h + where + g Nothing (Just c) = Just c + g curr _ = curr + h (StyledChunk (FgBg f b) d s) = StyledChunk (FgBg (g f f') (g b b')) d s + +-- Apply decoration to a flat styled string +applyDeco :: Decoration -> D.DList StyledChunk -> D.DList StyledChunk +applyDeco d = fmap h + where + g ds d = if {-Plain `elem` ds ||-} d `elem` ds then ds else d : ds + h (StyledChunk c ds s) = StyledChunk c (g ds d) s + +-- Tag the actual strings with all the hierarchically attached styles +flatten :: StyledText -> D.DList StyledChunk +flatten (Pure t) = D.singleton $ StyledChunk (FgBg Nothing Nothing) [] t +flatten (Colored f b s) = applyColor f b $ flatten s +flatten (Decorated d s) = applyDeco d $ flatten s +flatten (Concat ss) = foldr (\ q qs -> flatten q <> qs) D.empty ss + +-- If a message to be colored starts with a digit, insert dummy codes to +-- separate the text from the color code number +protect :: T.Text -> T.Text +protect t = + case T.uncons t of + Nothing -> T.empty + Just (d, r) -> + if isDigit d + then decoCode Bold `T.cons` decoCode Bold `T.cons` t + else t + +encodeColor :: Maybe Color -> Maybe Color -> T.Text -> T.Text +encodeColor Nothing Nothing t = t +encodeColor f b t = colorCode f b <> protect t `T.snoc` colorChar + +encodeDeco :: [Decoration] -> T.Text -> T.Text +encodeDeco ds s = foldl f s $ nub ds + where + f s' d = let c = decoCode d in c `T.cons` s' `T.snoc` c + +-- | Convert a styled string value into an IRC style-coded text message. +encode :: StyledText -> T.Text +encode = foldr (\ sc t -> f sc <> t) T.empty . flatten + where + f (StyledChunk (FgBg f b) ds s) = encodeDeco ds $ encodeColor f b s + +-- | Remove style from a string, returning just the content. +strip :: StyledText -> T.Text +strip (Pure s) = s +strip (Colored _ _ s) = strip s +strip (Decorated _ s) = strip s +strip (Concat l) = foldr (\ st t -> strip st <> t) T.empty l + +-- this is cool, but only do this if it doesn't take too much time... +--decode :: T.Text -> StyledText diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -17,10 +17,13 @@ import Data.List (findIndex) import Data.Monoid ((<>)) +import Data.Text (Text, pack) +import Data.Text.IO (putStrLn) import Network.IRC.Fun.Color +import Prelude hiding (putStrLn) import System.Exit (exitFailure) -cases :: [(StyledString, String, String)] +cases :: [(StyledText, Text, Text)] cases = [ ( Green #> "hello beautiful world" , "\ETX3hello beautiful world\ETX" @@ -52,7 +55,7 @@ ) ] -results :: [(Bool, String, Bool, String)] +results :: [(Bool, Text, Bool, Text)] results = map f cases where f (styled, encoded, stripped) = @@ -60,7 +63,10 @@ s = strip styled in (e == encoded, e, s == stripped, s) -failure :: Maybe (Int, Bool, StyledString, String, String) +showt :: Show a => a -> Text +showt = pack . show + +failure :: Maybe (Int, Bool, StyledText, Text, Text) failure = do loc <- findIndex (\ (e, _, s, _) -> not (e && s)) results case (cases !! loc, results !! loc) of @@ -70,12 +76,12 @@ Just (loc + 1, False, styled, stripped, s) _ -> error "Test impl error" -putFailure :: Int -> Bool -> StyledString -> String -> String -> IO () +putFailure :: Int -> Bool -> StyledText -> Text -> Text -> IO () putFailure n enc styled expected got = do - putStrLn $ "TEST " ++ show n ++ " FAILED:" - putStrLn $ (if enc then "encode " else "strip ") ++ show styled - putStrLn $ "Expected: " ++ show expected - putStrLn $ "Got: " ++ show got + putStrLn $ "TEST " <> showt n <> " FAILED:" + putStrLn $ (if enc then "encode " else "strip ") <> showt styled + putStrLn $ "Expected: " <> showt expected + putStrLn $ "Got: " <> showt got main :: IO () main =