diff --git a/precis.cabal b/precis.cabal --- a/precis.cabal +++ b/precis.cabal @@ -1,5 +1,5 @@ name: precis -version: 0.4.0 +version: 0.5.0 license: OtherLicense license-file: LICENCE copyright: Stephen Tetley @@ -10,11 +10,22 @@ description: Summarize API differences between revisions of Cabal packages. . - Note Precis library is BSD3, Precis executable is LGPL apropos + Precis library is BSD3, Precis executable is LGPL apropos the dependency on CppHs. . + NOTE for version 0.5.0 - the next version is likely to have + substantial changes. Version 0.5.0 does have a better strategy + to resolve conditional modules, but otherwise it is not a + compelling upgrade. If you have 0.4.0 installed, I recommend + you skip this revision and wait for the next version. + . CHANGES + 0.4.0 to 0.5.0 . + * Major re-organization. Module-to-file resolution substantially + changed. Should be better for Cabal fines that use condition + variables. + . 0.3.1 to 0.4.0 . * Substantial changes to reporting - now a summary is printed @@ -44,22 +55,26 @@ hs-source-dirs: src - exposed-modules: - Precis.CabalPackage, - Precis.Datatypes, + exposed-modules: + Precis.Cabal, + Precis.Cabal.CabalPackage, + Precis.Cabal.Datatypes, + Precis.Cabal.InterimDatatypes, + Precis.Cabal.ResolveM, Precis.Diff, - Precis.HsSrcUtils, + Precis.HsSrc.Datatypes, + Precis.HsSrc.Utils, Precis.HtmlReport, Precis.ModuleProperties, - Precis.PathUtils, - Precis.PPShowS, Precis.ReportMonad, Precis.StyleSheet, Precis.TextOutput, + Precis.Utils.Common, + Precis.Utils.ControlOperators, + Precis.Utils.PPShowS, Precis.VersionNumber other-modules: - Precis.Utils executable precis main-is: Main.hs @@ -68,18 +83,23 @@ other-modules: CPP, - Precis.CabalPackage, - Precis.Datatypes, + Precis.Cabal, + Precis.Cabal.CabalPackage, + Precis.Cabal.Datatypes, + Precis.Cabal.InterimDatatypes, + Precis.Cabal.ResolveM, Precis.Diff, - Precis.HsSrcUtils, + Precis.HsSrc.Datatypes, + Precis.HsSrc.Utils, Precis.HtmlReport, Precis.ModuleProperties, - Precis.PathUtils, - Precis.PPShowS, Precis.ReportMonad, Precis.StyleSheet, Precis.TextOutput, - Precis.Utils, + Precis.Utils.Common, + Precis.Utils.ControlOperators, + Precis.Utils.PPShowS, Precis.VersionNumber + diff --git a/src/CPP.hs b/src/CPP.hs --- a/src/CPP.hs +++ b/src/CPP.hs @@ -21,7 +21,7 @@ , precisCpphsOptions ) where -import Precis.Datatypes +import Precis.HsSrc.Datatypes import Language.Preprocessor.Cpphs diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -16,9 +16,9 @@ module Main where import CPP -import Precis.CabalPackage -import Precis.Datatypes -import Precis.HsSrcUtils +import Precis.Cabal +import Precis.HsSrc.Datatypes +import Precis.HsSrc.Utils import Precis.HtmlReport import Precis.VersionNumber @@ -83,11 +83,10 @@ 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 - + ans1 <- extractPackageInfo new_cabal_file + ans2 <- extractPackageInfo old_cabal_file case (ans1,ans2) of - (Right new_cp, Right old_cp) -> sk new_cp old_cp + (Right new_pkg, Right old_pkg) -> sk new_pkg old_pkg (Left err, _) -> precisExitFail 2 $ cabalFileErrorMsg err (_, Left err) -> precisExitFail 2 $ cabalFileErrorMsg err where @@ -96,7 +95,7 @@ Just path -> fullReportHtml path new_cp old_cp -fullReportHtml :: FilePath -> CabalPrecis -> CabalPrecis -> IO () +fullReportHtml :: FilePath -> Package -> Package -> IO () fullReportHtml out_path new_cp old_cp = do { (my_doc,msg) <- makeFullReport fullParseModule new_cp old_cp ; putStrLn $ msg @@ -104,7 +103,7 @@ } -shortReport :: CabalPrecis -> CabalPrecis -> IO () +shortReport :: Package -> Package -> IO () shortReport new_cp old_cp = do { msg <- makeShortReport fullParseModule new_cp old_cp ; putStrLn $ msg @@ -112,10 +111,8 @@ -- | macro-expand and parse -- -fullParseModule :: SourceFile -> IO (Either ModuleParseError Module) -fullParseModule (UnresolvedFile name) = - return $ Left $ ERR_MODULE_FILE_MISSING name -fullParseModule (SourceFile _ file_name) = do +fullParseModule :: HsSourceFile -> IO (Either ModuleParseError Module) +fullParseModule (HsSourceFile _ file_name) = do mx_src <- preprocessFile precisCpphsOptions file_name return $ readModule mx_src diff --git a/src/Precis/Cabal.hs b/src/Precis/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Precis/Cabal.hs @@ -0,0 +1,51 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.Cabal +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- Import module for Cabal libs +-- +-------------------------------------------------------------------------------- + + +module Precis.Cabal + ( + module Precis.Cabal.Datatypes + , ModName + , getModName + + , extractPackageInfo + + ) where + +import Precis.Cabal.CabalPackage +import Precis.Cabal.Datatypes +import Precis.Cabal.InterimDatatypes +import Precis.Cabal.ResolveM + +import Control.Monad + +extractPackageInfo :: FilePath -> IO (Either CabalFileError Package) +extractPackageInfo path = + extractPrecis path >>= \ans -> + case ans of + Left err -> return $ Left err + Right precis -> liftM Right $ buildPackage precis + +buildPackage :: CabalPrecis -> IO Package +buildPackage precis = resolvePrecis precis known_extensions >>= \(e,i,u) -> + return $ Package { package_name = pkg_name $ precis + , package_version = pkg_version $ precis + , exposed_modules = e + , internal_modules = i + , unresolved_modules = u + } + + diff --git a/src/Precis/Cabal/CabalPackage.hs b/src/Precis/Cabal/CabalPackage.hs new file mode 100644 --- /dev/null +++ b/src/Precis/Cabal/CabalPackage.hs @@ -0,0 +1,180 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.Cabal.CabalPackage +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- +-------------------------------------------------------------------------------- + + +module Precis.Cabal.CabalPackage + ( + + known_extensions + , extractPrecis + + ) where + +import Precis.Cabal.Datatypes +import Precis.Cabal.InterimDatatypes +import Precis.Utils.Common + +import qualified Distribution.Package as D +import qualified Distribution.PackageDescription as D +import qualified Distribution.PackageDescription.Parse as D +import qualified Distribution.Verbosity as D +import qualified Distribution.Version as D + +import Control.Monad +import Data.List ( intersperse ) +import System.Directory + + +-- | File extensions that Precis can handle: +-- +-- > ["hs", "lhs"] +-- + +known_extensions :: [FileExtension] +known_extensions = ["hs", "lhs"] + + +extractPrecis :: FilePath -> IO (Either CabalFileError CabalPrecis) +extractPrecis cabal_file = + doesFileExist cabal_file >>= \exists -> + if exists then extractP cabal_file else cabalFileMissing cabal_file + + + +cabalFileMissing :: FilePath -> IO (Either CabalFileError a) +cabalFileMissing file = return $ Left $ ERR_CABAL_FILE_MISSING file + + + +extractP :: FilePath -> IO (Either CabalFileError CabalPrecis) +extractP cabal_file = + liftM sk (safeReadGPD D.normal cabal_file) + where + sk = mapRight (buildPrecis cabal_file) + +safeReadGPD :: D.Verbosity -> FilePath + -> IO (Either CabalFileError D.GenericPackageDescription) +safeReadGPD verbo path = + catch (liftM Right $ D.readPackageDescription verbo path) + (\e -> return $ Left $ ERR_CABAL_FILE_PARSE $ show e) + + +buildPrecis :: FilePath -> D.GenericPackageDescription -> CabalPrecis +buildPrecis path gpd = + CabalPrecis { pkg_name = getName gpd + , pkg_version = getVersion gpd + , path_to_cabal_file = cabalFilePath path + , cond_libraries = getLibraries gpd + , cond_exes = getExes gpd + } + + + +-------------------------------------------------------------------------------- +-- Extract from Package description + +getName :: D.GenericPackageDescription -> String +getName = extractNameText . D.package . D.packageDescription + +getVersion :: D.GenericPackageDescription -> String +getVersion = extractVersionText . D.package . D.packageDescription + + +-- Getting \"Libraries\" is complicated due to Conditions... +-- +-- Here all libraries are extracted, it seems typical that the +-- Library within the PackageDescription is empty. +-- +getLibraries :: D.GenericPackageDescription -> [CabalLibrary] +getLibraries gpd = filter (not . emptyLibrary) $ mbCons x xs + where + x = fmap extractLibrary $ D.library $ D.packageDescription $ gpd + xs = fmap extractLibrary $ allLibraries $ gpd + + +emptyLibrary :: CabalLibrary -> Bool +emptyLibrary (CabalLibrary [] [] []) = True +emptyLibrary _ = False + +mbCons :: Maybe a -> [a] -> [a] +mbCons opt xs = maybe xs (:xs) $ opt + + +-- Again, getting \"Executables\" is complicated by Conditions... +-- +getExes :: D.GenericPackageDescription -> [CabalExe] +getExes gpd = xs ++ ys + where + xs = map extractExe $ allExecutables gpd + ys = map extractExe $ D.executables $ D.packageDescription gpd + + +extractNameText :: D.PackageIdentifier -> String +extractNameText = fn . D.pkgName + where fn (D.PackageName str) = str + +extractVersionText :: D.PackageIdentifier -> String +extractVersionText = fn . D.versionBranch . D.pkgVersion + where fn = concat . intersperse "." . map show + + +extractLibrary :: D.Library -> CabalLibrary +extractLibrary lib = + CabalLibrary { library_src_dirs = getSourceDirs $ D.libBuildInfo lib + , public_modules = mkExpos lib + , private_modules = getPrivateModules $ D.libBuildInfo lib + } + where + mkExpos = map moduleDesc . D.exposedModules + + + +extractExe :: D.Executable -> CabalExe +extractExe exe = + CabalExe { exe_main_module = ExeMainPath $ D.modulePath exe + , exe_src_dirs = getSourceDirs $ D.buildInfo exe + , exe_other_modules = getPrivateModules $ D.buildInfo exe + } + +getSourceDirs :: D.BuildInfo -> [CabalSourceDir] +getSourceDirs = map cabalSourceDir . D.hsSourceDirs + +getPrivateModules :: D.BuildInfo -> [ModuleDesc] +getPrivateModules = map moduleDesc . D.otherModules + + +allLibraries :: D.GenericPackageDescription -> [D.Library] +allLibraries = maybe [] fn . D.condLibrary + where + fn :: D.CondTree D.ConfVar [D.Dependency] D.Library -> [D.Library] + fn = ctfold (:) [] + + +allExecutables :: D.GenericPackageDescription -> [D.Executable] +allExecutables = concat . map (ctfold (:) [] . snd) . D.condExecutables + + + +-------------------------------------------------------------------------------- +-- General helper + +ctfold :: (a -> b -> b) -> b -> (D.CondTree v c a) -> b +ctfold op initial node = foldr compfold x (D.condTreeComponents node) + where + x = D.condTreeData node `op` initial + compfold (_,t1, Nothing) b = ctfold op b t1 + compfold (_,t1, Just t2) b = ctfold op (ctfold op b t1) t2 + + diff --git a/src/Precis/Cabal/Datatypes.hs b/src/Precis/Cabal/Datatypes.hs new file mode 100644 --- /dev/null +++ b/src/Precis/Cabal/Datatypes.hs @@ -0,0 +1,81 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.Cabal.Datatypes +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- Datatype for working with /Packages/ ... +-- +-------------------------------------------------------------------------------- + + +module Precis.Cabal.Datatypes + ( + + Package(..) + + , CabalFileError(..) + , cabalFileErrorMsg + + , HsSourceFile(..) + , hsSourceFile + , UnresolvedModule(..) + + + ) where + +import Precis.Cabal.InterimDatatypes + +import qualified System.FilePath as FP + +-- Because of CondTree/Conditional a Cabal file can appear as +-- though it contains more than one Library, some normalization +-- has to be performed on this structure... +-- +data Package = Package + { package_name :: String + , package_version :: String + , exposed_modules :: [HsSourceFile] + , internal_modules :: [HsSourceFile] + , unresolved_modules :: [UnresolvedModule] + } + deriving (Eq,Show) + + + +data CabalFileError = ERR_CABAL_FILE_MISSING FilePath + | ERR_CABAL_FILE_PARSE String + deriving (Eq,Show) + + +cabalFileErrorMsg :: CabalFileError -> String +cabalFileErrorMsg (ERR_CABAL_FILE_MISSING s) = "*** Error: missing file - " ++ s +cabalFileErrorMsg (ERR_CABAL_FILE_PARSE s) = "*** Error: parse error - " ++ s + +----- + + +data HsSourceFile = HsSourceFile + { module_name :: ModName + , full_path_to :: FilePath + } + deriving (Eq,Ord,Show) + +-- | An unresolved module couldn\'t be found in the listed source +-- directories. +-- +newtype UnresolvedModule = UnresolvedModule { unresolved_name :: ModName } + deriving (Eq,Ord,Show) + + +-- smart constructor + +hsSourceFile :: ModName -> FilePath -> HsSourceFile +hsSourceFile name path = HsSourceFile name (FP.normalise path) + diff --git a/src/Precis/Cabal/InterimDatatypes.hs b/src/Precis/Cabal/InterimDatatypes.hs new file mode 100644 --- /dev/null +++ b/src/Precis/Cabal/InterimDatatypes.hs @@ -0,0 +1,183 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.Cabal.InterimDatatypes +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- Datatype for working with Cabal files... +-- +-------------------------------------------------------------------------------- + + +module Precis.Cabal.InterimDatatypes + ( + + FileExtension + + , CabalFilePath + , cabalFilePath + , pathToCabalFile + , directoriesToCabalFile + + , ExeMainPath(..) + , CabalSourceDir + , cabalSourceDir + , directoriesToSource + + , ModName + , modName + , getModName + + , ModuleDesc + , moduleDesc + , moduleDescName + , moduleDirectories + + , CabalPrecis(..) + , CabalLibrary(..) + , CabalExe(..) + + ) where + +import qualified Distribution.ModuleName as D + +import Data.List ( intersperse ) +import System.FilePath + + + +type FileExtension = String + + +-- | 'CabalFilePath' is both the full, normalized path to the +-- cabal file and the directory parts to the file. +-- +-- This is an opaque type - construct with 'cabalFilePath'. +-- +data CabalFilePath = CabalFilePath + { cabal_full_loc :: FilePath + , cabal_path_to_split :: [FilePath] + } + deriving (Eq,Ord,Show) + +-- | Constructor for 'CabalFilePath' - the input FilePath is +-- normalized before constructing the data type. +-- +cabalFilePath :: FilePath -> CabalFilePath +cabalFilePath path = + CabalFilePath { cabal_full_loc = full, cabal_path_to_split = parts } + where + full = normalise path + parts = splitPath $ dropFileName full + +pathToCabalFile :: CabalFilePath -> FilePath +pathToCabalFile = cabal_full_loc + +directoriesToCabalFile :: CabalFilePath -> [FilePath] +directoriesToCabalFile = cabal_path_to_split + + +newtype ExeMainPath = ExeMainPath { relPathToExeMain :: FilePath } + deriving (Eq,Ord,Show) + +data CabalSourceDir = CabalSourceDir + { srcdir_rel_loc :: FilePath + , srcdir_path_to_split :: [FilePath] + } + deriving (Eq,Ord,Show) + +cabalSourceDir :: FilePath -> CabalSourceDir +cabalSourceDir path = + CabalSourceDir { srcdir_rel_loc = rel, srcdir_path_to_split = parts } + where + rel = normalise path + parts = splitPath rel + + +directoriesToSource :: CabalSourceDir -> [FilePath] +directoriesToSource = srcdir_path_to_split + + +newtype ModName = ModName { mod_name :: String } + deriving (Eq,Ord,Show) + +modName :: D.ModuleName -> ModName +modName = ModName . concat . intersperse "." . D.components + +getModName :: ModName -> String +getModName = mod_name + + +data ModuleDesc = ModuleDesc + { module_desc_name :: ModName + , module_components :: [FilePath] + } + deriving (Eq,Ord,Show) + + +moduleDesc :: D.ModuleName -> ModuleDesc +moduleDesc mname = + ModuleDesc { module_desc_name = name, module_components = parts } + where + xs = D.components mname + name = ModName $ concat $ intersperse "." xs + + -- Add separator to inits but not last... + parts = foldr fn [] xs where fn e [] = [e] + fn e ac = (e++[pathSeparator]):ac + + +moduleDescName :: ModuleDesc -> ModName +moduleDescName = module_desc_name + +moduleDirectories :: ModuleDesc -> [FilePath] +moduleDirectories = module_components + +-- Do we want /resolution/ during the building +-- the CabalPrecis or afterwards? +-- +-- i.e. when do we query the file system to locate the modules? + + +-- Because of CondTree/Conditional a Cabal file can appear as +-- though it contains more than one Library, some normalization +-- has to be performed on this structure... +-- +data CabalPrecis = CabalPrecis + { pkg_name :: String + , pkg_version :: String + , path_to_cabal_file :: CabalFilePath + , cond_libraries :: [CabalLibrary] + , cond_exes :: [CabalExe] + } + deriving (Eq,Show) + +-- One library per cabal file / package. + +data CabalLibrary = CabalLibrary + { library_src_dirs :: [CabalSourceDir] + , public_modules :: [ModuleDesc] + , private_modules :: [ModuleDesc] + } + deriving (Eq,Ord,Show) + +-- Zero / one or more exe per cabal file / package. +-- The executable file will include the extension... + +data CabalExe = CabalExe + { exe_main_module :: ExeMainPath + , exe_src_dirs :: [CabalSourceDir] + , exe_other_modules :: [ModuleDesc] + } + deriving (Eq,Ord,Show) + + + + + diff --git a/src/Precis/Cabal/ResolveM.hs b/src/Precis/Cabal/ResolveM.hs new file mode 100644 --- /dev/null +++ b/src/Precis/Cabal/ResolveM.hs @@ -0,0 +1,243 @@ +{-# OPTIONS -Wall #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.Cabal.ResolveM +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- A Monad transofrmer (over IO) for revolving module names +-- to FilePaths. +-- +-------------------------------------------------------------------------------- + + +module Precis.Cabal.ResolveM + ( + + resolvePrecis + , ResolveM + , runResolve + , getFilePathLoc + , getEIU + + ) where + +import Precis.Cabal.Datatypes +import Precis.Cabal.InterimDatatypes +import Precis.Utils.Common +import Precis.Utils.ControlOperators + +import Control.Applicative +import Control.Monad + +import Data.Set ( Set ) +import qualified Data.Set as Set +import System.Directory +import qualified System.FilePath as FP + + + +-- Are there any more useful manipulations than simply +-- resolving module_names to file_paths? + +resolvePrecis :: CabalPrecis + -> [FileExtension] + -> IO ([HsSourceFile],[HsSourceFile],[UnresolvedModule]) +resolvePrecis precis exts = + do { (_,st) <- runResolve (path_to_cabal_file precis) exts process + ; return $ getEIU st + } + where + process = do { mapM_ resolveLibrary (cond_libraries precis) + ; mapM_ resolveExe (cond_exes precis) + } + + + +resolveLibrary :: CabalLibrary -> ResolveM () +resolveLibrary lib@(CabalLibrary {library_src_dirs = src_dirs}) = + do { mapM_ (resolveExposedModule src_dirs) (public_modules lib) + ; mapM_ (resolveHiddenModule src_dirs) (private_modules lib) + } + + + +resolveExe :: CabalExe -> ResolveM () +resolveExe exe@(CabalExe {exe_src_dirs=src_dirs}) = + do { mapM_ (resolveHiddenModule src_dirs) (exe_other_modules exe) + ; return () -- THE EXE MODULE TODO... + } + + +resolveExposedModule :: [CabalSourceDir] -> ModuleDesc -> ResolveM () +resolveExposedModule = resolveModule logExposed + +resolveHiddenModule :: [CabalSourceDir] -> ModuleDesc -> ResolveM () +resolveHiddenModule = resolveModule logHidden + +resolveModule :: (ModName -> FilePath -> ResolveM ()) + -> [CabalSourceDir] -> ModuleDesc -> ResolveM () +resolveModule sk src_dirs mod_desc = + getFilePathLoc src_dirs mod_desc >>= \ans -> + case ans of + Nothing -> logUnresolved (moduleDescName mod_desc) + Just path -> sk (moduleDescName mod_desc) path + + +getFilePathLoc :: [CabalSourceDir] -> ModuleDesc -> ResolveM (Maybe (FilePath)) +getFilePathLoc src_dirs mod_desc = do + root <- asks root_path + exts <- asks known_exts + firstSuccess validFile (makeAll root exts) + where + makeAll root exts = + directoryProduct (\opt_dir ext -> fullPath root opt_dir mod_desc ext) + src_dirs + exts + + +directoryProduct :: (Maybe a -> b -> c) -> [a] -> [b] -> [c] +directoryProduct f [] ys = [f Nothing b | b <- ys] +directoryProduct f xs ys = [f (Just a) b | a <- xs , b <- ys ] + + +fullPath :: CabalFilePath -> Maybe CabalSourceDir -> ModuleDesc -> FileExtension + -> FilePath +fullPath root opt_src_dir mdesc ext = FP.normalise $ + prepend (directoriesToCabalFile root) $ + prepend (maybe [] directoriesToSource opt_src_dir) $ + modulePath mdesc ext + +prepend :: [FilePath] -> FilePath -> FilePath +prepend xs = FP.combine (FP.joinPath xs) + +modulePath :: ModuleDesc -> FileExtension -> FilePath +modulePath mdesc ext = step (moduleDirectories mdesc) + where + step [] = ext -- Really an error? + step [a] = FP.addExtension a ext + step (a:as) = FP.combine a $ step as + + + + + + +-------------------------------------------------------------------------------- +-- + + +data RSt = RSt { internal_mods :: Set HsSourceFile + , exposed_mods :: Set HsSourceFile + , unresolveds :: [UnresolvedModule] + } + +stateZero :: RSt +stateZero = RSt Set.empty Set.empty [] + +getEIU :: RSt -> ([HsSourceFile],[HsSourceFile],[UnresolvedModule]) +getEIU rst = ( Set.toList $ exposed_mods rst + , Set.toList $ internal_mods rst + , unresolveds rst ) + + +data REnv = REnv { root_path :: CabalFilePath, known_exts :: [FileExtension] } + +newtype ResolveM a = ResolveM { getResolveM :: REnv -> RSt -> IO (a,RSt) } + +instance Functor ResolveM where + fmap f mf = ResolveM $ \env st -> getResolveM mf env st >>= \(a,st') -> + return (f a,st') + + +instance Applicative ResolveM where + pure a = ResolveM $ \_ st -> return (a,st) + af <*> a = ResolveM $ \env st -> getResolveM af env st >>= \(f,st') -> + getResolveM a env st' >>= \(b,st'') -> + return (f b, st'') + + +instance Monad ResolveM where + return a = ResolveM $ \_ st -> return (a,st) + m >>= k = ResolveM $ \env st -> getResolveM m env st >>= \(a,st') -> + getResolveM (k a) env st' + + + +runResolve :: CabalFilePath -> [FileExtension] -> ResolveM a -> IO (a,RSt) +runResolve root exts mf = getResolveM mf env stateZero + where + env = REnv { root_path = root, known_exts = exts } + +ask :: ResolveM REnv +ask = ResolveM $ \env st -> return (env,st) + +asks :: (REnv -> a) -> ResolveM a +asks f = liftM f ask + +{- +get :: ResolveM RSt +get = ResolveM $ \_ st -> return (st,st) + +set :: RSt -> ResolveM () +set st = ResolveM $ \_ _ -> return ((),st) + +sets :: (RSt -> (a,RSt)) -> ResolveM a +sets f = ResolveM $ \_ st -> return (f st) +-} + +sets_ :: (RSt -> RSt) -> ResolveM () +sets_ f = ResolveM $ \_ st -> return ((), f st) + + +liftIO :: IO a -> ResolveM a +liftIO ma = ResolveM $ \_ st -> ma >>= \a -> return (a,st) + +validFile :: FilePath -> ResolveM (Maybe FilePath) +validFile path = valid (liftIO . doesFileExist) path + + +logUnresolved :: ModName -> ResolveM () +logUnresolved name = sets_ (star unresolveds upd) + where + upd us s = s {unresolveds = UnresolvedModule name : us} + + + + +-- The module might already be hidden or even exposed... +-- +-- If already hidded - don't add +-- If already exposed - don't add +-- +logHidden :: ModName -> FilePath -> ResolveM () +logHidden name path = sets_ (star2 exposed_mods internal_mods upd) + where + hs_src = HsSourceFile name path + upd exs ins s = if Set.member hs_src exs + then s + else s { internal_mods = Set.insert hs_src ins } + + +-- The module might already be exposed or hidden... +-- +-- If already hidded - remove from hidden list add to exposed list +-- If already exposed - don't add +-- +logExposed :: ModName -> FilePath -> ResolveM () +logExposed name path = sets_ (star2 exposed_mods internal_mods upd) + where + hs_src = HsSourceFile name path + upd exs ins s = if Set.member hs_src ins + then s { internal_mods = Set.delete hs_src ins + , exposed_mods = optAdd hs_src exs } + else s { exposed_mods = optAdd hs_src exs } + + optAdd a s = if Set.member a s then s else Set.insert a s + diff --git a/src/Precis/CabalPackage.hs b/src/Precis/CabalPackage.hs deleted file mode 100644 --- a/src/Precis/CabalPackage.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Precis.CabalPackage --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : to be determined. --- --- --------------------------------------------------------------------------------- - - -module Precis.CabalPackage - ( - Extension - , extractPrecis - , known_extensions - - ) where - -import Precis.Datatypes -import Precis.PathUtils -import Precis.Utils - -import Distribution.ModuleName -import Distribution.Package -import Distribution.PackageDescription -import Distribution.PackageDescription.Parse -import Distribution.Verbosity -import Distribution.Version - -import Control.Monad -import Data.List ( intersperse, nub ) -import System.Directory -import System.FilePath - -type Extension = String - - -extractPrecis :: FilePath -> [Extension] -> IO (Either CabalFileError CabalPrecis) -extractPrecis cabal_file exts = do - exists <- doesFileExist cabal_file - if exists then extractP cabal_file exts `onSuccessM` post - else return $ Left $ ERR_CABAL_FILE_MISSING cabal_file - where - post = return . nubSourceFiles - - -known_extensions :: [Extension] -known_extensions = ["hs", "lhs"] - -extractP :: FilePath -> [String] -> IO (Either CabalFileError CabalPrecis) -extractP cabal_file_path exts = - safeReadPackageDescription normal cabal_file_path `onSuccessM` sk - where - root_to_cabal = dropFileName cabal_file_path - sk gen_pkg = do { (expos,privs) <- getSourceFiles gen_pkg root_to_cabal exts - ; return $ CabalPrecis - { package_name = getName gen_pkg - , package_version = getVersion gen_pkg - , path_to_cabal_file = cabal_file_path - , exposed_modules = expos - , internal_modules = privs - } - } - -type SafeGPD = Either CabalFileError GenericPackageDescription - -safeReadPackageDescription :: Verbosity -> FilePath -> IO SafeGPD -safeReadPackageDescription verbo path = - catch (liftM Right $ readPackageDescription verbo path) - (\e -> return $ Left $ ERR_CABAL_FILE_PARSE $ show e) - --------------------------------------------------------------------------------- --- Extract from Package description - -getName :: GenericPackageDescription -> String -getName = extrNameText . package . packageDescription - -getVersion :: GenericPackageDescription -> String -getVersion = extrVersionText . package . packageDescription - - -extrNameText :: PackageIdentifier -> String -extrNameText = fn . pkgName - where fn (PackageName str) = str - -extrVersionText :: PackageIdentifier -> String -extrVersionText = fn . versionBranch . pkgVersion - where fn = concat . intersperse "." . map show - - - --- extract source files - -getSourceFiles :: GenericPackageDescription - -> FilePath - -> [String] - -> IO ([SourceFile], [SourceFile]) -getSourceFiles pkg_desc root exts = do - lib_mods <- mapM (resolveLibrary root exts) $ allLibraries pkg_desc - exe_mods <- mapM (resolveExecutable root exts) $ allExecutables pkg_desc - let (lib_expos, lib_privs) = foldr fn ([],[]) lib_mods - return (lib_expos, lib_privs ++ concat exe_mods) - where - fn (a,b) (xs,ys) = (a++xs,b++ys) - - -allLibraries :: GenericPackageDescription -> [Library] -allLibraries = maybe [] fn . condLibrary - where - fn :: CondTree ConfVar [Dependency] Library -> [Library] - fn = ctfold (:) [] - - -allExecutables :: GenericPackageDescription -> [Executable] -allExecutables = concat . map (ctfold (:) [] . snd) . condExecutables - - -resolveLibrary :: FilePath -> [String] -> Library -> IO ([SourceFile], [SourceFile]) -resolveLibrary root exts lib = liftM2 (,) (fn expos) (fn others) - where - fn mods = resolveFiles root src_paths mods exts - (src_paths, expos, others) = libraryContents lib - -libraryContents :: Library -> ([FilePath], [ModuleName], [ModuleName]) -libraryContents lib = (src_paths, expo_modules, other_modules) - where - src_paths = hsSourceDirs $ libBuildInfo lib - expo_modules = exposedModules lib - other_modules = otherModules $ libBuildInfo lib - -resolveExecutable :: FilePath -> [String] -> Executable -> IO [SourceFile] -resolveExecutable root exts exe = resolveFiles root src_paths mods exts - where - (src_paths, mods) = executableModules exe - - -executableContents :: Executable -> ([FilePath], FilePath, [ModuleName]) -executableContents exe = (src_paths, exe_main_module, other_modules) - where - src_paths = hsSourceDirs $ buildInfo exe - exe_main_module = modulePath exe - other_modules = otherModules $ buildInfo exe - - --- All executable modules considered internal... - -executableModules :: Executable -> ([FilePath], [ModuleName]) -executableModules = fn . executableContents - where - fn (as,exe,cs) = (as, exeModuleName exe : cs) - --------------------------------------------------------------------------------- --- reconcile modules - --- Initially a precis may have dublicates (via Cabal\'s --- conditional mechanism). --- -nubSourceFiles :: CabalPrecis -> CabalPrecis -nubSourceFiles cp@(CabalPrecis _ _ _ exs ins) = - cp { exposed_modules = exs', internal_modules = ins' } - where - exs' = nub exs - ins' = filter (not . (`elem` exs')) $ nub ins - --------------------------------------------------------------------------------- --- General helper - -ctfold :: (a -> b -> b) -> b -> (CondTree v c a) -> b -ctfold op initial node = foldr compfold x (condTreeComponents node) - where - x = condTreeData node `op` initial - compfold (_,t1, Nothing) b = ctfold op b t1 - compfold (_,t1, Just t2) b = ctfold op (ctfold op b t1) t2 - - diff --git a/src/Precis/Datatypes.hs b/src/Precis/Datatypes.hs deleted file mode 100644 --- a/src/Precis/Datatypes.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Precis.Datatypes --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : to be determined. --- --- --------------------------------------------------------------------------------- - - -module Precis.Datatypes - ( - StrName - , TextRep - , CabalFileError(..) - , cabalFileErrorMsg - - , CabalPrecis(..) - , SourceFile(..) - , sourceFile - , sourceFileModule - - , MacroExpandedSrcFile(..) - , ModuleParseError(..) - , moduleParseErrorMsg - - , ExportItem(..) - , exportItemName - - , InstanceDecl(..) - , instanceDeclName - - , DatatypeDecl(..) - , datatypeDeclName - - , TypeSigDecl(..) - , typeSigDeclName - - ) where - - -import System.FilePath - - --- Don\'t use the Name type from haskell-src-exts. --- Precis doesn\'t need its distinction between identifiers --- and symbols. --- - -type StrName = String -type TextRep = String - -data CabalFileError = ERR_CABAL_FILE_MISSING FilePath - | ERR_CABAL_FILE_PARSE String - deriving (Eq,Show) - - -cabalFileErrorMsg :: CabalFileError -> String -cabalFileErrorMsg (ERR_CABAL_FILE_MISSING s) = "*** Error: missing file - " ++ s -cabalFileErrorMsg (ERR_CABAL_FILE_PARSE s) = "*** Error: parse error - " ++ s - - -data CabalPrecis = CabalPrecis - { package_name :: StrName - , package_version :: String - , path_to_cabal_file :: FilePath - , exposed_modules :: [SourceFile] - , internal_modules :: [SourceFile] - } - deriving (Eq,Show) - --- -data SourceFile - = SourceFile { module_name :: StrName - , full_path_to :: FilePath - } - | UnresolvedFile { unresolved_file_name :: StrName } - deriving (Eq,Ord,Show) - - --- smart constructor - -sourceFile :: String -> FilePath -> SourceFile -sourceFile name path = SourceFile name (normalise path) - - - -sourceFileModule :: SourceFile -> StrName -sourceFileModule (SourceFile n _) = n -sourceFileModule (UnresolvedFile n) = n -- defer to unresolved - - - - --------------------------------------------------------------------------------- --- Precis for individual source files - -data MacroExpandedSrcFile = MacroExpandedSrcFile - { source_file_name :: String - , expanded_source :: String - } - - --- | Module file names are derived from the cabal file. --- So the name is tracked if it is missing... --- -data ModuleParseError = ERR_MODULE_FILE_MISSING String - | ERR_MODULE_FILE_PARSE String - deriving (Eq,Show) - -moduleParseErrorMsg :: ModuleParseError -> String -moduleParseErrorMsg (ERR_MODULE_FILE_MISSING s) = - "*** Error: missing file - " ++ s -moduleParseErrorMsg (ERR_MODULE_FILE_PARSE s) = - "*** Error: parse error - " ++ s - - -data ExportItem = ModuleExport StrName - | DataOrClass StrName TextRep - | Variable StrName - deriving (Eq,Show) - -exportItemName :: ExportItem -> StrName -exportItemName (ModuleExport s) = s -exportItemName (DataOrClass s _) = s -exportItemName (Variable s) = s - - -data InstanceDecl = InstanceDecl - { class_name :: StrName - , type_rep :: TextRep - , full_rep :: TextRep - } - deriving (Eq,Show) - -instanceDeclName :: InstanceDecl -> StrName -instanceDeclName = class_name - - -data DatatypeDecl = DatatypeDecl - { datatype_name :: StrName - , datatype_rep :: TextRep - } - deriving (Eq,Show) - -datatypeDeclName :: DatatypeDecl -> StrName -datatypeDeclName = datatype_name - - -data TypeSigDecl = TypeSigDecl - { type_decl_name :: StrName - , type_signature :: TextRep - } - deriving (Eq,Show) - -typeSigDeclName :: TypeSigDecl -> StrName -typeSigDeclName = type_decl_name diff --git a/src/Precis/Diff.hs b/src/Precis/Diff.hs --- a/src/Precis/Diff.hs +++ b/src/Precis/Diff.hs @@ -32,7 +32,7 @@ ) where -import Precis.Utils +import Precis.Utils.Common import Data.List ( find ) @@ -57,7 +57,6 @@ fmap f (Add a) = Add (f a) fmap f (Equ a) = Equ (f a) fmap f (Del a) = Del (f a) - diff --git a/src/Precis/HsSrc/Datatypes.hs b/src/Precis/HsSrc/Datatypes.hs new file mode 100644 --- /dev/null +++ b/src/Precis/HsSrc/Datatypes.hs @@ -0,0 +1,108 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.HsSrc.Datatypes +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- +-------------------------------------------------------------------------------- + + +module Precis.HsSrc.Datatypes + ( + TextRep + , StrName + + , MacroExpandedSrcFile(..) + , ModuleParseError(..) + , moduleParseErrorMsg + + , ExportItem(..) + , exportItemName + + , InstanceDecl(..) + , instanceDeclName + + , DatatypeDecl(..) + , datatypeDeclName + + , TypeSigDecl(..) + , typeSigDeclName + + ) where + + + + +type TextRep = String +type StrName = String + +-------------------------------------------------------------------------------- +-- Precis for individual source files + +data MacroExpandedSrcFile = MacroExpandedSrcFile + { source_file_name :: String + , expanded_source :: String + } + + +-- | Module file names are derived from the cabal file. +-- So the name is tracked if it is missing... +-- +data ModuleParseError = ERR_MODULE_FILE_MISSING String + | ERR_MODULE_FILE_PARSE String + deriving (Eq,Show) + +moduleParseErrorMsg :: ModuleParseError -> String +moduleParseErrorMsg (ERR_MODULE_FILE_MISSING s) = + "*** Error: missing file - " ++ s +moduleParseErrorMsg (ERR_MODULE_FILE_PARSE s) = + "*** Error: parse error - " ++ s + + +data ExportItem = ModuleExport StrName + | DataOrClass StrName TextRep + | Variable StrName + deriving (Eq,Show) + +exportItemName :: ExportItem -> StrName +exportItemName (ModuleExport s) = s +exportItemName (DataOrClass s _) = s +exportItemName (Variable s) = s + + +data InstanceDecl = InstanceDecl + { class_name :: StrName + , type_rep :: TextRep + , full_rep :: TextRep + } + deriving (Eq,Show) + +instanceDeclName :: InstanceDecl -> StrName +instanceDeclName = class_name + + +data DatatypeDecl = DatatypeDecl + { datatype_name :: StrName + , datatype_rep :: TextRep + } + deriving (Eq,Show) + +datatypeDeclName :: DatatypeDecl -> StrName +datatypeDeclName = datatype_name + + +data TypeSigDecl = TypeSigDecl + { type_decl_name :: StrName + , type_signature :: TextRep + } + deriving (Eq,Show) + +typeSigDeclName :: TypeSigDecl -> StrName +typeSigDeclName = type_decl_name diff --git a/src/Precis/HsSrc/Utils.hs b/src/Precis/HsSrc/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Precis/HsSrc/Utils.hs @@ -0,0 +1,101 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.HsSrc.Utils +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- +-------------------------------------------------------------------------------- + + +module Precis.HsSrc.Utils + ( + + readModule + , parseModuleWithExts + , extractQName + , extractCName + , extractModuleName + , extractName + , extractSpecialCon + + , getModuleName + + , namedDecls + + , hsppList + + ) where + +import Precis.HsSrc.Datatypes + +import Language.Haskell.Exts hiding ( name ) -- package: haskell-src-exts + + +readModule :: MacroExpandedSrcFile -> Either ModuleParseError Module +readModule (MacroExpandedSrcFile filename mx_src) = + case parseModuleWithExts knownExtensions filename mx_src of + ParseFailed loc msg -> Left $ ERR_MODULE_FILE_PARSE $ mkMsg msg loc + ParseOk a -> Right $ a + where + 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 + where + pmode = defaultParseMode { extensions = exts + , parseFilename = file_name + , ignoreLinePragmas = False } + + +extractQName :: QName -> String +extractQName (Qual mname name) = extractModuleName mname ++ extractName name +extractQName (UnQual name) = extractName name +extractQName (Special spc) = extractSpecialCon spc + +extractCName :: CName -> String +extractCName (VarName name) = extractName name +extractCName (ConName name) = extractName name + +extractModuleName :: ModuleName -> String +extractModuleName (ModuleName name) = name + +extractName :: Name -> String +extractName (Ident name) = name +extractName (Symbol name) = name + +extractSpecialCon :: SpecialCon -> String +extractSpecialCon = prettyPrint + +-------------------------------------------------------------------------------- + +getModuleName :: Module -> ModuleName +getModuleName (Module _ mn _ _ _ _ _) = mn + + +-------------------------------------------------------------------------------- + +-- +namedDecls :: Decl -> [(StrName,TextRep)] +namedDecls t@(TypeDecl _ n _ _) = [(extractName n, prettyPrint t)] +namedDecls t@(TypeFamDecl _ n _ _) = [(extractName n, prettyPrint t)] +namedDecls t@(DataDecl _ _ _ n _ _ _) = [(extractName n, prettyPrint t)] +namedDecls t@(GDataDecl _ _ _ n _ _ _ _) = [(extractName n, prettyPrint t)] +namedDecls t@(DataFamDecl _ _ n _ _) = [(extractName n, prettyPrint t)] +namedDecls t@(ClassDecl _ _ n _ _ _) = [(extractName n, prettyPrint t)] +namedDecls t@(InstDecl _ _ q _ _) = [(extractQName q, prettyPrint t)] +namedDecls t@(DerivDecl _ _ q _) = [(extractQName q, prettyPrint t)] +namedDecls t@(TypeSig _ ns _) = map fn ns + where fn n = (extractName n, prettyPrint t) +namedDecls _ = [] + + +hsppList :: Pretty a => [a] -> String +hsppList = unwords . map prettyPrint diff --git a/src/Precis/HsSrcUtils.hs b/src/Precis/HsSrcUtils.hs deleted file mode 100644 --- a/src/Precis/HsSrcUtils.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Precis.HsSrcUtils --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : to be determined. --- --- --------------------------------------------------------------------------------- - - -module Precis.HsSrcUtils - ( - - readModule - , parseModuleWithExts - , extractQName - , extractCName - , extractModuleName - , extractName - , extractSpecialCon - - , getModuleName - - , namedDecls - - , hsppList - - ) where - -import Precis.Datatypes - -import Language.Haskell.Exts hiding ( name ) -- package: haskell-src-exts - - -readModule :: MacroExpandedSrcFile -> Either ModuleParseError Module -readModule (MacroExpandedSrcFile filename mx_src) = - case parseModuleWithExts knownExtensions filename mx_src of - ParseFailed loc msg -> Left $ ERR_MODULE_FILE_PARSE $ mkMsg msg loc - ParseOk a -> Right $ a - where - 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 - where - pmode = defaultParseMode { extensions = exts - , parseFilename = file_name - , ignoreLinePragmas = False } - - -extractQName :: QName -> String -extractQName (Qual mname name) = extractModuleName mname ++ extractName name -extractQName (UnQual name) = extractName name -extractQName (Special spc) = extractSpecialCon spc - -extractCName :: CName -> String -extractCName (VarName name) = extractName name -extractCName (ConName name) = extractName name - -extractModuleName :: ModuleName -> String -extractModuleName (ModuleName name) = name - -extractName :: Name -> String -extractName (Ident name) = name -extractName (Symbol name) = name - -extractSpecialCon :: SpecialCon -> String -extractSpecialCon = prettyPrint - --------------------------------------------------------------------------------- - -getModuleName :: Module -> ModuleName -getModuleName (Module _ mn _ _ _ _ _) = mn - - --------------------------------------------------------------------------------- - --- -namedDecls :: Decl -> [(StrName,TextRep)] -namedDecls t@(TypeDecl _ n _ _) = [(extractName n, prettyPrint t)] -namedDecls t@(TypeFamDecl _ n _ _) = [(extractName n, prettyPrint t)] -namedDecls t@(DataDecl _ _ _ n _ _ _) = [(extractName n, prettyPrint t)] -namedDecls t@(GDataDecl _ _ _ n _ _ _ _) = [(extractName n, prettyPrint t)] -namedDecls t@(DataFamDecl _ _ n _ _) = [(extractName n, prettyPrint t)] -namedDecls t@(ClassDecl _ _ n _ _ _) = [(extractName n, prettyPrint t)] -namedDecls t@(InstDecl _ _ q _ _) = [(extractQName q, prettyPrint t)] -namedDecls t@(DerivDecl _ _ q _) = [(extractQName q, prettyPrint t)] -namedDecls t@(TypeSig _ ns _) = map fn ns - where fn n = (extractName n, prettyPrint t) -namedDecls _ = [] - - -hsppList :: Pretty a => [a] -> String -hsppList = unwords . map prettyPrint diff --git a/src/Precis/HtmlReport.hs b/src/Precis/HtmlReport.hs --- a/src/Precis/HtmlReport.hs +++ b/src/Precis/HtmlReport.hs @@ -22,13 +22,14 @@ ) where -import Precis.Datatypes +import Precis.Cabal import Precis.Diff -import Precis.StyleSheet +import Precis.HsSrc.Datatypes import Precis.ModuleProperties -import Precis.PPShowS ( toString, line ) import Precis.ReportMonad +import Precis.StyleSheet import Precis.TextOutput +import Precis.Utils.PPShowS ( toString, line ) import Language.Haskell.Exts ( Module ) -- package: haskell-src-exts import Text.XHtml hiding ( name ) -- package: xhtml @@ -40,28 +41,29 @@ makeShortReport :: ModuleParseFunction - -> CabalPrecis - -> CabalPrecis + -> Package + -> Package -> IO TextSummary makeShortReport pf ncp ocp = liftM snd $ makeReport MSG_AND_HTML pf ncp ocp makeFullReport :: ModuleParseFunction - -> CabalPrecis - -> CabalPrecis + -> Package + -> Package -> IO (Html,TextSummary) makeFullReport = makeReport MSG_AND_HTML makeReport :: ReportLevel -> ModuleParseFunction - -> CabalPrecis - -> CabalPrecis + -> Package + -> Package -> IO (Html,TextSummary) makeReport lvl pf new old = liftM post $ execReportM pf lvl $ do { packageNamesAndVersions new old + ; countUnresolveds (unresolved_modules new) ; moduleCountSummary new old - ; compareExposedModules (exposed_modules new) (exposed_modules old) + ; compareExposedModules new old } where post (hs,stats) = (assembleDoc (package_name new) hs, mkText stats) @@ -78,7 +80,7 @@ -------------------------------------------------------------------------------- -- -packageNamesAndVersions :: CabalPrecis -> CabalPrecis -> ReportM () +packageNamesAndVersions :: Package -> Package -> ReportM () packageNamesAndVersions new old = do { tellHtml $ h1 << ("Change summary: " ++ package_name new) ; tellHtml $ h2 << (toString $ comparingMsg new old) @@ -98,8 +100,8 @@ -moduleCountSummary :: CabalPrecis -> CabalPrecis -> ReportM () -moduleCountSummary new old = +moduleCountSummary :: Package -> Package -> ReportM () +moduleCountSummary new old = do { countDeletions incrRemovedModules expos ; tellHtml $ docModulesDiffs expos privs } @@ -109,18 +111,19 @@ -compareExposedModules :: [SourceFile] -> [SourceFile] -> ReportM () +compareExposedModules :: Package -> Package -> ReportM () compareExposedModules new old = - mapM_ compareSrcFileEdit $ diffExposedSrcFiles new old + mapM_ compareSrcFileEdit $ + diffExposedSrcFiles (exposed_modules new) (exposed_modules old) -compareSrcFileEdit :: Edit4 SourceFile -> ReportM () -compareSrcFileEdit (DIF a b) = compareSourceFiles a b +compareSrcFileEdit :: Edit4 HsSourceFile -> ReportM () +compareSrcFileEdit (DIF a b) = compareHsSourceFiles a b compareSrcFileEdit _ = return () -compareSourceFiles :: SourceFile -> SourceFile -> ReportM () -compareSourceFiles new old = do +compareHsSourceFiles :: HsSourceFile -> HsSourceFile -> ReportM () +compareHsSourceFiles new old = do do { tellHtml $ docStartSummary new ; pf <- askParseFun ; new_ans <- liftIO $ pf new @@ -131,7 +134,7 @@ (_, Left err) -> failk (OLD old) err } where - failk cmpmod err = do { tellParseFail (fmap sourceFileModule cmpmod) + failk cmpmod err = do { tellParseFail (fmap (getModName . module_name) cmpmod) ; tellHtml $ docModuleParseError cmpmod err } @@ -205,7 +208,8 @@ - +countUnresolveds :: [UnresolvedModule] -> ReportM () +countUnresolveds = mapM_ (tellUnresolved . NEW . getModName . unresolved_name) -------------------------------------------------------------------------------- -- Helpers @@ -256,16 +260,16 @@ 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 ++ ":") +docStartSummary :: HsSourceFile -> Html +docStartSummary src_file = h2 << ((getModName $ module_name src_file) ++ ":") -docModuleParseError :: CMP SourceFile -> ModuleParseError -> Html +docModuleParseError :: CMP HsSourceFile -> ModuleParseError -> Html docModuleParseError (OLD _src) err = pre << (moduleParseErrorMsg err) docModuleParseError (NEW _src) err = pre << (moduleParseErrorMsg err) -docModulesDiffs :: [Edit3 StrName] -> [Edit3 StrName] -> Html +docModulesDiffs :: [Edit3 ModName] -> [Edit3 ModName] -> Html docModulesDiffs expos privs = expos_doc +++ privs_doc where expos_doc = maybe docNoExpos (withHeader2 "Exposed modules:") @@ -291,13 +295,13 @@ [ "No internal modules counted." ] -modulesTable :: [Edit3 StrName] -> Maybe Html +modulesTable :: [Edit3 ModName] -> 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 + fn (Add a) i = makeRow i "+" $ getModName a + fn (Equ a) i = makeRow i "" $ getModName a + fn (Del a) i = makeRow i "-" $ getModName a makeRow i op name = tr << [ td << (show i), td << op, td << name ] diff --git a/src/Precis/ModuleProperties.hs b/src/Precis/ModuleProperties.hs --- a/src/Precis/ModuleProperties.hs +++ b/src/Precis/ModuleProperties.hs @@ -35,9 +35,10 @@ ) where -import Precis.Datatypes +import Precis.Cabal import Precis.Diff -import Precis.HsSrcUtils +import Precis.HsSrc.Datatypes +import Precis.HsSrc.Utils import Language.Haskell.Exts hiding ( name, op ) -- package: haskell-src-exts @@ -45,32 +46,29 @@ + -------------------------------------------------------------------------------- -- all modules (exposed and internal) in a cabal file -diffExposedModules :: CabalPrecis -> CabalPrecis -> [Edit3 StrName] +diffExposedModules :: Package -> Package -> [Edit3 ModName] diffExposedModules new old = diff3 (==) new' old' where - new' = map getName $ exposed_modules new - old' = map getName $ exposed_modules old + new' = map module_name $ exposed_modules new + old' = map module_name $ exposed_modules old -diffInternalModules :: CabalPrecis -> CabalPrecis -> [Edit3 StrName] + +diffInternalModules :: Package -> Package -> [Edit3 ModName] diffInternalModules new old = diff3 (==) new' old' where - new' = map getName $ internal_modules new - old' = map getName $ internal_modules old - -getName :: SourceFile -> StrName -getName (SourceFile m _) = m -getName (UnresolvedFile s) = s - + new' = map module_name $ internal_modules new + old' = map module_name $ internal_modules old -diffExposedSrcFiles :: [SourceFile] -> [SourceFile] -> [Edit4 SourceFile] +diffExposedSrcFiles :: [HsSourceFile] -> [HsSourceFile] -> [Edit4 HsSourceFile] diffExposedSrcFiles new old = diff4 equal (/=) new old where - s `equal` t = getName s == getName t + s `equal` t = module_name s == module_name t -------------------------------------------------------------------------------- -- export lists diff --git a/src/Precis/PPShowS.hs b/src/Precis/PPShowS.hs deleted file mode 100644 --- a/src/Precis/PPShowS.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Precis.PPShowS --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : to be determined. --- --- Pretty print combinators for ShowS --- --------------------------------------------------------------------------------- - - -module Precis.PPShowS - ( - - toString - , putShowS - , putShowSLine - - , punctuate - , encloseSep - , list - , tupled - , semiBrace - - , hcat - , hsep - , vsep - , (<>) - , (<+>) - - , sep - , line - - , squotes - , dquotes - , braces - , parens - , angles - , brackets - - , lparen - , rparen - , langle - , rangle - , lbrace - , rbrace - , lbracket - , rbracket - - , sglquote - , dblquote - , semi - , colon - , comma - , space - , dot - , equal - , backslash - , newline - , bar - - , empty - , text - , char - , int - - , repeatChar - , prefixLines - , nextLine - - ) where - -infixr 5 `line` -infixr 6 <>,<+> - -toString :: ShowS -> String -toString = ($ []) - -putShowS :: ShowS -> IO () -putShowS = putStr . toString - -putShowSLine :: ShowS -> IO () -putShowSLine = putStrLn . toString - - -punctuate :: ShowS -> [ShowS] -> [ShowS] -punctuate _ [] = [] -punctuate _ [x] = [x] -punctuate s (x:xs) = (x . s) : punctuate s xs - -encloseSep :: ShowS -> ShowS -> ShowS -> [ShowS] -> ShowS -encloseSep l r _ [] = l . r -encloseSep l r _ [x] = l . x . r -encloseSep l r s xs = l . hcat (punctuate s xs) . r - -list :: [ShowS] -> ShowS -list = encloseSep lbracket rbracket comma - -tupled :: [ShowS] -> ShowS -tupled = encloseSep lparen rparen comma - -semiBrace :: [ShowS] -> ShowS -semiBrace = encloseSep lbrace rbrace semi - -hcat :: [ShowS] -> ShowS -hcat = fold (.) - -hsep :: [ShowS] -> ShowS -hsep = fold sep - -vsep :: [ShowS] -> ShowS -vsep = fold line - - -(<>) :: ShowS -> ShowS -> ShowS -(<>) = (.) - -(<+>) :: ShowS -> ShowS -> ShowS -(<+>) f g = f <> space <> g - - -fold :: (ShowS -> ShowS -> ShowS) -> [ShowS] -> ShowS -fold _ [] = id -fold f xs = foldr1 f xs - -sep :: ShowS -> ShowS -> ShowS -x `sep` y = x . space . y - -line :: ShowS -> ShowS -> ShowS -x `line` y = x . newline . y - -squotes :: ShowS -> ShowS -squotes = enclose sglquote sglquote - -dquotes :: ShowS -> ShowS -dquotes = enclose dblquote dblquote - -braces :: ShowS -> ShowS -braces = enclose lbrace rbrace - -parens :: ShowS -> ShowS -parens = enclose lparen rparen - -angles :: ShowS -> ShowS -angles = enclose langle rangle - -brackets :: ShowS -> ShowS -brackets = enclose lbracket rbracket - -enclose :: ShowS -> ShowS -> ShowS -> ShowS -enclose l r x = l . x . r - -lparen :: ShowS -lparen = showChar '(' - -rparen :: ShowS -rparen = showChar ')' - -langle :: ShowS -langle = showChar '<' - -rangle :: ShowS -rangle = showChar '>' - -lbrace :: ShowS -lbrace = showChar '{' - -rbrace :: ShowS -rbrace = showChar '}' - -lbracket :: ShowS -lbracket = showChar '[' - -rbracket :: ShowS -rbracket = showChar ']' - - -sglquote :: ShowS -sglquote = showChar '\'' - - -dblquote :: ShowS -dblquote = showChar '"' - -semi :: ShowS -semi = showChar ';' - -colon :: ShowS -colon = showChar ':' - -comma :: ShowS -comma = showChar ',' - -space :: ShowS -space = showChar ' ' - -dot :: ShowS -dot = showChar '.' - -equal :: ShowS -equal = showChar '=' - -backslash :: ShowS -backslash = showChar '\\' - -newline :: ShowS -newline = showChar '\n' - -bar :: ShowS -bar = showChar '|' - - -empty :: ShowS -empty = id - -text :: String -> ShowS -text = showString - -char :: Char -> ShowS -char = showChar - -int :: Int -> ShowS -int = shows - - -repeatChar :: Int -> Char -> ShowS -repeatChar i = showString . replicate i - - -prefixLines :: ShowS -> String -> ShowS -prefixLines pre xs = vsep $ map ((pre <>) . text) $ lines xs - --- | Note - this function evaluates the second arg and uses (++) --- via 'showString'. --- -nextLine :: ShowS -> ShowS -> ShowS -nextLine f g = step $ toString g - where - step str | null str = f - | otherwise = f `line` (showString str) diff --git a/src/Precis/PathUtils.hs b/src/Precis/PathUtils.hs deleted file mode 100644 --- a/src/Precis/PathUtils.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Precis.PathUtils --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : to be determined. --- --- --------------------------------------------------------------------------------- - - -module Precis.PathUtils - ( - exeModuleName - , resolveFiles - , removePrefix - , resolveToCabalFileLoc - ) where - -import Precis.Datatypes - -import Distribution.ModuleName - -import Data.List ( intersperse ) -import Data.Monoid -import System.Directory -import System.FilePath - - --- should have \".hs\" or \".lhs\" extension -exeModuleName :: FilePath -> ModuleName -exeModuleName = fromString . dropExtension - -resolveFiles :: FilePath - -> [FilePath] - -> [ModuleName] - -> [String] - -> IO [SourceFile] -resolveFiles path_root src_dirs mod_names exts = - let cp_paths = map fn $ longCrossProduct src_dirs mod_names in - mapM resolve cp_paths - where - fn (path,modu) = (mname modu, moduleLongPath path_root path modu) - - resolve (mod_name,path) = do { ans <- findByExtension path exts - ; case ans of - Nothing -> - return $ UnresolvedFile $ mod_name - Just path' -> - return $ sourceFile mod_name path' - } - - -findByExtension :: FilePath -> [String] -> IO (Maybe FilePath) -findByExtension _ [] = return Nothing -findByExtension path (e:es) = let full = addExtension path e in - doesFileExist full >>= \ans -> if ans then return (Just full) - else findByExtension path es - - -moduleLongPath :: FilePath -> FilePath -> ModuleName -> FilePath -moduleLongPath root src_dir mod_name = - joinPath $ splitPath root ++ splitPath src_dir ++ components mod_name - - -longCrossProduct :: Monoid a => [a] -> [b] -> [(a,b)] -longCrossProduct [] ys = map (\b -> (mempty,b)) ys -longCrossProduct xs ys = [(a,b) | a <- xs , b <- ys ] - - -mname :: ModuleName -> String -mname = concat . intersperse "." . components - --------------------------------------------------------------------------------- - -removePrefix :: FilePath -> FilePath -> FilePath -removePrefix pre path = joinPath $ step (fn pre) (fn path) - where - fn = splitPath . normalise - step (x:xs) (y:ys) | x == y = step xs ys - step _ ys = ys - --------------------------------------------------------------------------------- - -resolveToCabalFileLoc :: FilePath -> FilePath -> FilePath -resolveToCabalFileLoc cabal_file src_file = - (dropFileName cabal_file) `combine` src_file diff --git a/src/Precis/ReportMonad.hs b/src/Precis/ReportMonad.hs --- a/src/Precis/ReportMonad.hs +++ b/src/Precis/ReportMonad.hs @@ -33,6 +33,7 @@ , liftIO , tellHtml + , tellUnresolved , tellParseFail , incrRemovedModules @@ -48,9 +49,11 @@ ) where -import Precis.Datatypes -import Precis.Utils +import Precis.Cabal.Datatypes +import Precis.HsSrc.Datatypes +import Precis.Utils.Common + import Language.Haskell.Exts ( Module ) -- package: haskell-src-exts import Text.XHtml hiding ( name ) -- package: xhtml @@ -75,8 +78,9 @@ fmap f (OLD a) = OLD (f a) data ChangeStats = ChangeStats - { unparseable_modules :: [CMP StrName] - , removed_modules :: Int + { unresolved_mods :: [CMP StrName] + , unparseable_mods :: [CMP StrName] + , removed_mods :: Int -- exports from a module , removed_exports :: Int @@ -96,7 +100,7 @@ } deriving (Show) -type ModuleParseFunction = SourceFile -> IO (Either ModuleParseError Module) +type ModuleParseFunction = HsSourceFile -> IO (Either ModuleParseError Module) data ReportLevel = JUST_MSG | MSG_AND_HTML deriving (Eq,Show) @@ -128,7 +132,7 @@ log_zero :: Log log_zero = ([],stats_zero) where - stats_zero = ChangeStats [] 0 0 0 0 0 0 0 0 0 + 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 @@ -154,13 +158,17 @@ updateStats fn = ReportM $ \_ (hs,stats) -> returnIO ((),(hs, fn stats)) +tellUnresolved :: CMP StrName -> ReportM () +tellUnresolved name = updateStats $ + pstar (\xs s -> s { unresolved_mods = name:xs}) unresolved_mods + tellParseFail :: CMP StrName -> ReportM () tellParseFail name = updateStats $ - pstar (\xs s -> s { unparseable_modules = name:xs}) unparseable_modules + pstar (\xs s -> s { unparseable_mods = name:xs}) unparseable_mods incrRemovedModules :: ReportM () incrRemovedModules = updateStats $ - pstar (\i s -> s { removed_modules = i+1}) removed_modules + pstar (\i s -> s { removed_mods = i+1}) removed_mods incrRemovedExports :: ReportM () diff --git a/src/Precis/TextOutput.hs b/src/Precis/TextOutput.hs --- a/src/Precis/TextOutput.hs +++ b/src/Precis/TextOutput.hs @@ -21,16 +21,18 @@ , comparingMsg ) where -import Precis.Datatypes -import Precis.PPShowS +import Precis.Cabal.Datatypes import Precis.ReportMonad +import Precis.Utils.PPShowS import Data.Maybe showChangeStats :: ChangeStats -> ShowS showChangeStats = vsep . catMaybes . sequence funs where - funs = [ unparseableModules, removedModules + funs = [ unresolvedModules + , unparseableModules + , removedModules , removedExports, changedExports , removedDatatypes, changedDatatypes , removedTypeSigs, changedTypeSigs @@ -38,8 +40,20 @@ ] + +unresolvedModules :: ChangeStats -> Maybe ShowS +unresolvedModules = step . unresolved_mods + 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 found: " `line` k + unparseableModules :: ChangeStats -> Maybe ShowS -unparseableModules = step . unparseable_modules +unparseableModules = step . unparseable_mods where step [] = Nothing step xs = Just $ prolog $ vsep $ map fn xs @@ -52,7 +66,7 @@ removedModules :: ChangeStats -> Maybe ShowS removedModules = - countMsg "removed" "exposed module" "exposed modules" . removed_modules + countMsg "removed" "exposed module" "exposed modules" . removed_mods removedExports :: ChangeStats -> Maybe ShowS removedExports = @@ -99,7 +113,7 @@ -------------------------------------------------------------------------------- -comparingMsg :: CabalPrecis -> CabalPrecis -> ShowS +comparingMsg :: Package -> Package -> ShowS comparingMsg new old = suffixEllipses $ hsep $ map text [ "Comparing", package_name new, package_version new , "to", package_name old, package_version old diff --git a/src/Precis/Utils.hs b/src/Precis/Utils.hs deleted file mode 100644 --- a/src/Precis/Utils.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Precis.Utils --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : to be determined. --- --- Utils --- --------------------------------------------------------------------------------- - - -module Precis.Utils - ( - unlist - - , 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 - -type H a = [a] -> [a] - -snocH :: H a -> a -> H a -snocH f a = f . (a:) - -toListH :: H a -> [a] -toListH = ($ []) - - -onSuccess :: Monad m => Either a b -> (b -> m c) -> m (Either a c) -onSuccess (Left a) _ = return (Left a) -onSuccess (Right b) mf = liftM Right $ mf b - - -onSuccessM :: Monad m => m (Either a b) -> (b -> m c) -> m (Either a c) -onSuccessM ma msk = ma >>= step - 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/Utils/Common.hs b/src/Precis/Utils/Common.hs new file mode 100644 --- /dev/null +++ b/src/Precis/Utils/Common.hs @@ -0,0 +1,145 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.Utils.Common +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- Utils +-- +-------------------------------------------------------------------------------- + + +module Precis.Utils.Common + ( + -- * Hughes list + H + , emptyH + , wrapH + , consH + , snocH + , appendH + , veloH + , concatH + + , toListH + , fromListH + + -- * Others + , unlist + + , mapLeft + , mapRight + + , onSuccessM + + , pstar + , pstar2 + , star + , star2 + + ) where + + +import Control.Monad + + +-- Hughes lists + +type H a = [a] -> [a] + +infixr 2 `snocH` + + +emptyH :: H a +emptyH = id + +wrapH :: a -> H a +wrapH a = consH a id + +consH :: a -> H a -> H a +consH a f = (a:) . f + +snocH :: H a -> a -> H a +snocH f a = f . (a:) + +appendH :: H a -> H a -> H a +appendH f g = f . g + + +-- | Traverse a list as per 'map' applying the supplied function +-- to each element, *but* pruduce a Hughes list as output. +-- +-- +-- +veloH :: (a -> b) -> [a] -> H b +veloH _ [] = id +veloH f (x:xs) = consH (f x) $ veloH f xs + +concatH :: [H a] -> H a +concatH = foldr (.) id + + +toListH :: H a -> [a] +toListH = ($ []) + +fromListH :: [a] -> H a +fromListH [] = id +fromListH xs = (xs++) + +-------------------------------------------------------------------------------- + +unlist :: [String] -> String +unlist [] = "" +unlist [w] = w +unlist (w:ws) = w ++ ',' : ' ' : unwords ws + + +-- Where\'s the bifunctor class when you need it... + +mapLeft :: (a -> s) -> Either a b -> Either s b +mapLeft f (Left a) = Left $ f a +mapLeft _ (Right b) = Right b + +mapRight :: (b -> t) -> Either a b -> Either a t +mapRight _ (Left a) = Left a +mapRight f (Right b) = Right $ f b + + + + +onSuccessM :: Monad m => m (Either a b) -> (b -> m c) -> m (Either a c) +onSuccessM ma msk = ma >>= step + 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 + +star :: (r -> a) + -> (a -> r -> ans) + -> r -> ans +star fa f x = f (fa x) x + +star2 :: (r -> a) -> (r -> b) + -> (a -> b -> r -> ans) + -> r -> ans +star2 fa fb f x = f (fa x) (fb x) x + diff --git a/src/Precis/Utils/ControlOperators.hs b/src/Precis/Utils/ControlOperators.hs new file mode 100644 --- /dev/null +++ b/src/Precis/Utils/ControlOperators.hs @@ -0,0 +1,59 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.Utils.ControlOperators +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- ALL NAMES PROVISIONAL... +-- +-------------------------------------------------------------------------------- + + +module Precis.Utils.ControlOperators + ( + suppress + , elaborate + + , firstSuccess + , valid + , validE + + ) where + + + +suppress :: Either e a -> Maybe a +suppress (Right a) = Just a +suppress _ = Nothing + +elaborate :: e -> Maybe a -> Either e a +elaborate ex Nothing = Left ex +elaborate _ (Just a) = Right a + + + + +-- | Apply the function to the list +firstSuccess :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) +firstSuccess mf xs0 = step xs0 + where + step [] = return Nothing + step (x:xs) = mf x >>= \ans -> case ans of + Just a -> return $ Just a + Nothing -> step xs + + + +valid :: Monad m => (a -> m Bool) -> a -> m (Maybe a) +valid test a = test a >>= \ans -> + if ans then return (Just a) else return Nothing + +validE :: Monad m => ex -> (a -> m Bool) -> a -> m (Either ex a) +validE ex test a = test a >>= \ans -> + if ans then return (Right a) else return (Left ex) diff --git a/src/Precis/Utils/PPShowS.hs b/src/Precis/Utils/PPShowS.hs new file mode 100644 --- /dev/null +++ b/src/Precis/Utils/PPShowS.hs @@ -0,0 +1,246 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Precis.Utils.PPShowS +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : to be determined. +-- +-- Pretty print combinators for ShowS +-- +-------------------------------------------------------------------------------- + + +module Precis.Utils.PPShowS + ( + + toString + , putShowS + , putShowSLine + + , punctuate + , encloseSep + , list + , tupled + , semiBrace + + , hcat + , hsep + , vsep + , (<>) + , (<+>) + + , sep + , line + + , squotes + , dquotes + , braces + , parens + , angles + , brackets + + , lparen + , rparen + , langle + , rangle + , lbrace + , rbrace + , lbracket + , rbracket + + , sglquote + , dblquote + , semi + , colon + , comma + , space + , dot + , equal + , backslash + , newline + , bar + + , empty + , text + , char + , int + + , repeatChar + , prefixLines + , nextLine + + ) where + +infixr 5 `line` +infixr 6 <>,<+> + +toString :: ShowS -> String +toString = ($ []) + +putShowS :: ShowS -> IO () +putShowS = putStr . toString + +putShowSLine :: ShowS -> IO () +putShowSLine = putStrLn . toString + + +punctuate :: ShowS -> [ShowS] -> [ShowS] +punctuate _ [] = [] +punctuate _ [x] = [x] +punctuate s (x:xs) = (x . s) : punctuate s xs + +encloseSep :: ShowS -> ShowS -> ShowS -> [ShowS] -> ShowS +encloseSep l r _ [] = l . r +encloseSep l r _ [x] = l . x . r +encloseSep l r s xs = l . hcat (punctuate s xs) . r + +list :: [ShowS] -> ShowS +list = encloseSep lbracket rbracket comma + +tupled :: [ShowS] -> ShowS +tupled = encloseSep lparen rparen comma + +semiBrace :: [ShowS] -> ShowS +semiBrace = encloseSep lbrace rbrace semi + +hcat :: [ShowS] -> ShowS +hcat = fold (.) + +hsep :: [ShowS] -> ShowS +hsep = fold sep + +vsep :: [ShowS] -> ShowS +vsep = fold line + + +(<>) :: ShowS -> ShowS -> ShowS +(<>) = (.) + +(<+>) :: ShowS -> ShowS -> ShowS +(<+>) f g = f <> space <> g + + +fold :: (ShowS -> ShowS -> ShowS) -> [ShowS] -> ShowS +fold _ [] = id +fold f xs = foldr1 f xs + +sep :: ShowS -> ShowS -> ShowS +x `sep` y = x . space . y + +line :: ShowS -> ShowS -> ShowS +x `line` y = x . newline . y + +squotes :: ShowS -> ShowS +squotes = enclose sglquote sglquote + +dquotes :: ShowS -> ShowS +dquotes = enclose dblquote dblquote + +braces :: ShowS -> ShowS +braces = enclose lbrace rbrace + +parens :: ShowS -> ShowS +parens = enclose lparen rparen + +angles :: ShowS -> ShowS +angles = enclose langle rangle + +brackets :: ShowS -> ShowS +brackets = enclose lbracket rbracket + +enclose :: ShowS -> ShowS -> ShowS -> ShowS +enclose l r x = l . x . r + +lparen :: ShowS +lparen = showChar '(' + +rparen :: ShowS +rparen = showChar ')' + +langle :: ShowS +langle = showChar '<' + +rangle :: ShowS +rangle = showChar '>' + +lbrace :: ShowS +lbrace = showChar '{' + +rbrace :: ShowS +rbrace = showChar '}' + +lbracket :: ShowS +lbracket = showChar '[' + +rbracket :: ShowS +rbracket = showChar ']' + + +sglquote :: ShowS +sglquote = showChar '\'' + + +dblquote :: ShowS +dblquote = showChar '"' + +semi :: ShowS +semi = showChar ';' + +colon :: ShowS +colon = showChar ':' + +comma :: ShowS +comma = showChar ',' + +space :: ShowS +space = showChar ' ' + +dot :: ShowS +dot = showChar '.' + +equal :: ShowS +equal = showChar '=' + +backslash :: ShowS +backslash = showChar '\\' + +newline :: ShowS +newline = showChar '\n' + +bar :: ShowS +bar = showChar '|' + + +empty :: ShowS +empty = id + +text :: String -> ShowS +text = showString + +char :: Char -> ShowS +char = showChar + +int :: Int -> ShowS +int = shows + + +repeatChar :: Int -> Char -> ShowS +repeatChar i = showString . replicate i + + +prefixLines :: ShowS -> String -> ShowS +prefixLines pre xs = vsep $ map ((pre <>) . text) $ lines xs + +-- | Note - this function evaluates the second arg and uses (++) +-- via 'showString'. +-- +nextLine :: ShowS -> ShowS -> ShowS +nextLine f g = step $ toString g + where + step str | null str = f + | otherwise = f `line` (showString str) diff --git a/src/Precis/VersionNumber.hs b/src/Precis/VersionNumber.hs --- a/src/Precis/VersionNumber.hs +++ b/src/Precis/VersionNumber.hs @@ -24,4 +24,4 @@ -- | Version number -- precis_version_number :: String -precis_version_number = "0.4.0" +precis_version_number = "0.5.0"