CssA.hs

{-# LANGUAGE OverloadedStrings #-}

module CssA where

import Data.Text hiding (concat, map)
import Text.XML.HXT.Core hiding (trace)

cssA :: (ArrowList a) => (Text, Text) -> a String String
cssA ("font-family", "serif") = arr $ ("\\textsf{"++) . (++"}")
cssA ("font-size", v) = arr $
                        (\s -> "\\fontsize{" ++ (unpack v) ++ "}{" 
                               ++ (unpack v) ++ "}\\selectfont " ++ s)
cssA ("display", "block") = arr (++"\\par\n")
cssA ("display", "inline") = this

csstex.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import System.Environment
import Text.CSS.Parse
import Data.Text hiding (concat, map)

import Text.Parsec hiding (many, (<|>))
import Control.Applicative
import Text.Parsec.Text

import Text.XML.HXT.Core hiding (trace)

import Debug.Trace

import CssA

main = do
  (fileName:_) <- getArgs
  contents <- readFile fileName
  let css = case parseNestedBlocks $ pack contents of
--              Right nb -> nb
--  putStrLn $ show css

--        Left error -> ???
        Right nb -> makeInstructions nb

  text <-runX (readDocument [] "test.html"
               >>>
               catA (map applyCss css)
              )
  putStrLn $ concat text
  return ()

applyCss :: (ArrowXml a) => CssInstruction -> a XmlTree String
applyCss (slctrs, instructions) = deepest $ ifA (seqA (map bySelector slctrs))
                                    (getChildren >>> getText
                                                 >>> seqA (map cssA instructions))
                                    (eelem "" >>> getText)

bySelector :: (ArrowXml a) => CssSelector -> a XmlTree XmlTree
bySelector (CSElement c _ True) = deepest $ (hasName (unpack c))
bySelector (CSElement c _ _) = hasName (unpack c)
bySelector (CSClass t) = hasAttrValue "class" (==(unpack t))
bySelector (CSId t) = hasAttrValue "id" (==(unpack t))
bySelector (CSAlt k v _ _) = hasAttrValue (unpack k) (==(unpack v))



-- parsing CSS selector

data CssSelector = CSElement { elemName :: Text
                             , isChild :: Bool
                             , isDescendant :: Bool}
                 | CSClass Text
                 | CSId Text
                 | CSAlt { altKey :: Text
                         , altVal :: Text
                         , includeVal :: Bool
                         , prefixMatch :: Bool}
                 | CSPseudo Text
                   deriving (Show)

data CssDirective = CssDirective Text [CssSelector]
                  deriving (Show)

type CssInstruction = ([CssSelector], [(Text, Text)])

makeInstructions :: [NestedBlock] -> [CssInstruction]
makeInstructions [] = []
makeInstructions (b@(LeafBlock _):bs) = (makeInstruction b):(makeInstructions bs)

makeInstruction :: NestedBlock -> CssInstruction
makeInstruction (LeafBlock cssblock) = (selectors s, snd cssblock)
  where s = fst cssblock
        selectors s = case parse parseSelector "" s of
--          Left _ -> ???
          Right slctrs -> slctrs


-- if the length is more than 1, it's a grouped/decendant/child selector.
parseSelector :: Parser [CssSelector]
parseSelector = do
  manyTill (choice [ try slctrElm <* spaces
                   , try slctrCls <* spaces
                   , try slctrIds <* spaces
                   , try slctrAlt <* spaces
                   ]) eof

parseDirective :: Parser CssDirective
parseDirective = CssDirective <$> (oneOf "@" *> slctrLetters <* spaces) <*> parseSelector

slctrLetters :: Parser Text
slctrLetters = pack <$> (string "*" <|> many1 alphaNum)
--selectorLetters = many1 $ choice [ try (letter <* (try $ lookAhead $ oneOf ".#"))
--                                 , letter]

slctrElm :: Parser CssSelector
slctrElm = do 
  separator <- many $ char ','
  spaces
  cld <- many $ char '>'
  spaces
  name <- slctrLetters
  return $ CSElement { elemName = name
                     , isChild = if "" == cld then False else True
                     , isDescendant = if "" == separator && "" == cld then True else False}

slctrCls :: Parser CssSelector
slctrCls = CSClass <$> (oneOf "." *> slctrLetters)

slctrIds :: Parser CssSelector
slctrIds = CSId <$> (oneOf "#" *> slctrLetters)

slctrAlt :: Parser CssSelector
slctrAlt = oneOf "[" *> altKeyVal <* oneOf "]"

altKeyVal :: Parser CssSelector
altKeyVal = do
  key <- pack <$> many1 alphaNum
  spaces
  tld <- many $ char '~'
  prf <- many $ char '|'
  spaces
  many $ string "="
  spaces
  val <- pack <$> many alphaNum
  many $ string "\""
  spaces
  return $ CSAlt { altKey = key, altVal = val
                 , includeVal = if "" == tld then False else True
                 , prefixMatch = if "" == prf then False else True}

my.css

p {display: block}

p.b {font-family: serif;
     font-size: 15pt}

test.html

<div>
<p class="a">
abc
</p>
<a src="foo.png"/>
<p class="b">
efg
</p>
</div>