heterocephalus 0.1.0.0 → 1.0.0

raw patch · 4 files changed

+144/−828 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• heterocephalus.cabal +1/−1
• src/Text/Hamlet/Parse.hs +1/−689
• src/Text/Heterocephalus.hs +123/−127
• src/Text/Heterocephalus/Parse.hs +19/−11

@@ -1,5 +1,5 @@ name:                heterocephalus-version:             0.1.0.0+version:             1.0.0 synopsis:            A flexible and type safe template engine for Haskell. description:         Please see README.md homepage:            https://github.com/arowM/heterocephalus#readme

@@ -5,15 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} module Text.Hamlet.Parse     ( Result (..)-    , Content (..)-    , Doc (..)-    , parseDoc-    , HamletSettings (..)-    , defaultHamletSettings-    , xhtmlHamletSettings-    , CloseStyle (..)     , Binding (..)-    , NewlineStyle (..)     , specialOrIdent     , DataConstr (..)     , Module (..)@@ -21,16 +13,9 @@     where  import Text.Shakespeare.Base-import Control.Applicative ((<$>), Applicative (..))+import Control.Applicative (Applicative (..)) import Control.Monad-import Control.Arrow-import Data.Char (isUpper) import Data.Data-import Text.ParserCombinators.Parsec hiding (Line)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Maybe (mapMaybe, fromMaybe, isNothing)-import Language.Haskell.TH.Syntax (Lift (..))  data Result v = Error String | Ok v     deriving (Show, Eq, Read, Data, Typeable)@@ -45,661 +30,6 @@     pure = return     (<*>) = ap -data Content = ContentRaw String-             | ContentVar Deref-             | ContentUrl Bool Deref -- ^ bool: does it include params?-             | ContentEmbed Deref-             | ContentMsg Deref-             | ContentAttrs Deref-    deriving (Show, Eq, Read, Data, Typeable)--data Line = LineForall Deref Binding-          | LineIf Deref-          | LineElseIf Deref-          | LineElse-          | LineWith [(Deref, Binding)]-          | LineMaybe Deref Binding-          | LineNothing-          | LineCase Deref-          | LineOf Binding-          | LineTag-            { _lineTagName :: String-            , _lineAttr :: [(Maybe Deref, String, Maybe [Content])]-            , _lineContent :: [Content]-            , _lineClasses :: [(Maybe Deref, [Content])]-            , _lineAttrs :: [Deref]-            , _lineNoNewline :: Bool-            }-          | LineContent [Content] Bool -- ^ True == avoid newlines-    deriving (Eq, Show, Read)--parseLines :: HamletSettings -> String -> Result (Maybe NewlineStyle, HamletSettings, [(Int, Line)])-parseLines set s =-    case parse parser s s of-        Left e -> Error $ show e-        Right x -> Ok x-  where-    parser = do-        mnewline <- parseNewline-        let set' =-                case mnewline of-                    Nothing ->-                        case hamletNewlines set of-                            DefaultNewlineStyle -> set { hamletNewlines = AlwaysNewlines }-                            _ -> set-                    Just n -> set { hamletNewlines = n }-        res <- many (parseLine set')-        return (mnewline, set', res)--    parseNewline =-        (try (many eol' >> spaceTabs >> string "$newline ") >> parseNewline' >>= \nl -> eol' >> return nl) <|>-        return Nothing-    parseNewline' =-        (try (string "always") >> return (Just AlwaysNewlines)) <|>-        (try (string "never") >> return (Just NoNewlines)) <|>-        (try (string "text") >> return (Just NewlinesText))--    eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ())--parseLine :: HamletSettings -> Parser (Int, Line)-parseLine set = do-    ss <- fmap sum $ many ((char ' ' >> return 1) <|>-                           (char '\t' >> fail "Tabs are not allowed in Hamlet indentation"))-    x <- doctype <|>-         doctypeDollar <|>-         comment <|>-         ssiInclude <|>-         htmlComment <|>-         doctypeRaw <|>-         backslash <|>-         controlIf <|>-         controlElseIf <|>-         (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|>-         controlMaybe <|>-         (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|>-         controlForall <|>-         controlWith <|>-         controlCase <|>-         controlOf <|>-         angle <|>-         invalidDollar <|>-         (eol' >> return (LineContent [] True)) <|>-         (do-            (cs, avoidNewLines) <- content InContent-            isEof <- (eof >> return True) <|> return False-            if null cs && ss == 0 && isEof-                then fail "End of Hamlet template"-                else return $ LineContent cs avoidNewLines)-    return (ss, x)-  where-    eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ())-    eol = eof <|> eol'-    doctype = do-        try $ string "!!!" >> eol-        return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] True-    doctypeDollar = do-        _ <- try $ string "$doctype "-        name <- many $ noneOf "\r\n"-        eol-        case lookup name $ hamletDoctypeNames set of-            Nothing -> fail $ "Unknown doctype name: " ++ name-            Just val -> return $ LineContent [ContentRaw $ val ++ "\n"] True--    doctypeRaw = do-        x <- try $ string "<!"-        y <- many $ noneOf "\r\n"-        eol-        return $ LineContent [ContentRaw $ concat [x, y, "\n"]] True--    invalidDollar = do-        _ <- char '$'-        fail "Received a command I did not understand. If you wanted a literal $, start the line with a backslash."-    comment = do-        _ <- try $ string "$#"-        _ <- many $ noneOf "\r\n"-        eol-        return $ LineContent [] True-    ssiInclude = do-        x <- try $ string "<!--#"-        y <- many $ noneOf "\r\n"-        eol-        return $ LineContent [ContentRaw $ x ++ y] False-    htmlComment = do-        _ <- try $ string "<!--"-        _ <- manyTill anyChar $ try $ string "-->"-        x <- many nonComments-        eol-        return $ LineContent [ContentRaw $ concat x] False {- FIXME -} -- FIXME handle variables?-    nonComments = (many1 $ noneOf "\r\n<") <|> (do-        _ <- char '<'-        (do-            _ <- try $ string "!--"-            _ <- manyTill anyChar $ try $ string "-->"-            return "") <|> return "<")-    backslash = do-        _ <- char '\\'-        (eol >> return (LineContent [ContentRaw "\n"] True))-            <|> (uncurry LineContent <$> content InContent)-    controlIf = do-        _ <- try $ string "$if"-        spaces-        x <- parseDeref-        _ <- spaceTabs-        eol-        return $ LineIf x-    controlElseIf = do-        _ <- try $ string "$elseif"-        spaces-        x <- parseDeref-        _ <- spaceTabs-        eol-        return $ LineElseIf x-    binding = do-        y <- identPattern-        spaces-        _ <- string "<-"-        spaces-        x <- parseDeref-        _ <- spaceTabs-        return (x,y)-    bindingSep = char ',' >> spaceTabs-    controlMaybe = do-        _ <- try $ string "$maybe"-        spaces-        (x,y) <- binding-        eol-        return $ LineMaybe x y-    controlForall = do-        _ <- try $ string "$forall"-        spaces-        (x,y) <- binding-        eol-        return $ LineForall x y-    controlWith = do-        _ <- try $ string "$with"-        spaces-        bindings <- (binding `sepBy` bindingSep) `endBy` eol-        return $ LineWith $ concat bindings -- concat because endBy returns a [[(Deref,Ident)]]-    controlCase = do-        _ <- try $ string "$case"-        spaces-        x <- parseDeref-        _ <- spaceTabs-        eol-        return $ LineCase x-    controlOf = do-        _   <- try $ string "$of"-        spaces-        x <- identPattern-        _   <- spaceTabs-        eol-        return $ LineOf x-    content cr = do-        x <- many $ content' cr-        case cr of-            InQuotes -> void $ char '"'-            NotInQuotes -> return ()-            NotInQuotesAttr -> return ()-            InContent -> eol-        return (cc $ map fst x, any snd x)-      where-        cc [] = []-        cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c-        cc (a:b) = a : cc b-    content' cr = contentHash <|> contentAt <|> contentCaret-                              <|> contentUnder-                              <|> contentReg' cr-    contentHash = do-        x <- parseHash-        case x of-            Left str -> return (ContentRaw str, null str)-            Right deref -> return (ContentVar deref, False)-    contentAt = do-        x <- parseAt-        return $ case x of-                    Left str -> (ContentRaw str, null str)-                    Right (s, y) -> (ContentUrl y s, False)-    contentCaret = do-        x <- parseCaret-        case x of-            Left str -> return (ContentRaw str, null str)-            Right deref -> return (ContentEmbed deref, False)-    contentUnder = do-        x <- parseUnder-        case x of-            Left str -> return (ContentRaw str, null str)-            Right deref -> return (ContentMsg deref, False)-    contentReg' x = (flip (,) False) <$> contentReg x-    contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n"-    contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>"-    contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>"-    contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\"\n\r"-    tagAttribValue notInQuotes = do-        cr <- (char '"' >> return InQuotes) <|> return notInQuotes-        fst <$> content cr-    tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes-    tagCond = do-        d <- between (char ':') (char ':') parseDeref-        tagClass (Just d) <|> tagAttrib (Just d)-    tagClass x = do-        clazz <- char '.' >> tagAttribValue NotInQuotes-        let hasHash (ContentRaw s) = any (== '#') s-            hasHash _ = False-        if any hasHash clazz-            then fail $ "Invalid class: " ++ show clazz ++ ". Did you want a space between a class and an ID?"-            else return (TagClass (x, clazz))-    tagAttrib cond = do-        s <- many1 $ noneOf " \t=\r\n><"-        v <- (char '=' >> Just <$> tagAttribValue NotInQuotesAttr) <|> return Nothing-        return $ TagAttrib (cond, s, v)--    tagAttrs = do-        _ <- char '*'-        d <- between (char '{') (char '}') parseDeref-        return $ TagAttribs d--    tag' = foldr tag'' ("div", [], [], [])-    tag'' (TagName s) (_, y, z, as) = (s, y, z, as)-    tag'' (TagIdent s) (x, y, z, as) = (x, (Nothing, "id", Just s) : y, z, as)-    tag'' (TagClass s) (x, y, z, as) = (x, y, s : z, as)-    tag'' (TagAttrib s) (x, y, z, as) = (x, s : y, z, as)-    tag'' (TagAttribs s) (x, y, z, as) = (x, y, z, s : as)--    ident :: Parser Ident-    ident = do-      i <- many1 (alphaNum <|> char '_' <|> char '\'')-      white-      return (Ident i)-     <?> "identifier"--    parens = between (char '(' >> white) (char ')' >> white)--    brackets = between (char '[' >> white) (char ']' >> white)--    braces = between (char '{' >> white) (char '}' >> white)--    comma = char ',' >> white--    atsign = char '@' >> white--    equals = char '=' >> white--    white = skipMany $ char ' '--    wildDots = string ".." >> white--    isVariable (Ident (x:_)) = not (isUpper x)-    isVariable (Ident []) = error "isVariable: bad identifier"--    isConstructor (Ident (x:_)) = isUpper x-    isConstructor (Ident []) = error "isConstructor: bad identifier"--    identPattern :: Parser Binding-    identPattern = gcon True <|> apat-      where-      apat = choice-        [ varpat-        , gcon False-        , parens tuplepat-        , brackets listpat-        ]--      varpat = do-        v <- try $ do v <- ident-                      guard (isVariable v)-                      return v-        option (BindVar v) $ do-          atsign-          b <- apat-          return (BindAs v b)-       <?> "variable"--      gcon :: Bool -> Parser Binding-      gcon allowArgs = do-        c <- try $ do c <- dataConstr-                      return c-        choice-          [ record c-          , fmap (BindConstr c) (guard allowArgs >> many apat)-          , return (BindConstr c [])-          ]-       <?> "constructor"--      dataConstr = do-        p <- dcPiece-        ps <- many dcPieces-        return $ toDataConstr p ps--      dcPiece = do-        x@(Ident y) <- ident-        guard $ isConstructor x-        return y--      dcPieces = do-        _ <- char '.'-        dcPiece--      toDataConstr x [] = DCUnqualified $ Ident x-      toDataConstr x (y:ys) =-          go (x:) y ys-        where-          go front next [] = DCQualified (Module $ front []) (Ident next)-          go front next (rest:rests) = go (front . (next:)) rest rests--      record c = braces $ do-        (fields, wild) <- option ([], False) $ go-        return (BindRecord c fields wild)-        where-        go = (wildDots >> return ([], True))-           <|> (do x         <- recordField-                   (xs,wild) <- option ([],False) (comma >> go)-                   return (x:xs,wild))--      recordField = do-        field <- ident-        p <- option (BindVar field) -- support punning-                    (equals >> identPattern)-        return (field,p)--      tuplepat = do-        xs <- identPattern `sepBy` comma-        return $ case xs of-          [x] -> x-          _   -> BindTuple xs--      listpat = BindList <$> identPattern `sepBy` comma--    angle = do-        _ <- char '<'-        name' <- many  $ noneOf " \t.#\r\n!>"-        let name = if null name' then "div" else name'-        xs <- many $ try ((many $ oneOf " \t\r\n") >>-              (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrs <|> tagAttrib Nothing))-        _ <- many $ oneOf " \t\r\n"-        _ <- char '>'-        (c, avoidNewLines) <- content InContent-        let (tn, attr, classes, attrsd) = tag' $ TagName name : xs-        if '/' `elem` tn-          then fail "A tag name may not contain a slash. Perhaps you have a closing tag in your HTML."-          else return $ LineTag tn attr c classes attrsd avoidNewLines--data TagPiece = TagName String-              | TagIdent [Content]-              | TagClass (Maybe Deref, [Content])-              | TagAttrib (Maybe Deref, String, Maybe [Content])-              | TagAttribs Deref-    deriving Show--data ContentRule = InQuotes | NotInQuotes | NotInQuotesAttr | InContent--data Nest = Nest Line [Nest]--nestLines :: [(Int, Line)] -> [Nest]-nestLines [] = []-nestLines ((i, l):rest) =-    let (deeper, rest') = span (\(i', _) -> i' > i) rest-     in Nest l (nestLines deeper) : nestLines rest'--data Doc = DocForall Deref Binding [Doc]-         | DocWith [(Deref, Binding)] [Doc]-         | DocCond [(Deref, [Doc])] (Maybe [Doc])-         | DocMaybe Deref Binding [Doc] (Maybe [Doc])-         | DocCase Deref [(Binding, [Doc])]-         | DocContent Content-    deriving (Show, Eq, Read, Data, Typeable)--nestToDoc :: HamletSettings -> [Nest] -> Result [Doc]-nestToDoc _set [] = Ok []-nestToDoc set (Nest (LineForall d i) inside:rest) = do-    inside' <- nestToDoc set inside-    rest' <- nestToDoc set rest-    Ok $ DocForall d i inside' : rest'-nestToDoc set (Nest (LineWith dis) inside:rest) = do-    inside' <- nestToDoc set inside-    rest' <- nestToDoc set rest-    Ok $ DocWith dis inside' : rest'-nestToDoc set (Nest (LineIf d) inside:rest) = do-    inside' <- nestToDoc set inside-    (ifs, el, rest') <- parseConds set ((:) (d, inside')) rest-    rest'' <- nestToDoc set rest'-    Ok $ DocCond ifs el : rest''-nestToDoc set (Nest (LineMaybe d i) inside:rest) = do-    inside' <- nestToDoc set inside-    (nothing, rest') <--        case rest of-            Nest LineNothing ninside:x -> do-                ninside' <- nestToDoc set ninside-                return (Just ninside', x)-            _ -> return (Nothing, rest)-    rest'' <- nestToDoc set rest'-    Ok $ DocMaybe d i inside' nothing : rest''-nestToDoc set (Nest (LineCase d) inside:rest) = do-    let getOf (Nest (LineOf x) insideC) = do-            insideC' <- nestToDoc set insideC-            Ok (x, insideC')-        getOf _ = Error "Inside a $case there may only be $of.  Use '$of _' for a wildcard."-    cases <- mapM getOf inside-    rest' <- nestToDoc set rest-    Ok $ DocCase d cases : rest'-nestToDoc set (Nest (LineTag tn attrs content classes attrsD avoidNewLine) inside:rest) = do-    let attrFix (x, y, z) = (x, y, [(Nothing, z)])-    let takeClass (a, "class", b) = Just (a, fromMaybe [] b)-        takeClass _ = Nothing-    let clazzes = classes ++ mapMaybe takeClass attrs-    let notClass (_, x, _) = x /= "class"-    let noclass = filter notClass attrs-    let attrs' =-            case clazzes of-              [] -> map attrFix noclass-              _ -> (testIncludeClazzes clazzes, "class", map (second Just) clazzes)-                       : map attrFix noclass-    let closeStyle =-            if not (null content) || not (null inside)-                then CloseSeparate-                else hamletCloseStyle set tn-    let end = case closeStyle of-                CloseSeparate ->-                    DocContent $ ContentRaw $ "</" ++ tn ++ ">"-                _ -> DocContent $ ContentRaw ""-        seal = case closeStyle of-                 CloseInside -> DocContent $ ContentRaw "/>"-                 _ -> DocContent $ ContentRaw ">"-        start = DocContent $ ContentRaw $ "<" ++ tn-        attrs'' = concatMap attrToContent attrs'-        newline' = DocContent $ ContentRaw-                 $ case hamletNewlines set of { AlwaysNewlines | not avoidNewLine -> "\n"; _ -> "" }-    inside' <- nestToDoc set inside-    rest' <- nestToDoc set rest-    Ok $ start-       : attrs''-      ++ map (DocContent . ContentAttrs) attrsD-      ++ seal-       : map DocContent content-      ++ inside'-      ++ end-       : newline'-       : rest'-nestToDoc set (Nest (LineContent content avoidNewLine) inside:rest) = do-    inside' <- nestToDoc set inside-    rest' <- nestToDoc set rest-    let newline' = DocContent $ ContentRaw-                   $ case hamletNewlines set of { NoNewlines -> ""; _ -> if nextIsContent && not avoidNewLine then "\n" else "" }-        nextIsContent =-            case (inside, rest) of-                ([], Nest LineContent{} _:_) -> True-                ([], Nest LineTag{} _:_) -> True-                _ -> False-    Ok $ map DocContent content ++ newline':inside' ++ rest'-nestToDoc _set (Nest (LineElseIf _) _:_) = Error "Unexpected elseif"-nestToDoc _set (Nest LineElse _:_) = Error "Unexpected else"-nestToDoc _set (Nest LineNothing _:_) = Error "Unexpected nothing"-nestToDoc _set (Nest (LineOf _) _:_) = Error "Unexpected 'of' (did you forget a $case?)"--compressDoc :: [Doc] -> [Doc]-compressDoc [] = []-compressDoc (DocForall d i doc:rest) =-    DocForall d i (compressDoc doc) : compressDoc rest-compressDoc (DocWith dis doc:rest) =-    DocWith dis (compressDoc doc) : compressDoc rest-compressDoc (DocMaybe d i doc mnothing:rest) =-    DocMaybe d i (compressDoc doc) (fmap compressDoc mnothing)-  : compressDoc rest-compressDoc (DocCond [(a, x)] Nothing:DocCond [(b, y)] Nothing:rest)-    | a == b = compressDoc $ DocCond [(a, x ++ y)] Nothing : rest-compressDoc (DocCond x y:rest) =-    DocCond (map (second compressDoc) x) (compressDoc `fmap` y)-    : compressDoc rest-compressDoc (DocCase d cs:rest) =-    DocCase d (map (second compressDoc) cs) : compressDoc rest-compressDoc (DocContent (ContentRaw ""):rest) = compressDoc rest-compressDoc ( DocContent (ContentRaw x)-            : DocContent (ContentRaw y)-            : rest-            ) = compressDoc $ (DocContent $ ContentRaw $ x ++ y) : rest-compressDoc (DocContent x:rest) = DocContent x : compressDoc rest--parseDoc :: HamletSettings -> String -> Result (Maybe NewlineStyle, [Doc])-parseDoc set s = do-    (mnl, set', ls) <- parseLines set s-    let notEmpty (_, LineContent [] _) = False-        notEmpty _ = True-    let ns = nestLines $ filter notEmpty ls-    ds <- nestToDoc set' ns-    return (mnl, compressDoc ds)--attrToContent :: (Maybe Deref, String, [(Maybe Deref, Maybe [Content])]) -> [Doc]-attrToContent (Just cond, k, v) =-    [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing]-attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k]-attrToContent (Nothing, k, [(Nothing, Nothing)]) = [DocContent $ ContentRaw $ ' ' : k]-attrToContent (Nothing, k, [(Nothing, Just v)]) =-    DocContent (ContentRaw (' ' : k ++ "=\""))-  : map DocContent v-  ++ [DocContent $ ContentRaw "\""]-attrToContent (Nothing, k, v) = -- only for class-      DocContent (ContentRaw (' ' : k ++ "=\""))-    : concatMap go (init v)-    ++ go' (last v)-    ++ [DocContent $ ContentRaw "\""]-  where-    go (Nothing, x) = map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "]-    go (Just b, x) =-        [ DocCond-            [(b, map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "])]-            Nothing-        ]-    go' (Nothing, x) = maybe [] (map DocContent) x-    go' (Just b, x) =-        [ DocCond-            [(b, maybe [] (map DocContent) x)]-            Nothing-        ]---- | Settings for parsing of a hamlet document.-data HamletSettings = HamletSettings-    {-      -- | The value to replace a \"!!!\" with. Do not include the trailing-      -- newline.-      hamletDoctype :: String-      -- | Should we add newlines to the output, making it more human-readable?-      --  Useful for client-side debugging but may alter browser page layout.-    , hamletNewlines :: NewlineStyle-      -- | How a tag should be closed. Use this to switch between HTML, XHTML-      -- or even XML output.-    , hamletCloseStyle :: String -> CloseStyle-      -- | Mapping from short names in \"$doctype\" statements to full doctype.-    , hamletDoctypeNames :: [(String, String)]-    }--data NewlineStyle = NoNewlines -- ^ never add newlines-                  | NewlinesText -- ^ add newlines between consecutive text lines-                  | AlwaysNewlines -- ^ add newlines everywhere-                  | DefaultNewlineStyle-    deriving Show--instance Lift NewlineStyle where-    lift NoNewlines = [|NoNewlines|]-    lift NewlinesText = [|NewlinesText|]-    lift AlwaysNewlines = [|AlwaysNewlines|]-    lift DefaultNewlineStyle = [|DefaultNewlineStyle|]--instance Lift (String -> CloseStyle) where-    lift _ = [|\s -> htmlCloseStyle s|]--instance Lift HamletSettings where-    lift (HamletSettings a b c d) = [|HamletSettings $(lift a) $(lift b) $(lift c) $(lift d)|]----- See the html specification for a list of all void elements:--- https://www.w3.org/TR/html/syntax.html#void-elements-htmlEmptyTags :: Set String-htmlEmptyTags = Set.fromAscList-    [ "area"-    , "base"-    , "basefont" -- not html 5-    , "br"-    , "col"-    , "embed"-    , "frame"    -- not html 5-    , "hr"-    , "img"-    , "input"-    , "isindex"  -- not html 5-    , "keygen"-    , "link"-    , "meta"-    , "param"-    , "source"-    , "track"-    , "wbr"-    ]---- | Defaults settings: HTML5 doctype and HTML-style empty tags.-defaultHamletSettings :: HamletSettings-defaultHamletSettings = HamletSettings "<!DOCTYPE html>" DefaultNewlineStyle htmlCloseStyle doctypeNames--xhtmlHamletSettings :: HamletSettings-xhtmlHamletSettings =-    HamletSettings doctype DefaultNewlineStyle xhtmlCloseStyle doctypeNames-  where-    doctype =-      "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " ++-      "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"--htmlCloseStyle :: String -> CloseStyle-htmlCloseStyle s =-    if Set.member s htmlEmptyTags-        then NoClose-        else CloseSeparate--xhtmlCloseStyle :: String -> CloseStyle-xhtmlCloseStyle s =-    if Set.member s htmlEmptyTags-        then CloseInside-        else CloseSeparate--data CloseStyle = NoClose | CloseInside | CloseSeparate--parseConds :: HamletSettings-           -> ([(Deref, [Doc])] -> [(Deref, [Doc])])-           -> [Nest]-           -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest])-parseConds set front (Nest LineElse inside:rest) = do-    inside' <- nestToDoc set inside-    Ok (front [], Just inside', rest)-parseConds set front (Nest (LineElseIf d) inside:rest) = do-    inside' <- nestToDoc set inside-    parseConds set (front . (:) (d, inside')) rest-parseConds _ front rest = Ok (front [], Nothing, rest)--doctypeNames :: [(String, String)]-doctypeNames =-    [ ("5", "<!DOCTYPE html>")-    , ("html", "<!DOCTYPE html>")-    , ("1.1", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">")-    , ("strict", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")-    ]- data Binding = BindVar Ident              | BindAs Ident Binding              | BindConstr DataConstr [Binding]@@ -714,24 +44,6 @@  newtype Module = Module [String]     deriving (Eq, Show, Read, Data, Typeable)--spaceTabs :: Parser String-spaceTabs = many $ oneOf " \t"---- | When using conditional classes, it will often be a single class, e.g.:------ > <div :isHome:.homepage>------ If isHome is False, we do not want any class attribute to be present.--- However, due to combining multiple classes together, the most obvious--- implementation would produce a class="". The purpose of this function is to--- work around that. It does so by checking if all the classes on this tag are--- optional. If so, it will only include the class attribute if at least one--- conditional is true.-testIncludeClazzes :: [(Maybe Deref, [Content])] -> Maybe Deref-testIncludeClazzes cs-    | any (isNothing . fst) cs = Nothing-    | otherwise = Just $ DerefBranch (DerefIdent specialOrIdent) $ DerefList $ mapMaybe fst cs  -- | This funny hack is to allow us to refer to the 'or' function without -- requiring the user to have it in scope. See how this function is used in

@@ -3,10 +3,15 @@ module Text.Heterocephalus   (   -- * Core functions-    compile-  , compileFile+    compileText+  , compileTextFile+  , compileHtml+  , compileHtmlFile    -- * low-level+  , HeterocephalusSetting(escapeExp)+  , compile+  , compileFile   , compileFromString   ) where @@ -17,75 +22,163 @@ import qualified Data.Text.Lazy as TL import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax hiding (Module)+import Text.Blaze (preEscapedToMarkup) import Text.Blaze.Html (toHtml) import Text.Blaze.Internal (preEscapedText) import Text.Hamlet import Text.Hamlet.Parse-       hiding (defaultHamletSettings, parseDoc, HamletSettings) import Text.Shakespeare.Base -import Text.Heterocephalus.Parse (parseDoc)+import Text.Heterocephalus.Parse (Doc(..), Content(..), parseDoc)  {- $setup   >>> :set -XTemplateHaskell -XQuasiQuotes-  >>> import Text.Blaze.Html.Renderer.String+  >>> import Text.Blaze.Renderer.String -}  {-| Heterocephalus quasi-quoter.+  This function DOES NOT escape template variables.+  To render the compiled file, use @Text.Blaze.Renderer.*.renderMarkup@. -  >>> renderHtml (let as = ["a", "b"] in [compile|sample %{ forall a <- as }key: #{a}, %{ endforall }|] "")-  "sample key: a, key: b, "+  >>> renderMarkup (let as = ["<a>", "b"] in [compileText|sample %{ forall a <- as }key: #{a}, %{ endforall }|])+  "sample key: <a>, key: b, " -  >>> renderHtml (let num=2 in [compile|#{num} is %{ if even num }even number.%{ else }odd number.%{ endif }|] "")+  >>> renderMarkup (let num=2 in [compileText|#{num} is %{ if even num }even number.%{ else }odd number.%{ endif }|])   "2 is even number."  -}-compile :: QuasiQuoter-compile = compileWithSettings hamletRules defaultHamletSettings+compileText :: QuasiQuoter+compileText = compile textSetting -{-| Compile a template file.--}-compileFile :: FilePath -> Q Exp-compileFile = compileFileWithSettings hamletRules defaultHamletSettings+{-| Heterocephalus quasi-quoter for Html.+  Same as 'compileText' but this function do escape template variables for Html. -compileWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter-compileWithSettings hr set =+  >>> renderMarkup (let as = ["<a>", "b"] in [compileHtml|sample %{ forall a <- as }key: #{a}, %{ endforall }|])+  "sample key: &lt;a&gt;, key: b, "+ -}+compileHtml :: QuasiQuoter+compileHtml = compile htmlSetting++{-| Heterocephalus quasi-quoter.+  Same as 'compileText' but this function read template literal from an external file.++  >>> putStr $ renderMarkup (let as = ["<a>", "b"] in $(compileTextFile "templates/sample.txt"))+  sample+  key: <a>,+  key: b,+ -}+compileTextFile :: FilePath -> Q Exp+compileTextFile = compileFile textSetting++{-| Heterocephalus quasi-quoter.+  Same as 'compileTextFile' but escapes template variables for Html.++  >>> putStr $ renderMarkup (let as = ["<a>", "b"] in $(compileHtmlFile "templates/sample.txt"))+  sample+  key: &lt;a&gt;,+  key: b,+ -}+compileHtmlFile :: FilePath -> Q Exp+compileHtmlFile = compileFile htmlSetting++compile :: HeterocephalusSetting -> QuasiQuoter+compile set =   QuasiQuoter-  { quoteExp = compileFromString hr set+  { quoteExp = compileFromString set   , quotePat = error "not used"   , quoteType = error "not used"   , quoteDec = error "not used"   } -compileFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp-compileFileWithSettings qhr set fp = do+{-| Compile a template file.+-}+compileFile :: HeterocephalusSetting -> FilePath -> Q Exp+compileFile set fp = do   qAddDependentFile fp   contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp-  compileFromString qhr set contents+  compileFromString set contents -compileFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp-compileFromString qhr set s = do-  hr <- qhr-  hrWithEnv hr $ \env -> docsToExp env hr [] $ docFromString set s+compileFromString :: HeterocephalusSetting -> String -> Q Exp+compileFromString set s =+  docsToExp set [] $ docFromString s -docFromString :: HamletSettings -> String -> [Doc]-docFromString _ s =+docFromString :: String -> [Doc]+docFromString s =   case parseDoc s of     Error s' -> error s'     Ok d -> d +data HeterocephalusSetting = HeterocephalusSetting+  { escapeExp :: Q Exp+  } +{-| A setting that escapes template variables for Html+ -}+htmlSetting :: HeterocephalusSetting+htmlSetting = HeterocephalusSetting+  { escapeExp = [|toHtml|]+  }++{-| A setting that DOES NOT escape template variables+ -}+textSetting :: HeterocephalusSetting+textSetting = HeterocephalusSetting+  { escapeExp = [|preEscapedToMarkup|]+  }+ -- ==============================================--- Codes from Text.Hamlet that is not exposed+--  Helper functions -- ============================================== -docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp-docsToExp env hr scope docs = do-  exps <- mapM (docToExp env hr scope) docs+docsToExp :: HeterocephalusSetting -> Scope -> [Doc] -> Q Exp+docsToExp set scope docs = do+  exps <- mapM (docToExp set scope) docs   case exps of     [] -> [|return ()|]     [x] -> return x     _ -> return $ DoE $ map NoBindS exps +-- TODO What's scope?+docToExp :: HeterocephalusSetting -> Scope -> Doc -> Q Exp+docToExp set scope (DocForall list idents inside) = do+  let list' = derefToExp scope list+  (pat, extraScope) <- bindingPattern idents+  let scope' = extraScope ++ scope+  mh <- [|F.mapM_|]+  inside' <- docsToExp set scope' inside+  let lam = LamE [pat] inside'+  return $ mh `AppE` lam `AppE` list'+docToExp set scope (DocCond conds final) = do+  conds' <- mapM go conds+  final' <-+    case final of+      Nothing -> [|Nothing|]+      Just f -> do+        f' <- docsToExp set scope f+        j <- [|Just|]+        return $ j `AppE` f'+  ch <- [|condH|]+  return $ ch `AppE` ListE conds' `AppE` final'+  where+    go :: (Deref, [Doc]) -> Q Exp+    go (d, docs) = do+      let d' = derefToExp ((specialOrIdent, VarE 'or) : scope) d+      docs' <- docsToExp set scope docs+      return $ TupE [d', docs']+docToExp set v (DocContent c) = contentToExp set v c++contentToExp :: HeterocephalusSetting -> Scope -> Content -> Q Exp+contentToExp _ _ (ContentRaw s) = do+  os <- [|preEscapedText . pack|]+  let s' = LitE $ StringL s+  return $ os `AppE` s'+contentToExp set scope (ContentVar d) = do+  str <- escapeExp set+  return $ str `AppE` derefToExp scope d++-- ==============================================+-- Codes from Text.Hamlet that is not exposed+-- ==============================================+ unIdent :: Ident -> String unIdent (Ident s) = s @@ -159,103 +252,6 @@   TyConI (DataD _ _ _ _ cons _) <- reify typeName   [fields] <- return [fields | RecC name fields <- cons, name == conName]   return [fieldName | (fieldName, _, _) <- fields]--docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp-docToExp env hr scope (DocForall list idents inside) = do-  let list' = derefToExp scope list-  (pat, extraScope) <- bindingPattern idents-  let scope' = extraScope ++ scope-  mh <- [|F.mapM_|]-  inside' <- docsToExp env hr scope' inside-  let lam = LamE [pat] inside'-  return $ mh `AppE` lam `AppE` list'-docToExp env hr scope (DocWith [] inside) = do-  inside' <- docsToExp env hr scope inside-  return $ inside'-docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do-  let deref' = derefToExp scope deref-  (pat, extraScope) <- bindingPattern idents-  let scope' = extraScope ++ scope-  inside' <- docToExp env hr scope' (DocWith dis inside)-  let lam = LamE [pat] inside'-  return $ lam `AppE` deref'-docToExp env hr scope (DocMaybe val idents inside mno) = do-  let val' = derefToExp scope val-  (pat, extraScope) <- bindingPattern idents-  let scope' = extraScope ++ scope-  inside' <- docsToExp env hr scope' inside-  let inside'' = LamE [pat] inside'-  ninside' <--    case mno of-      Nothing -> [|Nothing|]-      Just no -> do-        no' <- docsToExp env hr scope no-        j <- [|Just|]-        return $ j `AppE` no'-  mh <- [|maybeH|]-  return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'-docToExp env hr scope (DocCond conds final) = do-  conds' <- mapM go conds-  final' <--    case final of-      Nothing -> [|Nothing|]-      Just f -> do-        f' <- docsToExp env hr scope f-        j <- [|Just|]-        return $ j `AppE` f'-  ch <- [|condH|]-  return $ ch `AppE` ListE conds' `AppE` final'-  where-    go :: (Deref, [Doc]) -> Q Exp-    go (d, docs) = do-      let d' = derefToExp ((specialOrIdent, VarE 'or) : scope) d-      docs' <- docsToExp env hr scope docs-      return $ TupE [d', docs']-docToExp env hr scope (DocCase deref cases) = do-  let exp_ = derefToExp scope deref-  matches <- mapM toMatch cases-  return $ CaseE exp_ matches-  where-    toMatch :: (Binding, [Doc]) -> Q Match-    toMatch (idents, inside) = do-      (pat, extraScope) <- bindingPattern idents-      let scope' = extraScope ++ scope-      insideExp <- docsToExp env hr scope' inside-      return $ Match pat (NormalB insideExp) []-docToExp env hr v (DocContent c) = contentToExp env hr v c--contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp-contentToExp _ hr _ (ContentRaw s) = do-  os <- [|preEscapedText . pack|]-  let s' = LitE $ StringL s-  return $ hrFromHtml hr `AppE` (os `AppE` s')-contentToExp _ hr scope (ContentVar d) = do-  str <- [|toHtml|]-  return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)-contentToExp env hr scope (ContentUrl hasParams d) =-  case urlRender env of-    Nothing -> error "URL interpolation used, but no URL renderer provided"-    Just wrender ->-      wrender $ \render -> do-        let render' = return render-        ou <--          if hasParams-            then [|\(u, p) -> $(render') u p|]-            else [|\u -> $(render') u []|]-        let d' = derefToExp scope d-        pet <- [|toHtml|]-        return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))-contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d-contentToExp env hr scope (ContentMsg d) =-  case msgRender env of-    Nothing ->-      error "Message interpolation used, but no message renderer provided"-    Just wrender ->-      wrender $ \render ->-        return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)-contentToExp _ hr scope (ContentAttrs d) = do-  html <- [|attrsToHtml . toAttributes|]-  return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d)  type QueryParameters = [(Text, Text)] 

@@ -13,7 +13,7 @@ import Text.ParserCombinators.Parsec hiding (Line) import Text.Shakespeare.Base -import Text.Hamlet.Parse hiding (parseDoc)+import Text.Hamlet.Parse  data Control   = ControlForall Deref Binding@@ -25,6 +25,15 @@   | NoControl Content   deriving (Show, Eq, Read, Data, Typeable) +data Doc = DocForall Deref Binding [Doc]+         | DocCond [(Deref, [Doc])] (Maybe [Doc])+         | DocContent Content+    deriving (Show, Eq, Read, Data, Typeable)++data Content = ContentRaw String+             | ContentVar Deref+    deriving (Show, Eq, Read, Data, Typeable)+ type UserParser a = Parsec String a  docFromString :: String -> [Doc]@@ -35,7 +44,7 @@  parseDoc :: String -> Result [Doc] parseDoc s = do-  controls <- concat <$> mapM parseLineControl (lines s)+  controls <- parseLineControl s   return $ controlsToDocs controls  controlsToDocs :: [Control] -> [Doc]@@ -111,7 +120,7 @@ lineControl = manyTill control $ try eof >> return ()  control :: UserParser () Control-control = controlHash <|> controlCaret <|> controlPercent <|> controlReg+control = controlHash <|> controlPercent <|> controlReg   where     controlPercent = do       x <- parsePercent@@ -124,16 +133,15 @@         case x of           Left str -> ContentRaw str           Right deref -> ContentVar deref-    controlCaret = do-      x <- parseCaret-      return . NoControl $-        case x of-          Left str -> ContentRaw str-          Right deref -> ContentEmbed deref-    controlReg = (NoControl . ContentRaw) <$> many (noneOf "#%^\r\n")+    controlReg = (NoControl . ContentRaw) <$> many (noneOf "#%")  parsePercent :: UserParser () (Either String Control)-parsePercent = parseControl '%'+parsePercent = do+  a <- parseControl '%'+  optional eol+  return a+ where+  eol = (char '\n' >> return ()) <|> (string "\r\n" >> return ())  parseControl :: Char -> UserParser () (Either String Control) parseControl c = do