ColorParser.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}

module ColorParser where

import Control.Monad
import Data.Aeson as A (ToJSON, Value, encode, object, (.=))
import Data.Aeson.Key (fromString)
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Char
import Data.Function
import Data.Functor
import Data.List
import Data.Void
import Debug.Trace
import GHC.Generics (Generic)
import System.Environment (getArgs)
import Text.Megaparsec
import Text.Megaparsec.Char

main :: IO ()
main = do
  path <-
    getArgs >>= \case
      [path] -> pure path
      _ -> fail "Usage: ColorParser <path>"
  file <- readFile path
  case parse colorBlocks path file of
    Left err -> putStrLn (errorBundlePretty err)
    Right colors -> do
      writeJSON colors
      writeCSS (colors & filter ((/= "100") . _colorNum))
      writeTailwindJSON (colors & filter ((/= "100") . _colorNum))

writeJSON :: [Color] -> IO ()
writeJSON colors =
  BS.writeFile "colors.json" (encode colors)

writeTailwindJSON :: [Color] -> IO ()
writeTailwindJSON colors = do
  let inner :: Value
      inner =
        colors
          & groupBy ((==) `on` _colorGroup)
          & map
            ( \gr ->
                fromString (map toLower (_colorGroup (head gr)))
                  .= object
                    ( gr
                        & map
                          ( \color ->
                              fromString (padStart 2 '0' (_colorNum color))
                                .= ("var(" ++ _colorCustomProperty color ++ ")")
                          )
                    )
            )
          & object
  BS.writeFile "tailwind.json" (encode inner)

writeCSS :: [Color] -> IO ()
writeCSS colors = do
  let cssInner =
        colors
          & groupBy ((==) `on` _colorGroup)
          & map
            ( \gr ->
                ( concat ["    /* ", _colorGroup (head gr), " */"]
                    : ( gr
                          & map
                            ( \color ->
                                concat ["    ", _colorCustomProperty color, ": ", _colorHex color, ";"]
                            )
                      )
                )
                  & unlines
            )
      css =
        [ "@layer base {",
          "  :root {",
          unlines cssInner,
          "  }",
          "}"
        ]
          & unlines

  writeFile "colors.css" css

-- @layer base {
--   :root {
--     --color-navy-05: #00131d;
--     --color-navy-10: #002639;
--     --color-navy-15: #05344c;
--     --color-navy-20: #144056;
--     --color-navy-30: #32586b;
--     --color-navy-40: #50707f;
--     --color-navy-50: #698290;
--     --color-navy-60: #8397a0;
--     --color-navy-70: #a6b5bc;
--     --color-navy-80: #c2cbd1;
--     --color-navy-90: #dee3e5;
--     --color-navy-95: #f1f1f2;
--     --color-navy-99: #fbfbfc;

--     --color-blue-05: #03131a;
--     --color-blue-10: #062738;
--     --color-blue-15: #093448;
--     --color-blue-20: #0b3f58;
--     --color-blue-30: #0f5678;
--     --color-blue-40: #136e99;
--     --color-blue-50: #1785bb;
--     --color-blue-60: #1d9dd9;
--     --color-blue-70: #37bfff;
--     --color-blue-80: #7bd4ff;
--     --color-blue-90: #beeaff;
--     --color-blue-95: #def4ff;
--     --color-blue-99: #f7fcff;
--   }
-- }

type Parser = Parsec Void String

colorName :: Parser (String, String)
colorName = do
  name <- some letterChar <* char '/'
  num <- some digitChar <* optional hspace1
  guard (length name > 2)
  let result = (name, num)
  -- trace ("Parsed colorName: " ++ result) (pure result)
  pure result

colorHex :: Parser String
colorHex = do
  hex <- char '#' *> count 6 hexDigitChar <* optional hspace1
  let result = '#' : hex
  -- trace ("Parsed colorHex: " ++ result) (pure result)
  pure result

colorBlock :: Parser [Color]
colorBlock = do
  names <- some (colorName <* newline)
  hexes <- some (colorHex <* optional newline)
  let result = names `zip` hexes
  -- trace ("Parsed colorBlock: " ++ show result) (pure result)
  pure
    ( result
        & map
          ( \((name_, num), hex_) ->
              Color
                (name_ ++ "/" ++ num)
                hex_
                ( "--"
                    ++ intercalate
                      "-"
                      [ "color",
                        map toLower name_,
                        padStart 2 '0' num
                      ]
                )
                name_
                num
          )
    )

padStart :: Int -> Char -> String -> String
padStart n c xs = replicate (n - length xs) c ++ xs

anyLine :: Parser ()
anyLine = void do
  someTill anySingle (void newline <|> eof)

-- traceM xs
-- trace "Parsed anyLine" (pure ())

colorBlocks :: Parser [Color]
colorBlocks = do
  blocks <- many (try colorBlock <|> anyLine $> [])
  -- blocks <- some colorBlock
  eof
  let result = concat blocks
  -- trace ("Parsed colorBlocks: " ++ show result) (pure result)
  pure result

data Color = Color
  { _colorName :: String,
    _colorHex :: String,
    _colorCustomProperty :: String,
    _colorGroup :: String,
    _colorNum :: String
  }
  deriving (Show, ToJSON, Generic)