Hackfoofery

Alson Kemp

Archive for the ‘Geekery’ Category

A HAML parser for Haskell

with 2 comments

HAML‘s lovely. As I’ve been working with Turbinado, I’ve been having some issues with HSP. HSP is an insanely impressive piece of software, but its error messages can be a bit unclear. So I started playing around a bit with HAML. Got me wondering “How easy would be to write a HAML parser in Haskell?”

So I tried. Here’s a first-pass, to-be-updated [and somewhat incomplete] HAML parser for Haskell. Not all of the features are implemented, but it’s a start.  It generates HTML bits suitable for compilation by GHC.

Input

f = content
 
page = #content
         .left.column
         %h2 Welcome to our site!
         %p = print_information
         %p
           = print_inline
         .right.column
           = render
         [abba = ding, ding = abba] dinger

Output

f =
    (stringToHtml "content")
page =
       ((tag "div"![strAttr "id" "content"])
         ((tag "div"![strAttr "class" "left column"])
         ((tag "h2")
             (stringToHtml "Welcome to our site!")
         )
         +++
         ((tag "p")
            (stringToHtml print_information)
         )
         +++
         ((tag "p")
           (stringToHtml print_inline)
         )
         +++
         ((tag "div"![strAttr "class" "right column"])
           (stringToHtml render)
         )
         +++
         ((tag "div"![strAttr "abba" "ding", strAttr "ding" "abba"])
                                    (stringToHtml "dinger")
         )
         )
       )

le Code

module Main where
 
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Language
import Text.ParserCombinators.Parsec.Pos
import qualified Text.ParserCombinators.Parsec.Token as T
import Data.Char
import Data.List
import Data.Maybe
import System.IO.Unsafe
 
main = do s <- getContents
          case (parse mainParser "stdin" s) of
            Left  err -> putStrLn "Error: " >> print err
            Right hs  -> putStrLn hs
 
-- Try to parse HAML, otherwise re-output raw lines
 
mainParser = do whiteSpace
                ls <- many1 (hamlCode <|> tilEOL)
                return $ unlines ls
--
-- * HAML lexer
--
hamlLexer = T.makeTokenParser emptyDef
whiteSpace= T.whiteSpace hamlLexer
lexeme    = T.lexeme hamlLexer
symbol    = T.symbol hamlLexer
natural   = T.natural hamlLexer
parens    = T.parens hamlLexer
semi      = T.semi hamlLexer
squares   = T.squares hamlLexer
stringLiteral= T.stringLiteral hamlLexer
identifier= T.identifier hamlLexer
reserved  = T.reserved hamlLexer
reservedOp= T.reservedOp hamlLexer
commaSep1 = T.commaSep1 hamlLexer
--
-- * Main HAML parsers
--
 
-- hamlCode is just many identifiers (e.g. 'func a b c' followed by '=' followed by a hamlBlock
-- func a b c = %somehaml
hamlCode = try ( do is <- many1 identifier
                    symbol "="
                    currentPos <- getPosition
                    x <- manyTill1
                          (lexeme $ hamlBlock)
                          (notSameIndent currentPos)
                    return $ (concat $ intersperse " " is) ++
                             " = \n" ++
                             (concat $ (intersperse (indent currentPos ++ "+++\n")  $ filter (not . null) $ x))
                  )
 
-- A Block may start with some whitespace, then has a valid bit of data
hamlBlock   = do currentPos <- getPosition
                 bs <- manyTill1
                      (pTag <|> pText)
                      (notSameIndent currentPos)
                 return $ intercalate (indent currentPos ++ "+++\n") bs
 
pTag    = do    currentPos <- getPosition
                try
                    (do t  <- lexeme tagParser
                        ts <- (isInline currentPos >> char '/' >> return []) <|>
                              (hamlBlock)
                        return $ intercalate "\n" $ filter (not . null) $
                          [ (indent currentPos) ++ "((" ++ (if (null ts) then "i" else "") ++ t  ++ ")"
                          , if null ts then [] else ts
                          , (indent currentPos) ++ ")\n"]
                    )
 
pText = lexeme stringParser
 
notSameIndent p = (eof >> return []) <|>
                  (do innerPos <- getPosition
                      case (sourceColumn p) == (sourceColumn innerPos) of
                                True  -> pzero
                                False -> return []
                  )
 
--
-- * Various little parsers
--
 
tagParser :: CharParser () String
tagParser = do     t <- optionMaybe tagParser'
                   i <- optionMaybe idParser
                   c <- optionMaybe (many1 classParser)
                   a <- optionMaybe attributesParser
                   if (isJust t || isJust i || isJust c || isJust a)
                     then
                       do return $ "tag \"" ++ (fromMaybe "div" t) ++ "\"" ++
                           (if not (isJust i || isJust c || isJust a) then "" else
                              concat $
                               [ "!["
                               , intercalate ", " $ filter (not . null)
                                   [ (maybe "" (\i' -> "strAttr \"id\" \"" ++ i' ++ "\"") i)
                                   , (maybe "" (\c' -> "strAttr \"class\" \"" ++ (intercalate " " c') ++ "\"") c)
                                   , (maybe "" (\kv -> intercalate ", " $ map (\(k,v) -> "strAttr \"" ++ k ++ "\" \"" ++ v ++ "\"") kv) a)
                                   ]
                               , "]"]
                           )
                     else pzero
 
tagParser' :: CharParser () String
tagParser' =  do char '%'
                 many1 termChar
 
idParser :: CharParser () String
idParser = do char '#'
              many1 termChar
 
classParser :: CharParser () String
classParser = do char '.'
                 many1 termChar
 
attributesParser :: CharParser () [(String, String)]
attributesParser = squares (commaSep1 attributeParser)
 
attributeParser :: CharParser () (String, String)
attributeParser = do k <- identifier
                     symbol "="
                     cs <- many1 identifier
                     return (k, intercalate " " cs)
 
stringParser :: CharParser () String
stringParser = do   currentPos <- getPosition
                    modifier <- optionMaybe (char '=' <|> char '-')
                    whiteSpace
                    c <- alphaNum
                    cs<- tilEOL
                    case modifier of
                      Just '-' -> return $ (indent currentPos) ++ "-" ++ c:cs
                      Just '=' -> return $ (indent currentPos) ++ "(stringToHtml " ++ c:cs ++ ")"
                      Nothing  -> return $ (indent currentPos) ++ "(stringToHtml \"" ++ c:cs ++ "\")"
 
--
-- * Utility functions
--
 
isInline     p = do p2 <- getPosition
                    case (sourceLine p  ) == (sourceLine p2) of
                      True -> return []
                      False -> pzero
isSameIndent p1 p2 = (sourceColumn p1) == (sourceColumn p2)
 
tilEOL = manyTill1 (noneOf "\n") eol
eol = newline <|> (eof >> return '\n')
 
termChar = satisfy (\c -> (isAlphaNum c) || (c `elem` termPunctuation) )
termPunctuation = "-_"
indent p = take (sourceColumn (p) - 1) (repeat ' ')
 
manyTill1 p e =  do ms <- manyTill p e
                    case (null ms) of
                      True  -> pzero
                      False -> return ms

Golly, but I wish that I’d cleaned up the code, but there it is in all of its raw, un-thought-through glory…

Written by alson

December 11th, 2008 at 1:56 am

Posted in Geekery,Programming

Tagged with , ,

ANNOUNCE: Turbinado V0.2 “Still Ugly”

without comments

More progress on Turbinado. Look! A whole “+0.1″!

Progress continues on Turbinado.  Turbinado can be found at:
 http://www.turbinado.org

The source can be found at:
 http://github.com/alsonkemp/turbinado/tree/master
   (see the /App directory for the code for www.turbinado.org)

New in V0.2:
  * A better "Environment" type (rather than using Dynamics) (-> a 50%
speed boost?  That's unpossible!);
  * A functional early version of an ORM for PostgreSQL (note: still
needs to handle updates; hdbc-postgresql has a bug with sensing
nullable columns);
  * A prettier website;
  * Licensing -> BSD.

Expect V0.3 in the next week or so with:
  * More view helpers;
  * An ORM which handles INSERT/UPDATE...;
  * A little CMS built using the ORM.

Future release:
  * Separate the website out from the framework.  For now, they're
evolving together, so live together. 

Written by alson

November 26th, 2008 at 2:11 am

ANNOUNCE: Turbinado V0.1

without comments

Posted to the Haskell mailing list:

I'd like to announce Turbinado, a very young and raw MVC web framework
for Haskell.  While the framework doesn't exactly copy Ruby on Rails,
it certainly rhymes...  It's very early days for Turbinado, but the
framework is moving along nicely.  There are still issues to be ironed
out and architectural details to be decided, so help/contribution would be
very much appreciated.

Turbinado can be found at:
<a rel="nofollow" href="http://www.turbinado.org/" target="_top">http://www.turbinado.org</a>

The source can be found at:
<a rel="nofollow" href="http://github.com/alsonkemp/turbinado/tree/master" target="_top">http://github.com/alsonkemp/turbinado/tree/master</a>
(see the /App directory for the code for www.turbinado.org)

Turbinado:
* Provides a fast web server (based on HSP; see
<a rel="nofollow" href="http://turbinado.org/Home/Performance%29;" target="_top">http://turbinado.org/Home/Performance);</a>
* Provides a straightforward organization for your website (courtesy
of Rails);
* Uses simple HTML-like templating (courtesy of HSX);
* Is easily extensible (courtesy of an Environment built out of _Map
String Dynamic_, not the most type-safe of beasties; Help!);
* Configurable routing (see Config/Routes.hs).

Turbinado is currently lacking:
* Documentation...
* An easy install...
* A database ORM based on HDBC (visibly incomplete and ugly in
Turbinado/Database/ORM);
* Many more HTML helpers;
* Controllers for partials (lightweight "controls" ala ASP.NET);
* Strong error reporting and handling;
* Lots of functionality and plugins;
* ... the favorite feature that you want to develop for Turbinado ...

Written by alson

November 18th, 2008 at 2:10 am