irc-fun-color 0.1.0.1 → 0.2.0.0
raw patch · 11 files changed
+663/−394 lines, 11 filesdep +dlistdep +formattingdep +irc-fun-types
Dependencies added: dlist, formatting, irc-fun-types, text, text-show
Files
- NEWS +0/−49
- NEWS.md +79/−0
- README +0/−14
- README.md +14/−0
- irc-fun-color.cabal +18/−5
- src/Network/IRC/Fun/Color.hs +10/−318
- src/Network/IRC/Fun/Color/Format.hs +47/−0
- src/Network/IRC/Fun/Color/Format/Long.hs +56/−0
- src/Network/IRC/Fun/Color/Format/Short.hs +56/−0
- src/Network/IRC/Fun/Color/Style.hs +369/−0
- test/test.hs +14/−8
− NEWS
@@ -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)
+ NEWS.md view
@@ -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)
− README
@@ -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:--<http://hackage.haskell.org/package/irc-fun-color>--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.
+ README.md view
@@ -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:++<http://hackage.haskell.org/package/irc-fun-color>++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.
irc-fun-color.cabal view
@@ -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
src/Network/IRC/Fun/Color.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-color. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -13,324 +13,16 @@ - <http://creativecommons.org/publicdomain/zero/1.0/>. -} --- | 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
+ src/Network/IRC/Fun/Color/Format.hs view
@@ -0,0 +1,47 @@+{- This file is part of irc-fun-color.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ 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+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++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
+ src/Network/IRC/Fun/Color/Format/Long.hs view
@@ -0,0 +1,56 @@+{- This file is part of irc-fun-color.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ 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+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++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
+ src/Network/IRC/Fun/Color/Format/Short.hs view
@@ -0,0 +1,56 @@+{- This file is part of irc-fun-color.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ 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+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++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
+ src/Network/IRC/Fun/Color/Style.hs view
@@ -0,0 +1,369 @@+{- This file is part of irc-fun-color.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ 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+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- | 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
test/test.hs view
@@ -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 =