Permalink
Browse files

Switching from HSX-based templating to a custom preprocessor-based te…

…mplating system. Supports HAML and XHTML
  • Loading branch information...
alsonkemp committed Jun 9, 2009
1 parent baecdd9 commit 8eaf4bca90f2caea525c9400ecb9ab583c5a0576
View
@@ -7,12 +7,13 @@ import Data.Maybe
import qualified Network.HTTP as HTTP
import qualified Network.URI as URI
-markup = <html>
+markup =
+ <html>
<head>
<meta name="verify-v1" content="w8VesxPmDH0sX71+bZUok+LyY0eDG5aM6v8odpbkEm8=" />
<title>Turbinado: MVC Framework for Haskell</title>
- <meta name="keywords" content="turbinado, haskell, mvc, model, view, controller, ruby, rails"> </meta>
- <meta name="description" content="Turbinado is a Model-View-Controller-ish web framework written in Haskell. Ruby On Rails comes to Haskell."> </meta>
+ <meta name="keywords" content="turbinado, haskell, mvc, model, view, controller, ruby, rails"/>
+ <meta name="description" content="Turbinado is a Model-View-Controller-ish web framework written in Haskell. Ruby On Rails comes to Haskell."/>
<% styleSheetTag "normalize" "screen" %>
<% styleSheetTag "pressurized" "screen" %>
<% styleSheetTag "turbinado" "screen" %>
@@ -58,9 +59,10 @@ markup = <html>
</body>
</html>
-menuItem :: FilePath -> String -> View XML
+menuItem :: FilePath -> String -> VHtml
menuItem p t = do e <- getEnvironment
let ru = HTTP.rqURI $ fromJust $ getRequest e
active = if isPrefixOf p (URI.uriPath ru) then "active" else ""
- <li class=active><a href=p><%t%></a></li>
+ %li
+ %a{href=p}= t
@@ -1,7 +1,8 @@
module App.Views.Develop.Index where
import Turbinado.View
-markup = <div>
+markup =
+ <div>
<h2>! Windows</h2>
<p>This software doesn't work on Windows. Linux/Unix only at this point.</p>
@@ -12,7 +13,7 @@ markup = <div>
<h2>To Do</h2>
<ul class="standard-list">
<li>
- Move to a simpler templating system (e.g. <% anchorTag "http://haml.hamptoncatlin.com/" "HAML" %>-like ). HSX is a lovely piece of work, but it's pretty finicky and I feel like I'm trying to "see the Matrix" when I read its compilation error messages.
+ Move to a simpler templating system (e.g. <% anchorTag "http://haml.hamptoncatlin.com/" "HAML" %>-like ). HSX is a lovely piece of work, but it's pretty finicky and I feel like I'm trying to \"see the Matrix\" when I read its compilation error messages.
</li>
<li>Build a mini-CMS to manage these pages.</li>
<li>Complete the ORM in Turbinado/Database/ORM.</li>
View
@@ -1,8 +1,9 @@
module App.Views.Home.Index where
import Turbinado.View
-markup :: View XML
-markup= <div>
+markup :: VHtml
+markup=
+ <div>
<h1>Turbinado?</h1>
<div style="float:right">
<img src="http://upload.wikimedia.org/wikipedia/en/thumb/0/0e/TurbinadoSugar.jpg/757px-TurbinadoSugar.jpg" width="300" />
View
@@ -14,7 +14,7 @@ compileArgs =
[ "-fglasgow-exts"
, "-XOverlappingInstances"
, "-XUndecidableInstances"
- , "-F", "-pgmFtrhsx"
+ , "-F", "-pgmFtrturbinado"
, "-fno-warn-overlapping-patterns"
, "-odir " ++ compiledDir
, "-hidir " ++ compiledDir
View
@@ -1,13 +1,11 @@
module Config.Routes where
+import App.Controllers.Home
+import App.Controllers.Develop
+
--
-- Import modules for which you'll be creating static routes.
--
-import App.Layouts.Default
-import App.Controllers.Home
-import App.Controllers.Develop
-import App.Views.Home.Index
-import App.Views.Develop.Index
--
-- Configure dynamic routes for on-the-fly compiled-and-loaded
@@ -25,15 +23,12 @@ routes = [ "/:controller/:action/:id.:format"
-- Statically compile and load these Layouts, Controllers and Views
--
staticLayouts =
- [ ("App/Layouts/Default.hs", "markup", App.Layouts.Default.markup)
- ]
+ []
staticControllers =
[ ("App/Controllers/Home.hs", "index", App.Controllers.Home.index)
, ("App/Controllers/Develop.hs", "index", App.Controllers.Develop.index)
]
staticViews =
- [ ("App/Views/Home/Index.hs", "markup", App.Views.Home.Index.markup)
- , ("App/Views/Develop/Index.hs", "markup", App.Views.Develop.Index.markup)
- ]
+ []
@@ -3,7 +3,6 @@ module Turbinado.Controller.Monad (
Controller,
runController,
withController,
-
get,
put,
-- * Functions
@@ -27,12 +26,8 @@ import Turbinado.Utility.General
-- | The Controller monad is a state wrapper around
-- the IO monad.
-
type Controller = StateT Environment IO
-instance HasEnvironment Controller where
- getEnvironment = get
- setEnvironment = put
-- | Runs a Controller computation in a particular environment. Since Controller wraps the IO monad,
-- the result of running it will be an IO computation.
@@ -30,7 +30,7 @@ import Turbinado.Environment.Request
import Turbinado.Environment.Response
import Turbinado.Utility.Data
import Turbinado.View.Monad hiding (liftIO)
-import Turbinado.View.XML
+import Turbinado.View.HTML
import Turbinado.Controller.Monad
-- | Create a new store for Code data
@@ -117,7 +117,8 @@ loadCode ct cmap cl = do
mergeCode :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> m CodeMap
mergeCode ct cmap cl = do
debugM $ "\tMerging " ++ (fst cl)
- ms <- customMergeToDir (joinPath [normalise $ getStub ct]) (fst cl) compiledDir
+ let stub = (joinPath [normalise $ getStub ct])
+ ms <- customMergeToDir stub (fst cl) compiledDir
case ms of
MergeFailure err -> do debugM ("\tMerge error : " ++ (show err))
return $ insert cl (CodeLoadFailure $ unlines err) cmap
@@ -89,7 +89,7 @@ splitOn c l = reverse $ worker c l []
-- Handle static routes
----------------------------------------------------------------------------
---addStaticViews :: [(String, String, View XML)] -> CodeMap -> CodeMap
+--addStaticViews :: [(String, String, View VHtml)] -> CodeMap -> CodeMap
addStaticViews [] cm = cm
addStaticViews ((p,f,v):vs) cm = let cm' = M.insert (p,f) (CodeLoadView v $ UTCTime (ModifiedJulianDay 1000000) (secondsToDiffTime 0)) cm in
addStaticViews vs cm'
@@ -4,7 +4,7 @@ module Turbinado.Layout.Helpers.Misc (
import Turbinado.View
-googleAnalytics :: String -> View XML
+googleAnalytics :: String -> VHtml
googleAnalytics g = javaScriptBlock $
" var gaJsHost = ((\"https:\" == document.location.protocol) ? \"https://ssl.\" : \"http://www.\"); " ++
" document.write(unescape(\"%3Cscript src='\" + gaJsHost + \"google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E\")); " ++
@@ -4,7 +4,8 @@ module Turbinado.Layout.Helpers.Tags (
import Turbinado.View
-styleSheetTag :: String -> String -> View XML
-styleSheetTag s m = return $ cdata $ "<link media=\"" ++ m ++"\" type=\"text/css\" rel=\"stylesheet\" href=\"/css/" ++ s ++".css\">"
+styleSheetTag :: String -> String -> VHtml
+styleSheetTag s m =
+ itag "link" ! [strAttr "media" m, strAttr "type" "text/css", strAttr "rel" "stylesheet", strAttr "href" ("/css/" ++ s ++".css")]
@@ -0,0 +1,29 @@
+module Turbinado.PreProcessor.Parser.Common 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
+
+indent p = take (sourceColumn (p) - 1) (repeat ' ')
+
+manyTill1 :: CharParser () a -> CharParser () b -> CharParser () [a]
+manyTill1 p e = do ms <- manyTill p e
+ case (null ms) of
+ True -> pzero
+ False -> return ms
+
+tilEOL:: CharParser () String
+tilEOL = manyTill1 (noneOf "\n") eol <?> "characters in tilEOL"
+
+eol :: CharParser () Char
+eol = newline <|> (eof >> return '\n')
+
+blankLine :: CharParser () String
+blankLine = char '\n' >> return ""
+
+anyLine :: CharParser () String
+anyLine = blankLine <|> tilEOL
@@ -1,4 +1,4 @@
-module Main where
+module Turbinado.PreProcessor.Parser.HAML (hamlParser) where
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Language
@@ -7,18 +7,11 @@ import qualified Text.ParserCombinators.Parsec.Token as T
import Data.Char
import Data.List
import Data.Maybe
-import System.IO.Unsafe
+import Turbinado.PreProcessor.Parser.Common
-main = do s <- getContents
- case (parse mainParser "stdin" s) of
- Left err -> putStrLn "Error: " >> print err
- Right hs -> putStrLn hs
+-- | HAML code starts with a HAML tag.
+hamlParser = pTag
--- Try to parse HAML, otherwise re-output raw lines
-
-mainParser = do whiteSpace
- ls <- many1 (hamlCode <|> tilEOL)
- return $ unlines ls
--
-- * HAML lexer
--
@@ -29,7 +22,7 @@ symbol = T.symbol hamlLexer
natural = T.natural hamlLexer
parens = T.parens hamlLexer
semi = T.semi hamlLexer
-squares = T.squares hamlLexer
+braces = T.braces hamlLexer
stringLiteral= T.stringLiteral hamlLexer
identifier= T.identifier hamlLexer
reserved = T.reserved hamlLexer
@@ -38,46 +31,29 @@ commaSep1 = T.commaSep1 hamlLexer
--
-- * Main HAML parsers
--
-
--- hamlCode is just many identifiers followed by = followed by a hamlBlock
--- f 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
+
+-- A Block always starts with some whitespace, then has a valid bit of data
+hamlBlock = do whiteSpace
+ currentPos <- getPosition
bs <- manyTill1
- (pTag <|> pText)
- (notSameIndent currentPos)
- return $ intercalate (indent currentPos ++ "+++\n") bs
+ (try pTag <|> pText <?> "tag or text")
+ (shallower currentPos)
+ return $ intercalate "+++\n" bs
pTag = do currentPos <- getPosition
try
- (do t <- lexeme tagParser
- ts <- (isInline currentPos >> char '/' >> return []) <|>
- (hamlBlock)
+ (do t <- lexeme tagParser <?> "tag"
+ ts <- ((closeTag currentPos <|> eol) >> return []) <|>
+ (try hamlBlock) <|>
+ (blankLine) <?> "closing tag, block or blankLine in pTag"
return $ intercalate "\n" $ filter (not . null) $
[ (indent currentPos) ++ "((" ++ (if (null ts) then "i" else "") ++ t ++ ")"
, if null ts then [] else ts
- , (indent currentPos) ++ ")\n"]
+ , (indent currentPos) ++ " )"]
)
pText = lexeme stringParser
-
-notSameIndent p = (eof >> return []) <|>
- (do innerPos <- getPosition
- case (sourceColumn p) == (sourceColumn innerPos) of
- True -> pzero
- False -> return []
- )
+closeTag p = isInline p >> char '/'
--
-- * Various little parsers
@@ -116,24 +92,24 @@ classParser = do char '.'
many1 termChar
attributesParser :: CharParser () [(String, String)]
-attributesParser = squares (commaSep1 attributeParser)
+attributesParser = braces (commaSep1 attributeParser)
attributeParser :: CharParser () (String, String)
-attributeParser = do k <- identifier
+attributeParser = do k <- identifier <?> "identifier in key of attribute"
symbol "="
- cs <- many1 identifier
+ cs <- many1 identifier <?> "identifier in value of attribute"
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 ++ "\")"
+ Just '-' -> do b <- hamlBlock
+ return $ (indent currentPos) ++ "(" ++ cs ++ "\n" ++ b ++ "\n" ++ (indent currentPos) ++ ")"
+ Just '=' -> return $ (indent currentPos) ++ "(stringToVHtml $ " ++ cs ++ ")"
+ Nothing -> return $ (indent currentPos) ++ "(stringToVHtml \"" ++ cs ++ "\")"
--
@@ -146,14 +122,22 @@ isInline p = do p2 <- getPosition
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
+
+shallower p = (eof >> return []) <|>
+ (do innerPos <- getPosition
+ case (sourceColumn innerPos) < (sourceColumn p) of
+ True -> return []
+ False -> pzero
+ )
+
+deeper p = (eof >> return []) <|>
+ (do innerPos <- getPosition
+ case (sourceColumn innerPos) > (sourceColumn p) of
+ True -> return []
+ False -> pzero
+ )
+
@@ -0,0 +1,15 @@
+module Turbinado.PreProcessor.Parser.Id (idParser) 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 Turbinado.PreProcessor.Parser.Common
+
+-- | Returns all lines unmodified
+idParser = do currentPos <- getPosition
+ l <- anyLine
+ return $ (indent currentPos) ++ l
Oops, something went wrong.

0 comments on commit 8eaf4bc

Please sign in to comment.