module Text.RichReports
where
import Data.List (intersperse)
import Data.String.Utils (join, replace)
import qualified Text.Ascetic.HTML as H
type Message = Report
data Highlight =
HighlightUnbound
| HighlightUnreachable
| HighlightDuplicate
| HighlightError
| Highlight [H.Class]
deriving (Eq, Show)
data Category =
Keyword
| Literal
| Constant
| Variable
| Error
deriving (Eq, Show)
data Report =
Text String
| C Category [Highlight] [Message] String
| Space
| Lt
| Gt
| Conc [Report]
| Field Report
| Row [Report]
| Table [Report]
| Indent Report
| Line [String] [Report]
| LineIfFlat [String] Report
| Atom [Highlight] [Message] [Report]
| Span [Highlight] [Message] [Report]
| Block [Highlight] [Message] [Report]
| BlockIndent [Highlight] [Message] [Report]
| Intersperse Report [Report]
| Finalize Report
deriving (Show, Eq)
class ToReport a where
report :: a -> Report
class ToHighlights a where
highlights :: a -> [Highlight]
class ToMessages a where
messages :: a -> [Message]
instance ToReport a => ToReport [a] where
report xs = Conc $ map report xs
instance ToReport a => ToReport (Maybe a) where
report x = Conc $ maybe [] (\r -> [report r]) x
keyword = C Keyword [] []
keyword_ = C Keyword
key = C Keyword [] []
key_ = C Keyword
literal = C Literal [] []
literal_ = C Literal
lit = C Literal [] []
lit_ = C Literal
constant = C Constant [] []
constant_ = C Constant
const = C Constant [] []
const_ = C Constant
variable = C Variable [] []
variable_ = C Variable
var = C Variable [] []
var_ = C Variable
error = C Error [] []
error_ = C Error
err = C Error [] []
err_ = C Error
highlight :: Highlight -> [H.Class]
highlight h = case h of
HighlightUnbound -> ["RichReports_Highlight_Unbound"]
HighlightUnreachable -> ["RichReports_Highlight_Unreachable"]
HighlightDuplicate -> ["RichReports_Highlight_Duplicate"]
HighlightError -> ["RichReports_Highlight_Error"]
Highlight hs -> hs
messageToAttr :: [Message] -> (H.Property, H.Value)
messageToAttr ms =
let conv m =
replace "\r" "" $
replace "\n" "" $
replace "'" "\\'" $
replace "\"" """ $
show $ H.html m
in ("onclick", "msg(this, [" ++ (join "," ["'" ++ conv m ++ "'" | m <- ms]) ++ "]);")
instance H.ToHTML Report where
html r = case r of
Text s -> H.content s
C c hs ms s ->
H.span_
( [ ("class",
"RichReports_" ++ show c
++ " " ++ (if length ms > 0 then "RichReports_Clickable" else "")
++ " " ++ (if length hs > 0 then "RichReports_Highlight" else "")
++ " " ++ (join " " (concat (map highlight hs)))
)
]
++ ( if length ms > 0 then [messageToAttr ms] else [] )
)
[H.content s]
Space -> H.content " "
Conc rs -> H.conc [H.html r | r <- rs]
Field r -> H.td (H.html r)
Row rs -> H.tr [ H.html r | r <- rs ]
Table rs -> H.table [ H.html r | r <- rs ]
Line _ rs -> H.div [H.html r | r <- rs]
Atom hs ms rs ->
let out = H.span_ [("class", join " " (concat (map highlight hs)))] [H.html r | r <- rs]
in case ms of
[] -> out
ms -> H.span [H.span_ [("class","RichReports_Clickable"), messageToAttr ms] [out]]
Span hs ms rs ->
let out = H.span_ [("class", join " " (concat (map highlight hs)))] [H.html r | r <- rs]
in case ms of
[] -> out
ms -> H.span [H.span_ [("class","RichReports_Clickable RichReports_Clickable_Exclamation"), messageToAttr ms] [H.content "!"], out]
Block _ _ rs -> H.div [H.html r | r <- rs]
BlockIndent _ _ rs -> H.div_ [("class", "RichReports_BlockIndent")] [H.html r | r <- rs]
Intersperse r rs -> H.conc $ intersperse (H.html r) [H.html r | r <- rs]
Finalize r ->
H.file
(H.head [
H.meta_ [("http-equiv","Content-type"),("content","text/html;charset=UTF-8")],
H.style (
H.CSS [
( ["body"],
Nothing,
[ ("font-family", "Courier,Monospace"),
("font-size", "12px")
]
),
( ["table"],
Nothing,
[ ("font-family", "Courier,Monospace"),
("font-size", "12px")
]
),
( ["#RichReports_Message"],
Nothing,
[ ("background-color","yellow"),
("padding","3px"),
("border","1px solid black"),
("font-family", "Courier,Monospace"),
("font-size", "12px"),
("cursor","pointer")
]
),
( [".RichReports_Clickable"], Nothing, [("cursor","pointer")] ),
( [".RichReports_Clickable_Exclamation"],
Nothing,
[ ("background-color","yellow"),
("border","1px solid black"),
("margin","0px 5px 0px 5px"),
("padding","0px 2px 0px 2px"),
("font-size","9px")
]
),
( [".RichReports_Clickable"], Just "hover", [("background-color","yellow")] ),
( [".RichReports_Keyword"], Nothing, [("font-weight","bold"), ("color","blue")] ),
( [".RichReports_Variable"], Nothing, [("font-style","italic"), ("color","green")] ),
( [".RichReports_Literal"], Nothing, [("font-weight","bold"), ("color","firebrick")] ),
( [".RichReports_Error"], Nothing, [("font-weight","bold"), ("color","red"), ("text-decoration","underline")] ),
( [".RichReports_Highlight"], Nothing, [("margin","2px")] ),
( [".RichReports_Highlight_Unbound"], Nothing, [("background-color","orange")] ),
( [".RichReports_Highlight_Unreachable"], Nothing, [("background-color","orange")] ),
( [".RichReports_Highlight_Duplicate"], Nothing, [("background-color","yellow")] ),
( [".RichReports_Highlight_Error"], Nothing, [("background-color","lightpink")] ),
( [".RichReports_BlockIndent"], Nothing, [("margin-left","10px")] )
]
),
H.script_ [("type","text/javascript"), ("src","http://ajax.googleapis.com/ajax/libs/jquery/1.4.3/jquery.min.js")] "",
H.script $
"function msg (obj, msgs) {"
++ "var html = '';"
++ "for (var i = 0; i < msgs.length; i++) html += '<div class=\"RichReports_MessagePortion\">' + msgs[i] + '</div>';"
++ "document.getElementById('RichReports_Message').innerHTML = html;"
++ "document.getElementById('RichReports_Message').style.display = 'inline-block';"
++ "var top = $(obj).offset().top;"
++ "var left = $(obj).offset().left;"
++ "$('#RichReports_Message').offset({top:top + 15, left:left + 15});"
++ "}"
])
(H.body [
H.html r,
H.div_ [("id","RichReports_Message"), ("style","display:none;"), ("onclick", "this.style.display='none';")] [H.content ""]
])
_ -> H.content ""
--eof