module Language.Haskell.HsColour.MIRC (hscolour) where
import Language.Haskell.HsColour.Classify as Classify
import Language.Haskell.HsColour.Colourise
import Data.Char(isAlphaNum)
hscolour :: ColourPrefs
-> String
-> String
hscolour :: ColourPrefs -> String -> String
hscolour pref :: ColourPrefs
pref = ((TokenType, String) -> String) -> [(TokenType, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ColourPrefs -> (TokenType, String) -> String
renderToken ColourPrefs
pref) ([(TokenType, String)] -> String)
-> (String -> [(TokenType, String)]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(TokenType, String)]
tokenise
renderToken :: ColourPrefs -> (TokenType,String) -> String
renderToken :: ColourPrefs -> (TokenType, String) -> String
renderToken pref :: ColourPrefs
pref (t :: TokenType
t,s :: String
s) = [Highlight] -> String -> String
fontify (ColourPrefs -> TokenType -> [Highlight]
colourise ColourPrefs
pref TokenType
t) String
s
fontify :: [Highlight] -> String -> String
fontify hs :: [Highlight]
hs =
MircColour -> String -> String
mircColours ([Highlight] -> MircColour
joinColours [Highlight]
hs)
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Highlight] -> String -> String
highlight ((Highlight -> Bool) -> [Highlight] -> [Highlight]
forall a. (a -> Bool) -> [a] -> [a]
filter (Highlight -> [Highlight] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`[Highlight
Normal,Highlight
Bold,Highlight
Underscore,Highlight
ReverseVideo]) [Highlight]
hs)
where
highlight :: [Highlight] -> String -> String
highlight [] s :: String
s = String
s
highlight (h :: Highlight
h:hs :: [Highlight]
hs) s :: String
s = Highlight -> String -> String
font Highlight
h ([Highlight] -> String -> String
highlight [Highlight]
hs String
s)
font :: Highlight -> String -> String
font Normal s :: String
s = String
s
font Bold s :: String
s = '\^B'Char -> String -> String
forall a. a -> [a] -> [a]
:String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++"\^B"
font Underscore s :: String
s = '\^_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++"\^_"
font ReverseVideo s :: String
s = '\^V'Char -> String -> String
forall a. a -> [a] -> [a]
:String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++"\^V"
data MircColour = Mirc { MircColour -> Colour
fg::Colour, MircColour -> Bool
dim::Bool, MircColour -> Maybe Colour
bg::Maybe Colour, MircColour -> Bool
blink::Bool}
joinColours :: [Highlight] -> MircColour
joinColours :: [Highlight] -> MircColour
joinColours = (Highlight -> MircColour -> MircColour)
-> MircColour -> [Highlight] -> MircColour
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Highlight -> MircColour -> MircColour
join (Mirc :: Colour -> Bool -> Maybe Colour -> Bool -> MircColour
Mirc {fg :: Colour
fg=Colour
Black, dim :: Bool
dim=Bool
False, bg :: Maybe Colour
bg=Maybe Colour
forall a. Maybe a
Nothing, blink :: Bool
blink=Bool
False})
where
join :: Highlight -> MircColour -> MircColour
join Blink mirc :: MircColour
mirc = MircColour
mirc {blink :: Bool
blink=Bool
True}
join Dim mirc :: MircColour
mirc = MircColour
mirc {dim :: Bool
dim=Bool
True}
join (Foreground fg :: Colour
fg) mirc :: MircColour
mirc = MircColour
mirc {fg :: Colour
fg=Colour
fg}
join (Background bg :: Colour
bg) mirc :: MircColour
mirc = MircColour
mirc {bg :: Maybe Colour
bg=Colour -> Maybe Colour
forall a. a -> Maybe a
Just Colour
bg}
join Concealed mirc :: MircColour
mirc = MircColour
mirc {fg :: Colour
fg=Colour
Black, bg :: Maybe Colour
bg=Colour -> Maybe Colour
forall a. a -> Maybe a
Just Colour
Black}
join _ mirc :: MircColour
mirc = MircColour
mirc
mircColours :: MircColour -> String -> String
mircColours :: MircColour -> String -> String
mircColours (Mirc fg :: Colour
fg dim :: Bool
dim Nothing blink :: Bool
blink) s :: String
s = '\^C'Char -> String -> String
forall a. a -> [a] -> [a]
: Colour -> Bool -> String
code Colour
fg Bool
dimString -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++"\^O"
mircColours (Mirc fg :: Colour
fg dim :: Bool
dim (Just bg :: Colour
bg) blink :: Bool
blink) s :: String
s = '\^C'Char -> String -> String
forall a. a -> [a] -> [a]
: Colour -> Bool -> String
code Colour
fg Bool
dimString -> String -> String
forall a. [a] -> [a] -> [a]
++','
Char -> String -> String
forall a. a -> [a] -> [a]
: Colour -> Bool -> String
code Colour
bg Bool
blinkString -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++"\^O"
code :: Colour -> Bool -> String
code :: Colour -> Bool -> String
code Black False = "01"
code Red False = "05"
code Green False = "03"
code Yellow False = "07"
code Blue False = "02"
code Magenta False = "06"
code Cyan False = "10"
code White False = "00"
code Black True = "14"
code Red True = "04"
code Green True = "09"
code Yellow True = "08"
code Blue True = "12"
code Magenta True = "13"
code Cyan True = "11"
code White True = "15"
code c :: Colour
c@(Rgb _ _ _) b :: Bool
b = Colour -> Bool -> String
code (Colour -> Colour
projectToBasicColour8 Colour
c) Bool
b