diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Petr Pilař + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Petr Pilař nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Template/HSML.hs b/src/Template/HSML.hs new file mode 100644 --- /dev/null +++ b/src/Template/HSML.hs @@ -0,0 +1,15 @@ +module Template.HSML +( module Export +) where + +------------------------------------------------------------------------------ +import Template.HSML.Internal.TH as Export +import Template.HSML.Internal.Types as Export ( HSMLTemplate(..) + , Options(..) + , defaultHSML + , defaultSHSML + ) +------------------------------------------------------------------------------ + + + diff --git a/src/Template/HSML/Internal/Parser.hs b/src/Template/HSML/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Template/HSML/Internal/Parser.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE RecordWildCards #-} + +module Template.HSML.Internal.Parser +( hsmlParser +, shsmlParser + +, hsmlTemplate +, shsmlTemplate +) where + +------------------------------------------------------------------------------ +import qualified Language.Haskell.Exts.Parser as HE +-- import qualified Language.Haskell.Exts.Extension as HE +-- import qualified Language.Haskell.Exts.Syntax as HE +------------------------------------------------------------------------------ +import Control.Applicative +------------------------------------------------------------------------------ +import Data.Monoid ((<>)) +------------------------------------------------------------------------------ +import qualified Text.Parsec.String as P +import qualified Text.Parsec.Prim as P +------------------------------------------------------------------------------ +import qualified Template.HSML.Internal.Types as I +import qualified Template.HSML.Internal.Parser.Raw as I +------------------------------------------------------------------------------ + +hsmlTemplate :: String -> Either String I.Template +hsmlTemplate str = + case P.parse hsmlParser ".HSML" str of + Right tpl -> Right tpl + Left err -> Left $ show err + +hsmlParser :: P.Parser I.Template +hsmlParser = I.hsmlParser >>= transform + +shsmlTemplate :: String -> Either String I.Template +shsmlTemplate str = + case P.parse shsmlParser ".HSML" str of + Right tpl -> Right tpl + Left err -> Left $ show err + +shsmlParser :: P.Parser I.Template +shsmlParser = I.shsmlParser >>= transform + +------------------------------------------------------------------------------ + +transform :: I.RTemplate -> P.Parser I.Template +transform I.Template{..} = do + args <- mapM transformArg templateArgs + decs <- mapM transformDec templateDecs + sections <- mapM transformSection templateSections + return I.Template + { I.templateArgs = args + , I.templateDecs = decs + , I.templateSections = sections + } + +transformArg :: I.RArg -> P.Parser I.Arg +transformArg (I.RArg name mtype) = + case mtype of + Just stype -> + case HE.parseType stype of + HE.ParseOk t -> return . I.Arg name $ Just t + HE.ParseFailed _ r -> fail $ "Could not parse type \"" <> stype <> "\", reason: " <> r + Nothing -> return $ I.Arg name Nothing + +transformDec :: I.RDec -> P.Parser I.Dec +transformDec (I.RDec sdec) = + case HE.parseDecl sdec of + HE.ParseOk d -> return $ I.Dec d + HE.ParseFailed _ r -> fail $ "Could not parse declaration \"" <> sdec <> "\", reason: " <> r + +transformExp :: I.RExp -> P.Parser I.Exp +transformExp (I.RExp sexp) = + case HE.parseExp sexp of + HE.ParseOk e -> return $ I.Exp e + HE.ParseFailed _ r -> fail $ "Could not parse expression \"" <> sexp <> "\", reason: " <> r + +transformSection :: I.RSection -> P.Parser I.Section +transformSection (I.ElementNode name rattributes rsections) = do + attributes <- mapM transformAttribute rattributes + sections <- mapM transformSection rsections + return $ I.ElementNode name attributes sections +transformSection (I.ElementLeaf name rattributes) = do + attributes <- mapM transformAttribute rattributes + return $ I.ElementLeaf name attributes +transformSection (I.Text text) = return $ I.Text text +transformSection (I.TextRaw text) = return $ I.TextRaw text +transformSection (I.Expression rexp) = I.Expression <$> transformExp rexp + +transformAttribute :: I.RAttribute -> P.Parser I.Attribute +transformAttribute (I.Attribute rname rvalue) = + I.Attribute <$> transformName rname <*> transformValue rvalue + where + transformName (I.AttributeNameExp rexp) = I.AttributeNameExp <$> transformExp rexp + transformName (I.AttributeNameText text) = return $ I.AttributeNameText text + + transformValue (I.AttributeValueExp rexp) = I.AttributeValueExp <$> transformExp rexp + transformValue (I.AttributeValueText text) = return $ I.AttributeValueText text + diff --git a/src/Template/HSML/Internal/Parser/Raw.hs b/src/Template/HSML/Internal/Parser/Raw.hs new file mode 100644 --- /dev/null +++ b/src/Template/HSML/Internal/Parser/Raw.hs @@ -0,0 +1,213 @@ +module Template.HSML.Internal.Parser.Raw +( hsmlParser +, shsmlParser +) where + +------------------------------------------------------------------------------ +import Control.Applicative +import Control.Monad +------------------------------------------------------------------------------ +import Data.Char +------------------------------------------------------------------------------ +import qualified Text.Parsec.String as P +import qualified Text.Parsec.Combinator as P +import qualified Text.Parsec.Char as P +import qualified Text.Parsec.Prim as P +------------------------------------------------------------------------------ +import qualified Template.HSML.Internal.Types as I +------------------------------------------------------------------------------ + +-- | .HSML parser. +hsmlParser:: P.Parser I.RTemplate +hsmlParser = do + spaces + args <- P.try $ sepEndBy argument spaces + chus <- P.try $ sepEndBy1 chunk spaces + P.eof + return . templateFromSyntax $ Syntax args chus + +-- | Simple .HSML parser (argument are not allowed). +shsmlParser :: P.Parser I.RTemplate +shsmlParser = do + spaces + chus <- P.try $ sepEndBy1 chunk spaces + P.eof + return . templateFromSyntax $ Syntax [] chus + +-------------------------------------------------------------------------------- + +templateFromSyntax :: Syntax -> I.RTemplate +templateFromSyntax (Syntax args chunks) = + I.Template args decs secs + where + (decs, secs) = foldr go ([], []) chunks + go (Dec d) (ds, ss) = (d : ds, ss) + go (Sec s) (ds, ss) = (ds, s : ss) + +-------------------------------------------------------------------------------- + +chunk :: P.Parser Chunk +chunk = Dec <$> declaration <|> + Sec <$> section + +-------------------------------------------------------------------------------- +-- | Declaration + +-- | Raw declaration conforms to the following: +-- "{a|" [ "::" ] "|}" +argument :: P.Parser I.RArg +argument = do + P.string "{a|" >> spaces + aname <- funIdent + atype <- maybeParser $ P.spaces >> P.string "::" >> spaces >> typeIdent + spaces >> P.string "|}" >> spaces + return $ I.RArg aname atype + +-------------------------------------------------------------------------------- +-- | Declaration + +-- | Raw declaration conforms to the following: +-- "{d|" "|}" +declaration :: P.Parser I.RDec +declaration = I.RDec <$> wrappedText 'd' P.anyChar + +-------------------------------------------------------------------------------- +-- | Section + +section :: P.Parser I.RSection +section = P.try ( elementNode <|> + elementLeaf <|> + expression <|> + textRaw <|> + text + ) + +-------------------------------------------------------------------------------- +-- | Elements + +elementNode :: P.Parser I.RSection +elementNode = P.try $ do + (name, attributes) <- tagOpening <* P.string ">" + body <- many section + tagClosing name + return $ I.ElementNode name attributes body + +elementLeaf :: P.Parser I.RSection +elementLeaf = P.try $ do + (name, attributes) <- tagOpening <* P.string "/>" + return $ I.ElementLeaf name attributes + +attribute :: P.Parser I.RAttribute +attribute = do + n <- attributeName + spaces >> P.char '=' >> spaces + v <- attributeValue + return $ I.Attribute n v + +attributeName :: P.Parser I.RAttributeName +attributeName = P.try $ + P.try (I.AttributeNameText <$> attributeIdent) <|> + (I.AttributeNameExp . I.RExp <$> expressionText) + +attributeValue :: P.Parser I.RAttributeValue +attributeValue = P.try $ + P.try (P.char '\"' *> (I.AttributeValueText <$> attributeIdent) <* P.char '\"') <|> + (I.AttributeValueExp . I.RExp <$> expressionText) + +attributeIdent :: P.Parser String +attributeIdent = P.many1 $ P.satisfy ((||) <$> isAlphaNum <*> (`elem` " -_")) + +-------------------------------------------------------------------------------- +-- | Text + +text :: P.Parser I.RSection +text = P.try $ I.Text <$> P.many1 (textChar '\\' (`elem` "<{")) + +textRaw :: P.Parser I.RSection +textRaw = I.TextRaw <$> wrappedText 'r' (textChar '\\' (`elem` "<{")) + +textChar :: Char -> (Char -> Bool) -> P.Parser Char +textChar esc needEsc = escapedChar <|> P.satisfy (\c -> not (needEsc c || c == esc)) + where + escapedChar = P.try $ P.char esc >> P.anyChar + +-------------------------------------------------------------------------------- +-- | Expression + +-- | Raw expression conforms to the following: +-- "{e|" "|}" +expression :: P.Parser I.RSection +expression = I.Expression . I.RExp <$> expressionText + +-------------------------------------------------------------------------------- + +tagOpening :: P.Parser (String, [I.RAttribute]) +tagOpening = P.try $ do + P.char '<' >> spaces + name <- tagIdentifier + spaces + attributes <- sepEndBy attribute spaces + return (name, attributes) + +tagClosing :: String -> P.Parser () +tagClosing tagName = P.try . void $ do + P.string "' + +tagIdentifier :: P.Parser String +tagIdentifier = P.try $ P.many1 P.alphaNum + +-------------------------------------------------------------------------------- + +expressionText :: P.Parser String +expressionText = wrappedText 'e' P.anyChar + +wrappedText :: Char -> P.Parser Char -> P.Parser String +wrappedText m p = P.try $ + P.string ['{', m, '|'] *> many1Until p (P.string "|}") <* P.string "|}" + +funIdent :: P.Parser String +funIdent = (:) <$> P.lower <*> P.many P.alphaNum + +typeIdent :: P.Parser String +typeIdent = (:) <$> P.upper <*> P.many (P.satisfy (/= ' ')) + +-------------------------------------------------------------------------------- + +data Syntax = Syntax [I.RArg] [Chunk] + +data Chunk = Dec I.RDec + | Sec I.RSection + +-------------------------------------------------------------------------------- +-- CONVENIENCE FUNCTIONS + +maybeParser :: P.Parser a -> P.Parser (Maybe a) +maybeParser p = (Just <$> P.try p) <|> return Nothing + +spaces :: P.Parser () +spaces = void $ P.many P.space + +-- spaces1 :: P.Parser () +-- spaces1 = void $ P.many1 P.space + +sepEndBy1 :: P.Parser a -> P.Parser b -> P.Parser [a] +sepEndBy1 p sep = P.try $ do + x <- p + P.try ((x:) <$> (sep >> sepEndBy p sep)) <|> return [x] + +sepEndBy :: P.Parser a -> P.Parser b -> P.Parser [a] +sepEndBy p sep = P.try (sepEndBy1 p sep) <|> return [] + +manyUntil :: P.Parser a -> P.Parser b -> P.Parser [a] +manyUntil p stop = P.try $ P.manyTill p (P.lookAhead $ void (P.try stop) <|> void P.eof) + +many1Until :: P.Parser a -> P.Parser b -> P.Parser [a] +many1Until p stop = P.try $ do + x <- p + xs <- manyUntil p stop + return $ x : xs + diff --git a/src/Template/HSML/Internal/TH.hs b/src/Template/HSML/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Template/HSML/Internal/TH.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} + +module Template.HSML.Internal.TH +( hsmlWith +, hsml +, m + +, hsmlStringWith +, hsmlFileWith + +, shsmlStringWith +, shsmlString +, shsmlFileWith +, shsmlFile +) where + +-------------------------------------------------------------------------------- +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Quote as TH +import qualified Language.Haskell.TH.Syntax as TH +-- import qualified Language.Haskell.Exts.Syntax as HE +import qualified Language.Haskell.Meta.Syntax.Translate as HE +-------------------------------------------------------------------------------- +import qualified Text.Blaze as B +import qualified Text.Blaze.Internal as B +-------------------------------------------------------------------------------- +-- import Control.Applicative +import Control.Monad +-------------------------------------------------------------------------------- +-- import Data.Char +import Data.String +import Data.Monoid +-- import qualified Data.Generics as G +-------------------------------------------------------------------------------- +import qualified Template.HSML.Internal.Types as I +import qualified Template.HSML.Internal.Parser as I +-------------------------------------------------------------------------------- + +hsmlWith :: I.Options -> TH.QuasiQuoter +hsmlWith opts = TH.QuasiQuoter + { TH.quoteExp = shsmlStringWith opts + , TH.quoteDec = hsmlStringWith opts + , TH.quotePat = const $ fail "You can not use the .HSML QuasiQuoter as a pattern." + , TH.quoteType = const $ fail "You can not use the .HSML QuasiQuoter as a type." + } +{-# INLINE hsmlWith #-} + +hsml :: TH.QuasiQuoter +hsml = TH.QuasiQuoter + { TH.quoteExp = shsmlString + , TH.quoteDec = const $ fail "You can not use the .HSML QuasiQuoter as a declaration." + , TH.quotePat = const $ fail "You can not use the .HSML QuasiQuoter as a pattern." + , TH.quoteType = const $ fail "You can not use the .HSML QuasiQuoter as a type." + } +{-# INLINE hsml #-} + +m :: TH.QuasiQuoter +m = hsml +{-# INLINE m #-} + +-------------------------------------------------------------------------------- +-- | .HSML + +hsmlFileWith :: I.Options -> FilePath -> TH.Q [TH.Dec] +hsmlFileWith opts path = TH.runIO (readFile path) >>= hsmlStringWith opts +{-# INLINE hsmlFileWith #-} + +hsmlFile :: String -> FilePath -> TH.Q [TH.Dec] +hsmlFile = hsmlFileWith . I.defaultHSML +{-# INLINE hsmlFile #-} + +hsmlStringWith :: I.Options -> String -> TH.Q [TH.Dec] +hsmlStringWith opts str = + case I.hsmlTemplate str of + Right tpl -> makeDec opts tpl + Left err -> fail err +{-# INLINE hsmlStringWith #-} + +hsmlString :: String -> String -> TH.Q [TH.Dec] +hsmlString = hsmlStringWith . I.defaultHSML +{-# INLINE hsmlString #-} + +-------------------------------------------------------------------------------- +-- | Simple .HSML (without arguments) + +shsmlFileWith :: I.Options -> FilePath -> TH.ExpQ +shsmlFileWith opts path = TH.runIO (readFile path) >>= shsmlStringWith opts +{-# INLINE shsmlFileWith #-} + +shsmlFile :: FilePath -> TH.ExpQ +shsmlFile = shsmlFileWith I.defaultSHSML +{-# INLINE shsmlFile #-} + +shsmlStringWith :: I.Options -> String -> TH.ExpQ +shsmlStringWith opts str = + case I.shsmlTemplate str of + Right I.Template{..} -> makeExp opts templateDecs templateSections + Left err -> fail err +{-# INLINE shsmlStringWith #-} + +shsmlString :: String -> TH.ExpQ +shsmlString = shsmlStringWith I.defaultSHSML +{-# INLINE shsmlString #-} + +-------------------------------------------------------------------------------- + +-- | This function take options @ template and generates the record type and +-- instance of .HSMLTemplate for that record type. +makeDec :: I.Options -> I.Template -> TH.Q [TH.Dec] +makeDec opts@(I.Options _ tname fname) (I.Template args decs sections) = do + (vars, fields) <- makeVarsAndFields + tdata <- makeData vars fields + tinst <- makeInstance vars + return [tdata, tinst] + where + dataName :: TH.Name + dataName = HE.toName tname + + -- | This function generates the type variable names and fields. + makeVarsAndFields :: TH.Q ([TH.Name], [TH.VarStrictType]) + makeVarsAndFields = foldM go ([], []) args + where + go (vs, fs) (I.Arg an (Just at)) = + return (vs, (HE.toName $ fname an, TH.NotStrict, HE.toType at) : fs) + go (vs, fs) (I.Arg an Nothing) = do + v <- TH.newName "a" + return (v : vs, (HE.toName $ fname an, TH.NotStrict, TH.VarT v) : fs) + + -- | This function generates the instance in .HSMLTemplate. + makeInstance :: [TH.Name] -> TH.DecQ + makeInstance vars = + -- instance .HSMLTemplate ( ) where + -- renderTemplate @({ }) = + -- + TH.instanceD + (return []) + (TH.conT ''I.HSMLTemplate `TH.appT` contyp) + [TH.funD 'I.renderTemplate [clause]] + where + -- This is the data type applied to all the type variables. + contyp = foldl (\acc n -> acc `TH.appT` TH.varT n) (TH.conT dataName) vars + + -- This is the clause for renderTemplate. + clause = do + arg <- TH.newName "tpl" + TH.clause [TH.asP arg $ TH.recP dataName binds] + (TH.normalB $ makeExp opts decs sections) [] + -- This is the { = , ... } pattern. + binds = map (\(I.Arg n _) -> return (HE.toName $ fname n, TH.VarP $ HE.toName n)) args + + -- | This function generates the record type. + makeData :: [TH.Name] -> [TH.VarStrictType] -> TH.DecQ + makeData vars fields = return $ + -- data = { } + TH.DataD [] dataName (map TH.PlainTV vars) [TH.RecC dataName fields] [] + +makeExp :: I.Options -> [I.Dec] -> [I.Section] -> TH.ExpQ +makeExp opts decs sections = + TH.letE (declarationsToDecs decs) + (sectionsToExp opts sections) + +-------------------------------------------------------------------------------- + +declarationsToDecs :: [I.Dec] -> [TH.DecQ] +declarationsToDecs = map declarationToDec + where declarationToDec (I.Dec dec) = return $ HE.toDec dec + + +sectionsToExp :: I.Options -> [I.Section] -> TH.ExpQ +sectionsToExp opts sections = + [e| mconcat $(TH.listE $ map (sectionToExp opts) sections) :: B.Markup |] + +sectionToExp :: I.Options -> I.Section -> TH.ExpQ +sectionToExp opts@I.Options{..} section = + case section of + (I.ElementNode name atts sections) -> + [e| applyAttributes $(TH.listE $ map attributeToExp atts) $ + B.Parent (fromString name) + (fromString $ "<" <> name) + (fromString $ " name <> ">") + $(sectionsToExp opts sections) |] + (I.ElementLeaf name atts) -> + [e| applyAttributes $(TH.listE $ map attributeToExp atts) $ + B.Leaf (fromString name) + (fromString $ "<" <> name) + (fromString ">") |] + (I.Text str) -> [e| B.string str |] + (I.TextRaw str) -> [e| B.preEscapedString str |] + (I.Expression (I.Exp e)) -> + if optSectionsToMarkup + then [e| B.toMarkup $(return $ HE.toExp e) |] + else return $ HE.toExp e + +applyAttributes :: [B.Attribute] -> B.MarkupM a -> B.MarkupM a +applyAttributes attributes markup = foldl (B.!) markup attributes + +attributeToExp :: I.Attribute -> TH.ExpQ +attributeToExp (I.Attribute aname avalue) = + [e| B.attribute (fromString $(attributeNameToExp aname)) + (fromString (" " <> $(attributeNameToExp aname) <> "=\"")) + (fromString $(attributeValueToExp avalue)) |] + where + attributeNameToExp (I.AttributeNameExp (I.Exp e)) = return $ HE.toExp e + attributeNameToExp (I.AttributeNameText str) = [e| str |] + + attributeValueToExp (I.AttributeValueExp (I.Exp e)) = return $ HE.toExp e + attributeValueToExp (I.AttributeValueText str) = [e| str |] + diff --git a/src/Template/HSML/Internal/Types.hs b/src/Template/HSML/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Template/HSML/Internal/Types.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Template.HSML.Internal.Types +( HSMLTemplate(..) +, Options(..) +, defaultHSML +, defaultSHSML + +, PTemplate(..) +, PSection(..) +, PAttribute(..) +, PAttributeName(..) +, PAttributeValue(..) + +, Template +, Section +, Attribute +, AttributeName +, AttributeValue + +, RTemplate +, RSection +, RAttribute +, RAttributeName +, RAttributeValue + +, Arg(..) +, Dec(..) +, Exp(..) + +, RArg(..) +, RDec(..) +, RExp(..) +) where + +-------------------------------------------------------------------------------- +import qualified Language.Haskell.Exts.Syntax as HE +-------------------------------------------------------------------------------- +import Data.Char (toUpper, toLower) +import Data.Monoid ((<>)) +-------------------------------------------------------------------------------- +import qualified Text.Blaze as B (Markup) +-------------------------------------------------------------------------------- + +class HSMLTemplate a where + renderTemplate :: a -> B.Markup + +defaultHSML :: String -> Options +defaultHSML name = Options + { optSectionsToMarkup = True + , optTemplateName = firstUpper name + , optTemplateFieldName = \a -> firstLower name <> firstUpper a + } + where + firstUpper "" = "" + firstUpper (c:cs) = toUpper c : cs + + firstLower "" = "" + firstLower (c:cs) = toLower c : cs + +defaultSHSML :: Options +defaultSHSML = Options + { optSectionsToMarkup = True + , optTemplateName = undefined + , optTemplateFieldName = undefined + } + +-- | This type let's you customize some behaviour of the templating system. +data Options = Options + { + -- ^ If (and only if) set to True, applies `Blaze.Text.toMarkup` to + -- section expression + optSectionsToMarkup :: Bool + + -- ^ The name of the generated record. + -- NOTE: Has no effect on s.HSML templates. + , optTemplateName :: String + + -- ^ The name of the fields of the genrated record. + -- NOTE: Has no effect on sHTML templates. + , optTemplateFieldName :: String -> String + } + +-------------------------------------------------------------------------------- +-- | Handy synonyms + +type Template = PTemplate Arg Dec Exp +type Section = PSection Exp +type Attribute = PAttribute Exp +type AttributeName = PAttributeName Exp +type AttributeValue = PAttributeValue Exp + +type RTemplate = PTemplate RArg RDec RExp +type RSection = PSection RExp +type RAttribute = PAttribute RExp +type RAttributeName = PAttributeName RExp +type RAttributeValue = PAttributeValue RExp + +-------------------------------------------------------------------------------- +-- | The Template. This includes arguments, declarations and sections + +data PTemplate arg dec exp = Template + { templateArgs :: [arg] + , templateDecs :: [dec] + , templateSections :: [PSection exp] + } + +instance Show e => Show (PTemplate a d e) where + show tpl = unlines . map show $ templateSections tpl + +data PSection exp = ElementNode String [PAttribute exp] [PSection exp] + | ElementLeaf String [PAttribute exp] + | Text String + | TextRaw String + | Expression exp + +instance Show e => Show (PSection e) where + show (ElementNode name _ sections) = concat [ "<" <> name <> ">\n" + , unlines (map show sections) + , " name <> ">\n" + ] + show (ElementLeaf name _) = "<" <> name <> "/>" + show (Text str) = hsmlEscape str + show (TextRaw str) = str + show (Expression e) = show e + +hsmlEscape :: String -> String +hsmlEscape "" = "" +hsmlEscape (c:rest) = + if shouldEscape c + then '\\' : c : hsmlEscape rest + else c : hsmlEscape rest + where + shouldEscape = (`elem` "<{") + +data PAttribute exp = Attribute (PAttributeName exp) (PAttributeValue exp) + +data PAttributeName exp = AttributeNameText String + | AttributeNameExp exp + +data PAttributeValue exp = AttributeValueText String + | AttributeValueExp exp + +data Arg = Arg String (Maybe HE.Type) +newtype Dec = Dec HE.Decl +newtype Exp = Exp HE.Exp + +data RArg = RArg String (Maybe String) deriving Show +newtype RDec = RDec String deriving Show +newtype RExp = RExp String deriving Show + diff --git a/template-hsml.cabal b/template-hsml.cabal new file mode 100644 --- /dev/null +++ b/template-hsml.cabal @@ -0,0 +1,42 @@ +name: template-hsml +version: 0.1.0.0 +synopsis: Haskell's Simple Markup Language +description: HSML syntax is very similar to that of XML, but there are less rules. + The main advantage over plain HTML is that it allows you to embed Haskell declarations + and expression directly into your template. + + The main dvantage over something like Blaze is thatit saves + you the overhead of using Blaze's combinators. It's also relatively easy to port your existing + plain HTML templates into HSML (most of the times, cut & paste will suffice). + + For examples, see the examples directory. +license: BSD3 +license-file: LICENSE +author: Petr Pilař +maintainer: maintainer+the.palmik@gmail.com +copyright: Petr Pilař 2012 +category: Web, Template, Templating +build-type: Simple +cabal-version: >=1.8 +stability: Experimental + +library + hs-source-dirs: src + + exposed-modules: + Template.HSML + + other-modules: + Template.HSML.Internal.TH + , Template.HSML.Internal.Types + , Template.HSML.Internal.Parser + , Template.HSML.Internal.Parser.Raw + + build-depends: + base == 4.5.* + + , blaze-markup == 0.5.* + , haskell-src-exts == 1.13.* + , haskell-src-meta == 0.5.* + , parsec == 3.1.* + , template-haskell == 2.7.*