Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-
- 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
Add Comment
Please, Sign In to add comment