module Precis.HtmlReport
(
makeShortReport
, makeFullReport
) where
import Precis.Cabal
import Precis.Diff
import Precis.HsSrc.Datatypes
import Precis.ModuleProperties
import Precis.ReportMonad
import Precis.StyleSheet
import Precis.TextOutput
import Precis.Utils.PPShowS ( toString, line )
import Language.Haskell.Exts ( Module )
import Text.XHtml hiding ( name )
import Control.Monad
type TextSummary = String
makeShortReport :: ModuleParseFunction
-> Package
-> Package
-> IO TextSummary
makeShortReport pf ncp ocp = liftM snd $ makeReport MSG_AND_HTML pf ncp ocp
makeFullReport :: ModuleParseFunction
-> Package
-> Package
-> IO (Html,TextSummary)
makeFullReport = makeReport MSG_AND_HTML
makeReport :: ReportLevel
-> ModuleParseFunction
-> Package
-> Package
-> IO (Html,TextSummary)
makeReport lvl pf new old = liftM post $ execReportM pf lvl $
do { packageNamesAndVersions new old
; countUnresolveds (unresolved_modules new)
; moduleCountSummary new old
; compareExposedModules new old
}
where
post (hs,stats) = (assembleDoc (package_name new) hs, mkText stats)
mkText stats = toString $
(comparingMsg new old) `line` showChangeStats stats
assembleDoc :: String -> [Html] -> Html
assembleDoc pkg_name hs = docHead pkg_name +++ body << concatHtml hs
packageNamesAndVersions :: Package -> Package -> ReportM ()
packageNamesAndVersions new old =
do { tellHtml $ h1 << ("Change summary: " ++ package_name new)
; tellHtml $ h2 << (toString $ comparingMsg new old)
; warnOnNameDiff (package_name new) (package_name old)
; tellHtml $ docCaveat
}
warnOnNameDiff :: String -> String -> ReportM ()
warnOnNameDiff new_name old_name
| new_name == old_name = return ()
| otherwise = do { tellHtml $ p << warn_msg }
where
warn_msg = unwords $ [ "Warning: package names different -"
, new_name, "vs.", old_name ]
moduleCountSummary :: Package -> Package -> ReportM ()
moduleCountSummary new old =
do { countDeletions incrRemovedModules expos
; tellHtml $ docModulesDiffs expos privs
}
where
expos = diffExposedModules new old
privs = diffInternalModules new old
compareExposedModules :: Package -> Package -> ReportM ()
compareExposedModules new old =
mapM_ compareSrcFileEdit $
diffExposedSrcFiles (exposed_modules new) (exposed_modules old)
compareSrcFileEdit :: Edit4 HsSourceFile -> ReportM ()
compareSrcFileEdit (DIF a b) = compareHsSourceFiles a b
compareSrcFileEdit _ = return ()
compareHsSourceFiles :: HsSourceFile -> HsSourceFile -> ReportM ()
compareHsSourceFiles new old = do
do { tellHtml $ docStartSummary new
; pf <- askParseFun
; new_ans <- liftIO $ pf new
; old_ans <- liftIO $ pf old
; case (new_ans, old_ans) of
(Right a, Right b) -> compareModules a b
(Left err,_) -> failk (NEW new) err
(_, Left err) -> failk (OLD old) err
}
where
failk cmpmod err = do { tellParseFail (fmap (getModName . module_name) cmpmod)
; tellHtml $ docModuleParseError cmpmod err
}
data CompareAlg e = CompareAlg
{ algName :: String
, changedLogger :: ReportM ()
, removedLogger :: ReportM ()
, diffCollect :: Module -> Module -> [Edit4 e]
, textPrinter :: e -> String
}
compareModules :: Module -> Module -> ReportM ()
compareModules new old =
do { runCompareAlg exports_alg new old
; runCompareAlg datadecls_alg new old
; runCompareAlg typesigs_alg new old
; runCompareAlg instances_alg new old
}
runCompareAlg :: CompareAlg e -> Module -> Module -> ReportM ()
runCompareAlg alg new old = let diff_list = (diffCollect alg) new old in
do { countWarnings (changedLogger alg) (removedLogger alg) diff_list
; tellHtml $
renderModifications (algName alg) (textPrinter alg) diff_list
}
exports_alg :: CompareAlg ExportItem
exports_alg = CompareAlg { algName = "Exports list"
, changedLogger = incrChangedExports
, removedLogger = incrRemovedExports
, diffCollect = diffExports
, textPrinter = ppExport
}
where
ppExport (ModuleExport s) = s
ppExport (DataOrClass _ s) = s
ppExport (Variable s) = s
datadecls_alg :: CompareAlg DatatypeDecl
datadecls_alg = CompareAlg { algName = "Data declarations"
, changedLogger = incrChangedDatatypes
, removedLogger = incrRemovedDatatypes
, diffCollect = diffDataDecls
, textPrinter = datatype_rep
}
typesigs_alg :: CompareAlg TypeSigDecl
typesigs_alg = CompareAlg { algName = "Type signatures"
, changedLogger = incrChangedTypeSigs
, removedLogger = incrRemovedTypeSigs
, diffCollect = diffTypeSigs
, textPrinter = ppTypeSig
}
where
ppTypeSig a = type_decl_name a ++ " :: " ++ type_signature a
instances_alg :: CompareAlg InstanceDecl
instances_alg = CompareAlg { algName = "Class instances"
, changedLogger = incrChangedInstances
, removedLogger = incrRemovedInstances
, diffCollect = diffInstances
, textPrinter = full_rep
}
countUnresolveds :: [UnresolvedModule] -> ReportM ()
countUnresolveds = mapM_ (tellUnresolved . NEW . getModName . unresolved_name)
countWarnings :: ReportM () -> ReportM () -> [Edit4 a] -> ReportM ()
countWarnings mchange mdelete = mapM_ step where
step (DIF _ _) = mchange
step (DEL _) = mdelete
step _ = return ()
countDeletions :: ReportM () -> [Edit3 a] -> ReportM ()
countDeletions mf = mapM_ step where
step (Del _) = mf
step _ = return ()
renderModifications :: String -> (a -> String) -> [Edit4 a] -> Html
renderModifications txt pp es = case renderBody es of
[] -> noHtml
xs -> (h3 << txt) +++ concatHtml xs
where
renderBody (DIF a b:xs) = diffMarkup pp a b : renderBody xs
renderBody (DEL a:xs) = delMarkup pp a : renderBody xs
renderBody (_:xs) = renderBody xs
renderBody [] = []
diffMarkup :: (a -> String) -> a -> a -> Html
diffMarkup pp a b = concatHtml [ p << "New"
, docChangedCode (NEW $ pp a)
, p << "Old"
, docChangedCode (OLD $ pp b)
]
delMarkup :: (a -> String) -> a -> Html
delMarkup pp a = concatHtml [ p << "Deleted"
, docDeletedCode (pp a)
]
docHead :: String -> Html
docHead pkg_name = header << doc_title +++ doc_style
where
doc_title = thetitle << ("Change summary: " +++ pkg_name)
doc_style = style ! [thetype "text/css"] << inline_stylesheet
docStartSummary :: HsSourceFile -> Html
docStartSummary src_file = h2 << ((getModName $ module_name src_file) ++ ":")
docModuleParseError :: CMP HsSourceFile -> ModuleParseError -> Html
docModuleParseError (OLD _src) err = pre << (moduleParseErrorMsg err)
docModuleParseError (NEW _src) err = pre << (moduleParseErrorMsg err)
docModulesDiffs :: [Edit3 ModName] -> [Edit3 ModName] -> Html
docModulesDiffs expos privs = expos_doc +++ privs_doc
where
expos_doc = maybe docNoExpos (withHeader2 "Exposed modules:")
$ modulesTable expos
privs_doc = maybe docNoPrivs (withHeader2 "Internal modules:")
$ modulesTable privs
withHeader2 :: String -> Html -> Html
withHeader2 txt htm = (h2 << txt) +++ htm
docNoExpos :: Html
docNoExpos = p << txt where
txt = unwords $
[ "No exposed modules counted."
, "Precis only summarizes libraries or combined"
, "library/exe packages."
]
docNoPrivs :: Html
docNoPrivs = p << txt where
txt = unwords $
[ "No internal modules counted." ]
modulesTable :: [Edit3 ModName] -> Maybe Html
modulesTable [] = Nothing
modulesTable xs = Just $ table << zipWith fn xs [1::Int ..]
where
fn (Add a) i = makeRow i "+" $ getModName a
fn (Equ a) i = makeRow i "" $ getModName a
fn (Del a) i = makeRow i "-" $ getModName a
makeRow i op name = tr << [ td << (show i), td << op, td << name ]
docCaveat :: Html
docCaveat = p << txt
where
txt = unwords $
[ "Note, Precis uses a shallow mechanism to detect changes."
, "Syntax elements are parsed by Haskell-src-exts and comparison"
, "is made on the strings extracted from pretty-printing them."
, "This means that Precis should be oblivious to"
, "white-space differences, but harmless changes will be"
, "flagged as differences. e.g. adding a new deriving clause"
, "to a datatype."
]
docChangedCode :: CMP String -> Html
docChangedCode = step
where
step (NEW s) = pre ! [new_style] << s
step (OLD s) = pre ! [old_style] << s
new_style = theclass "oldcode"
old_style = theclass "newcode"
docDeletedCode :: String -> Html
docDeletedCode s = pre ! [del_style] << s
where
del_style = theclass "deletedcode"