diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,31 @@ #!/usr/bin/env runhaskell + import Distribution.Simple -main = defaultMain +import Distribution.Simple.Setup ( SDistFlags ) +import Distribution.PackageDescription ( HookedBuildInfo, emptyHookedBuildInfo ) + + +main = defaultMainWithHooks sdist_warning_hooks + +sdist_warning_hooks :: UserHooks +sdist_warning_hooks = simpleUserHooks { preSDist = sdistVersionWarning } + + +sdistVersionWarning :: Args -> SDistFlags -> IO HookedBuildInfo +sdistVersionWarning _ _ = + mapM_ putStrLn msg >> printVersionNumberFile >> return emptyHookedBuildInfo + where + msg = [ "-------------------------------------------------------" + , "-------------------------------------------------------" + , "" + , "WARNING - is Precis.VersionNumber correct?" + , "" + , "-------------------------------------------------------" + , "-------------------------------------------------------" + ] + +printVersionNumberFile :: IO () +printVersionNumberFile = + readFile "src/Precis/VersionNumber.hs" >>= putStrLn + diff --git a/precis.cabal b/precis.cabal --- a/precis.cabal +++ b/precis.cabal @@ -1,5 +1,5 @@ name: precis -version: 0.3.1 +version: 0.4.0 license: OtherLicense license-file: LICENCE copyright: Stephen Tetley @@ -13,7 +13,16 @@ Note Precis library is BSD3, Precis executable is LGPL apropos the dependency on CppHs. . - + CHANGES + . + 0.3.1 to 0.4.0 + . + * Substantial changes to reporting - now a summary is printed + to the console, and an HTML report can be generated via a + command line flag. + . + * Changed constructor names for Edit data type + . build-type: Simple stability: unstable @@ -25,24 +34,33 @@ library build-depends: base < 5, containers < 0.5, - Cabal >= 1.8 && < 2.0, - filepath >= 1.1 && < 2.0, - directory >= 1.0 && < 2.0, - haskell-src-exts >= 1.8 && < 2.0, - cpphs >= 1.11 && < 2.0 + Cabal >= 1.8 && < 2.0, + filepath >= 1.1 && < 2.0, + directory >= 1.0 && < 2.0, + haskell-src-exts >= 1.8 && < 2.0, + cpphs >= 1.11 && < 2.0, + xhtml >= 3000.2 && < 3010 + hs-source-dirs: src exposed-modules: Precis.CabalPackage, Precis.Datatypes, + Precis.Diff, Precis.HsSrcUtils, + Precis.HtmlReport, Precis.ModuleProperties, Precis.PathUtils, Precis.PPShowS, - Precis.Properties, - Precis.Utils + Precis.ReportMonad, + Precis.StyleSheet, + Precis.TextOutput, + Precis.VersionNumber + other-modules: + Precis.Utils + executable precis main-is: Main.hs @@ -52,11 +70,16 @@ CPP, Precis.CabalPackage, Precis.Datatypes, + Precis.Diff, Precis.HsSrcUtils, + Precis.HtmlReport, Precis.ModuleProperties, Precis.PathUtils, Precis.PPShowS, - Precis.Properties, - Precis.Utils + Precis.ReportMonad, + Precis.StyleSheet, + Precis.TextOutput, + Precis.Utils, + Precis.VersionNumber diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -19,20 +19,17 @@ import Precis.CabalPackage import Precis.Datatypes import Precis.HsSrcUtils -import Precis.ModuleProperties -import Precis.PPShowS -import Precis.Properties +import Precis.HtmlReport +import Precis.VersionNumber import Language.Haskell.Exts ( Module ) -- package: haskell-src-exts +import Text.XHtml ( renderHtml ) -- package: xhtml + import System.Environment import System.Exit import System.Console.GetOpt --- | REMEMBER TO CHANGE THIS! --- ***************************************************************************** -version_number :: String -version_number = "0.3.0" header :: String header = "Usage: precis " @@ -45,12 +42,15 @@ data Flag = Usage | Version + | HtmlReport String deriving (Eq, Show) options :: [OptDescr Flag] options = [ Option ['h'] ["help"] (NoArg Usage) help_message , Option ['v'] ["version"] (NoArg Version) "show version" + , Option ['o'] ["out"] (ReqArg HtmlReport "FILE") + "output HTML report" ] main :: IO () @@ -63,12 +63,17 @@ main2 opts _ _ | Usage `elem` opts = precisExit $ usageInfo header options | Version `elem` opts = precisExit $ - "precis version " ++ version_number + "precis version " ++ precis_version_number -main2 _ [newc,oldc] [] = runCompare newc oldc -main2 _ _ errs = +main2 opts [newc,oldc] [] = runCompare (lookupOutFile opts) newc oldc +main2 _ _ errs = precisExitFail 1 (concat errs ++ usageInfo header options) +lookupOutFile :: [Flag] -> Maybe String +lookupOutFile [] = Nothing +lookupOutFile (HtmlReport out:_) = Just out +lookupOutFile (_:xs) = lookupOutFile xs + precisExit :: String -> IO () precisExit s = putStrLn s >> exitWith ExitSuccess @@ -76,8 +81,8 @@ precisExitFail i s = putStrLn s >> exitWith (ExitFailure i) -runCompare :: FilePath -> FilePath -> IO () -runCompare new_cabal_file old_cabal_file = do +runCompare :: (Maybe FilePath) -> FilePath -> FilePath -> IO () +runCompare mb_out new_cabal_file old_cabal_file = do ans1 <- extractPrecis new_cabal_file known_extensions ans2 <- extractPrecis old_cabal_file known_extensions @@ -86,122 +91,24 @@ (Left err, _) -> precisExitFail 2 $ cabalFileErrorMsg err (_, Left err) -> precisExitFail 2 $ cabalFileErrorMsg err where - sk new_cp old_cp = do - { printPackageNameAndVersions new_cp old_cp - ; printModuleCountSummary new_cp old_cp - ; compareExposedModules (exposedModulesProp new_cp) - (exposedModulesProp old_cp) - } - - -printPackageNameAndVersions :: CabalPrecis -> CabalPrecis -> IO () -printPackageNameAndVersions new_cp old_cp = putShowSLine $ vsep - [ repeatChar 50 '-' - , packageNames (package_name new_cp) (package_name old_cp) - , repeatChar 50 '-' - , packageVersions (package_version new_cp) (package_version old_cp) - , newline - ] - where - packageNames a b | a == b = text a - | otherwise = text a <+> text "*** Warning: comparing to " - <+> text b - packageVersions a b = text "Version:" <+> text a - <+> text "compared to Version:" - <+> text b - -printModuleCountSummary :: CabalPrecis -> CabalPrecis -> IO () -printModuleCountSummary new_cp old_cp = putShowSLine $ vsep - [ text "Exposed modules:" - , summarizeAddedRemoved "file" "files" id expos - , text "Internal modules:" - , summarizeAddedRemoved "file" "files" id privs - , newline - ] - where - new_pm = packageModulesProp new_cp - old_pm = packageModulesProp old_cp - (expos,privs) = diffPackageModulesProps new_pm old_pm - - -compareExposedModules :: ExposedModulesProp -> ExposedModulesProp -> IO () -compareExposedModules new_expos old_expos = - mapM_ compareSrcFileEdit $ diffExposedModulesProps new_expos old_expos - -compareSrcFileEdit :: Edit SourceFile -> IO () -compareSrcFileEdit (Conflict a b) = compareSourceFiles a b -compareSrcFileEdit _ = return () - - -compareSourceFiles :: SourceFile -> SourceFile -> IO () -compareSourceFiles new_sf old_sf = do - putShowSLine $ newline <> text (module_name new_sf) - new_ans <- fullParseModule new_sf - old_ans <- fullParseModule old_sf - case (new_ans, old_ans) of - (Right new_modu, Right old_modu) -> compareModules new_modu old_modu - (Left err,_) -> putStrLn $ moduleParseErrorMsg err - (_, Left err) -> putStrLn $ moduleParseErrorMsg err - - -compareModules :: Module -> Module -> IO () -compareModules new_modu old_modu = - compareExports new_modu old_modu >> - compareDataDecls new_modu old_modu >> - compareTypeSigs new_modu old_modu >> - compareInstances new_modu old_modu - - -compareExports :: Module -> Module -> IO () -compareExports new_modu old_modu = putShowSLine $ vsep - [ text "Explicit exports:" - , summarizeAddedConflictRemoved "export" "exports" txt expos - ] - where - new_expos = exportsProp new_modu - old_expos = exportsProp old_modu - expos = diffExportsProps new_expos old_expos - - txt (ModuleExport s) = s - txt (DataOrClass _ r) = r - txt (Variable s) = s - -compareInstances :: Module -> Module -> IO () -compareInstances new_modu old_modu = putShowSLine $ vsep - [ text "Instances:" - , summarizeAddedConflictRemoved "instance" "instances" txt expos - ] - where - new_insts = instancesProp new_modu - old_insts = instancesProp old_modu - expos = diffInstancesProps new_insts old_insts - - txt (InstanceDecl _ _ r) = r + sk new_cp old_cp = case mb_out of + Nothing -> shortReport new_cp old_cp + Just path -> fullReportHtml path new_cp old_cp -compareDataDecls :: Module -> Module -> IO () -compareDataDecls new_modu old_modu = putShowSLine $ vsep - [ text "Exported data type decls:" - , summarizeAddedConflictRemoved "data type" "data types" datatype_rep ddecls - ] - where - new_ddecls = dataDeclsProp new_modu - old_ddecls = dataDeclsProp old_modu - ddecls = diffDataDeclsProps new_ddecls old_ddecls +fullReportHtml :: FilePath -> CabalPrecis -> CabalPrecis -> IO () +fullReportHtml out_path new_cp old_cp = + do { (my_doc,msg) <- makeFullReport fullParseModule new_cp old_cp + ; putStrLn $ msg + ; writeFile out_path (renderHtml my_doc) + } -compareTypeSigs :: Module -> Module -> IO () -compareTypeSigs new_modu old_modu = putShowSLine $ vsep - [ text "Exported type sigs:" - , summarizeAddedConflictRemoved "type signature" - "type signatures" ppty tysigs - ] - where - new_tysigs = typeSigsProp new_modu - old_tysigs = typeSigsProp old_modu - tysigs = diffTypeSigsProps new_tysigs old_tysigs - - ppty (TypeSigDecl n r) = n ++ " :: " ++ r +shortReport :: CabalPrecis -> CabalPrecis -> IO () +shortReport new_cp old_cp = + do { msg <- makeShortReport fullParseModule new_cp old_cp + ; putStrLn $ msg + } -- | macro-expand and parse -- diff --git a/src/Precis/Datatypes.hs b/src/Precis/Datatypes.hs --- a/src/Precis/Datatypes.hs +++ b/src/Precis/Datatypes.hs @@ -24,7 +24,7 @@ , CabalPrecis(..) , SourceFile(..) , sourceFile - , sourceFileName + , sourceFileModule , MacroExpandedSrcFile(..) , ModuleParseError(..) @@ -91,9 +91,9 @@ -sourceFileName :: SourceFile -> StrName -sourceFileName (SourceFile n _) = n -sourceFileName (UnresolvedFile n) = n +sourceFileModule :: SourceFile -> StrName +sourceFileModule (SourceFile n _) = n +sourceFileModule (UnresolvedFile n) = n -- defer to unresolved diff --git a/src/Precis/Diff.hs b/src/Precis/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Precis/Diff.hs @@ -0,0 +1,115 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.Diff +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- Two Diff types (3 state and 4 state) +-- +-------------------------------------------------------------------------------- + + +module Precis.Diff + ( + + -- * Edit types + Edit4(..) + , Edit3(..) + + -- * Edit operations + , diff4 + , diff3 + + , addedRemoved + , conflictRemoved + , addedConflictRemoved + + ) where + +import Precis.Utils + +import Data.List ( find ) + +-------------------------------------------------------------------------------- + +data Edit4 a = ADD a | DIF a a | EQU a | DEL a + deriving (Eq,Show) + +-- some edits are better as ADD | EQU | DEL though... + +data Edit3 a = Add a | Equ a | Del a + deriving (Eq,Show) + + +instance Functor Edit4 where + fmap f (ADD a) = ADD (f a) + fmap f (DIF a b) = DIF (f a) (f b) + fmap f (EQU a) = EQU (f a) + fmap f (DEL a) = DEL (f a) + +instance Functor Edit3 where + fmap f (Add a) = Add (f a) + fmap f (Equ a) = Equ (f a) + fmap f (Del a) = Del (f a) + + + + +diff4 :: (a -> a -> Bool) -> (a -> a -> Bool) -> [a] -> [a] -> [Edit4 a] +diff4 matches conflict as bs = toListH $ checkShort bs (checkLong as id) + where + checkLong [] f = f + checkLong (x:xs) f = case find (matches x) bs of + Just b | conflict x b -> checkLong xs (f `snocH` DIF x b) + | otherwise -> checkLong xs (f `snocH` EQU x) + Nothing -> checkLong xs (f `snocH` ADD x) + + checkShort [] f = f + checkShort (y:ys) f = case find (matches y) as of + Just _ -> checkShort ys f -- already found + Nothing -> checkShort ys (f `snocH` DEL y) + + +diff3 :: (a -> a -> Bool) -> [a] -> [a] -> [Edit3 a] +diff3 matches as bs = toListH $ checkShort bs (checkLong as id) + where + checkLong [] f = f + checkLong (x:xs) f = case find (matches x) bs of + Just _ -> checkLong xs (f `snocH` Equ x) + Nothing -> checkLong xs (f `snocH` Add x) + + checkShort [] f = f + checkShort (y:ys) f = case find (matches y) as of + Just _ -> checkShort ys f -- already found + Nothing -> checkShort ys (f `snocH` Del y) + + +addedRemoved :: [Edit4 a] -> ([a],[a]) +addedRemoved = foldr fn ([],[]) + where + fn (ADD a) (as,rs) = (a:as,rs) + fn (DEL r) (as,rs) = (as,r:rs) + fn _ acc = acc + +addedConflictRemoved :: [Edit4 a] -> ([a],[(a,a)],[a]) +addedConflictRemoved = foldr fn ([],[],[]) + where + fn (ADD a) (as,cs,rs) = (a:as,cs,rs) + fn (DIF a b) (as,cs,rs) = (as,(a,b):cs,rs) + fn (DEL r) (as,cs,rs) = (as,cs,r:rs) + fn _ acc = acc + + +conflictRemoved :: [Edit4 a] -> ([(a,a)],[a]) +conflictRemoved = foldr fn ([],[]) + where + fn (DIF a b) (cs,rs) = ((a,b):cs,rs) + fn (DEL r) (cs,rs) = (cs,r:rs) + fn _ acc = acc + diff --git a/src/Precis/HsSrcUtils.hs b/src/Precis/HsSrcUtils.hs --- a/src/Precis/HsSrcUtils.hs +++ b/src/Precis/HsSrcUtils.hs @@ -34,7 +34,6 @@ ) where import Precis.Datatypes -import Precis.PPShowS import Language.Haskell.Exts hiding ( name ) -- package: haskell-src-exts @@ -45,9 +44,8 @@ ParseFailed loc msg -> Left $ ERR_MODULE_FILE_PARSE $ mkMsg msg loc ParseOk a -> Right $ a where - mkMsg msg loc = toString $ text msg <+> ppLoc loc - ppLoc (SrcLoc _ l c) = parens $ - (text "line:" <+> int l <+> text ", column:" <+> int c) + mkMsg msg loc = msg ++ " - " ++ ppLoc loc + ppLoc (SrcLoc _ l c) = unwords ["line:", show l ++ ",", "column:", show c] parseModuleWithExts :: [Extension] -> FilePath -> String -> ParseResult Module parseModuleWithExts exts file_name txt = parseModuleWithMode pmode txt @@ -96,7 +94,6 @@ namedDecls t@(DerivDecl _ _ q _) = [(extractQName q, prettyPrint t)] namedDecls t@(TypeSig _ ns _) = map fn ns where fn n = (extractName n, prettyPrint t) - namedDecls _ = [] diff --git a/src/Precis/HtmlReport.hs b/src/Precis/HtmlReport.hs new file mode 100644 --- /dev/null +++ b/src/Precis/HtmlReport.hs @@ -0,0 +1,332 @@ +{-# 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.Datatypes +import Precis.Diff +import Precis.StyleSheet +import Precis.ModuleProperties +import Precis.PPShowS ( toString, line ) +import Precis.ReportMonad +import Precis.TextOutput + +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 + -> CabalPrecis + -> CabalPrecis + -> IO TextSummary +makeShortReport pf ncp ocp = liftM snd $ makeReport MSG_AND_HTML pf ncp ocp + + +makeFullReport :: ModuleParseFunction + -> CabalPrecis + -> CabalPrecis + -> IO (Html,TextSummary) +makeFullReport = makeReport MSG_AND_HTML + + +makeReport :: ReportLevel + -> ModuleParseFunction + -> CabalPrecis + -> CabalPrecis + -> IO (Html,TextSummary) +makeReport lvl pf new old = liftM post $ execReportM pf lvl $ + do { packageNamesAndVersions new old + ; moduleCountSummary new old + ; compareExposedModules (exposed_modules new) (exposed_modules 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 :: CabalPrecis -> CabalPrecis -> 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 :: CabalPrecis -> CabalPrecis -> ReportM () +moduleCountSummary new old = + do { countDeletions incrRemovedModules expos + ; tellHtml $ docModulesDiffs expos privs + } + where + expos = diffExposedModules new old + privs = diffInternalModules new old + + + +compareExposedModules :: [SourceFile] -> [SourceFile] -> ReportM () +compareExposedModules new old = + mapM_ compareSrcFileEdit $ diffExposedSrcFiles new old + +compareSrcFileEdit :: Edit4 SourceFile -> ReportM () +compareSrcFileEdit (DIF a b) = compareSourceFiles a b +compareSrcFileEdit _ = return () + + + +compareSourceFiles :: SourceFile -> SourceFile -> ReportM () +compareSourceFiles 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 sourceFileModule 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 + } + + + + + +-------------------------------------------------------------------------------- +-- 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 :: SourceFile -> Html +docStartSummary src_file = h2 << (sourceFileModule src_file ++ ":") + +docModuleParseError :: CMP SourceFile -> ModuleParseError -> Html +docModuleParseError (OLD _src) err = pre << (moduleParseErrorMsg err) +docModuleParseError (NEW _src) err = pre << (moduleParseErrorMsg err) + + + +docModulesDiffs :: [Edit3 StrName] -> [Edit3 StrName] -> 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 StrName] -> Maybe Html +modulesTable [] = Nothing +modulesTable xs = Just $ table << zipWith fn xs [1::Int ..] + where + fn (Add a) i = makeRow i "+" a + fn (Equ a) i = makeRow i "" a + fn (Del a) i = makeRow i "-" 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" + diff --git a/src/Precis/ModuleProperties.hs b/src/Precis/ModuleProperties.hs --- a/src/Precis/ModuleProperties.hs +++ b/src/Precis/ModuleProperties.hs @@ -18,40 +18,26 @@ module Precis.ModuleProperties ( - PackageModulesProp - , packageModulesProp - , PackageModulesList(..) - , diffPackageModulesProps - - , ExposedModulesProp - , exposedModulesProp - , ExposedModulesList - , diffExposedModulesProps + diffExposedModules + , diffInternalModules + , diffExposedSrcFiles -- - , ExportsProp - , exportsProp - , diffExportsProps + , diffExports -- - , InstancesProp - , instancesProp - , diffInstancesProps + , diffInstances -- - , DataDeclsProp - , dataDeclsProp - , diffDataDeclsProps + , diffDataDecls - , TypeSigsProp - , typeSigsProp - , diffTypeSigsProps + , diffTypeSigs ) where import Precis.Datatypes +import Precis.Diff import Precis.HsSrcUtils -import Precis.Properties import Language.Haskell.Exts hiding ( name, op ) -- package: haskell-src-exts @@ -62,94 +48,42 @@ -------------------------------------------------------------------------------- -- all modules (exposed and internal) in a cabal file -type PackageModulesProp = Property PackageModulesList -data PackageModulesList = PackageModulesList - { public_modules :: [StrName] - , private_modules :: [StrName] - } - deriving (Eq,Show) - -makePackageModulesProp :: PackageModulesList -> PackageModulesProp -makePackageModulesProp = Property name descr +diffExposedModules :: CabalPrecis -> CabalPrecis -> [Edit3 StrName] +diffExposedModules new old = diff3 (==) new' old' where - name = "Modules list" - descr = "Lists of exposed and internal modules in a package." - -packageModulesProp :: CabalPrecis -> PackageModulesProp -packageModulesProp = makePackageModulesProp . packageModulesList + new' = map getName $ exposed_modules new + old' = map getName $ exposed_modules old -packageModulesList :: CabalPrecis -> PackageModulesList -packageModulesList cp = PackageModulesList expos privs +diffInternalModules :: CabalPrecis -> CabalPrecis -> [Edit3 StrName] +diffInternalModules new old = diff3 (==) new' old' where - expos = map sourceFileName $ exposed_modules cp - privs = map sourceFileName $ internal_modules cp + new' = map getName $ internal_modules new + old' = map getName $ internal_modules old +getName :: SourceFile -> StrName +getName (SourceFile m _) = m +getName (UnresolvedFile s) = s -diffPackageModulesProps :: PackageModulesProp - -> PackageModulesProp - -> ([Edit StrName],[Edit StrName]) -diffPackageModulesProps = diffProperty cmp - where - cmp :: PackageModulesList -> PackageModulesList - -> ([Edit StrName],[Edit StrName]) - cmp (PackageModulesList expos privs) (PackageModulesList expos' privs') = - (xs,ys) - where - xs = difference (==) (/=) expos expos' - ys = difference (==) (/=) privs privs' --------------------------------------------------------------------------------- --- exposed modules in cabal file - -type ExposedModulesProp = Property ExposedModulesList - -type ExposedModulesList = [SourceFile] - -makeExposedModulesProp :: ExposedModulesList -> ExposedModulesProp -makeExposedModulesProp = Property name descr - where - name = "Exposed modules" - descr = "Exposed modules (with paths) in a package." - -exposedModulesProp :: CabalPrecis -> ExposedModulesProp -exposedModulesProp = makeExposedModulesProp . exposed_modules - - -diffExposedModulesProps :: ExposedModulesProp - -> ExposedModulesProp - -> [Edit SourceFile] -diffExposedModulesProps = diffProperty cmp +diffExposedSrcFiles :: [SourceFile] -> [SourceFile] -> [Edit4 SourceFile] +diffExposedSrcFiles new old = diff4 equal (/=) new old where - cmp :: ExposedModulesList -> ExposedModulesList -> [Edit SourceFile] - cmp es1 es2 = difference (lift2a (==)) (/=) es1 es2 - - - lift2a :: (StrName -> StrName -> b) -> SourceFile -> SourceFile -> b - lift2a op s1 s2 = sourceFileName s1 `op` sourceFileName s2 + s `equal` t = getName s == getName t -------------------------------------------------------------------------------- -- export lists -type ExportsProp = Property ExportsList -makeExportsProp :: ExportsList -> ExportsProp -makeExportsProp = Property name descr - where - name = "Module exports" - descr = "Explicit exports from a module (class instances not counted)." - - -type ExportsList = [ExportItem] - - -exportsProp :: Module -> ExportsProp -exportsProp modu = makeExportsProp (exportsList modu) +diffExports :: Module -> Module -> [Edit4 ExportItem] +diffExports new old = diff4 equal (/=) (exportsList new) (exportsList old) + where + equal s1 s2 = exportItemName s1 == exportItemName s2 -exportsList :: Module -> ExportsList +exportsList :: Module -> [ExportItem] exportsList (Module _ _ _ _ mb_expos _ _) = maybe [] (map makeExportItem) mb_expos @@ -165,34 +99,23 @@ DataOrClass (extractQName name) (prettyPrint s) -diffExportsProps :: ExportsProp -> ExportsProp -> [Edit ExportItem] -diffExportsProps = diffProperty cmp - where - cmp :: ExportsList -> ExportsList -> [Edit ExportItem] - cmp es1 es2 = difference (lift2a (==)) (/=) es1 es2 - - lift2a :: (StrName -> StrName -> b) -> ExportItem -> ExportItem -> b - lift2a op s1 s2 = exportItemName s1 `op` exportItemName s2 - - -------------------------------------------------------------------------------- -- class instances -type InstancesProp = Property InstancesList -makeInstancesProp :: InstancesList -> InstancesProp -makeInstancesProp = Property name descr - where - name = "Instance declarations" - descr = "Instance declarations defined in the module." - +-- compare instances on class name and text rep of type +-- +type InstanceKey = (StrName,TextRep) -type InstancesList = [InstanceDecl] +instanceKey :: InstanceDecl -> InstanceKey +instanceKey (InstanceDecl s k _) = (s,k) -instancesProp :: Module -> InstancesProp -instancesProp modu = makeInstancesProp (instancesList modu) +diffInstances :: Module -> Module -> [Edit4 InstanceDecl] +diffInstances new old = diff4 equal (/=) (instancesList new) (instancesList old) + where + equal s1 s2 = instanceKey s1 == instanceKey s2 -instancesList :: Module -> InstancesList +instancesList :: Module -> [InstanceDecl] instancesList (Module _ _ _ _ _ _ ds) = catMaybes $ map makeInstanceDecl ds makeInstanceDecl :: Decl -> Maybe InstanceDecl @@ -201,42 +124,18 @@ makeInstanceDecl _ = Nothing --- compare instances on class name and text rep of type --- -type InstanceKey = (StrName,TextRep) -instanceKey :: InstanceDecl -> InstanceKey -instanceKey (InstanceDecl s k _) = (s,k) - -diffInstancesProps :: InstancesProp -> InstancesProp -> [Edit InstanceDecl] -diffInstancesProps = diffProperty cmp - where - cmp :: InstancesList -> InstancesList -> [Edit InstanceDecl] - cmp xs1 xs2 = difference (lift2a (==)) (/=) xs1 xs2 - - lift2a :: (InstanceKey -> InstanceKey -> b) - -> InstanceDecl -> InstanceDecl -> b - lift2a op s1 s2 = instanceKey s1 `op` instanceKey s2 - - - -------------------------------------------------------------------------------- -- exported data types (regular and GADTS) -type DataDeclsProp = Property DataDeclsList -makeDataDeclsProp :: DataDeclsList -> DataDeclsProp -makeDataDeclsProp = Property name descr - where - name = "Exported data declarations" - descr = "Data declarations exported from exposed modules." +diffDataDecls :: Module -> Module -> [Edit4 DatatypeDecl] +diffDataDecls new old = diff4 equal (/=) (dataDeclsList new) (dataDeclsList old) + where + equal s1 s2 = datatypeDeclName s1 == datatypeDeclName s2 -type DataDeclsList = [DatatypeDecl] -dataDeclsProp :: Module -> DataDeclsProp -dataDeclsProp modu = makeDataDeclsProp (dataDeclsList modu) - -dataDeclsList :: Module -> DataDeclsList +dataDeclsList :: Module -> [DatatypeDecl] dataDeclsList (Module _ _ _ _ mb_expo _ ds) = filterDatatypes mb_expo all_datas where all_datas = catMaybes $ map makeDatatypeDecl ds @@ -261,34 +160,18 @@ mkExpoT _ = Nothing -diffDataDeclsProps :: DataDeclsProp -> DataDeclsProp -> [Edit DatatypeDecl] -diffDataDeclsProps = diffProperty cmp - where - cmp :: DataDeclsList -> DataDeclsList -> [Edit DatatypeDecl] - cmp xs1 xs2 = difference (lift2a (==)) (/=) xs1 xs2 - - lift2a :: (StrName -> StrName -> b) -> DatatypeDecl -> DatatypeDecl -> b - lift2a op s1 s2 = datatypeDeclName s1 `op` datatypeDeclName s2 - -------------------------------------------------------------------------------- -- exported type sigs -type TypeSigsProp = Property TypeSigsList -makeTypeSigsProp :: TypeSigsList -> TypeSigsProp -makeTypeSigsProp = Property name descr - where - name = "Exported type signatures" - descr = unwords [ "Type signatures of functions, constants... exported" - , "from exposed modules."] +diffTypeSigs :: Module -> Module -> [Edit4 TypeSigDecl] +diffTypeSigs new old = diff4 equal (/=) (typeSigsList new) (typeSigsList old) + where + equal s1 s2 = typeSigDeclName s1 == typeSigDeclName s2 -type TypeSigsList = [TypeSigDecl] -typeSigsProp :: Module -> TypeSigsProp -typeSigsProp modu = makeTypeSigsProp (typeSigsList modu) - -typeSigsList :: Module -> TypeSigsList +typeSigsList :: Module -> [TypeSigDecl] typeSigsList (Module _ _ _ _ mb_expo _ ds) = filterTypeSigs mb_expo all_typesigs where all_typesigs = concat $ map makeTypeSigDecl ds @@ -308,13 +191,3 @@ mkExpoT (EVar n) = Just $ extractQName n mkExpoT _ = Nothing - - -diffTypeSigsProps :: TypeSigsProp -> TypeSigsProp -> [Edit TypeSigDecl] -diffTypeSigsProps = diffProperty cmp - where - cmp :: TypeSigsList -> TypeSigsList -> [Edit TypeSigDecl] - cmp xs1 xs2 = difference (lift2a (==)) (/=) xs1 xs2 - - lift2a :: (StrName -> StrName -> b) -> TypeSigDecl -> TypeSigDecl -> b - lift2a op s1 s2 = typeSigDeclName s1 `op` typeSigDeclName s2 diff --git a/src/Precis/PPShowS.hs b/src/Precis/PPShowS.hs --- a/src/Precis/PPShowS.hs +++ b/src/Precis/PPShowS.hs @@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- | --- Module : Precis.HString +-- Module : Precis.PPShowS -- Copyright : (c) Stephen Tetley 2010 -- License : BSD3 -- diff --git a/src/Precis/Properties.hs b/src/Precis/Properties.hs deleted file mode 100644 --- a/src/Precis/Properties.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Precis.Properties --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : to be determined. --- --- --- --------------------------------------------------------------------------------- - - -module Precis.Properties - ( - -- * Property type - Property(..) - - -- * Edit type - , Edit(..) - - -- * Edit operations - , difference - , diffProperty - , addedRemoved - , summarizeAddedRemoved - , summarizeConflictRemoved - , summarizeAddedConflictRemoved - - ) where - -import Precis.PPShowS -import Precis.Utils - -import Data.List ( find ) - - -data Property n = Property - { property_name :: String - , property_description :: String - , property_value :: n - } - deriving (Eq,Ord,Show) - - --------------------------------------------------------------------------------- - -data Edit a = Added a | Conflict a a | Same a | Removed a - deriving (Eq,Show) - - - -difference :: (a -> a -> Bool) -> (a -> a -> Bool) -> [a] -> [a] -> [Edit a] -difference matches conflict as bs = toListH $ checkShort bs (checkLong as id) - where - checkLong [] f = f - checkLong (x:xs) f = case find (matches x) bs of - Just b | conflict x b -> checkLong xs (f `snocH` Conflict x b) - | otherwise -> checkLong xs (f `snocH` Same x) - Nothing -> checkLong xs (f `snocH` Added x) - - checkShort [] f = f - checkShort (y:ys) f = case find (matches y) as of - Just _ -> checkShort ys f -- already found - Nothing -> checkShort ys (f `snocH` Removed y) - - - -diffProperty :: (n -> n -> b) -> Property n -> Property n -> b -diffProperty cmp (Property _ _ a) (Property _ _ b) = cmp a b - - -addedRemoved :: [Edit a] -> ([a],[a]) -addedRemoved = foldr fn ([],[]) - where - fn (Added a) (as,rs) = (a:as,rs) - fn (Removed r) (as,rs) = (as,r:rs) - fn _ acc = acc - -addedConflictRemoved :: [Edit a] -> ([a],[(a,a)],[a]) -addedConflictRemoved = foldr fn ([],[],[]) - where - fn (Added a) (as,cs,rs) = (a:as,cs,rs) - fn (Conflict a b) (as,cs,rs) = (as,(a,b):cs,rs) - fn (Removed r) (as,cs,rs) = (as,cs,r:rs) - fn _ acc = acc - - -conflictRemoved :: [Edit a] -> ([(a,a)],[a]) -conflictRemoved = foldr fn ([],[]) - where - fn (Conflict a b) (cs,rs) = ((a,b):cs,rs) - fn (Removed r) (cs,rs) = (cs,r:rs) - fn _ acc = acc - - -summarizeAddedRemoved :: String -> String -> (a -> String) -> [Edit a] -> ShowS -summarizeAddedRemoved single plural sf xs = - added_msg <> comma <+> removed_msg - `nextLine` vsep (map (addedLine sf) as) - `nextLine` vsep (map (removedLine sf) rs) - where - (as,rs) = addedRemoved xs - added_msg = addedMsg single plural (length as) - removed_msg = removedMsg single plural (length rs) - - -summarizeConflictRemoved :: String -> String -> (a -> String) -> [Edit a] -> ShowS -summarizeConflictRemoved single plural sf xs = - conflict_msg <> comma <+> removed_msg - `nextLine` vsep (map (conflictLine sf) cs) - `nextLine` vsep (map (removedLine sf) rs) - where - (cs,rs) = conflictRemoved xs - conflict_msg = conflictMsg single plural (length cs) - removed_msg = removedMsg single plural (length rs) - - -summarizeAddedConflictRemoved :: String - -> String - -> (a -> String) -> [Edit a] -> ShowS -summarizeAddedConflictRemoved single plural sf xs = - added_msg <> comma <+> conflict_msg <> comma <+> removed_msg - `nextLine` vsep (map (addedLine sf) as) - `nextLine` vsep (map (conflictLine sf) cs) - `nextLine` vsep (map (removedLine sf) rs) - where - (as,cs,rs) = addedConflictRemoved xs - added_msg = addedMsg single plural (length as) - conflict_msg = conflictMsg single plural (length cs) - removed_msg = removedMsg single plural (length rs) - - --- - -msgCount :: String -> String -> Int -> ShowS -msgCount single _ 1 = int 1 <+> text single -msgCount _ plural n = int n <+> text plural - - -addedMsg :: String -> String -> Int -> ShowS -addedMsg single plural i = msgCount single plural i <+> text "added (+)" - -conflictMsg :: String -> String -> Int -> ShowS -conflictMsg single plural i = msgCount single plural i <+> text "conflict (*)" - -removedMsg :: String -> String -> Int -> ShowS -removedMsg single plural i = msgCount single plural i <+> text "removed (-)" - - -addedLine :: (a -> String) -> a -> ShowS -addedLine f a = char '+' <+> (text $ f a) - -conflictLine :: (a -> String) -> (a,a) -> ShowS -conflictLine f (a,b) = prefixLines (text "< ") (f a) `line` - prefixLines (text "> ") (f b) <> newline - -removedLine :: (a -> String) -> a -> ShowS -removedLine f a = char '-' <+> (text $ f a) diff --git a/src/Precis/ReportMonad.hs b/src/Precis/ReportMonad.hs new file mode 100644 --- /dev/null +++ b/src/Precis/ReportMonad.hs @@ -0,0 +1,198 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.ReportMonad +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- Logging monad for collecting report fragments +-- +-------------------------------------------------------------------------------- + + +module Precis.ReportMonad + ( + -- * Report-monad + ReportM + , Log + , CMP(..) + , ChangeStats(..) + + , ModuleParseFunction + , ReportLevel(..) + + , runReportM + , execReportM + + , askParseFun + , liftIO + + , tellHtml + , tellParseFail + + , incrRemovedModules + , incrRemovedExports + , incrChangedExports + , incrRemovedDatatypes + , incrChangedDatatypes + , incrRemovedTypeSigs + , incrChangedTypeSigs + , incrRemovedInstances + , incrChangedInstances + + + ) where + +import Precis.Datatypes +import Precis.Utils + +import Language.Haskell.Exts ( Module ) -- package: haskell-src-exts +import Text.XHtml hiding ( name ) -- package: xhtml + +import Control.Monad + +-- Note - the monad has Writer operations but State implementation. +-- We don't particulary want append, snoc would be better, cons plus +-- final reverse will do. + +-- + +type Log = ([Html],ChangeStats) + +-- Stats collects changes that should bump a /major version +-- number/ as well as files that can't be parsed. + +data CMP a = NEW a | OLD a + deriving (Eq,Show) + +instance Functor CMP where + fmap f (NEW a) = NEW (f a) + fmap f (OLD a) = OLD (f a) + +data ChangeStats = ChangeStats + { unparseable_modules :: [CMP StrName] + , removed_modules :: Int + + -- exports from a module + , removed_exports :: Int + , changed_exports :: Int + + -- datatypes + , removed_datatypes :: Int + , changed_datatypes :: Int + + -- type signatures of functions / constants + , removed_typesigs :: Int + , changed_typesigs :: Int + + -- class instances + , removed_instances :: Int + , changed_instances :: Int + } + deriving (Show) + +type ModuleParseFunction = SourceFile -> IO (Either ModuleParseError Module) + +data ReportLevel = JUST_MSG | MSG_AND_HTML + deriving (Eq,Show) + +type Env = (ModuleParseFunction, ReportLevel) + +-- Reader (for report level) x State +-- +newtype ReportM a = ReportM { getReportM :: Env -> Log -> IO (a,Log) } + +instance Functor ReportM where + fmap f (ReportM rf) = ReportM $ \e w -> + rf e w `bindIO` \(a,w') -> returnIO (f a,w') + +returnIO :: a -> IO a +returnIO = return + +bindIO :: IO a -> (a -> IO b) -> IO b +bindIO = (>>=) + + +instance Monad ReportM where + return a = ReportM $ \_ w -> returnIO (a,w) + ma >>= mf = ReportM $ \e w -> (getReportM ma e w) `bindIO` \(a,w') -> + (getReportM . mf) a e w' + + + +log_zero :: Log +log_zero = ([],stats_zero) + where + stats_zero = ChangeStats [] 0 0 0 0 0 0 0 0 0 + +runReportM :: ModuleParseFunction -> ReportLevel -> ReportM a -> IO (a,Log) +runReportM pf lvl mf = (getReportM mf) (pf,lvl) log_zero `bindIO` post + where + post (a,(hs,stats)) = returnIO (a,(reverse hs,stats)) + +execReportM :: ModuleParseFunction -> ReportLevel -> ReportM a -> IO Log +execReportM pf lvl mf = liftM snd (runReportM pf lvl mf) + +askParseFun :: ReportM ModuleParseFunction +askParseFun = ReportM $ \(pf,_) w -> returnIO (pf,w) + +liftIO :: IO a -> ReportM a +liftIO mf = ReportM $ \_ w -> mf `bindIO` \a -> returnIO (a,w) + + +tellHtml :: Html -> ReportM () +tellHtml h = ReportM $ \(_,lvl) (hs,stats) -> case lvl of + JUST_MSG -> returnIO ((),(hs,stats)) + MSG_AND_HTML -> returnIO ((),(h:hs,stats)) + +updateStats :: (ChangeStats -> ChangeStats) -> ReportM () +updateStats fn = ReportM $ \_ (hs,stats) -> returnIO ((),(hs, fn stats)) + + +tellParseFail :: CMP StrName -> ReportM () +tellParseFail name = updateStats $ + pstar (\xs s -> s { unparseable_modules = name:xs}) unparseable_modules + +incrRemovedModules :: ReportM () +incrRemovedModules = updateStats $ + pstar (\i s -> s { removed_modules = i+1}) removed_modules + + +incrRemovedExports :: ReportM () +incrRemovedExports = updateStats $ + pstar (\i s -> s { removed_exports = i+1}) removed_exports + +incrChangedExports :: ReportM () +incrChangedExports = updateStats $ + pstar (\i s -> s { changed_exports = i+1}) changed_exports + + +incrRemovedDatatypes :: ReportM () +incrRemovedDatatypes = updateStats $ + pstar (\i s -> s { removed_datatypes = i+1}) removed_datatypes + +incrChangedDatatypes :: ReportM () +incrChangedDatatypes = updateStats $ + pstar (\i s -> s { changed_datatypes = i+1}) changed_datatypes + + +incrRemovedTypeSigs :: ReportM () +incrRemovedTypeSigs = updateStats $ + pstar (\i s -> s { removed_typesigs = i+1}) removed_typesigs + +incrChangedTypeSigs :: ReportM () +incrChangedTypeSigs = updateStats $ + pstar (\i s -> s { changed_typesigs = i+1}) changed_typesigs + +incrRemovedInstances :: ReportM () +incrRemovedInstances = updateStats $ + pstar (\i s -> s { removed_instances = i+1}) removed_instances + +incrChangedInstances :: ReportM () +incrChangedInstances = updateStats $ + pstar (\i s -> s { changed_instances = i+1}) changed_instances diff --git a/src/Precis/StyleSheet.hs b/src/Precis/StyleSheet.hs new file mode 100644 --- /dev/null +++ b/src/Precis/StyleSheet.hs @@ -0,0 +1,79 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.StyleSheet +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- Creating a report in HTML... +-- +-------------------------------------------------------------------------------- + + +module Precis.StyleSheet + ( + inline_stylesheet + + ) where + +import Text.XHtml hiding ( navy, maroon ) -- package: xhtml + + +inline_stylesheet :: Html +inline_stylesheet = primHtml $ unlines $ + [ "" + ] + +-- some named colours... + +aliceblue :: String +aliceblue = "rgb(240,249,255)" + +bisque :: String +bisque = "rgb(255,228,197)" + +brown :: String +brown = "rgb(165,43,43)" + +-- chocolate :: String +-- chocolate = "rgb(211,106,31)" + +-- crimson :: String +-- crimson = "rgb(221,20,60)" + +-- indianred :: String +-- indianred = "rgb(206,93,93)" + +-- lightcoral :: String +-- lightcoral = "rgb(240,128,128)" + +-- lightsalmon :: String +-- lightsalmon = "rgb(255,160,122)" + +-- maroon :: String +-- maroon = "rgb(128,0,0)" + +mintcream :: String +mintcream = "rgb(246,255,250)" + +-- navy :: String +-- navy = "rgb(0,0,128)" + +whitesmoke :: String +whitesmoke = "rgb(246,246,246)" diff --git a/src/Precis/TextOutput.hs b/src/Precis/TextOutput.hs new file mode 100644 --- /dev/null +++ b/src/Precis/TextOutput.hs @@ -0,0 +1,108 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.TextOutput +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- Print ChangeStats to the console. +-- +-------------------------------------------------------------------------------- + + +module Precis.TextOutput + ( + showChangeStats + , comparingMsg + ) where + +import Precis.Datatypes +import Precis.PPShowS +import Precis.ReportMonad + +import Data.Maybe + +showChangeStats :: ChangeStats -> ShowS +showChangeStats = vsep . catMaybes . sequence funs + where + funs = [ unparseableModules, removedModules + , removedExports, changedExports + , removedDatatypes, changedDatatypes + , removedTypeSigs, changedTypeSigs + , removedInstances, changedInstances + ] + + +unparseableModules :: ChangeStats -> Maybe ShowS +unparseableModules = step . unparseable_modules + where + step [] = Nothing + step xs = Just $ prolog $ vsep $ map fn xs + + fn (NEW s) = space <> text s <+> parens (text "new") + fn (OLD s) = space <> text s <+> parens (text "old") + + prolog k = text "The following modules could not be parsed: " `line` k + + +removedModules :: ChangeStats -> Maybe ShowS +removedModules = + countMsg "removed" "exposed module" "exposed modules" . removed_modules + +removedExports :: ChangeStats -> Maybe ShowS +removedExports = + countMsg "removed" "export list item" "export list items" . removed_exports + +changedExports :: ChangeStats -> Maybe ShowS +changedExports = + countMsg "changed" "export" "exports" . changed_exports + + +removedDatatypes :: ChangeStats -> Maybe ShowS +removedDatatypes = countMsg "removed" "datatype" "datatypes" . removed_datatypes + +changedDatatypes :: ChangeStats -> Maybe ShowS +changedDatatypes = + countMsg "changed" "datatype" "datatypes" . changed_datatypes + + + +removedTypeSigs :: ChangeStats -> Maybe ShowS +removedTypeSigs = + countMsg "removed" "type signature" "type signatures" . removed_typesigs + +changedTypeSigs :: ChangeStats -> Maybe ShowS +changedTypeSigs = + countMsg "changed" "type signature" "type signatures" . changed_typesigs + + +removedInstances :: ChangeStats -> Maybe ShowS +removedInstances = + countMsg "removed" "class instance" "class instances" . removed_instances + +changedInstances :: ChangeStats -> Maybe ShowS +changedInstances = + countMsg "changed" "class instance" "class instances" . changed_instances + + +countMsg :: String -> String -> String -> Int -> Maybe ShowS +countMsg act single plural n + | n <= 0 = Nothing + | n == 1 = Just $ int 1 <+> text single <+> text act + | otherwise = Just $ int n <+> text plural <+> text act + + +-------------------------------------------------------------------------------- + +comparingMsg :: CabalPrecis -> CabalPrecis -> ShowS +comparingMsg new old = suffixEllipses $ hsep $ map text + [ "Comparing", package_name new, package_version new + , "to", package_name old, package_version old + ] + where + suffixEllipses = (<> text "...") diff --git a/src/Precis/Utils.hs b/src/Precis/Utils.hs --- a/src/Precis/Utils.hs +++ b/src/Precis/Utils.hs @@ -17,20 +17,28 @@ module Precis.Utils ( + unlist - H + , H , snocH , toListH , onSuccess , onSuccessM + , pstar + , pstar2 + + ) where import Control.Monad - +unlist :: [String] -> String +unlist [] = "" +unlist [w] = w +unlist (w:ws) = w ++ ',' : ' ' : unwords ws -- Hughes lists @@ -53,4 +61,18 @@ where step (Left a) = return (Left a) step (Right b) = liftM Right $ msk b + +-------------------------------------------------------------------------------- +-- pstars - starling combinator with args permuted +-- useful for record updates + +pstar :: (a -> r -> ans) + -> (r -> a) + -> r -> ans +pstar f fa x = f (fa x) x + +pstar2 :: (a -> b -> r -> ans) + -> (r -> a) -> (r -> b) + -> r -> ans +pstar2 f fa fb x = f (fa x) (fb x) x diff --git a/src/Precis/VersionNumber.hs b/src/Precis/VersionNumber.hs new file mode 100644 --- /dev/null +++ b/src/Precis/VersionNumber.hs @@ -0,0 +1,27 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.VersionNumber +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : +-- +-- Version number +-- +-------------------------------------------------------------------------------- + +module Precis.VersionNumber + ( + precis_version_number + + ) where + + +-- | Version number +-- +precis_version_number :: String +precis_version_number = "0.4.0"