packages feed

hmarkup (empty) → 3000.0.0

raw patch · 8 files changed

+691/−0 lines, 8 filesdep +basedep +mtldep +networkbuild-type:Customsetup-changed

Dependencies added: base, mtl, network, parsec, xhtml

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2006, Björn Bringert+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 names of the copyright owners nor the names of the +  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.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple (defaultMainWithHooks, defaultUserHooks)++main :: IO ()+main = defaultMainWithHooks defaultUserHooks
+ Text/HMarkup.hs view
@@ -0,0 +1,21 @@+module Text.HMarkup (MarkupXHtmlPrefs(..), MarkupXHtmlFormat,+                     markupToHtml, defaultMarkupXHtmlPrefs, +                     standardMarkupFormats) where++import Text.HMarkup.Parse+import Text.HMarkup.XHtml++import Text.XHtml (Html)++import Control.Monad (liftM)+import Control.Monad.Error ()++-- | Parse some markup and format it as HTML.+markupToHtml :: Monad m => +                MarkupXHtmlPrefs m -> String +             -> m (Either String Html) +                -- ^ An error message or an HTML document.+markupToHtml pref s = +    case parseMarkup "<input>" s of+      Left err  -> return $ Left err+      Right doc -> liftM Right $ docToHtml pref doc
+ Text/HMarkup/Entities.hs view
@@ -0,0 +1,268 @@+module Text.HMarkup.Entities where++import Data.Map (Map)+import qualified Data.Map as Map++getEntity :: Monad m => String -> m String+getEntity n = case Map.lookup n entities of+                Nothing -> fail $ "Unknown entity: " ++ n+                Just x  -> return x++-- this list was generated with: +-- runghc tools/markup-entities.hs tools/xhtml-dtd/xhtml-*.ent+entities :: Map String String+entities = Map.fromList [+  ("nbsp", "\160"),+  ("iexcl", "\161"),+  ("cent", "\162"),+  ("pound", "\163"),+  ("curren", "\164"),+  ("yen", "\165"),+  ("brvbar", "\166"),+  ("sect", "\167"),+  ("uml", "\168"),+  ("copy", "\169"),+  ("ordf", "\170"),+  ("laquo", "\171"),+  ("not", "\172"),+  ("shy", "\173"),+  ("reg", "\174"),+  ("macr", "\175"),+  ("deg", "\176"),+  ("plusmn", "\177"),+  ("sup2", "\178"),+  ("sup3", "\179"),+  ("acute", "\180"),+  ("micro", "\181"),+  ("para", "\182"),+  ("middot", "\183"),+  ("cedil", "\184"),+  ("sup1", "\185"),+  ("ordm", "\186"),+  ("raquo", "\187"),+  ("frac14", "\188"),+  ("frac12", "\189"),+  ("frac34", "\190"),+  ("iquest", "\191"),+  ("Agrave", "\192"),+  ("Aacute", "\193"),+  ("Acirc", "\194"),+  ("Atilde", "\195"),+  ("Auml", "\196"),+  ("Aring", "\197"),+  ("AElig", "\198"),+  ("Ccedil", "\199"),+  ("Egrave", "\200"),+  ("Eacute", "\201"),+  ("Ecirc", "\202"),+  ("Euml", "\203"),+  ("Igrave", "\204"),+  ("Iacute", "\205"),+  ("Icirc", "\206"),+  ("Iuml", "\207"),+  ("ETH", "\208"),+  ("Ntilde", "\209"),+  ("Ograve", "\210"),+  ("Oacute", "\211"),+  ("Ocirc", "\212"),+  ("Otilde", "\213"),+  ("Ouml", "\214"),+  ("times", "\215"),+  ("Oslash", "\216"),+  ("Ugrave", "\217"),+  ("Uacute", "\218"),+  ("Ucirc", "\219"),+  ("Uuml", "\220"),+  ("Yacute", "\221"),+  ("THORN", "\222"),+  ("szlig", "\223"),+  ("agrave", "\224"),+  ("aacute", "\225"),+  ("acirc", "\226"),+  ("atilde", "\227"),+  ("auml", "\228"),+  ("aring", "\229"),+  ("aelig", "\230"),+  ("ccedil", "\231"),+  ("egrave", "\232"),+  ("eacute", "\233"),+  ("ecirc", "\234"),+  ("euml", "\235"),+  ("igrave", "\236"),+  ("iacute", "\237"),+  ("icirc", "\238"),+  ("iuml", "\239"),+  ("eth", "\240"),+  ("ntilde", "\241"),+  ("ograve", "\242"),+  ("oacute", "\243"),+  ("ocirc", "\244"),+  ("otilde", "\245"),+  ("ouml", "\246"),+  ("divide", "\247"),+  ("oslash", "\248"),+  ("ugrave", "\249"),+  ("uacute", "\250"),+  ("ucirc", "\251"),+  ("uuml", "\252"),+  ("yacute", "\253"),+  ("thorn", "\254"),+  ("yuml", "\255"),+  ("quot", "\34"),+  ("amp", "\38"),+  ("lt", "\60"),+  ("gt", "\62"),+  ("apos", "\39"),+  ("OElig", "\338"),+  ("oelig", "\339"),+  ("Scaron", "\352"),+  ("scaron", "\353"),+  ("Yuml", "\376"),+  ("circ", "\710"),+  ("tilde", "\732"),+  ("ensp", "\8194"),+  ("emsp", "\8195"),+  ("thinsp", "\8201"),+  ("zwnj", "\8204"),+  ("zwj", "\8205"),+  ("lrm", "\8206"),+  ("rlm", "\8207"),+  ("ndash", "\8211"),+  ("mdash", "\8212"),+  ("lsquo", "\8216"),+  ("rsquo", "\8217"),+  ("sbquo", "\8218"),+  ("ldquo", "\8220"),+  ("rdquo", "\8221"),+  ("bdquo", "\8222"),+  ("dagger", "\8224"),+  ("Dagger", "\8225"),+  ("permil", "\8240"),+  ("lsaquo", "\8249"),+  ("rsaquo", "\8250"),+  ("euro", "\8364"),+  ("fnof", "\402"),+  ("Alpha", "\913"),+  ("Beta", "\914"),+  ("Gamma", "\915"),+  ("Delta", "\916"),+  ("Epsilon", "\917"),+  ("Zeta", "\918"),+  ("Eta", "\919"),+  ("Theta", "\920"),+  ("Iota", "\921"),+  ("Kappa", "\922"),+  ("Lambda", "\923"),+  ("Mu", "\924"),+  ("Nu", "\925"),+  ("Xi", "\926"),+  ("Omicron", "\927"),+  ("Pi", "\928"),+  ("Rho", "\929"),+  ("Sigma", "\931"),+  ("Tau", "\932"),+  ("Upsilon", "\933"),+  ("Phi", "\934"),+  ("Chi", "\935"),+  ("Psi", "\936"),+  ("Omega", "\937"),+  ("alpha", "\945"),+  ("beta", "\946"),+  ("gamma", "\947"),+  ("delta", "\948"),+  ("epsilon", "\949"),+  ("zeta", "\950"),+  ("eta", "\951"),+  ("theta", "\952"),+  ("iota", "\953"),+  ("kappa", "\954"),+  ("lambda", "\955"),+  ("mu", "\956"),+  ("nu", "\957"),+  ("xi", "\958"),+  ("omicron", "\959"),+  ("pi", "\960"),+  ("rho", "\961"),+  ("sigmaf", "\962"),+  ("sigma", "\963"),+  ("tau", "\964"),+  ("upsilon", "\965"),+  ("phi", "\966"),+  ("chi", "\967"),+  ("psi", "\968"),+  ("omega", "\969"),+  ("thetasym", "\977"),+  ("upsih", "\978"),+  ("piv", "\982"),+  ("bull", "\8226"),+  ("hellip", "\8230"),+  ("prime", "\8242"),+  ("Prime", "\8243"),+  ("oline", "\8254"),+  ("frasl", "\8260"),+  ("weierp", "\8472"),+  ("image", "\8465"),+  ("real", "\8476"),+  ("trade", "\8482"),+  ("alefsym", "\8501"),+  ("larr", "\8592"),+  ("uarr", "\8593"),+  ("rarr", "\8594"),+  ("darr", "\8595"),+  ("harr", "\8596"),+  ("crarr", "\8629"),+  ("lArr", "\8656"),+  ("uArr", "\8657"),+  ("rArr", "\8658"),+  ("dArr", "\8659"),+  ("hArr", "\8660"),+  ("forall", "\8704"),+  ("part", "\8706"),+  ("exist", "\8707"),+  ("empty", "\8709"),+  ("nabla", "\8711"),+  ("isin", "\8712"),+  ("notin", "\8713"),+  ("ni", "\8715"),+  ("prod", "\8719"),+  ("sum", "\8721"),+  ("minus", "\8722"),+  ("lowast", "\8727"),+  ("radic", "\8730"),+  ("prop", "\8733"),+  ("infin", "\8734"),+  ("ang", "\8736"),+  ("and", "\8743"),+  ("or", "\8744"),+  ("cap", "\8745"),+  ("cup", "\8746"),+  ("int", "\8747"),+  ("there4", "\8756"),+  ("sim", "\8764"),+  ("cong", "\8773"),+  ("asymp", "\8776"),+  ("ne", "\8800"),+  ("equiv", "\8801"),+  ("le", "\8804"),+  ("ge", "\8805"),+  ("sub", "\8834"),+  ("sup", "\8835"),+  ("nsub", "\8836"),+  ("sube", "\8838"),+  ("supe", "\8839"),+  ("oplus", "\8853"),+  ("otimes", "\8855"),+  ("perp", "\8869"),+  ("sdot", "\8901"),+  ("lceil", "\8968"),+  ("rceil", "\8969"),+  ("lfloor", "\8970"),+  ("rfloor", "\8971"),+  ("lang", "\9001"),+  ("rang", "\9002"),+  ("loz", "\9674"),+  ("spades", "\9824"),+  ("clubs", "\9827"),+  ("hearts", "\9829"),+  ("diams", "\9830")+ ]
+ Text/HMarkup/Parse.hs view
@@ -0,0 +1,161 @@+-- | Markup parsing.+module Text.HMarkup.Parse where++import Text.HMarkup.Entities+import Text.HMarkup.Types++import Control.Monad+import Data.Char+import Network.URI+import Numeric+import Text.ParserCombinators.Parsec++++parseMarkup :: Monad m => String -> String -> m Doc+parseMarkup source input = +    case parse pMarkup source input of+      Left err -> fail $ show err+      Right x  -> return x++pMarkup :: Parser Doc+pMarkup = liftM Doc $ skipWhite >> many pBlock++pBlock :: Parser Block+pBlock = do b <- try pChunk <|> try pHeader <|> try pItemList <|> pPara+            skipWhite+            return b++pChunk :: Parser Block+pChunk = do string "{{{"+            sps+            x <- pIdent+            sps+            string ":"+            optional nl+            s <- manyTill anyCharToUnixNL (try (string "}}}"))+            white+            return $ Chunk x s++anyCharToUnixNL :: Parser Char+anyCharToUnixNL = (nl >> return '\n') <|> anyChar++pHeader :: Parser Block+pHeader = do n <- liftM length $ many1 (char '=')+             x <- pTextsTill (try (sps >> count n (char '=') >> endBlock))+             return $ Header n x++pItemList :: Parser Block+pItemList = liftM ItemList (many1 pItem)++pItem :: Parser [Text]+pItem = char '-' >> sps >> pTextsTill (try endItem <|> try endBlock)+  where endItem = sps >> nl >> lookAhead (char '-') >> return ()++pPara :: Parser Block+pPara = liftM (Para . concat) $ manyTill1 pText (try endBlock)++endBlock :: Parser ()+endBlock = try (sps >> nl >> sps >> nl >> skipWhite) <|> (white >> eof)++pText :: Parser [Text]+pText = do s <- white+           t <- try pRef <|> try pEmph <|> try pTT <|> pWord+           return $ (if s then [WhiteSpace] else []) ++ [t]++pTextsTill :: Parser a -> Parser [Text]+pTextsTill end = liftM concat $ manyTill pText end++pEmph :: Parser Text+pEmph = char '*' >> liftM Emph (pTextsTill (char '*'))++pTT :: Parser Text+pTT = string "``" >> liftM TT (pTextsTill (string "``"))++pRef :: Parser Text+pRef = char '[' >> liftM2 Ref (white >> pURI) (pTextsTill (char ']'))++pWord :: Parser Text+pWord = liftM Word pToken++pIdent :: Parser String+pIdent = many1 (alphaNum <|> char '_')++pURI :: Parser URI+pURI = do t <- pToken+          case parseURIReference t of+            Nothing -> fail $ "Malformed URI: " ++ show t+            Just uri -> return uri++--+-- * Tokens+--++pToken :: Parser String+pToken = liftM concat $ many1 pTokenPiece++pTokenPiece :: Parser String+pTokenPiece = liftM (:[]) (try pEsc)+              <|> try pEntity+              <|> liftM return (satisfy (\c -> not (isSpace c || isSpecial c)))++isSpecial :: Char -> Bool+isSpecial c = c `elem` "[]*{}`"++pEsc :: Parser Char+pEsc = char '\\' >> anyChar++pEntity :: Parser String+pEntity = do char '&'+             x <- liftM return numEntity <|> namedEntity+             char ';'+             return x++numEntity :: Parser Char+numEntity = char '#' >> liftM chr ((char 'x' >> pHexInt) <|> pDecInt)++namedEntity :: Parser String+namedEntity = many1 alphaNum >>= getEntity++--+-- * Parsec utilities+--++nl :: Parser ()+nl = (char '\n' >> optional (char '\r')) +     <|> (char '\r' >> optional (char '\n'))++sp :: Parser ()+sp = oneOf [' ','\t'] >> return ()++sps :: Parser ()+sps = skipMany sp++white :: Parser Bool+white = liftM (not . null) $ many (sp <|> nl)++skipWhite :: Parser ()+skipWhite = skipMany (sp <|> nl)++manyTill1 :: GenParser tok st a -> GenParser tok st end -> GenParser tok st [a]+manyTill1 p end = liftM2 (:) p (manyTill p end)++followedBy :: Monad m => m a -> m b -> m a+followedBy x y = x >>= \v -> y >> return v+++pDecInt :: Parser Int+pDecInt = do ds <- many1 digit+             case readDec ds of+               [(x,"")] -> return x+               _ -> error $ "pDecInt: " ++ show ds++pHexInt :: Parser Int+pHexInt = do ds <- many1 hexDigit+             case readHex ds of+               [(x,"")] -> return x+               _ -> error $ "pHexInt: " ++ show ds++inFirstColumn :: GenParser tok st a -> GenParser tok st a+inFirstColumn p = do c <- liftM sourceColumn getPosition+                     if c == 1 then p else pzero
+ Text/HMarkup/Types.hs view
@@ -0,0 +1,16 @@+module Text.HMarkup.Types where++import Network.URI (URI)++newtype Doc = Doc [Block] deriving Show+data Block = Chunk String String+           | Header Int [Text] +           | Para [Text] +           | ItemList [[Text]]+             deriving Show+data Text = Emph [Text]+          | TT [Text]+          | Ref URI [Text]+          | Word String +          | WhiteSpace+            deriving Show
+ Text/HMarkup/XHtml.hs view
@@ -0,0 +1,173 @@+-- | Converting markup to HTML+module Text.HMarkup.XHtml (docToHtml,+                           MarkupXHtmlPrefs(..),+                           MarkupXHtmlFormat(..),+                           standardMarkupFormats,+                           defaultMarkupXHtmlPrefs,+                           markupURL, markupURI,+                           useChunkFormat, useRefFormat) where++import Text.HMarkup.Parse+import Text.HMarkup.Types++import Control.Monad+import Data.List+import Data.Maybe+import Network.URI+import Text.XHtml++data MarkupXHtmlPrefs m = MarkupXHtmlPrefs {+    markupFormats :: [MarkupXHtmlFormat m],+    -- | If set, all relative URIs will be resolved with this as a base.+    markupBaseURI :: Maybe URI+                                           }++data MarkupXHtmlFormat m = +    ChunkFormat {+                 formatName :: String,+                 formatChunk :: MarkupXHtmlPrefs m -> String -> m Html+                }+  | RefFormat {+               formatName :: String,+               formatRef :: MarkupXHtmlPrefs m -> URI -> [Text] -> m Html+              }++defaultMarkupXHtmlPrefs :: Monad m => MarkupXHtmlPrefs m+defaultMarkupXHtmlPrefs = +    MarkupXHtmlPrefs {+                      markupFormats = standardMarkupFormats,+                      markupBaseURI = Nothing+                     }++standardMarkupFormats :: Monad m => [MarkupXHtmlFormat m]+standardMarkupFormats = [+                         -- chunk formats+                         preChunk, +                         quoteChunk,+                         -- reference formats+                         imageRef+                        ]++--+-- * Chunk formatters+--++defaultChunkFormat :: Monad m => MarkupXHtmlFormat m+defaultChunkFormat = preChunk++preChunk :: Monad m => MarkupXHtmlFormat m+preChunk = ChunkFormat "pre" f+    where f _ s = return $ pre << s++quoteChunk :: Monad m => MarkupXHtmlFormat m+quoteChunk = ChunkFormat "quote" f+    where f pref = liftM (blockquote <<) . toHtmlOrPlain pref++--+-- * Ref formatters+--++defaultRefFormat :: Monad m => MarkupXHtmlFormat m+defaultRefFormat = RefFormat "link" f+ where+   f pref uri ts = +       liftM (anchor ! [href (markupURL pref uri)] <<) +              (textsToHtml pref ts')+    where ts' = if null ts then [Word (show uri)] else ts          ++imageRef :: Monad m => MarkupXHtmlFormat m+imageRef = RefFormat "image" f+    where +      f pref uri ts = +          do let tit = textsToPlain ts+                 url = case parseURIReference (uriPath uri) of+                         Nothing -> show uri+                         Just u  -> markupURL pref u+             return $ image ! [src url, alt tit]  ++--+-- * XHtml generation+--++docToHtml :: Monad m => +             MarkupXHtmlPrefs m -> Doc -> m Html+docToHtml pref (Doc ps) = liftM concatHtml (mapM (blockToHtml pref) ps)++blockToHtml :: Monad m => MarkupXHtmlPrefs m -> Block -> m Html+blockToHtml pref (Chunk n s) = useChunkFormat pref n s+blockToHtml pref (Header n ts) = liftM (h <<) (textsToHtml pref ts)+    where h = case n of+                _ | n < 1 -> error $ "Header " ++ show n+                1 -> h1+                2 -> h2+                3 -> h3+                4 -> h4+                5 -> h5+                6 -> h6+                _ -> h6 -- FIXME: what should we do here?+blockToHtml pref (Para ts) = liftM (paragraph <<) (textsToHtml pref ts)+blockToHtml pref (ItemList tss) = liftM unordList $ mapM (textsToHtml pref) tss++textsToHtml :: Monad m => MarkupXHtmlPrefs m -> [Text] -> m Html+textsToHtml pref = liftM concatHtml . mapM (textToHtml pref)++textToHtml :: Monad m => MarkupXHtmlPrefs m -> Text -> m Html+textToHtml pref (Emph ts) = liftM (emphasize <<) (textsToHtml pref ts)+textToHtml pref (TT ts) = liftM (tt <<) (textsToHtml pref ts)+textToHtml pref (Ref uri ts) = useRefFormat pref n uri ts+    where n = removeTrailing (uriScheme uri) ':'+textToHtml _ (Word t) = return $ toHtml t +textToHtml _ WhiteSpace = return $ toHtml " "++markupURI :: Monad m => MarkupXHtmlPrefs m -> URI -> URI+markupURI pref uri = case markupBaseURI pref of+                   Nothing   -> uri+                   Just baseURI -> uri `relativeTo'` baseURI+  where relativeTo' x y = +            fromMaybe (error $ "relativeTo " ++ show x ++ " " ++ show y) +                          (x `relativeTo` y)++markupURL :: Monad m => MarkupXHtmlPrefs m -> URI -> URL+markupURL pref = show . markupURI pref++removeTrailing :: Eq a => [a] -> a -> [a]+removeTrailing xs x = reverse $ dropWhile (==x) $ reverse xs++toHtmlOrPlain :: Monad m => +                       MarkupXHtmlPrefs m -> String -> m Html+toHtmlOrPlain pref s = +    case parseMarkup "<input>" s of+      Nothing -> return $ toHtml s+      Just x -> docToHtml pref x++useChunkFormat :: Monad m => MarkupXHtmlPrefs m -> String -> String -> m Html+useChunkFormat pref n s = +    do x <- case [f | f@(ChunkFormat n' _) <- markupFormats pref, n' == n] of+              []  -> return defaultChunkFormat+              [y] -> return y+              _   -> fail $ "More than one chunk format called " ++ n+       liftM (thediv ! [theclass ("chunk-"++n)] <<) $ formatChunk x pref s++useRefFormat :: Monad m => +                MarkupXHtmlPrefs m -> String -> URI -> [Text] -> m Html+useRefFormat pref n uri ts = +    do x <- case [f | f@(RefFormat n' _) <- markupFormats pref, n' == n] of+              []  -> return defaultRefFormat+              [y] -> return y+              _   -> fail $ "More than one ref format called " ++ n+       liftM (thespan ! [theclass ("ref-"++n)] <<) $ formatRef x pref uri ts+++--+-- * Generating plain text.+--++textsToPlain :: [Text] -> String+textsToPlain = concat . map textToPlain++textToPlain :: Text -> String+textToPlain (Emph ts) = "*" ++ textsToPlain ts ++ "*"+textToPlain (TT ts) = "``" ++ textsToPlain ts ++ "``"+textToPlain (Ref uri ts) = "[" ++ show uri ++ " " ++ textsToPlain ts ++ "]"+textToPlain (Word t) = t+textToPlain WhiteSpace = " "
+ hmarkup.cabal view
@@ -0,0 +1,20 @@+Name: hmarkup+Version: 3000.0.0+Copyright: Bjorn Bringert 2006+Maintainer: bjorn@bringert.net+Author: Bjorn Bringert+License: BSD3+License-file: LICENSE+build-depends: base, mtl, parsec, network, xhtml >= 3000.0.0+Extensions: +Synopsis: Simple wikitext-like markup format implementation.+Description:+ This package implements a simple extensible wikitext-like markup format.+ Currently the only implemented output format is XHTML.+Exposed-Modules: +  Text.HMarkup,+  Text.HMarkup.Parse,+  Text.HMarkup.Types,+  Text.HMarkup.XHtml+Other-modules: Text.HMarkup.Entities+ghc-options: -O2 -Wall