module Data.GraphViz.Attributes.HTML
( HtmlLabel(..)
, HtmlText
, HtmlTextItem(..)
, HtmlTable(..)
, HtmlRow(..)
, HtmlCell(..)
, HtmlImg(..)
, HtmlAttributes
, HtmlAttribute(..)
, HtmlAlign(..)
, HtmlVAlign(..)
, HtmlScale(..)
) where
import Data.GraphViz.Parsing
import Data.GraphViz.Printing
import Data.GraphViz.Attributes.Colors
import Data.GraphViz.Attributes.Internal
import Data.GraphViz.Util(bool)
import Numeric(readHex)
import Data.Char(chr, ord, isSpace)
import Data.Function(on)
import Data.List(groupBy, delete)
import Data.Maybe(maybeToList, listToMaybe)
import Data.Word(Word8, Word16)
import qualified Data.Map as Map
import Control.Monad(liftM)
data HtmlLabel = HtmlText HtmlText
| HtmlTable HtmlTable
deriving (Eq, Ord, Show, Read)
instance PrintDot HtmlLabel where
unqtDot (HtmlText txt) = unqtDot txt
unqtDot (HtmlTable tbl) = unqtDot tbl
instance ParseDot HtmlLabel where
parseUnqt = liftM HtmlTable parseUnqt
`onFail`
liftM HtmlText parseUnqt
`adjustErr`
(++ "\nCan't parse HtmlLabel")
parse = parseUnqt
type HtmlText = [HtmlTextItem]
data HtmlTextItem = HtmlStr String
| HtmlNewline HtmlAttributes
| HtmlFont HtmlAttributes HtmlText
deriving (Eq, Ord, Show, Read)
instance PrintDot HtmlTextItem where
unqtDot (HtmlStr str) = escapeValue str
unqtDot (HtmlNewline as) = printHtmlEmptyTag (text "BR") as
unqtDot (HtmlFont as txt) = printHtmlFontTag as $ unqtDot txt
unqtListToDot = hcat . map unqtDot
listToDot = unqtListToDot
instance ParseDot HtmlTextItem where
parseUnqt = oneOf [ liftM HtmlStr unescapeValue
, parseHtmlEmptyTag HtmlNewline "BR"
, parseHtmlFontTag HtmlFont parseUnqt
]
`adjustErr`
(++ "\nCan't parse HtmlTextItem")
parse = parseUnqt
parseUnqtList = many1 parseUnqt
parseList = parseUnqtList
data HtmlTable = HTable {
tableFontAttrs :: Maybe HtmlAttributes
, tableAttrs :: HtmlAttributes
, tableRows :: [HtmlRow]
}
deriving (Eq, Ord, Show, Read)
instance PrintDot HtmlTable where
unqtDot tbl = case tableFontAttrs tbl of
(Just as) -> printHtmlFontTag as tbl'
Nothing -> tbl'
where
tbl' = printHtmlTag (text "TABLE")
(tableAttrs tbl)
(toDot $ tableRows tbl)
instance ParseDot HtmlTable where
parseUnqt = wrapWhitespace (parseHtmlFontTag addFontAttrs pTbl)
`onFail`
pTbl
`adjustErr`
(++ "\nCan't parse HtmlTable")
where
pTbl = wrapWhitespace $ parseHtmlTag (HTable Nothing)
"TABLE"
(wrapWhitespace parseUnqt)
addFontAttrs fas tbl = tbl { tableFontAttrs = Just fas }
parse = parseUnqt
newtype HtmlRow = HtmlRow [HtmlCell]
deriving (Eq, Ord, Show, Read)
instance PrintDot HtmlRow where
unqtDot (HtmlRow cs) = printHtmlTag tr [] $ unqtDot cs
where
tr = text "TR"
unqtListToDot = hcat . map unqtDot
listToDot = unqtListToDot
instance ParseDot HtmlRow where
parseUnqt = wrapWhitespace $ parseHtmlTag (const HtmlRow) "TR" parseUnqt
`adjustErr`
(++ "\nCan't parse HtmlRow")
parse = parseUnqt
parseUnqtList = wrapWhitespace $ sepBy1 parseUnqt allWhitespace'
parseList = parseUnqtList
data HtmlCell = HtmlLabelCell HtmlAttributes HtmlLabel
| HtmlImgCell HtmlAttributes HtmlImg
deriving (Eq, Ord, Show, Read)
instance PrintDot HtmlCell where
unqtDot (HtmlLabelCell as l) = printCell as $ unqtDot l
unqtDot (HtmlImgCell as img) = printCell as $ unqtDot img
unqtListToDot = hsep . map unqtDot
listToDot = unqtListToDot
printCell :: HtmlAttributes -> DotCode -> DotCode
printCell = printHtmlTag (text "TD")
instance ParseDot HtmlCell where
parseUnqt = oneOf [ parseCell HtmlLabelCell parse
, parseCell HtmlImgCell $ wrapWhitespace parseUnqt
]
`adjustErr`
(++ "\nCan't parse HtmlCell")
where
parseCell = flip parseHtmlTag "TD"
parse = parseUnqt
parseUnqtList = wrapWhitespace $ sepBy1 parseUnqt allWhitespace'
parseList = parseUnqtList
newtype HtmlImg = HtmlImg HtmlAttributes
deriving (Eq, Ord, Show, Read)
instance PrintDot HtmlImg where
unqtDot (HtmlImg as) = printHtmlEmptyTag (text "IMG") as
instance ParseDot HtmlImg where
parseUnqt = wrapWhitespace (parseHtmlEmptyTag HtmlImg "IMG")
`adjustErr`
(++ "\nCan't parse HtmlImg")
parse = parseUnqt
type HtmlAttributes = [HtmlAttribute]
data HtmlAttribute = HtmlAlign HtmlAlign
| HtmlBAlign HtmlAlign
| HtmlBGColor Color
| HtmlBorder Word8
| HtmlCellBorder Word8
| HtmlCellPadding Word8
| HtmlCellSpacing Word8
| HtmlColor Color
| HtmlColSpan Word16
| HtmlFace String
| HtmlFixedSize Bool
| HtmlHeight Word16
| HtmlHRef String
| HtmlPointSize Double
| HtmlPort PortName
| HtmlRowSpan Word16
| HtmlScale HtmlScale
| HtmlSrc FilePath
| HtmlTarget String
| HtmlTitle String
| HtmlVAlign HtmlVAlign
| HtmlWidth Word16
deriving (Eq, Ord, Show, Read)
instance PrintDot HtmlAttribute where
unqtDot (HtmlAlign v) = printHtmlField "ALIGN" v
unqtDot (HtmlBAlign v) = printHtmlField "BALIGN" v
unqtDot (HtmlBGColor v) = printHtmlField "BGCOLOR" v
unqtDot (HtmlBorder v) = printHtmlField "BORDER" v
unqtDot (HtmlCellBorder v) = printHtmlField "CELLBORDER" v
unqtDot (HtmlCellPadding v) = printHtmlField "CELLPADDING" v
unqtDot (HtmlCellSpacing v) = printHtmlField "CELLSPACING" v
unqtDot (HtmlColor v) = printHtmlField "COLOR" v
unqtDot (HtmlColSpan v) = printHtmlField "COLSPAN" v
unqtDot (HtmlFace v) = printHtmlField' "FACE" $ escapeAttribute v
unqtDot (HtmlFixedSize v) = printHtmlField' "FIXEDSIZE" $ printBoolHtml v
unqtDot (HtmlHeight v) = printHtmlField "HEIGHT" v
unqtDot (HtmlHRef v) = printHtmlField' "HREF" $ escapeAttribute v
unqtDot (HtmlPointSize v) = printHtmlField "POINT-SIZE" v
unqtDot (HtmlPort v) = printHtmlField' "PORT" . escapeAttribute $ portName v
unqtDot (HtmlRowSpan v) = printHtmlField "ROWSPAN" v
unqtDot (HtmlScale v) = printHtmlField "SCALE" v
unqtDot (HtmlSrc v) = printHtmlField' "SRC" $ escapeAttribute v
unqtDot (HtmlTarget v) = printHtmlField' "TARGET" $ escapeAttribute v
unqtDot (HtmlTitle v) = printHtmlField' "TITLE" $ escapeAttribute v
unqtDot (HtmlVAlign v) = printHtmlField "VALIGN" v
unqtDot (HtmlWidth v) = printHtmlField "WIDTH" v
unqtListToDot = hsep . map unqtDot
listToDot = unqtListToDot
printHtmlField :: (PrintDot a) => String -> a -> DotCode
printHtmlField f = printHtmlField' f . unqtDot
printHtmlField' :: String -> DotCode -> DotCode
printHtmlField' f v = text f <> equals <> doubleQuotes v
instance ParseDot HtmlAttribute where
parseUnqt = oneOf [ parseHtmlField HtmlAlign "ALIGN"
, parseHtmlField HtmlBAlign "BALIGN"
, parseHtmlField HtmlBGColor "BGCOLOR"
, parseHtmlField HtmlBorder "BORDER"
, parseHtmlField HtmlCellBorder "CELLBORDER"
, parseHtmlField HtmlCellPadding "CELLPADDING"
, parseHtmlField HtmlCellSpacing "CELLSPACING"
, parseHtmlField HtmlColor "COLOR"
, parseHtmlField HtmlColSpan "COLSPAN"
, parseHtmlField' HtmlFace "FACE" unescapeAttribute
, parseHtmlField' HtmlFixedSize "FIXEDSIZE" parseBoolHtml
, parseHtmlField HtmlHeight "HEIGHT"
, parseHtmlField' HtmlHRef "HREF" unescapeAttribute
, parseHtmlField HtmlPointSize "POINT-SIZE"
, parseHtmlField' (HtmlPort . PN) "PORT" unescapeAttribute
, parseHtmlField HtmlRowSpan "ROWSPAN"
, parseHtmlField HtmlScale "SCALE"
, parseHtmlField' HtmlSrc "SRC" unescapeAttribute
, parseHtmlField' HtmlTarget "TARGET" unescapeAttribute
, parseHtmlField' HtmlTitle "TITLE" unescapeAttribute
`onFail`
parseHtmlField' HtmlTitle "TOOLTIP" unescapeAttribute
, parseHtmlField HtmlVAlign "VALIGN"
, parseHtmlField HtmlWidth "WIDTH"
]
parse = parseUnqt
parseUnqtList = sepBy parseUnqt allWhitespace
parseList = parseUnqtList
parseHtmlField :: (ParseDot a) => (a -> HtmlAttribute) -> String
-> Parse HtmlAttribute
parseHtmlField c f = parseHtmlField' c f parseUnqt
parseHtmlField' :: (a -> HtmlAttribute) -> String -> Parse a
-> Parse HtmlAttribute
parseHtmlField' c f p = do string f
parseEq
liftM c $ quotedParse p
data HtmlAlign = HLeft
| HCenter
| HRight
| HText
deriving (Eq, Ord, Bounded, Enum, Show, Read)
instance PrintDot HtmlAlign where
unqtDot HLeft = text "LEFT"
unqtDot HCenter = text "CENTER"
unqtDot HRight = text "RIGHT"
unqtDot HText = text "TEXT"
instance ParseDot HtmlAlign where
parseUnqt = oneOf [ stringRep HLeft "LEFT"
, stringRep HCenter "CENTER"
, stringRep HRight "RIGHT"
, stringRep HText "TEXT"
]
parse = parseUnqt
data HtmlVAlign = HTop
| HMiddle
| HBottom
deriving (Eq, Ord, Bounded, Enum, Show, Read)
instance PrintDot HtmlVAlign where
unqtDot HTop = text "TOP"
unqtDot HMiddle = text "MIDDLE"
unqtDot HBottom = text "BOTTOM"
instance ParseDot HtmlVAlign where
parseUnqt = oneOf [ stringRep HTop "TOP"
, stringRep HMiddle "MIDDLE"
, stringRep HBottom "BOTTOM"
]
parse = parseUnqt
data HtmlScale = HtmlNaturalSize
| HtmlScaleUniformly
| HtmlExpandWidth
| HtmlExpandHeight
| HtmlExpandBoth
deriving (Eq, Ord, Bounded, Enum, Show, Read)
instance PrintDot HtmlScale where
unqtDot HtmlNaturalSize = text "FALSE"
unqtDot HtmlScaleUniformly = text "TRUE"
unqtDot HtmlExpandWidth = text "WIDTH"
unqtDot HtmlExpandHeight = text "HEIGHT"
unqtDot HtmlExpandBoth = text "BOTH"
instance ParseDot HtmlScale where
parseUnqt = oneOf [ stringRep HtmlNaturalSize "FALSE"
, stringRep HtmlScaleUniformly "TRUE"
, stringRep HtmlExpandWidth "WIDTH"
, stringRep HtmlExpandHeight "HEIGHT"
, stringRep HtmlExpandBoth "BOTH"
]
parse = parseUnqt
escapeAttribute :: String -> DotCode
escapeAttribute = escapeHtml False
escapeValue :: String -> DotCode
escapeValue = escapeHtml True
escapeHtml :: Bool -> String -> DotCode
escapeHtml quotesAllowed = hcat
. concatMap escapeSegment
. groupBy ((==) `on` isSpace)
where
escapeSegment (s:sps) | isSpace s = char s : map numEscape sps
escapeSegment txt = map xmlChar txt
allowQuotes = if quotesAllowed
then Map.delete '"'
else id
escs = allowQuotes $ Map.fromList htmlEscapes
xmlChar c = maybe (char c) escape $ c `Map.lookup` escs
numEscape = escape' . (<>) (char '#') . int . ord
escape' e = char '&' <> e <> char ';'
escape = escape' . text
unescapeAttribute :: Parse String
unescapeAttribute = unescapeHtml False
unescapeValue :: Parse String
unescapeValue = unescapeHtml True
unescapeHtml :: Bool -> Parse String
unescapeHtml quotesAllowed = liftM concat
. many1 . oneOf $ [ parseEscpd
, validChars
]
where
parseEscpd = do character '&'
esc <- many1 $ satisfy (';' /=)
character ';'
let c = case esc of
('#':'x':hex) -> readMaybe readHex hex
('#':'X':hex) -> readMaybe readHex hex
('#':dec) -> readMaybe readInt dec
_ -> esc `Map.lookup` escMap
return $ maybeToList c
readMaybe f str = do (n, []) <- listToMaybe $ f str
return $ chr n
readInt :: ReadS Int
readInt = reads
allowQuotes = if quotesAllowed
then delete '"'
else id
escMap = Map.fromList htmlUnescapes
validChars = liftM return $ satisfy (`notElem` needEscaping)
needEscaping = allowQuotes $ map fst htmlEscapes
htmlEscapes :: [(Char, String)]
htmlEscapes = [ ('"', "quot")
, ('<', "lt")
, ('>', "gt")
, ('&', "amp")
]
++ map numEscape ['-', '\'']
where
numEscape c = (c, '#' : show (ord c))
htmlUnescapes :: [(String, Char)]
htmlUnescapes = maybeEscaped
++
map (uncurry (flip (,))) htmlEscapes
where
maybeEscaped = [("nbsp", ' '), ("apos", '\'')]
printBoolHtml :: Bool -> DotCode
printBoolHtml = text . bool "FALSE" "TRUE"
parseBoolHtml :: Parse Bool
parseBoolHtml = stringRep True "TRUE"
`onFail`
stringRep False "FALSE"
printHtmlTag :: DotCode -> HtmlAttributes -> DotCode -> DotCode
printHtmlTag t as v = angled (t <+> toDot as)
<> v
<> angled (fslash <> t)
printHtmlFontTag :: HtmlAttributes -> DotCode -> DotCode
printHtmlFontTag = printHtmlTag (text "FONT")
printHtmlEmptyTag :: DotCode -> HtmlAttributes -> DotCode
printHtmlEmptyTag t as = angled $ t <+> toDot as <> fslash
parseHtmlTag :: (HtmlAttributes -> val -> tag) -> String
-> Parse val -> Parse tag
parseHtmlTag c t pv = do as <- parseAngled openingTag
v <- pv
parseAngled $ character '/' >> t' >> allWhitespace'
return $ c as v
where
t' = string t
openingTag = do t'
as <- tryParseList' $ allWhitespace >> parse
allWhitespace'
return as
parseHtmlFontTag :: (HtmlAttributes -> val -> tag) -> Parse val -> Parse tag
parseHtmlFontTag = flip parseHtmlTag "FONT"
parseHtmlEmptyTag :: (HtmlAttributes -> tag) -> String -> Parse tag
parseHtmlEmptyTag c t = parseAngled
( do string t
as <- tryParseList' $ allWhitespace >> parse
allWhitespace'
character '/'
return $ c as
)