precis 0.3.1 → 0.4.0
raw patch · 15 files changed
+1030/−485 lines, 15 filesdep +xhtmlsetup-changed
Dependencies added: xhtml
Files
- Setup.hs +28/−1
- precis.cabal +34/−11
- src/Main.hs +31/−124
- src/Precis/Datatypes.hs +4/−4
- src/Precis/Diff.hs +115/−0
- src/Precis/HsSrcUtils.hs +2/−5
- src/Precis/HtmlReport.hs +332/−0
- src/Precis/ModuleProperties.hs +47/−174
- src/Precis/PPShowS.hs +1/−1
- src/Precis/Properties.hs +0/−163
- src/Precis/ReportMonad.hs +198/−0
- src/Precis/StyleSheet.hs +79/−0
- src/Precis/TextOutput.hs +108/−0
- src/Precis/Utils.hs +24/−2
- src/Precis/VersionNumber.hs +27/−0
Setup.hs view
@@ -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+
precis.cabal view
@@ -1,5 +1,5 @@ name: precis-version: 0.3.1+version: 0.4.0 license: OtherLicense license-file: LICENCE copyright: Stephen Tetley <stephen.tetley@gmail.com>@@ -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
src/Main.hs view
@@ -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 <new_cabal_file> <old_cabal_file>"@@ -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 --
src/Precis/Datatypes.hs view
@@ -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
+ src/Precis/Diff.hs view
@@ -0,0 +1,115 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Precis.Diff+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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+
src/Precis/HsSrcUtils.hs view
@@ -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 _ = []
+ src/Precis/HtmlReport.hs view
@@ -0,0 +1,332 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Precis.HtmlReport+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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"+
src/Precis/ModuleProperties.hs view
@@ -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
src/Precis/PPShowS.hs view
@@ -2,7 +2,7 @@ -------------------------------------------------------------------------------- -- |--- Module : Precis.HString+-- Module : Precis.PPShowS -- Copyright : (c) Stephen Tetley 2010 -- License : BSD3 --
− src/Precis/Properties.hs
@@ -1,163 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module : Precis.Properties--- Copyright : (c) Stephen Tetley 2010--- License : BSD3------ Maintainer : Stephen Tetley <stephen.tetley@gmail.com>--- 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)
+ src/Precis/ReportMonad.hs view
@@ -0,0 +1,198 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Precis.ReportMonad+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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
+ src/Precis/StyleSheet.hs view
@@ -0,0 +1,79 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Precis.StyleSheet+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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 $ + [ "<!--"+ , "body { background-color: white; color: black; "+ , " font-family: sans-serif; padding: 0 0; }"+ , ""+ , "h1 { background-color: " ++ whitesmoke ++ "; color: " ++ brown ++ " }"+ , ".oldcode { background-color: " ++ mintcream ++ "; "+ , " border: 1px solid #3a3; border-width: 0 1px 0 1px } "+ , ".newcode { background-color: " ++ aliceblue ++ "; "+ , " border: 1px solid #3a3; border-width: 0 1px 0 1px } "+ , ".deletedcode { background-color: " ++ bisque ++ "; "+ , " border: 1px solid #3a3; border-width: 0 1px 0 1px } "+ , "-->"+ ]+ +-- 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)"
+ src/Precis/TextOutput.hs view
@@ -0,0 +1,108 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Precis.TextOutput+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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 "...")
src/Precis/Utils.hs view
@@ -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
+ src/Precis/VersionNumber.hs view
@@ -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"