module Yi.Style.EmacsColours.Internal where
import Data.Bits (shiftR)
import Data.Char (toLower, toUpper, isSpace)
import Data.List (nub)
import Data.List.Split (splitOn)
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Data.Word (Word32)
import Text.Read (readMaybe)
import Yi.Style (Color(RGB))
rgb :: Word32 -> Color
rgb x = RGB (fromIntegral (x `shiftR` 16))
(fromIntegral (x `shiftR` 8))
(fromIntegral x)
data ColInfo = ColInfo { _colRgb :: (String, String, String)
, _colHex :: (String, Color)
, _colNames :: [String]
} deriving (Eq, Show)
toHaskell :: String -> String
toHaskell xs =
let ns = catMaybes $ map mkCol (lines xs)
as = ms $ map (\ci -> (mkFn $ _colNames ci, ci)) ns
ms [] = []
ms ((Nothing, _):ys) = ms ys
ms ((Just y, c):ys) = (y, c) : ms ys
jn ci ci' = ci { _colNames = _colNames ci ++ _colNames ci' }
mp = M.fromListWith jn as
in unlines $ map (uncurry colToHaskell) (M.toList mp)
colToHaskell :: String -> ColInfo -> String
colToHaskell fn (ColInfo (r, g, b) (n, h) ns) = splice
where
mkRgb = "R" ++ r ++ " G" ++ g ++ " B" ++ b
mkName = "Names: @" ++ show (nub ns) ++ "@"
splice = unlines $
[ "-- | " ++ mkName
, "--"
, "-- " ++ mkRgb ++ ", " ++ n
, fn ++ " :: Color"
, fn ++ " = " ++ show h
]
mkFn :: [String] -> Maybe String
mkFn ns = case catMaybes $ map mkFn' ns of
[] -> Nothing
s:_ -> Just s
where
mkFn' pn = case dropWhile isSpace pn of
[] -> Nothing
s:ss -> Just $ toLower s : camelise ss
camelise xs = case splitOn " " xs of
[] -> []
z:zs -> z ++ concatMap firstUpper zs
firstUpper [] = []
firstUpper (c:cs) = toUpper c : cs
mkCol :: String -> Maybe ColInfo
mkCol s = case splitOn "\t" s of
[rgb', '#':hex', pn', sn'] -> case splitOn " " rgb' of
[r, g, b] -> case readMaybe $ "0x" ++ hex' of
Just hex'' ->
Just $ ColInfo (r, g, b) ("0x" ++ hex', rgb hex'') [pn', sn']
_ -> Nothing
_ -> Nothing
_ -> Nothing