Untitled

{-
Zen coding shizzle:

*Main> process "html>(head>(title+meta)+body>p.intro)"
<html>
   <head>
      <title>
      </title>
      <meta />
   </head>
   <body>
      <p class="intro">
      </p>
   </body>
</html>

*Main> process "div#news.module>(div.header+div.body>ul>li#item-$*5)"
<div id="news" class="module">
   <div class="header">
   </div>
   <div class="body">
      <ul>
         <li id="item-1">
         </li>
         <li id="item-2">
         </li>
         <li id="item-3">
         </li>
         <li id="item-4">
         </li>
         <li id="item-5">
         </li>
      </ul>
   </div>
</div>

Use in emacs like this:

(defun zencode ()
  "Zen Coding utility."
  (interactive)
  (shell-command-on-region
   (line-beginning-position)
   (line-end-position)
   "/home/chris/Programs/bin/zencoding"
   t))
(define-key sgml-mode-map (kbd "\C-c \C-v") 'zencode)

-}
import System.Environment
import Control.Arrow (second)
import Text.ParserCombinators.Parsec
import Control.Applicative ((<$>))
import Text.XHtml (Html,(<<),(+++),(!))
import qualified Text.XHtml as XHTML
data Eye = TagName String
         | Tag String [(String,String)]
         | MultiTag Eye Int
         | Cons Eye Eye
         | List [Eye]
         deriving Show
main = interact $ process . concat . map replace
    -- strip out spaces (no need for them)
    where replace ' ' = []
          replace c = [c]
transform :: Maybe Int -> Eye -> (Html -> Html)
transform _ (MultiTag tag n) =
    \x -> XHTML.concatHtml $ map (<<x) $
            zipWith transform (map Just [1..]) $ replicate n tag
transform _ (TagName tagname) = XHTML.tag tagname
transform (Just i) (Tag tagname attrs) =
    XHTML.tag tagname ! map (uncurry XHTML.strAttr . additer) attrs where
        additer = second $ foldr replace [] where replace '$' = (show i++)
                                                  replace c = (c:)
transform _ (Tag tagname attrs) =
    XHTML.tag tagname ! map (uncurry XHTML.strAttr) attrs
transform i (Cons parent children) =
    (\x -> transform i parent << transform i children << x)
transform i (List eyes) =
    (\x -> foldr join XHTML.noHtml eyes) where
    join a r = (transform i a << XHTML.noHtml) +++ r
op :: Char -> Parser Char
op e = spaces >> char e >>= \e -> spaces >> return e
expr = try pexpr <|> try list <|> try consexpr <|> parens list
pexpr = parens expr
parens p = do op '('
              e <-  p
              op ')'
              return e
cons = do a <- tag
          op '>'
          b <- try pexpr <|> try cons <|> tag
          return $ Cons a b
consexpr = try (parens cons) <|> try cons <|> tag
list :: Parser Eye
list = do t <- consexpr
          op '+'
          r <- try (parens list) <|> try list <|> consexpr
          return $ List $ t : (case r of List rs -> rs; otherwise -> [r])

tag :: Parser Eye
tag = try tagMulti <|> tagMaybeProps

tagMulti :: Parser Eye
tagMulti = do t <- tagMaybeProps
              char '*'
              count <- read <$> many digit
              return $ MultiTag t count

tagMaybeProps :: Parser Eye
tagMaybeProps = try tagWithProps <|> tagName

tagWithProps :: Parser Eye
tagWithProps = do (Tag t props) <- tagName
                  op '['
                  props' <- many1 prop
                  op ']'
                  return $ Tag t (props ++ props')

prop :: Parser (String,String)
prop = do name <- name
          op '='
          value <- many1 $ satisfy $ not . flip any "]," . (==)
          many $ char ','
          return (name,value)

tagName :: Parser Eye
tagName = do
  n <- name
  id <- identifier <|> return ""
  classes <- many classname
  let idprop | null id = []
             | otherwise = [("id",id)]
      classprops = map ((,) "class") classes
  return $ Tag n $ idprop ++ classprops
  where
    idorclass = identifier <|> classname
    classname = char '.' >> name'
    identifier = char '#' >> name'
    name' = many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ "-$"

name = many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ":-"
process s = init $ case fragment of Right x -> x; _ -> ""
    where fragment = XHTML.prettyHtmlFragment . (\x -> x XHTML.noHtml)
                     . transform Nothing <$> flip parse "meye" expr s