{-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Precis.HtmlReport -- Copyright : (c) Stephen Tetley 2010 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : to be determined. -- -- Creating a report in HTML... -- -------------------------------------------------------------------------------- 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 ) -- package: haskell-src-exts import Text.XHtml hiding ( name ) -- package: xhtml import Control.Monad -- TextSummary to be printed to the console... 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) -------------------------------------------------------------------------------- -- Helpers 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) ] -------------------------------------------------------------------------------- -- Html ... 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"