diff --git a/Language/Haskell/Modules.hs b/Language/Haskell/Modules.hs --- a/Language/Haskell/Modules.hs +++ b/Language/Haskell/Modules.hs @@ -1,27 +1,6 @@ --- | This package provides three functions. The 'cleanImports' --- function uses ghc's -ddump-minimal-imports flag to generate --- minimized and explicit imports and re-insert them into the module. --- --- The 'splitModuleDecls' function moves each declaration of a module --- into a separate new module, and may also create three additional --- modules: ReExported (for identifiers that were re-exported from --- other imports), Instances (for declarations that don't result in an --- identifier to export), and OtherSymbols (for declarations that --- can't be turned into a module name.) --- --- In addition to creating new modules, 'splitModuleDecls' also scans the --- a set of modules (known as the moduVerse) and updates their imports --- to account for the new locations of the symbols. The moduVerse is --- stored in MonadClean's state, and is updated as modules are created --- and destroyed by 'splitModule' and 'catModules'. --- --- The 'splitModule' function is a version of 'splitModuleDecls' that --- allows the caller to customize the mapping from symbols to new --- modules. --- --- The 'mergeModules' function is the inverse operation of --- 'splitModule', it merges two or more modules into a new or existing --- module, updating imports of the moduVerse elements as necessary. +-- | This package provides functions to clean import lists, to split +-- up modules, and to merge modules. The important entry +-- points are: -- -- There are several features worth noting. The 'Params' type in the -- state of 'MonadClean' has a 'removeEmptyImports' field, which is @@ -32,49 +11,99 @@ -- -- These are the important entry points: -- --- * 'cleanImports' +-- * 'runCleanT' - Sets up the environment for splitting and merging. +-- These operations require updates to be made to all the modules +-- that import the modules being split or merged, so this +-- environment tracks the creation and removal of modules. This +-- allows a sequence of splits and merges to be performed without +-- forgetting to update newly created modules. -- --- * 'splitModule' +-- * 'cleanImports' - uses ghc's -ddump-minimal-imports flag to +-- generate minimized and explicit imports and re-insert them into +-- the module. -- --- * 'mergeModules' +-- * 'splitModule' - Splits a module into two or more parts according to +-- the argument function. -- --- * 'runMonadClean' - Sets up the environment for splitting and merging +-- * 'splitModuleDecls' - Calls 'splitModule' with a default first +-- argument. Each declaration goes into a different module, and +-- separate modules are created for instances and re-exports. Decls +-- that were local to the original module go into a subdirectory named +-- @Internal@. Symbols which can't be turned into valid module names +-- go into @OtherSymbols@. -- --- * 'Language.Haskell.Modules.Params' - Functions to control modes of operation +-- * 'mergeModules' - the inverse operation of 'splitModule', it +-- merges two or more modules into a new or existing module, updating +-- imports of the moduVerse elements as necessary. -- -- Examples: -- --- * Use @cleanImports@ to clean up the import lists of all the modules under @./Language@: +-- * Use 'findHsFiles' and 'cleanImports' to clean up the import lists +-- of all the modules under @./Language@: -- --- @findPaths \"Language\" >>= runMonadClean . mapM cleanImports . toList@ +-- @findHsFiles [\"Language\", \"Tests.hs\", \"Tests\"] >>= runCleanT . cleanImports@ -- --- * Use @splitModule@ to split up module --- @Language.Haskell.Modules.Common@, and then merge two of the pieces --- back in. +-- * Split the module @Language.Haskell.Modules.Common@, and then +-- merge two of the declarations back in: -- --- @findModules \"Language\" >>= \\ modules -> runMonadClean $ --- let mn = Language.Haskell.Exts.Syntax.ModuleName in --- modifyModuVerse (const modules) >> --- splitModule (mn \"Language.Haskell.Modules.Common\") >> --- mergeModules (map mn [\"Language.Haskell.Modules.Common.WithCurrentDirectory\", --- \"Language.Haskell.Modules.Common.ModulePathBase\"]) --- (mn \"Language.Haskell.Modules.Common\"))@ +-- @:m +Language.Haskell.Exts.Syntax +-- findHsModules [\"Language\", \"Tests.hs\", \"Tests\"] >>= \\ modules -> runCleanT $ +-- mapM putModule modules >> +-- splitModuleDecls \"Language\/Haskell\/Modules\/Common.hs\" >> +-- mergeModules [ModuleName \"Language.Haskell.Modules.Common.WithCurrentDirectory\", +-- ModuleName \"Language.Haskell.Modules.Common.Internal.ToEq\"] +-- (ModuleName \"Language.Haskell.Modules.Common\")@ +-- +-- * Move two declarations from Internal to Common. The intermediate module +-- @Tmp@ is used because using existing modules for a split is not allowed. +-- The exception to this is that you can leave declarations in the original module. +-- +-- @findHsModules [\"Language\", \"Tests.hs\", \"Tests\"] >>= \\ modules -> runCleanT $ +-- mapM putModule modules >> +-- splitModule (\\ n -> if elem n [Just (Ident \"ModuleResult\"), Just (Ident \"doResult\")] +-- then ModuleName \"Tmp\" +-- else ModuleName \"Language.Haskell.Modules.Internal\") +-- (ModuleName \"Language\/Haskell\/Modules\/Internal.hs\") >> +-- mergeModules [ModuleName \"Language.Haskell.Modules.Common\", ModuleName \"Tmp\"] +-- (ModuleName \"Language.Haskell.Modules.Common\")@ module Language.Haskell.Modules - ( cleanImports + ( + -- * Entry points + cleanImports , splitModule , splitModuleDecls + , defaultSymbolToModule , mergeModules - , module Language.Haskell.Modules.Params - , module Language.Haskell.Modules.Fold - , module Language.Haskell.Modules.Util.QIO - , findModules - , findPaths + -- * Runtime environment + , MonadClean + , CleanT + , runCleanT + , putModule + , findModule + , modifyDryRun + , modifyHsFlags + , modifyRemoveEmptyImports + , modifyExtensions + , modifyTestMode + , modifyDirs + , putDirs + -- * Progress reporting + , noisily + , quietly + -- * Helper functions + , modulePathBase + , findHsModules + , findHsFiles + , withCurrentDirectory ) where -import Language.Haskell.Modules.Fold (echo, echo2, foldDecls, foldExports, foldHeader, foldImports, foldModule, ignore, ignore2) +import Language.Haskell.Modules.Common (withCurrentDirectory) import Language.Haskell.Modules.Imports (cleanImports) +import Language.Haskell.Modules.Internal (CleanT, MonadClean, runCleanT) import Language.Haskell.Modules.Merge (mergeModules) -import Language.Haskell.Modules.Params (modifyDryRun, modifyExtensions, modifyHsFlags, modifyModuVerse, modifyRemoveEmptyImports, modifySourceDirs, modifyTestMode, runMonadClean) -import Language.Haskell.Modules.Split (splitModule, splitModuleDecls) +import Language.Haskell.Modules.ModuVerse (findModule, modifyExtensions, putModule) +import Language.Haskell.Modules.Params (modifyDryRun, modifyHsFlags, modifyRemoveEmptyImports, modifyTestMode) +import Language.Haskell.Modules.SourceDirs (modifyDirs, modulePathBase, SourceDirs(putDirs)) +import Language.Haskell.Modules.Split (defaultSymbolToModule, splitModule, splitModuleDecls) import Language.Haskell.Modules.Util.QIO (noisily, quietly) -import Language.Haskell.Modules.Util.Test (findModules, findPaths) +import Language.Haskell.Modules.Util.Test (findHsFiles, findHsModules) -- (findHsFiles, findHsModules) diff --git a/Language/Haskell/Modules/Common.hs b/Language/Haskell/Modules/Common.hs --- a/Language/Haskell/Modules/Common.hs +++ b/Language/Haskell/Modules/Common.hs @@ -1,19 +1,14 @@ -{-# LANGUAGE BangPatterns, FlexibleInstances, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns, FlexibleInstances, PackageImports, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Language.Haskell.Modules.Common ( groupBy' - , mapNames - , modulePathBase , withCurrentDirectory ) where -import Control.Exception (bracket) -import Data.Default (def, Default) +import "MonadCatchIO-mtl" Control.Monad.CatchIO (bracket, MonadCatchIO) +import Control.Monad.Trans (liftIO) import Data.List (groupBy, sortBy) -import qualified Language.Haskell.Exts.Annotated.Syntax as A (Name(..)) -import qualified Language.Haskell.Exts.Syntax as S (ModuleName(..), Name(..)) import System.Directory (getCurrentDirectory, setCurrentDirectory) -import System.FilePath ((<.>)) -- | Convert a compare function into an (==) toEq :: Ord a => (a -> a -> Ordering) -> (a -> a -> Bool) @@ -26,21 +21,8 @@ groupBy' :: Ord a => (a -> a -> Ordering) -> [a] -> [[a]] groupBy' cmp xs = groupBy (toEq cmp) $ sortBy cmp xs -mapNames :: Default a => [S.Name] -> [A.Name a] -mapNames [] = [] -mapNames (S.Ident x : more) = A.Ident def x : mapNames more -mapNames (S.Symbol x : more) = A.Symbol def x : mapNames more - --- | Construct the base of a module path. -modulePathBase :: S.ModuleName -> FilePath -modulePathBase (S.ModuleName name) = - map f name <.> "hs" - where - f '.' = '/' - f c = c - -withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory :: MonadCatchIO m => FilePath -> m a -> m a withCurrentDirectory path action = - bracket (getCurrentDirectory >>= \ save -> setCurrentDirectory path >> return save) - setCurrentDirectory + bracket (liftIO getCurrentDirectory >>= \ save -> liftIO (setCurrentDirectory path) >> return save) + (liftIO . setCurrentDirectory) (const action) diff --git a/Language/Haskell/Modules/Fold.hs b/Language/Haskell/Modules/Fold.hs --- a/Language/Haskell/Modules/Fold.hs +++ b/Language/Haskell/Modules/Fold.hs @@ -2,9 +2,7 @@ {-# LANGUAGE BangPatterns, CPP, FlexibleInstances, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Language.Haskell.Modules.Fold - ( ModuleInfo - , ModuleMap - , foldModule + ( foldModule , foldHeader , foldExports , foldImports @@ -19,18 +17,16 @@ import Control.Monad (when) import Control.Monad.State (get, put, runState, State) import Data.Char (isSpace) -import Data.Default (Default(def)) import Data.List (tails) -import Data.Map (Map) import Data.Monoid ((<>), Monoid) import Data.Sequence (Seq, (|>)) import qualified Language.Haskell.Exts.Annotated.Syntax as A (Decl, ExportSpec, ExportSpec(..), ExportSpecList(ExportSpecList), ImportDecl, Module(..), ModuleHead(..), ModuleName, ModulePragma, WarningText) import Language.Haskell.Exts.Comments (Comment(..)) import Language.Haskell.Exts.SrcLoc (SrcLoc(..), SrcSpan(..), SrcSpanInfo(..)) -import qualified Language.Haskell.Exts.Syntax as S (ModuleName) +import Language.Haskell.Modules.ModuVerse (ModuleInfo(ModuleInfo)) import Language.Haskell.Modules.Util.SrcLoc (endLoc, HasSpanInfo(..), increaseSrcLoc, srcLoc, srcPairText) -type Module = A.Module SrcSpanInfo +--type Module = A.Module SrcSpanInfo --type ModuleHead = A.ModuleHead SrcSpanInfo type ModulePragma = A.ModulePragma SrcSpanInfo type ModuleName = A.ModuleName SrcSpanInfo @@ -60,9 +56,6 @@ instance Spans (A.ModuleName SrcSpanInfo) where spans x = [fixSpan $ spanInfo x] instance Spans (A.WarningText SrcSpanInfo) where spans x = [fixSpan $ spanInfo x] -type ModuleInfo = (Module, String, [Comment]) -type ModuleMap = Map S.ModuleName ModuleInfo - -- This happens, a span with end column 0, even though column -- numbering begins at 1. Is it a bug in haskell-src-exts? fixSpan :: SrcSpanInfo -> SrcSpanInfo @@ -89,8 +82,8 @@ adjustSpans :: String -> [Comment] -> [SrcSpanInfo] -> [SrcSpanInfo] adjustSpans _ _ [] = [] adjustSpans _ _ [x] = [x] -adjustSpans text comments sps = - fst $ runState f (St def text comments sps) +adjustSpans text comments sps@(x : _) = + fst $ runState f (St (SrcLoc (srcFilename (srcLoc x)) 1 1) text comments sps) where f = do st <- get let b = loc_ st @@ -174,10 +167,10 @@ -> ModuleInfo -- ^ Parsed module -> r -- ^ Fold initialization value -> r -- ^ Result -foldModule _ _ _ _ _ _ _ _ _ _ (A.XmlPage _ _ _ _ _ _ _, _, _) _ = error "XmlPage: unsupported" -foldModule _ _ _ _ _ _ _ _ _ _ (A.XmlHybrid _ _ _ _ _ _ _ _ _, _, _) _ = error "XmlHybrid: unsupported" -foldModule topf pragmaf namef warnf pref exportf postf importf declf sepf (m@(A.Module _ mh ps is ds), text, comments) r0 = - (\ (_, (_, _, _, r)) -> r) $ runState doModule (text, def, spans m, r0) +foldModule _ _ _ _ _ _ _ _ _ _ (ModuleInfo (A.XmlPage _ _ _ _ _ _ _) _ _ _) _ = error "XmlPage: unsupported" +foldModule _ _ _ _ _ _ _ _ _ _ (ModuleInfo (A.XmlHybrid _ _ _ _ _ _ _ _ _) _ _ _) _ = error "XmlHybrid: unsupported" +foldModule topf pragmaf namef warnf pref exportf postf importf declf sepf (ModuleInfo (m@(A.Module (SrcSpanInfo (SrcSpan path _ _ _ _) _) mh ps is ds)) text comments _) r0 = + (\ (_, (_, _, _, r)) -> r) $ runState doModule (text, (SrcLoc path 1 1), spans m, r0) where doModule = do doSep topf diff --git a/Language/Haskell/Modules/Imports.hs b/Language/Haskell/Modules/Imports.hs --- a/Language/Haskell/Modules/Imports.hs +++ b/Language/Haskell/Modules/Imports.hs @@ -2,35 +2,36 @@ {-# OPTIONS_GHC -Wall #-} module Language.Haskell.Modules.Imports ( cleanImports + , cleanResults ) where import Control.Applicative ((<$>)) import "MonadCatchIO-mtl" Control.Monad.CatchIO as IO (bracket, catch, throw) import Control.Monad.Trans (liftIO) import Data.Char (toLower) -import Data.Default (def, Default) import Data.Foldable (fold) import Data.Function (on) -import Data.List (find, groupBy, intercalate, nub, nubBy, sortBy) +import Data.List (find, groupBy, intercalate, nub, sortBy) import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>), mempty) import Data.Sequence ((|>)) -import Data.Set as Set (empty, member, Set, singleton, toList, union, unions) -import Language.Haskell.Exts.Annotated (ParseResult(..)) +import Data.Set as Set (empty, member, Set, singleton, toList, union, unions, fromList) import Language.Haskell.Exts.Annotated.Simplify as S (sImportDecl, sImportSpec, sModuleName, sName) -import qualified Language.Haskell.Exts.Annotated.Syntax as A (Decl(DerivDecl), ImportDecl(..), ImportSpec(..), ImportSpecList(ImportSpecList), InstHead(..), Module(..), ModuleHead(ModuleHead), ModuleName(ModuleName), QName(..), Type(..)) +import qualified Language.Haskell.Exts.Annotated.Syntax as A (Decl(DerivDecl), ImportDecl(..), ImportSpec(..), ImportSpecList(ImportSpecList), InstHead(..), Module(..), ModuleHead(..), ModuleName(..), QName(..), Type(..)) import Language.Haskell.Exts.Extension (Extension(PackageImports)) import Language.Haskell.Exts.Pretty (defaultMode, PPHsMode(layout), PPLayout(PPInLine), prettyPrintWithMode) -import Language.Haskell.Exts.SrcLoc (SrcSpanInfo) +import Language.Haskell.Exts.SrcLoc (SrcLoc(..), SrcSpanInfo) import qualified Language.Haskell.Exts.Syntax as S (ImportDecl(importLoc, importModule, importSpecs), ModuleName(..), Name(..)) -import Language.Haskell.Modules.Fold (foldDecls, foldExports, foldHeader, foldImports, ModuleInfo) -import Language.Haskell.Modules.Internal (markForDelete, modifyParams, ModuleResult(Modified, Unchanged), MonadClean(getParams), Params(extensions, hsFlags, removeEmptyImports, scratchDir, sourceDirs), parseFile, parseFileWithComments) +import Language.Haskell.Modules.Fold (foldDecls, foldExports, foldHeader, foldImports) +import Language.Haskell.Modules.Internal (markForDelete, ModuleResult(..), MonadClean(getParams), Params(hsFlags, removeEmptyImports, scratchDir, testMode)) +import Language.Haskell.Modules.ModuVerse (getExtensions, loadModule, findModule, modifyExtensions, ModuleInfo(..), moduleName, parseModule) +import Language.Haskell.Modules.SourceDirs (modifyDirs, pathKey, PathKey(..), PathKey(unPathKey), SourceDirs(getDirs, putDirs)) import Language.Haskell.Modules.Util.DryIO (replaceFile, tildeBackup) import Language.Haskell.Modules.Util.QIO (qLnPutStr, quietly) +import Language.Haskell.Modules.Util.SrcLoc (srcLoc) import Language.Haskell.Modules.Util.Symbols (symbols) import System.Directory (createDirectoryIfMissing, getCurrentDirectory) import System.Exit (ExitCode(..)) -import System.FilePath ((<.>)) import System.Process (readProcessWithExitCode, showCommandForUser) {- @@ -41,7 +42,7 @@ cleanBuildImports :: LocalBuildInfo -> IO () cleanBuildImports lbi = mapM (toFilePath srcDirs) (maybe [] exposedModules (library (localPkgDescr lbi))) >>= \ libPaths -> - runMonadClean (Distribution.Simple.LocalBuildInfo.scratchDir lbi) $ mapM_ clean (libPaths ++ exePaths) + runCleanT (Distribution.Simple.LocalBuildInfo.scratchDir lbi) $ mapM_ clean (libPaths ++ exePaths) where clean path = cleanImports path >>= liftIO . putStrLn . either show (\ text -> path ++ ": " ++ maybe "no changes" (\ _ -> " updated") text) exePaths = map modulePath (executables (localPkgDescr lbi)) @@ -57,34 +58,58 @@ -} -- | Clean up the imports of a source file. -cleanImports :: MonadClean m => FilePath -> m ModuleResult -cleanImports path = - do text <- liftIO $ readFile path - source <- parseFileWithComments path - case source of - ParseOk (m@(A.Module _ h _ imports _decls), comments) -> - do let name = case h of - Just (A.ModuleHead _ x _ _) -> sModuleName x - _ -> S.ModuleName "Main" - hiddenImports = filter isHiddenImport imports - dumpImports path >> checkImports path name (m, text, comments) hiddenImports - ParseOk (A.XmlPage {}, _) -> error "cleanImports: XmlPage" - ParseOk (A.XmlHybrid {}, _) -> error "cleanImports: XmlHybrid" - ParseFailed _loc msg -> error ("cleanImports: - parse of " ++ path ++ " failed: " ++ msg) +cleanImports :: MonadClean m => [FilePath] -> m [ModuleResult] +cleanImports paths = + do keys <- mapM pathKey paths >>= return . fromList + dumpImports keys + mapM (\ key -> parseModule key >>= checkImports) (toList keys) + +cleanResults :: MonadClean m => [ModuleResult] -> m [ModuleResult] +cleanResults results = + do mode <- getParams >>= return . testMode + if mode then return results else (dump >> clean) where - isHiddenImport (A.ImportDecl {A.importSpecs = Just (A.ImportSpecList _ True _)}) = True - isHiddenImport _ = False + dump = + mapM (\ x -> case x of + Removed _ _ -> return Nothing + Unchanged _ _ -> return Nothing + Modified _ key _ -> return (Just key) + Created (S.ModuleName name) _ -> findModule name >>= return . fmap key_) results >>= + dumpImports . fromList . catMaybes + clean = + mapM (\ x -> case x of + Removed _ _ -> return x + Unchanged _ _ -> return x + Modified _name key _ -> doModule key + Created (S.ModuleName name) _ -> + do mi <- findModule name + let Just k = fmap key_ mi -- This is pretty sure to be a Just + x' <- doModule k + return $ toCreated x') results + -- The cleaning may have turned a Created result into Modified, + -- turn it back into Created. + toCreated (Modified name _key text) = Created name text + toCreated x@(Created {}) = x + toCreated _ = error "toCreated" + -- Update the cached version of the now modified module and then + -- clean its import list. + doModule key = + do info <- loadModule key + checkImports info -- | Run ghc with -ddump-minimal-imports and capture the resulting .imports file. -dumpImports :: MonadClean m => FilePath -> m () -dumpImports path = +dumpImports :: MonadClean m => Set PathKey -> m () +dumpImports keys = do scratch <- scratchDir <$> getParams liftIO $ createDirectoryIfMissing True scratch let cmd = "ghc" args <- hsFlags <$> getParams - dirs <- sourceDirs <$> getParams - exts <- extensions <$> getParams - let args' = args ++ ["--make", "-c", "-ddump-minimal-imports", "-outputdir", scratch, "-i" ++ intercalate ":" dirs, path] ++ map (("-X" ++) . show) exts + dirs <- getDirs + exts <- getExtensions + let args' = args ++ + ["--make", "-c", "-ddump-minimal-imports", "-outputdir", scratch, "-i" ++ intercalate ":" dirs] ++ + map (("-X" ++) . show) exts ++ + map unPathKey (toList keys) (code, _out, err) <- liftIO $ readProcessWithExitCode cmd args' "" case code of ExitSuccess -> quietly (qLnPutStr (showCommandForUser cmd args' ++ " -> Ok")) >> return () @@ -95,31 +120,50 @@ -- source file. We also need to modify the imports of any names -- that are types that appear in standalone instance derivations so -- their members are imported too. -checkImports :: MonadClean m => FilePath -> S.ModuleName -> ModuleInfo -> [A.ImportDecl SrcSpanInfo] -> m ModuleResult -checkImports path name@(S.ModuleName name') m extraImports = - do let importsPath = name' <.> ".imports" +checkImports :: MonadClean m => ModuleInfo -> m ModuleResult +checkImports info@(ModuleInfo (A.Module _ mh _ imports _) _ _ _) = + do let importsPath = maybe "Main" (\ (A.ModuleHead _ (A.ModuleName _ s) _ _) -> s) mh ++ ".imports" + -- The .imports file will appear in the real current directory, + -- ignore the source dir path. This may change in future + -- versions of GHC, see http://ghc.haskell.org/trac/ghc/ticket/7957 markForDelete importsPath - result <- - bracket (getParams >>= return . extensions) - (\ saved -> modifyParams (\ p -> p {extensions = saved})) - (\ saved -> modifyParams (\ p -> p {extensions = PackageImports : saved}) >> - parseFile importsPath `IO.catch` (\ (e :: IOError) -> liftIO (getCurrentDirectory >>= \ here -> throw . userError $ here ++ ": " ++ show e))) - case result of - ParseOk newImports -> updateSource path m newImports name extraImports - _ -> error ("checkImports: parse of " ++ importsPath ++ " failed - " ++ show result) + (ModuleInfo newImports _ _ _) <- + withDot $ + withPackageImportsExtension $ + (parseModule (PathKey importsPath) + `IO.catch` (\ (e :: IOError) -> liftIO (getCurrentDirectory >>= \ here -> + throw . userError $ here ++ ": " ++ show e))) + updateSource info newImports extraImports + where + extraImports = filter isHiddenImport imports + isHiddenImport (A.ImportDecl {A.importSpecs = Just (A.ImportSpecList _ True _)}) = True + isHiddenImport _ = False +checkImports _ = error "Unsupported module type" +withPackageImportsExtension :: MonadClean m => m a -> m a +withPackageImportsExtension a = + bracket (getExtensions) + (modifyExtensions . const) + (\ saved -> modifyExtensions (const (PackageImports : saved)) >> a) + +withDot :: MonadClean m => m a -> m a +withDot a = + bracket (getDirs) + (modifyDirs . const) + (\ _ -> putDirs ["."] >> a) + -- | If all the parsing went well and the new imports differ from the -- old, update the source file with the new imports. -updateSource :: MonadClean m => FilePath -> ModuleInfo -> A.Module SrcSpanInfo -> S.ModuleName -> [A.ImportDecl SrcSpanInfo] -> m ModuleResult -updateSource path m@(A.Module _ _ _ oldImports _, _, _) (A.Module _ _ _ newImports _) name extraImports = +updateSource :: MonadClean m => ModuleInfo -> A.Module SrcSpanInfo -> [A.ImportDecl SrcSpanInfo] -> m ModuleResult +updateSource m@(ModuleInfo (A.Module _ _ _ oldImports _) _ _ key) (A.Module _ _ _ newImports _) extraImports = do remove <- removeEmptyImports <$> getParams - maybe (qLnPutStr ("cleanImports: no changes to " ++ path) >> return (Unchanged name)) + maybe (qLnPutStr ("cleanImports: no changes to " ++ show key) >> return (Unchanged (moduleName m) key)) (\ text' -> - qLnPutStr ("cleanImports: modifying " ++ path) >> - replaceFile tildeBackup path text' >> - return (Modified name text')) + qLnPutStr ("cleanImports: modifying " ++ show key) >> + replaceFile tildeBackup (unPathKey key) text' >> + return (Modified (moduleName m) key text')) (replaceImports (fixNewImports remove m oldImports (newImports ++ extraImports)) m) -updateSource _ _ _ _ _ = error "updateSource" +updateSource _ _ _ = error "updateSource" -- | Compare the old and new import sets and if they differ clip out -- the imports from the sourceText and insert the new ones. @@ -155,12 +199,10 @@ mergeDecls xs@(x : _) = x {A.importSpecs = mergeSpecLists (catMaybes (map A.importSpecs xs))} where -- Merge a list of specs for the same module - -- mergeSpecLists :: [ImportSpecList] -> Maybe ImportSpecList + mergeSpecLists :: [A.ImportSpecList SrcSpanInfo] -> Maybe (A.ImportSpecList SrcSpanInfo) mergeSpecLists (A.ImportSpecList loc flag specs : ys) = Just (A.ImportSpecList loc flag (mergeSpecs (sortBy compareSpecs (nub (concat (specs : map (\ (A.ImportSpecList _ _ specs') -> specs') ys)))))) mergeSpecLists [] = error "mergeSpecLists" - -- unimplemented, should merge Foo and Foo(..) into Foo(..), and the like - mergeSpecs ys = nubBy equalSpecs ys expandSDTypes :: A.ImportDecl SrcSpanInfo -> A.ImportDecl SrcSpanInfo expandSDTypes i@(A.ImportDecl {A.importSpecs = Just (A.ImportSpecList l f specs)}) = i {A.importSpecs = Just (A.ImportSpecList l f (map (expandSpec i) specs))} @@ -196,9 +238,9 @@ sdTypes = standaloneDerivingTypes m standaloneDerivingTypes :: ModuleInfo -> Set (Maybe S.ModuleName, S.Name) -standaloneDerivingTypes (A.XmlPage _ _ _ _ _ _ _, _, _) = error "standaloneDerivingTypes A.XmlPage" -standaloneDerivingTypes (A.XmlHybrid _ _ _ _ _ _ _ _ _, _, _) = error "standaloneDerivingTypes A.XmlHybrid" -standaloneDerivingTypes (A.Module _ _ _ _ decls, _, _) = +standaloneDerivingTypes (ModuleInfo (A.XmlPage _ _ _ _ _ _ _) _ _ _) = error "standaloneDerivingTypes A.XmlPage" +standaloneDerivingTypes (ModuleInfo (A.XmlHybrid _ _ _ _ _ _ _ _ _) _ _ _) = error "standaloneDerivingTypes A.XmlHybrid" +standaloneDerivingTypes (ModuleInfo (A.Module _ _ _ _ decls) _ _ _) = unions (map derivDeclTypes decls) where -- derivDeclTypes :: Decl -> Set (Maybe S.ModuleName, S.Name) @@ -239,8 +281,9 @@ -- source locations. This will distinguish "import Foo as F" from -- "import Foo", but will let us group imports that can be merged. -- Don't merge hiding imports with regular imports. + SrcLoc path _ _ = srcLoc a noSpecs :: S.ImportDecl -> S.ImportDecl - noSpecs x = x { S.importLoc = def, + noSpecs x = x { S.importLoc = SrcLoc path 1 1, -- can we just use srcLoc a? S.importSpecs = case S.importSpecs x of Just (True, _) -> Just (True, []) -- hiding Just (False, _) -> Nothing @@ -259,6 +302,31 @@ equalSpecs :: A.ImportSpec SrcSpanInfo -> A.ImportSpec SrcSpanInfo -> Bool equalSpecs a b = compareSpecs a b == EQ + +-- Merge elements of a sorted spec list as possible +-- unimplemented, should merge Foo and Foo(..) into Foo(..), and the like +mergeSpecs :: [A.ImportSpec SrcSpanInfo] -> [A.ImportSpec SrcSpanInfo] +mergeSpecs [] = [] +mergeSpecs [x] = [x] +{- +-- We need to do this using the simplified syntax +mergeSpecs (x : y : zs) = + case (name x' == name y', x, y) of + (True, S.IThingAll _ _, _) -> mergeSpecs (x : zs) + (True, _, S.IThingAll _ _) -> mergeSpecs (y : zs) + (True, S.IThingWith _ n xs, S.IThingWith _ ys) -> mergeSpecs (S.IThingWith n (nub (xs ++ ys))) + (True, S.IThingWith _ _, _) -> mergeSpecs (x' : zs) + (True, _, S.IThingWith _ _) -> mergeSpecs (y' : zs) + _ -> x : mergeSpecs (y : zs) + where + x' = sImportSpec x + y' = sImportSpec y + name (S.IVar n) = n + name (S.IAbs n) = n + name (S.IThingAll n) = n + name (S.IThingWith n _) = n +-} +mergeSpecs xs = xs -- dropSuffix :: Eq a => [a] -> [a] -> [a] -- dropSuffix suf x = if isSuffixOf suf x then take (length x - length suf) x else x diff --git a/Language/Haskell/Modules/Internal.hs b/Language/Haskell/Modules/Internal.hs --- a/Language/Haskell/Modules/Internal.hs +++ b/Language/Haskell/Modules/Internal.hs @@ -1,38 +1,38 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings, PackageImports, ScopedTypeVariables, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, OverloadedStrings, PackageImports, + ScopedTypeVariables, StandaloneDeriving, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.Modules.Internal - ( runMonadClean + ( runCleanT , modifyParams - , parseFileWithComments - , parseFile - , modulePath , markForDelete , Params(..) + , CleanT , MonadClean(getParams, putParams) , ModuleResult(..) , doResult + , fixExport ) where -import Control.Applicative ((<$>)) import Control.Exception (SomeException, try) import "MonadCatchIO-mtl" Control.Monad.CatchIO as IO (catch, MonadCatchIO, throw) import Control.Monad.State (MonadState(get, put), StateT(runStateT)) import Control.Monad.Trans (liftIO, MonadIO) -import Data.Maybe (fromMaybe) -import Data.Set as Set (delete, empty, insert, Set, toList) -import qualified Language.Haskell.Exts.Annotated as A (Module, parseFileWithComments, parseFileWithMode) -import Language.Haskell.Exts.Comments (Comment) -import Language.Haskell.Exts.Extension (Extension) -import qualified Language.Haskell.Exts.Parser as Exts (defaultParseMode, ParseMode(extensions), ParseResult) -import Language.Haskell.Exts.SrcLoc (SrcSpanInfo) -import qualified Language.Haskell.Exts.Syntax as S (ModuleName) -import Language.Haskell.Modules.Common (modulePathBase) +import Data.Map as Map (empty, Map) +import Data.Monoid ((<>)) +import Data.Sequence as Seq (Seq, (|>)) +import Data.Set as Set (empty, insert, Set, toList) +import qualified Language.Haskell.Exts.Annotated as A (ExportSpec) +import Language.Haskell.Exts.Annotated.Simplify (sExportSpec) +import Language.Haskell.Exts.Pretty (prettyPrint) +import qualified Language.Haskell.Exts.Syntax as S (ExportSpec(..), ImportDecl, ModuleName(..)) +import Language.Haskell.Modules.ModuVerse (delName, ModuVerse(..), moduVerseInit, ModuVerseState, putModuleAnew, unloadModule) +import Language.Haskell.Modules.SourceDirs (PathKey(..), modulePath) import Language.Haskell.Modules.Util.DryIO (createDirectoryIfMissing, MonadDryRun(..), removeFileIfPresent, replaceFile, tildeBackup) -import Language.Haskell.Modules.Util.QIO (MonadVerbosity(..), qLnPutStr, qPutStr, quietly) +import Language.Haskell.Modules.Util.QIO (MonadVerbosity(..), qLnPutStr, quietly) import Language.Haskell.Modules.Util.Temp (withTempDirectory) import Prelude hiding (writeFile) -import System.Directory (doesFileExist, getCurrentDirectory, removeFile) -import System.FilePath ((), dropExtension, takeDirectory) +import System.Directory (removeFile) +import System.FilePath (dropExtension, takeDirectory) import System.IO.Error (isDoesNotExistError) -- | This contains the information required to run the state monad for @@ -46,17 +46,9 @@ -- be performed if this is ture. , verbosity :: Int -- ^ Increase or decrease the amount of progress reporting. - , extensions :: [Extension] - -- ^ Supply compiler extensions. These are provided to the module - -- parser and to GHC when it does the minimal import dumping. , hsFlags :: [String] -- ^ Extra flags to pass to GHC. - , sourceDirs :: [FilePath] - -- ^ Top level directories to search for source files and - -- imports. These directories would be the value used in the - -- hs-source-dirs parameter of a cabal file, and passed to ghc - -- via the -i option. - , moduVerse :: Maybe (Set S.ModuleName) + , moduVerse :: ModuVerseState -- ^ The set of modules that splitModules and catModules will -- check for imports of symbols that moved. , junk :: Set FilePath @@ -68,11 +60,22 @@ -- instances it contains, but usually it is not. Note that this -- option does not affect imports that started empty and end -- empty. + , extraImports :: Map S.ModuleName (Set S.ImportDecl) + -- ^ Deciding whether a module needs to be imported can be + -- difficult when instances are involved, this is a cheat to force + -- keys of the map to import the corresponding elements. , testMode :: Bool -- ^ For testing, do not run cleanImports on the results of the -- splitModule and catModules operations. } deriving (Eq, Ord, Show) +-- | An instance of MonadClean. +type CleanT m = StateT Params m + +instance MonadClean m => ModuVerse m where + getModuVerse = getParams >>= return . moduVerse + modifyModuVerse f = modifyParams (\ p -> p {moduVerse = f (moduVerse p)}) + class (MonadIO m, MonadCatchIO m, Functor m) => MonadClean m where getParams :: m Params putParams :: Params -> m () @@ -80,7 +83,7 @@ modifyParams :: MonadClean m => (Params -> Params) -> m () modifyParams f = getParams >>= putParams . f -instance (MonadCatchIO m, Functor m) => MonadClean (StateT Params m) where +instance (MonadCatchIO m, Functor m) => MonadClean (CleanT m) where getParams = get putParams = put @@ -95,68 +98,28 @@ -- | Create the environment required to do import cleaning and module -- splitting/merging. This environment, StateT Params m a, is an -- instance of MonadClean. -runMonadClean :: MonadCatchIO m => StateT Params m a -> m a -runMonadClean action = +runCleanT :: MonadCatchIO m => CleanT m a -> m a +runCleanT action = withTempDirectory "." "scratch" $ \ scratch -> do (result, params) <- runStateT action (Params {scratchDir = scratch, dryRun = False, verbosity = 1, hsFlags = [], - extensions = Exts.extensions Exts.defaultParseMode, - sourceDirs = ["."], - moduVerse = Nothing, - junk = empty, + moduVerse = moduVerseInit, + junk = Set.empty, removeEmptyImports = True, + extraImports = Map.empty, testMode = False}) mapM_ (\ x -> liftIO (try (removeFile x)) >>= \ (_ :: Either SomeException ()) -> return ()) (toList (junk params)) return result --- | Run 'A.parseFileWithComments' with the extensions stored in the state. -parseFileWithComments :: MonadClean m => FilePath -> m (Exts.ParseResult (A.Module SrcSpanInfo, [Comment])) -parseFileWithComments path = - do exts <- getParams >>= return . extensions - liftIO (A.parseFileWithComments (Exts.defaultParseMode {Exts.extensions = exts}) path) - --- | Run 'A.parseFileWithMode' with the extensions stored in the state. -parseFile :: MonadClean m => FilePath -> m (Exts.ParseResult (A.Module SrcSpanInfo)) -parseFile path = - do exts <- getParams >>= return . extensions - liftIO (A.parseFileWithMode (Exts.defaultParseMode {Exts.extensions = exts}) path) - --- | Search the path directory list for a source file that already exists. -findSourcePath :: MonadClean m => FilePath -> m FilePath -findSourcePath path = - findFile =<< (sourceDirs <$> getParams) - where - findFile (dir : dirs) = - do let x = dir path - exists <- liftIO $ doesFileExist x - if exists then return x else findFile dirs - findFile [] = - do -- Just building an error message here - here <- liftIO getCurrentDirectory - dirs <- sourceDirs <$> getParams - liftIO . throw . userError $ "findSourcePath failed, cwd=" ++ here ++ ", dirs=" ++ show dirs ++ ", path=" ++ path - --- | Search the path directory list, preferring an already existing file, but --- if there is none construct one using the first element of the directory list. -modulePath :: MonadClean m => S.ModuleName -> m FilePath -modulePath name = - findSourcePath (modulePathBase name) `IO.catch` (\ (_ :: IOError) -> makePath) - where - makePath = - do dirs <- sourceDirs <$> getParams - case dirs of - [] -> return (modulePathBase name) -- should this be an error? - (d : _) -> return $ d modulePathBase name - markForDelete :: MonadClean m => FilePath -> m () markForDelete x = modifyParams (\ p -> p {junk = insert x (junk p)}) data ModuleResult - = Unchanged S.ModuleName - | Removed S.ModuleName - | Modified S.ModuleName String + = Unchanged S.ModuleName PathKey + | Removed S.ModuleName PathKey + | Modified S.ModuleName PathKey String | Created S.ModuleName String deriving (Show, Eq, Ord) @@ -164,35 +127,49 @@ -- that needs to be done after all of these operations are completed -- so that all the compiles required for import cleaning succeed. On -- the other hand, we might be able to maintain the moduVerse here. -doResult :: MonadClean m => ModuleResult -> m ModuleResult -doResult x@(Unchanged _name) = - do quietly (qLnPutStr ("unchanged: " ++ show _name)) +doResult :: (ModuVerse m, MonadDryRun m, MonadVerbosity m) => ModuleResult -> m ModuleResult +doResult x@(Unchanged _name key) = + do quietly (qLnPutStr ("unchanged: " ++ show key)) return x -doResult x@(Removed name) = - do path <- modulePath name +doResult x@(Removed name key) = + do quietly (qLnPutStr ("removed: " ++ show key)) + let path = unPathKey key + unloadModule key -- I think this event handler is redundant. removeFileIfPresent path `IO.catch` (\ (e :: IOError) -> if isDoesNotExistError e then return () else throw e) - modifyModuVerse (Set.delete name) + delName name return x -doResult x@(Modified name text) = - do path <- modulePath name - qLnPutStr ("modifying " ++ show path) - (quietly . quietly . quietly . qPutStr $ " new text: " ++ show text) +doResult x@(Modified m@(S.ModuleName name) key text) = + do quietly (qLnPutStr ("modified: " ++ show key)) + path <- modulePath "hs" m + -- qLnPutStr ("modifying " ++ show path) + -- (quietly . quietly . quietly . qPutStr $ " new text: " ++ show text) replaceFile tildeBackup path text + putModuleAnew name return x -doResult x@(Created name text) = - do path <- modulePath name - qLnPutStr ("creating " ++ show path) - (quietly . quietly . quietly . qPutStr $ " containing " ++ show text) +doResult x@(Created m@(S.ModuleName name) text) = + do quietly (qLnPutStr ("created: " ++ name)) + path <- modulePath "hs" m + -- qLnPutStr ("creating " ++ show path) + -- (quietly . quietly . quietly . qPutStr $ " containing " ++ show text) createDirectoryIfMissing True (takeDirectory . dropExtension $ path) replaceFile tildeBackup path text - modifyModuVerse (Set.insert name) + putModuleAnew name return x --- | Modify the set of modules whose imports will be updated when --- modules are split or merged. No default, it is an error to run --- splitModules or catModules without first setting this. -modifyModuVerse :: MonadClean m => (Set S.ModuleName -> Set S.ModuleName) -> m () -modifyModuVerse f = modifyParams (\ p -> p {moduVerse = Just (f (fromMaybe empty (moduVerse p)))}) +-- | Update an export spec. The only thing we might need to change is +-- re-exports, of the form "module Foo". +fixExport :: [S.ModuleName] -> S.ModuleName -> S.ModuleName + -> A.ExportSpec l -> String -> String -> String -> Seq String -> Seq String +fixExport inNames outName thisName e pref s suff r = + case sExportSpec e of + S.EModuleContents name + -- when building the output module, omit re-exports of input modules + | thisName == outName && elem name inNames -> r + -- when building other modules, update re-exports of input + -- modules to be a re-export of the output module. + | elem name inNames -> r |> pref <> prettyPrint (S.EModuleContents outName) <> suff + -- Anything else is unchanged + _ -> r |> pref <> s <> suff diff --git a/Language/Haskell/Modules/Merge.hs b/Language/Haskell/Modules/Merge.hs --- a/Language/Haskell/Modules/Merge.hs +++ b/Language/Haskell/Modules/Merge.hs @@ -1,136 +1,124 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP, PackageImports, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Language.Haskell.Modules.Merge ( mergeModules ) where -import Control.Monad as List (mapM) -import Control.Monad.Trans (liftIO) +import Control.Monad as List (mapM, when) +import "MonadCatchIO-mtl" Control.Monad.CatchIO as IO (catch) import Data.Foldable (fold) import Data.Generics (Data, everywhere, mkT, Typeable) -import Data.List as List (intercalate, map) -import Data.Map as Map (fromList, insert, lookup, Map, member, toAscList) -import Data.Maybe (fromMaybe) +import Data.List as List (intercalate, map, find) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Monoid ((<>), mempty) -import Data.Sequence ((|>)) -import Data.Set as Set (difference, fromList, insert, Set, union) -import Data.Set.Extra as Set (mapM) -import Language.Haskell.Exts.Annotated.Simplify (sDecl, sExportSpec, sImportDecl, sModuleName) -import qualified Language.Haskell.Exts.Annotated.Syntax as A (ExportSpecList(ExportSpecList), ImportDecl(..), Module(Module), ModuleHead(ModuleHead)) -import Language.Haskell.Exts.Comments (Comment) -import Language.Haskell.Exts.Parser (fromParseResult) +import Data.Sequence as Seq ((<|), null, Seq, (|>)) +import Data.Set as Set (fromList, toList, union) +import Language.Haskell.Exts.Annotated.Simplify (sDecl, sImportDecl, sModuleName) +import qualified Language.Haskell.Exts.Annotated.Syntax as A (ImportDecl(ImportDecl), Module(Module), ModuleHead(ModuleHead)) import Language.Haskell.Exts.Pretty (prettyPrint) -import Language.Haskell.Exts.SrcLoc (SrcSpanInfo) -import qualified Language.Haskell.Exts.Syntax as S (ExportSpec(EModuleContents), ImportDecl(..), ModuleName(..)) -import Language.Haskell.Modules.Fold (echo, echo2, foldDecls, foldExports, foldHeader, foldImports, ignore, ignore2, ModuleInfo) -import Language.Haskell.Modules.Imports (cleanImports) -import Language.Haskell.Modules.Internal (doResult, modifyParams, modulePath, ModuleResult(Modified, Removed, Unchanged), MonadClean(getParams), Params(moduVerse, testMode), parseFileWithComments) +import Language.Haskell.Exts.SrcLoc (SrcInfo) +import qualified Language.Haskell.Exts.Syntax as S (ImportDecl(ImportDecl, importModule), ModuleName(..)) +import Language.Haskell.Modules.Fold (echo, echo2, foldDecls, foldExports, foldHeader, foldImports, ignore, ignore2) +import Language.Haskell.Modules.Imports (cleanResults) +import Language.Haskell.Modules.Internal (doResult, fixExport, ModuleResult(..), MonadClean) +import Language.Haskell.Modules.ModuVerse (getNames, ModuleInfo(..), parseModule, parseModuleMaybe, moduleName) +import Language.Haskell.Modules.SourceDirs (modulePathBase, pathKey, pathKeyMaybe) +import Language.Haskell.Modules.Util.QIO (qLnPutStr, quietly) -- | Merge the declarations from several modules into a single new -- one, updating the imports of the modules in the moduVerse to -- reflect the change. It *is* permissable to use one of the input -- modules as the output module. Note that circular imports can be -- created by this operation. -mergeModules :: MonadClean m => [S.ModuleName] -> S.ModuleName -> m (Set ModuleResult) -mergeModules inputs output = - do Just univ <- getParams >>= return . moduVerse - let univ' = union univ (Set.fromList (output : inputs)) - inputInfo <- loadModules inputs - result <- Set.mapM (doModule inputInfo inputs output) univ' >>= Set.mapM doResult - -- The inputs disappear and the output appears. If the output is one - -- of the inputs, it does not disappear. - modifyParams (\ p -> p {moduVerse = fmap (\ s -> Set.insert output (Set.difference s (Set.fromList inputs))) (moduVerse p)}) - Set.mapM clean result +mergeModules :: MonadClean m => [S.ModuleName] -> S.ModuleName -> m [ModuleResult] +mergeModules inNames outName = + do qLnPutStr ("mergeModules: [" ++ intercalate ", " (map prettyPrint inNames) ++ "] -> " ++ prettyPrint outName) + quietly $ + do univ <- getNames + let allNames = toList $ union univ (Set.fromList (outName : inNames)) + results <- List.mapM (doModule inNames outName) allNames >>= List.mapM doResult >>= List.mapM reportResult + cleanResults results where - clean x = - do flag <- getParams >>= return . not . testMode - case x of - (Modified name _) | flag -> modulePath name >>= cleanImports - _ -> return x + reportResult x@(Modified _ key _) = qLnPutStr ("mergeModules: modifying " ++ show key) >> return x + reportResult x@(Created name _) = qLnPutStr ("mergeModules: creating " ++ show name) >> return x + reportResult x@(Removed _ key) = qLnPutStr ("mergeModules: removing " ++ show key) >> return x + reportResult x = return x -- Process one of the modules in the moduVerse and return the result. -- The output module may not (yet) be an element of the moduVerse, in -- that case choose the first input modules to convert into the output -- module. -doModule :: MonadClean m => Map S.ModuleName (A.Module SrcSpanInfo, String, [Comment]) -> [S.ModuleName] -> S.ModuleName -> S.ModuleName -> m ModuleResult -doModule inputInfo inputs@(first : _) output name = - do -- The new module will be based on the existing module, unless - -- name equals output and output does not exist - let oldName = if name == output && not (Map.member name inputInfo) then first else name - (m, text, comments) <- maybe (loadModule oldName) return (Map.lookup name inputInfo) - return $ case () of - _ | name == output -> Modified name (doOutput inputInfo inputs output (m, text, comments)) - | elem name inputs -> Removed name - _ -> let text' = doOther inputs output (m, text, comments) in - if text /= text' then Modified name text' else Unchanged name -doModule _ [] _ _ = error "doModule: no inputs" - --- | Create the output module, the destination of the merge. -doOutput :: Map S.ModuleName ModuleInfo -> [S.ModuleName] -> S.ModuleName -> ModuleInfo -> String -doOutput inputInfo inNames outName m = - header ++ exports ++ imports ++ decls - where - header = fold (foldHeader echo2 echo (\ _ pref _ suff r -> r |> pref <> prettyPrint outName <> suff) echo m mempty) <> - fold (foldExports (\ s r -> r |> s <> maybe "" (intercalate ", " . List.map (prettyPrint)) (mergeExports inputInfo outName) <> "\n") ignore ignore2 m mempty) - exports = fromMaybe "" (foldExports ignore2 (\ _e pref _ _ r -> maybe (Just pref) Just r) ignore2 m Nothing) - imports = foldExports ignore2 ignore (\ s r -> r <> s {-where-}) m "" <> - -- Insert the new imports just after the first "pre" string of the imports - (fromMaybe "" (foldImports (\ _ pref _ _ r -> maybe (Just (pref <> unlines (List.map (moduleImports inputInfo) inNames))) Just r) m Nothing)) <> - (foldImports (\ _i pref s suff r -> r <> pref <> s <> suff) m "") - decls = fromMaybe "" (foldDecls (\ _d _ _ _ r -> Just (fromMaybe (unlines (List.map (moduleDecls inputInfo outName) inNames)) r)) (\ s r -> Just (maybe s (<> s) r)) m Nothing) - --- | Update a module that does not participate in the merge - this --- involves changing imports and exports of merged modules. --- (Shouldn't this also fix qualified symbols?) -doOther :: [S.ModuleName] -> S.ModuleName -> ModuleInfo -> String -doOther inputs output m = - fold (foldHeader echo2 echo echo echo m mempty) <> - fold (foldExports echo2 (\ x pref s suff r -> r |> pref <> fromMaybe s (fixModuleExport inputs output (sExportSpec x)) <> suff) echo2 m mempty) <> - fold (foldImports (\ x pref s suff r -> r |> pref <> fromMaybe s (fixModuleImport inputs output (sImportDecl x)) <> suff) m mempty) <> - fold (foldDecls echo echo2 m mempty) - -fixModuleExport :: [S.ModuleName] -> S.ModuleName -> S.ExportSpec -> Maybe String -fixModuleExport inputs output x = - case x of - S.EModuleContents y - | elem y inputs -> Just (prettyPrint (S.EModuleContents output)) - _ -> Nothing - -fixModuleImport :: [S.ModuleName] -> S.ModuleName -> S.ImportDecl -> Maybe String -fixModuleImport inputs output x = - case x of - S.ImportDecl {S.importModule = y} - | elem y inputs -> Just (prettyPrint (x {S.importModule = output})) - _ -> Nothing - -mergeExports :: Map S.ModuleName (A.Module SrcSpanInfo, String, [Comment]) -> S.ModuleName -> Maybe [S.ExportSpec] -mergeExports old new = - Just (concatMap mergeExports' (Map.toAscList old)) - where - mergeExports' (_, (A.Module _ Nothing _ _ _, _, _)) = error "mergeModules: no explicit export list" - mergeExports' (_, (A.Module _ (Just (A.ModuleHead _ _ _ Nothing)) _ _ _, _, _)) = error "mergeModules: no explicit export list" - mergeExports' (_, (A.Module _ (Just (A.ModuleHead _ _ _ (Just (A.ExportSpecList _ e)))) _ _ _, _, _)) = updateModuleContentsExports old new (List.map sExportSpec e) - mergeExports' (_, _) = error "mergeExports'" - -updateModuleContentsExports :: Map S.ModuleName (A.Module SrcSpanInfo, String, [Comment]) -> S.ModuleName -> [S.ExportSpec] -> [S.ExportSpec] -updateModuleContentsExports old new es = - foldl f [] es - where - f :: [S.ExportSpec] -> S.ExportSpec -> [S.ExportSpec] - f ys (S.EModuleContents m) = - let e' = S.EModuleContents (if Map.member m old then new else m) in - ys ++ if elem e' ys then [] else [e'] - f ys e = ys ++ [e] +doModule :: MonadClean m => + [S.ModuleName] -- The names of the merge input modules + -> S.ModuleName -- The name of the merge destination module + -> S.ModuleName -- The module we will work on + -> m ModuleResult +doModule inNames@(_ : _) outName thisName = + do -- The new module will be based on the first input module, + -- though its name will be changed to outModule. + inInfo@(firstInfo : _) <- + List.mapM (\ name -> pathKey (modulePathBase "hs" name) >>= parseModule) inNames + `IO.catch` (\ (_ :: IOError) -> error $ "mergeModules - failure reading input modules: " ++ show inNames) + outInfo <- pathKeyMaybe (modulePathBase "hs" outName) >>= parseModuleMaybe + thisInfo <- pathKeyMaybe (modulePathBase "hs" thisName) >>= parseModuleMaybe + let baseInfo@(ModuleInfo {module_ = A.Module _ _ _ _ _}) = fromMaybe firstInfo thisInfo + when (isJust outInfo && notElem outName inNames) (error "mergeModules - if output module exist it must also be one of the input modules") + case (thisName /= outName, List.find (\ x -> moduleName x == thisName) inInfo) of + (True, Just info) -> + return (Removed thisName (key_ info)) + _ -> + let header = + fold (foldHeader echo2 echo (if thisName == outName + then \ _ pref _ suff r -> r |> pref <> prettyPrint outName <> suff + else echo) + echo baseInfo mempty) + exports = + case baseInfo of + -- Is there an export list? + ModuleInfo {module_ = A.Module _ (Just (A.ModuleHead _ _ _ (Just _))) _ _ _} -> + let lparen = fold (foldExports (<|) ignore ignore2 baseInfo mempty) + newExports = + if thisName == outName + then -- This should be a reasonable string + -- to join two export lists. + let sep = map (\ c -> if c == '(' then ',' else c) lparen in + -- The output module gets modified + -- copies of all the input module + -- export lists. + intercalate sep $ filter (/= "") $ List.map (\ (_, info) -> fold (foldExports ignore2 (fixExport inNames outName thisName) ignore2 info mempty)) (zip inNames inInfo) + else fold (foldExports ignore2 (fixExport inNames outName thisName) ignore2 baseInfo mempty) + rparen = fold (foldExports ignore2 ignore (<|) baseInfo mempty) in + lparen <> newExports <> rparen + ModuleInfo {module_ = A.Module _ (Just (A.ModuleHead _ _ _ Nothing)) _ _ _} -> "where\n\n" + _ -> "" + imports = + if thisName == outName + then let pre = fold (foldImports (\ _ pref _ _ r -> if Seq.null r then r |> pref else r) baseInfo mempty) + newImports = unlines (List.map (\ info -> fold (foldImports (moduleImports inNames outName thisName) info mempty)) inInfo) in + pre <> newImports + else fold (foldImports (moduleImports inNames outName thisName) baseInfo mempty) + decls = + if thisName == outName + then fromMaybe "" (foldDecls (\ _ _ _ _ r -> Just (fromMaybe (unlines (List.map (moduleDecls inNames outName thisName) inInfo)) r)) (\ s r -> Just (maybe s (<> s) r)) baseInfo Nothing) + else moduleDecls inNames outName thisName baseInfo + text' = header <> exports <> imports <> decls in + return $ case thisInfo of + Just (ModuleInfo {text_ = text, key_ = key}) -> + if text' /= text then Modified thisName key text' else Unchanged thisName key + Nothing -> + Created thisName text' + -- return $ if text' /= text then Modified thisName (key_ thisInfo) text' else Unchanged thisName (key_ thisInfo) +doModule [] _ _ = error "doModule: no inputs" -moduleImports :: Map S.ModuleName ModuleInfo -> S.ModuleName -> String -moduleImports old name = - let (Just m) = Map.lookup name old in - foldImports (\ x pref s suff r -> - r - -- If this is the first import, omit the prefix, it includes the ") where" text. - <> (if r == "" then "" else pref) - <> if Map.member (sModuleName (A.importModule x)) old then "" else (s <> suff)) - m "" <> "\n" +moduleImports :: SrcInfo loc => + [S.ModuleName] -> S.ModuleName -> S.ModuleName + -> A.ImportDecl loc -> String -> String -> String -> Seq String -> Seq String +moduleImports inNames outName thisName x pref s suff r = + case sImportDecl x of + (S.ImportDecl {S.importModule = name}) + | notElem name inNames -> r |> pref <> s <> suff + | thisName == outName -> r + x' -> r |> pref <> prettyPrint (x' {S.importModule = outName}) <> suff -- | Grab the declarations out of the old modules, fix any -- qualified symbol references, prettyprint and return. @@ -142,42 +130,30 @@ -- In terms of what is going on right here, if m imports any of the -- modules in oldmap with an "as" qualifier, identifiers using the -- module name in the "as" qualifier must use new instead. -moduleDecls :: Map S.ModuleName ModuleInfo -> S.ModuleName -> S.ModuleName -> String -moduleDecls oldmap new name = - let (Just m@(A.Module _ _ _ imports _, _, _)) = Map.lookup name oldmap in - let oldmap' = foldr f oldmap imports in +moduleDecls :: [S.ModuleName] -> S.ModuleName -> S.ModuleName -> ModuleInfo -> String +moduleDecls inNames outName thisName info@(ModuleInfo (A.Module _ _ _ imports _) _ _ _) = + -- Get the import list for this module + let inNames' = inNames ++ if thisName == outName then mapMaybe qualifiedImportName imports else [] in fold (foldDecls (\ d pref s suff r -> let d' = sDecl d - d'' = fixReferences oldmap' new d' in + d'' = fixReferences inNames' outName d' in r |> pref <> (if d'' /= d' then prettyPrint d'' else s) <> suff) - echo2 m mempty) + echo2 info mempty) where - f (A.ImportDecl _ m _ _ _ (Just a) _specs) mp = - case Map.lookup (sModuleName m) oldmap of - Just x -> Map.insert (sModuleName a) x mp - _ -> mp - f _ mp = mp + -- Looking at an import, augment the map with the "as" name of a + -- qualified import. module and that module's info. + qualifiedImportName :: A.ImportDecl l -> Maybe S.ModuleName + qualifiedImportName (A.ImportDecl _ m _ _ _ (Just a) _specs) = + case elem (sModuleName m) inNames of + True -> Just (sModuleName a) + _ -> Nothing + qualifiedImportName _ = Nothing +moduleDecls _ _ _ (ModuleInfo m _ _ _) = error $ "Unsupported module type: " ++ show m --- | Change any ModuleName in 'old' to 'new'. Note that this will --- probably mess up the location information, so the result (if --- different from the original) should be prettyprinted, not --- exactPrinted. -fixReferences :: (Data a, Typeable a) => Map S.ModuleName ModuleInfo -> S.ModuleName -> a -> a -fixReferences oldmap new x = +-- | Change any ModuleName in 'old' to 'new'. +fixReferences :: (Data a, Typeable a) => [S.ModuleName] -> S.ModuleName -> a -> a +fixReferences oldNames new x = everywhere (mkT moveModuleName) x where moveModuleName :: S.ModuleName -> S.ModuleName - moveModuleName name@(S.ModuleName _) = if Map.member name oldmap then new else name - --- junk :: String -> Bool --- junk s = isSuffixOf ".imports" s || isSuffixOf "~" s - -loadModules :: MonadClean m => [S.ModuleName] -> m (Map S.ModuleName ModuleInfo) -loadModules names = List.mapM loadModule names >>= return . Map.fromList . zip names - -loadModule :: MonadClean m => S.ModuleName -> m ModuleInfo -loadModule name = - do path <- modulePath name - text <- liftIO $ readFile path - (m, comments) <- parseFileWithComments path >>= return . fromParseResult - return (m, text, comments) + moveModuleName name@(S.ModuleName _) = if elem name oldNames then new else name diff --git a/Language/Haskell/Modules/ModuVerse.hs b/Language/Haskell/Modules/ModuVerse.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/ModuVerse.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE CPP, FlexibleInstances, PackageImports, ScopedTypeVariables, StandaloneDeriving, UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module Language.Haskell.Modules.ModuVerse + ( ModuleInfo(..) + , moduleName + , ModuVerseState + , moduVerseInit + , ModuVerse(..) + , getNames + , getInfo + -- , putName + , putModule + , putModuleAnew + , findModule + , delName + , getExtensions + , modifyExtensions + -- , getSourceDirs + -- , modifySourceDirs + , parseModule + , parseModuleMaybe + , loadModule + , unloadModule + ) where + +import Control.Applicative ((<$>)) +import "MonadCatchIO-mtl" Control.Monad.CatchIO as IO (catch, MonadCatchIO, throw) +import Control.Monad.Trans (liftIO, MonadIO) +import Data.Map as Map (delete, empty, insert, keys, lookup, Map) +import Data.Maybe (fromMaybe) +import Data.Set as Set (fromList, Set) +import qualified Language.Haskell.Exts.Annotated as A (Module(..), ModuleHead(..), ModuleName(..), parseFileWithComments) +import Language.Haskell.Exts.Comments (Comment(..)) +import Language.Haskell.Exts.Extension (Extension) +import qualified Language.Haskell.Exts.Parser as Exts (defaultParseMode, fromParseResult, ParseMode(extensions, parseFilename), ParseResult) +import Language.Haskell.Exts.SrcLoc (SrcSpanInfo) +import Language.Haskell.Exts.Syntax as S (ModuleName(..)) +import Language.Haskell.Modules.SourceDirs (modulePathBase, pathKey, PathKey(..), pathKeyMaybe, SourceDirs(..)) +import Language.Haskell.Modules.Util.QIO (MonadVerbosity, qLnPutStr, quietly) +import System.IO.Error (isDoesNotExistError, isUserError) + +deriving instance Ord Comment + +data ModuleInfo + = ModuleInfo + { module_ :: A.Module SrcSpanInfo + , text_ :: String + , comments_ :: [Comment] + , key_ :: PathKey } + deriving (Eq, Ord, Show) + +{- +moduleName :: A.Module a -> S.ModuleName +moduleName (A.Module _ (Just (A.ModuleHead _ x _ _)) _ _ _) = sModuleName x +moduleName _ = S.ModuleName "Main" +-} + +moduleName :: ModuleInfo -> S.ModuleName +moduleName (ModuleInfo (A.Module _ mh _ _ _) _ _ _) = + S.ModuleName $ maybe "Main" (\ (A.ModuleHead _ (A.ModuleName _ s) _ _) -> s) mh +moduleName (ModuleInfo m _ _ _) = error $ "Unsupported Module: " ++ show m + +data ModuVerseState = + ModuVerseState { moduleNames_ :: Maybe (Map S.ModuleName ModuleInfo) + , moduleInfo_ :: Map PathKey ModuleInfo + , extensions_ :: [Extension] + , sourceDirs_ :: [FilePath] + -- ^ Top level directories to search for source files and + -- imports. These directories would be the value used in the + -- hs-source-dirs parameter of a cabal file, and passed to ghc + -- via the -i option. + } deriving (Eq, Ord, Show) + +moduVerseInit :: ModuVerseState +moduVerseInit = + ModuVerseState { moduleNames_ = Nothing + , moduleInfo_ = Map.empty + , extensions_ = Exts.extensions Exts.defaultParseMode + , sourceDirs_ = ["."] } + +getNames :: ModuVerse m => m (Set S.ModuleName) +getNames = getModuVerse >>= return . Set.fromList . keys . fromMaybe (error "No modules in ModuVerse, use putModule") . moduleNames_ + +getInfo :: ModuVerse m => S.ModuleName -> m (Maybe ModuleInfo) +getInfo name = getModuVerse >>= return . Map.lookup name . fromMaybe (error "No modules in ModuVerse, use putModule") . moduleNames_ + +putName :: ModuVerse m => S.ModuleName -> ModuleInfo -> m () +putName name info = modifyModuVerse (\ s -> s {moduleNames_ = Just (Map.insert name info (fromMaybe Map.empty (moduleNames_ s)))}) + +putModule :: (ModuVerse m, MonadVerbosity m) => String -> m () +putModule name = pathKey (modulePathBase "hs" (S.ModuleName name)) >>= parseModule >>= putName (S.ModuleName name) + +putModuleAnew :: (ModuVerse m, MonadVerbosity m) => String -> m () +putModuleAnew name = pathKey (modulePathBase "hs" (S.ModuleName name)) >>= loadModule >>= putName (S.ModuleName name) + +findModule :: (ModuVerse m, MonadVerbosity m) => String -> m (Maybe ModuleInfo) +findModule name = pathKeyMaybe (modulePathBase "hs" (S.ModuleName name)) >>= parseModuleMaybe + +delName :: ModuVerse m => S.ModuleName -> m () +delName name = modifyModuVerse (\ s -> s { moduleNames_ = Just (Map.delete name (fromMaybe Map.empty (moduleNames_ s))) + , moduleInfo_ = Map.empty }) + +class (MonadIO m, MonadCatchIO m, Functor m) => ModuVerse m where + getModuVerse :: m ModuVerseState + modifyModuVerse :: (ModuVerseState -> ModuVerseState) -> m () + +getExtensions :: ModuVerse m => m [Extension] +getExtensions = getModuVerse >>= return . extensions_ + +modifyExtensions :: ModuVerse m => ([Extension] -> [Extension]) -> m () +modifyExtensions f = modifyModuVerse (\ s -> s {extensions_ = f (extensions_ s)}) + +instance ModuVerse m => SourceDirs m where + putDirs xs = modifyModuVerse (\ s -> s {sourceDirs_ = xs}) + getDirs = getModuVerse >>= return . sourceDirs_ + +{- +getSourceDirs :: ModuVerse m => m [FilePath] +getSourceDirs = getModuVerse >>= return . sourceDirs_ + +-- | Modify the list of directories that will be searched for source +-- files, in a similar way to the Hs-Source-Dirs field in a cabal +-- file. Default is @[\".\"]@. +modifySourceDirs :: ModuVerse m => ([FilePath] -> [FilePath]) -> m () +modifySourceDirs f = modifyModuVerse (\ p -> p {sourceDirs_ = f (sourceDirs_ p)}) +-} + +parseModule :: (ModuVerse m, MonadVerbosity m) => PathKey -> m ModuleInfo +parseModule key = parseModuleMaybe (Just key) >>= maybe (error $ "parseModule - not found: " ++ show key) return + +parseModuleMaybe :: (ModuVerse m, MonadVerbosity m) => Maybe PathKey -> m (Maybe ModuleInfo) +parseModuleMaybe Nothing = return Nothing +parseModuleMaybe (Just key) = + (look >>= load) `IO.catch` (\ (e :: IOError) -> if isDoesNotExistError e || isUserError e then return Nothing else throw e) + where + look = + do verse <- getModuVerse + return $ Map.lookup key (moduleInfo_ verse) + load (Just x) = return (Just x) + load Nothing = Just <$> loadModule key + +-- | Force a possibly cached module to be reloaded. +loadModule :: (ModuVerse m, MonadVerbosity m) => PathKey -> m ModuleInfo +loadModule key = + do text <- liftIO $ readFile (unPathKey key) + quietly $ qLnPutStr ("parsing " ++ unPathKey key) + (parsed, comments) <- parseFileWithComments (unPathKey key) >>= return . Exts.fromParseResult + modifyModuVerse (\ x -> x {moduleInfo_ = Map.insert key (ModuleInfo parsed text comments key) (moduleInfo_ x)}) + return (ModuleInfo parsed text comments key) + +unloadModule :: (ModuVerse m, MonadVerbosity m) => PathKey -> m () +unloadModule key = + modifyModuVerse (\ x -> x {moduleInfo_ = Map.delete key (moduleInfo_ x)}) + +-- | Run 'A.parseFileWithComments' with the extensions stored in the state. +parseFileWithComments :: ModuVerse m => FilePath -> m (Exts.ParseResult (A.Module SrcSpanInfo, [Comment])) +parseFileWithComments path = + do exts <- getExtensions + liftIO (A.parseFileWithComments (Exts.defaultParseMode {Exts.extensions = exts, Exts.parseFilename = path}) path) diff --git a/Language/Haskell/Modules/Params.hs b/Language/Haskell/Modules/Params.hs --- a/Language/Haskell/Modules/Params.hs +++ b/Language/Haskell/Modules/Params.hs @@ -2,30 +2,15 @@ {-# LANGUAGE FlexibleInstances, OverloadedStrings, PackageImports, ScopedTypeVariables, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.Modules.Params - ( MonadClean - , runMonadClean - , modifyModuVerse - , modifyRemoveEmptyImports - , modifySourceDirs - , modifyExtensions + ( modifyRemoveEmptyImports , modifyHsFlags , modifyDryRun , modifyTestMode ) where -import Data.Maybe (fromMaybe) -import Data.Set (empty, Set) -import Language.Haskell.Exts.Extension (Extension) -import qualified Language.Haskell.Exts.Syntax as S (ModuleName) -import Language.Haskell.Modules.Internal (modifyParams, MonadClean, Params(dryRun, extensions, hsFlags, moduVerse, removeEmptyImports, sourceDirs, testMode), runMonadClean) +import Language.Haskell.Modules.Internal (modifyParams, MonadClean, Params(dryRun, hsFlags, removeEmptyImports, testMode)) import Prelude hiding (writeFile) --- | Modify the set of modules whose imports will be updated when --- modules are split or merged. No default, it is an error to run --- splitModules or catModules without first setting this. -modifyModuVerse :: MonadClean m => (Set S.ModuleName -> Set S.ModuleName) -> m () -modifyModuVerse f = modifyParams (\ p -> p {moduVerse = Just (f (fromMaybe empty (moduVerse p)))}) - -- | If this flag is set, imports that become empty are removed. -- Sometimes this will lead to errors, specifically when an instance -- in the removed import that was required is no longer be available. @@ -36,18 +21,6 @@ -- it was placed there only to import instances. Default is True. modifyRemoveEmptyImports :: MonadClean m => (Bool -> Bool) -> m () modifyRemoveEmptyImports f = modifyParams (\ p -> p {removeEmptyImports = f (removeEmptyImports p)}) - --- | Modify the list of directories that will be searched for source --- files, in a similar way to the Hs-Source-Dirs field in a cabal --- file. Default is @[\".\"]@. -modifySourceDirs :: MonadClean m => ([FilePath] -> [FilePath]) -> m () -modifySourceDirs f = modifyParams (\ p -> p {sourceDirs = f (sourceDirs p)}) - --- | Modify the extra extensions passed to the compiler and the --- parser. Default value is the list in --- 'Language.Haskell.Exts.Parser.defaultParseMode'. -modifyExtensions :: MonadClean m => ([Extension] -> [Extension]) -> m () -modifyExtensions f = modifyParams (\ p -> p {extensions = f (extensions p)}) -- | Modify the list of extra flags passed to GHC. Default is @[]@. modifyHsFlags :: MonadClean m => ([String] -> [String]) -> m () diff --git a/Language/Haskell/Modules/SourceDirs.hs b/Language/Haskell/Modules/SourceDirs.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/SourceDirs.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP, PackageImports, ScopedTypeVariables, StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module Language.Haskell.Modules.SourceDirs + ( SourceDirs(..) + , modifyDirs + , PathKey(..) + , pathKey + , pathKeyMaybe + , modulePath + , modulePathBase + ) where + +import "MonadCatchIO-mtl" Control.Monad.CatchIO as IO (catch, MonadCatchIO, throw) +import Control.Monad.Trans (liftIO, MonadIO) +import Language.Haskell.Exts.Syntax as S (ModuleName(..)) +import System.Directory (canonicalizePath, doesFileExist, getCurrentDirectory) +import System.FilePath ((<.>), ()) + +class MonadCatchIO m => SourceDirs m where + putDirs :: [FilePath] -> m () + getDirs :: m [FilePath] + +modifyDirs :: SourceDirs m => ([FilePath] -> [FilePath]) -> m () +modifyDirs f = getDirs >>= putDirs . f + +-- | A FilePath that can be assumed to be unique. +newtype PathKey = PathKey {unPathKey :: FilePath} deriving (Eq, Ord, Show) + +pathKey :: SourceDirs m => FilePath -> m PathKey +-- pathKey path = PathKey <$> liftIO (canonicalizePath path) +pathKey path = findFile path >>= liftIO . canonicalizePath >>= return . PathKey + +pathKeyMaybe :: SourceDirs m => FilePath -> m (Maybe PathKey) +pathKeyMaybe path = findFileMaybe path >>= maybe (return Nothing) (\ path' -> liftIO (canonicalizePath path') >>= return . Just . PathKey) + +-- | Search the path directory list, preferring an already existing file, but +-- if there is none construct one using the first element of the directory list. +modulePath :: SourceDirs m => String -> S.ModuleName -> m FilePath +modulePath ext name = + findFile path `IO.catch` (\ (_ :: IOError) -> makePath) + where + makePath = + do dirs <- getDirs + case dirs of + [] -> return path -- should this be an error? + (d : _) -> return $ d path + path = modulePathBase ext name + +-- | Construct the base of a module path. +modulePathBase :: String -> S.ModuleName -> FilePath +modulePathBase ext (S.ModuleName name) = + base <.> ext + where base = case ext of + "hs" -> map f name + "lhs" -> map f name + "imports" -> name + _ -> error $ "Unsupported extension: " ++ show ext + f '.' = '/' + f c = c + +-- | Search the path directory list for a source file that already exists. +-- FIXME: this should return a Maybe. +findFile :: SourceDirs m => FilePath -> m FilePath +findFile path = + findFileMaybe path >>= + maybe (do here <- liftIO getCurrentDirectory + dirs <- getDirs + liftIO . throw . userError $ "findFile failed, cwd=" ++ here ++ ", dirs=" ++ show dirs ++ ", path=" ++ path) + return + +findFileMaybe :: SourceDirs m => FilePath -> m (Maybe FilePath) +findFileMaybe path = + getDirs >>= f + where + f (dir : dirs) = + do let x = dir path + exists <- liftIO $ doesFileExist x + if exists then return (Just x) else f dirs + f [] = return Nothing diff --git a/Language/Haskell/Modules/Split.hs b/Language/Haskell/Modules/Split.hs --- a/Language/Haskell/Modules/Split.hs +++ b/Language/Haskell/Modules/Split.hs @@ -1,58 +1,38 @@ {-# LANGUAGE ScopedTypeVariables, TupleSections #-} -{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Language.Haskell.Modules.Split - ( DeclName(..) - , splitModule + ( splitModule , splitModuleDecls , defaultSymbolToModule ) where import Control.Exception (throw) -import Control.Monad (when) -import Control.Monad.Trans (liftIO) +import Control.Monad as List (mapM, mapM_) import Data.Char (isAlpha, isAlphaNum, toUpper) import Data.Default (Default(def)) import Data.Foldable as Foldable (fold) -import Data.List as List (filter, intercalate, map, nub) -import Data.Map as Map (delete, elems, empty, filter, insert, insertWith, lookup, Map, mapWithKey) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.List as List (filter, group, intercalate, map, nub, sort) +import Data.Map as Map (delete, elems, empty, filter, fromSet, insertWith, lookup, Map, mapWithKey) +import Data.Maybe (fromMaybe) import Data.Monoid ((<>), mempty) import Data.Sequence ((<|), (|>)) -import Data.Set as Set (delete, difference, empty, filter, fold, insert, intersection, map, member, null, Set, singleton, toList, union, unions) -import Data.Set.Extra as Set (gFind, mapM) -import Language.Haskell.Exts (fromParseResult, ParseResult(ParseOk, ParseFailed)) +import Data.Set as Set (empty, filter, fold, insert, intersection, map, member, null, Set, singleton, toList, union, unions) +import Data.Set.Extra as Set (gFind) import qualified Language.Haskell.Exts.Annotated as A (Decl, ImportDecl(..), ImportSpecList(..), Module(..), ModuleHead(ModuleHead), Name) -import Language.Haskell.Exts.Annotated.Simplify (sImportDecl, sImportSpec, sModuleName, sName) +import Language.Haskell.Exts.Annotated.Simplify (sExportSpec, sImportDecl, sImportSpec, sModule, sModuleName, sName) import Language.Haskell.Exts.Pretty (defaultMode, prettyPrint, prettyPrintWithMode) -import Language.Haskell.Exts.SrcLoc (SrcSpanInfo(..)) -import qualified Language.Haskell.Exts.Syntax as S (ExportSpec, ImportDecl(..), ModuleName(..), Name(..)) -import Language.Haskell.Modules.Fold (echo, echo2, foldDecls, foldExports, foldHeader, foldImports, foldModule, ignore, ignore2, ModuleInfo) -import Language.Haskell.Modules.Imports (cleanImports) -import Language.Haskell.Modules.Internal (doResult, modulePath, ModuleResult(..), MonadClean(getParams), Params(moduVerse, testMode), parseFileWithComments) +import Language.Haskell.Exts.SrcLoc (SrcLoc(..), SrcSpanInfo(..)) +import qualified Language.Haskell.Exts.Syntax as S (ExportSpec(..), ImportDecl(..), Module(..), ModuleName(..), Name(..)) +import Language.Haskell.Modules.Fold (echo, echo2, foldDecls, foldExports, foldHeader, foldImports, foldModule, ignore, ignore2) +import Language.Haskell.Modules.Imports (cleanResults) +import Language.Haskell.Modules.Internal (doResult, ModuleResult(..), MonadClean(getParams), Params(extraImports)) +import Language.Haskell.Modules.ModuVerse (getNames, ModuleInfo(..), moduleName, parseModule, findModule) +import Language.Haskell.Modules.SourceDirs (modulePathBase, pathKey) import Language.Haskell.Modules.Util.QIO (qLnPutStr, quietly) import Language.Haskell.Modules.Util.Symbols (exports, imports, symbols) import Prelude hiding (writeFile) import System.FilePath ((<.>)) -data DeclName - = Exported S.Name -- Maybe because...? - | Internal S.Name - | ReExported S.Name - | Instance - deriving (Eq, Ord, Show) - -isReExported :: DeclName -> Bool -isReExported (ReExported _) = True -isReExported _ = False - -parseModule :: MonadClean m => S.ModuleName -> m ModuleInfo -parseModule name = - do path <- modulePath name - text <- liftIO $ readFile path - (parsed, comments) <- parseFileWithComments path >>= return . fromParseResult - return (parsed, text, comments) - - -- | Split each of a module's declarations into a new module. Update -- the imports of all the modules in the moduVerse to reflect the split. -- For example, if you have a module like @@ -67,232 +47,302 @@ -- (.+.) = b + c -- @ -- --- After running @splitModule defaultSymbolToModule@ the @Start@ module will be gone. The --- @a@ and @b@ symbols will be in new modules named @Start.A@ and --- @Start.B@. Because they were not exported by @Start@, the @c@ and --- @c'@ symbols will both be in a new module named @Start.Internal.C@. --- And the @.+.@ symbol will be in a module named --- @Start.OtherSymbols@. Note that this module needs to import new --- @Start.A@ and @Start.Internal.C@ modules. +-- After running @splitModuleDecls "Start.hs"@ the @Start@ module will +-- be gone. The @a@ and @b@ symbols will be in new modules named +-- @Start.A@ and @Start.B@. Because they were not exported by +-- @Start@, the @c@ and @c'@ symbols will both be in a new module +-- named @Start.Internal.C@. And the @.+.@ symbol will be in a module +-- named @Start.OtherSymbols@. Note that this module needs to import +-- new @Start.A@ and @Start.Internal.C@ modules. -- -- If we had imported and then re-exported a symbol in Start it would -- go into a module named @Start.ReExported@. Any instance declarations -- would go into @Start.Instances@. splitModule :: MonadClean m => - (S.ModuleName -> DeclName -> S.ModuleName) -- ^ Map declaration to new module name - -> S.ModuleName - -> m () -splitModule symbolToModule old = parseModule old >>= splitModuleBy symbolToModule old + (Maybe S.Name -> S.ModuleName) + -- ^ Map declaration to new module name. The name @Nothing@ + -- is used for instance declarations. + -> FilePath + -> m [ModuleResult] +splitModule symToModule path = + do info <- pathKey path >>= parseModule + splitModuleBy symToModule info -- | Do splitModuleBy with the default symbol to module mapping (was splitModule) -splitModuleDecls :: MonadClean m => S.ModuleName -> m () -splitModuleDecls old = parseModule old >>= \ m -> splitModuleBy defaultSymbolToModule old m +splitModuleDecls :: MonadClean m => FilePath -> m [ModuleResult] +splitModuleDecls path = + do info <- pathKey path >>= parseModule + splitModuleBy (defaultSymbolToModule info) info -splitModuleBy :: MonadClean m => - (S.ModuleName -> DeclName -> S.ModuleName) - -> S.ModuleName -- ^ Parent module name - -> ModuleInfo -> m () -splitModuleBy symbolToModule old m = - do univ <- moduVerseCheck - changes <- doSplit (symbolToModule old) univ m >>= return . collisionCheck univ - setMapM_ doResult changes -- Write the new modules - setMapM_ doClean changes -- Clean the new modules after all edits are finished +splitModuleBy :: MonadClean m => (Maybe S.Name -> S.ModuleName) -> ModuleInfo -> m [ModuleResult] +splitModuleBy _ (ModuleInfo (A.XmlPage {}) _ _ _) = error "XmlPage" +splitModuleBy _ (ModuleInfo (A.XmlHybrid {}) _ _ _) = error "XmlPage" +splitModuleBy _ m@(ModuleInfo (A.Module _ _ _ _ []) _ _ key) = return [Unchanged (moduleName m) key] -- No declarations - nothing to split +splitModuleBy _ m@(ModuleInfo (A.Module _ _ _ _ [_]) _ _ key) = return [Unchanged (moduleName m) key] -- One declaration - nothing to split (but maybe we should anyway?) +splitModuleBy _ (ModuleInfo (A.Module _ Nothing _ _ _) _ _ _) = throw $ userError $ "splitModule: no explicit header" +splitModuleBy symToModule inInfo = + do qLnPutStr ("Splitting " ++ prettyPrint (moduleName inInfo)) + quietly $ + do eiMap <- getParams >>= return . extraImports + -- The name of the module to be split + let inName = moduleName inInfo + allNames <- getNames >>= return . Set.union outNames + changes <- List.mapM (doModule symToModule eiMap inInfo inName outNames) (toList allNames) + -- No good reason to use sets here + -- changes <- doSplit symToModule info >>= return . collisionCheck univ + List.mapM_ doResult changes -- Write the new modules + List.mapM_ reportResult changes + -- Clean the new modules after all edits are finished + cleanResults changes where - moduVerseCheck = getParams >>= return . fromMaybe (error "moduVerse not set, use modifyModuVerse") . moduVerse - collisionCheck univ s = - if not (Set.null illegal) + +{- collisionCheck univ s = + if (not $ Set.null $ Set.intersection univ $ Set.filter isCreated s) then error ("One or more module to be created by splitModule already exists: " ++ show (Set.toList illegal)) - else s - where - illegal = Set.intersection univ (created s) - created :: Set ModuleResult -> Set S.ModuleName - created = setMapMaybe (\ x -> case x of Created m' _ -> Just m'; _ -> Nothing) - -- Make sure this isn't trying to clobber a module that exists (other than 'old'.) - doClean :: MonadClean m => ModuleResult -> m () - doClean (Created m' _) = doClean' m' - doClean (Modified m' _) = doClean' m' - doClean (Removed _) = return () - doClean (Unchanged _) = return () - doClean' m' = - do flag <- getParams >>= return . not . testMode - when flag (modulePath m' >>= cleanImports >> return ()) + else s -} --- This returns a set of maybe because there may be instance --- declarations, in which case we want an Instances module to --- appear in newModuleNames below. -declared :: ModuleInfo -> Set (Maybe S.Name) -declared m = foldDecls (\ d _pref _s _suff r -> Set.union (symbols d) r) ignore2 m Set.empty + reportResult x@(Modified (S.ModuleName _) key _) = qLnPutStr ("splitModule: modifying " ++ show key) >> return x + reportResult x@(Created (S.ModuleName name) _) = qLnPutStr ("splitModule: creating " ++ name) >> return x + reportResult x@(Removed (S.ModuleName _) key) = qLnPutStr ("splitModule: removing " ++ show key) >> return x + reportResult x = return x -exported :: ModuleInfo -> Set (Maybe S.Name) -exported m = - case hasExportList m of - False -> declared m - True -> union (foldExports ignore2 (\ e _pref _s _suff r -> Set.union (symbols e) r) ignore2 m Set.empty) - -- Any instances declared are exported regardless of the export list - (if member Nothing (declared m) then singleton Nothing else Set.empty) + outNames = Set.map symToModule (union (declared inInfo) (exported inInfo)) + +doModule :: MonadClean m => + (Maybe S.Name -> S.ModuleName) + -> Map S.ModuleName (Set S.ImportDecl) + -> ModuleInfo -> S.ModuleName + -> Set S.ModuleName -> S.ModuleName -> m ModuleResult +doModule symToModule eiMap inInfo inName outNames thisName@(S.ModuleName s) = + case () of + _ | member thisName outNames -> + findModule s >>= \ thisInfo -> + return $ if thisName == inName + then Modified thisName (key_ inInfo) newModule + else case thisInfo of + Just (ModuleInfo {key_ = key}) -> + error $ "splitModule: output module already exists: " ++ show key + _ -> Created thisName newModule + | thisName == inName -> return (Removed thisName (key_ inInfo)) + | True -> + pathKey (modulePathBase "hs" thisName) >>= parseModule >>= \ oldInfo@(ModuleInfo _ oldText _ _) -> + let newText = updateImports oldInfo in + return $ if newText /= oldText then Modified thisName (key_ oldInfo) newText else Unchanged thisName (key_ oldInfo) where - hasExportList :: ModuleInfo -> Bool - hasExportList (A.Module _ Nothing _ _ _, _, _) = False - hasExportList (A.Module _ (Just (A.ModuleHead _ _ _ Nothing)) _ _ _, _, _) = False - hasExportList _ = True + -- Build a new module given its name and the list of + -- declarations it should contain. + newModule :: String + newModule = newHeader <> newExports <> newImports <> newDecls -newModuleNames :: (DeclName -> S.ModuleName) -> ModuleInfo -> Set S.ModuleName -newModuleNames symbolToModule m = - Set.map (symbolToModule . declName' m) (union (declared m) (exported m)) + -- Change the module name in the header + newHeader = + Foldable.fold (foldHeader echo2 echo (\ _n pref _ suff r -> r |> pref <> prettyPrint thisName <> suff) echo inInfo mempty) -declName' :: ModuleInfo -> Maybe S.Name -> DeclName -declName' m = - declName - where - declName :: Maybe S.Name -> DeclName - declName name = - case name of - Nothing -> Instance - Just name' -> - if reExported name' - then ReExported name' - else if internal name' - then Internal name' - else Exported name' - internal :: S.Name -> Bool - internal name = member (Just name) (difference (declared m) (exported m)) - reExported :: S.Name -> Bool - reExported name = member (Just name) (difference (exported m) (declared m)) + newExports = + -- If the module has an export list use its outline + maybe "\n ( " (\ _ -> Foldable.fold $ foldExports (<|) ignore ignore2 inInfo mempty) (moduleExports inInfo) <> --- | Create the set of module results implied by the split - --- creations, removals, and modifications. This includes the changes --- to the imports in modules that imported the original module. -doSplit :: MonadClean m => (DeclName -> S.ModuleName) -> Set S.ModuleName -> ModuleInfo -> m (Set ModuleResult) -doSplit _ _ (A.XmlPage {}, _, _) = error "XmlPage" -doSplit _ _ (A.XmlHybrid {}, _, _) = error "XmlPage" -doSplit _ _ (A.Module _ _ _ _ [], _, _) = return Set.empty -- No declarations - nothing to split -doSplit _ _ (A.Module _ _ _ _ [_], _, _) = return Set.empty -- One declaration - nothing to split (but maybe we should anyway?) -doSplit _ _ (A.Module _ Nothing _ _ _, _, _) = throw $ userError $ "splitModule: no explicit header" -doSplit symbolToModule univ m@(A.Module _ (Just (A.ModuleHead _ moduleName _ _)) _ _ _, _, _) = - do qLnPutStr ("Splitting " ++ show moduleName) - importChanges <- Set.mapM (updateImports m (sModuleName moduleName) symbolToModule) (Set.delete old univ) - return $ unions [ -- The changes required to existing imports - importChanges - -- Compute the result of splitting the parent module - , Set.map newModule moduleNames - -- Did the parent module disappear, or was it replaced? - , if member old moduleNames then Set.empty else singleton (Removed old) ] - where - moduleNames = newModuleNames symbolToModule m - -- The name of the module to be split - old = sModuleName moduleName + case Map.lookup thisName moduleDeclMap of + Nothing -> + doSeps (Foldable.fold (foldExports ignore2 + (\ e pref s suff r -> + if setAny isReExported (Set.map (declClass inInfo) (symbols e)) + then r |> [(pref, s <> suff)] + else r) + (\ s r -> r |> [("", s)]) inInfo mempty)) + Just _ -> + intercalate sep (nub (List.map (prettyPrintWithMode defaultMode) newExports')) <> "\n" <> + maybe " ) where\n" (\ _ -> Foldable.fold $ foldExports ignore2 ignore (<|) inInfo mempty) (moduleExports inInfo) + where + -- Build export specs of the symbols created by each declaration. + newExports' :: [S.ExportSpec] + newExports' = nub (concatMap (exports . fst) modDecls) + -- Re-construct a separated list + doSeps :: [(String, String)] -> String + doSeps [] = "" + doSeps ((_, hd) : tl) = hd <> concatMap (\ (a, b) -> a <> b) tl + + sep = exportSep "\n , " inInfo + + newImports = + case (oldImportText, newImports'') of + ([], "") -> "\n" + ([], s) -> s + ((pref, s, suff) : more, i) -> pref <> i <> s <> suff ++ concatMap (\ (pref', s', suff') -> pref' <> s' <> suff') more + where + oldImportText = foldImports (\ _ pref s suff r -> r ++ [(pref, s, suff)]) inInfo [] + newImports'' = + case Map.lookup thisName moduleDeclMap of + Nothing -> "" + Just _ -> unlines (List.map (prettyPrintWithMode defaultMode) (newImports' ++ instanceImports thisName eiMap)) + -- Import all the referenced symbols that are declared in + -- the original module and referenced in the new module. + newImports' :: [S.ImportDecl] + newImports' = + elems $ + mapWithKey toImportDecl $ + Map.delete thisName $ + Map.filter imported moduleDeclMap + where + imported pairs = + let declared' = justs (Set.unions (List.map (symbols . fst) pairs)) in + not (Set.null (Set.intersection declared' referenced)) + + newDecls = concatMap snd modDecls + + modDecls :: [(A.Decl SrcSpanInfo, String)] + modDecls = fromMaybe [] (Map.lookup thisName moduleDeclMap) + + moduleExports (ModuleInfo (A.Module _ Nothing _ _ _) _ _ _) = Nothing + moduleExports (ModuleInfo (A.Module _ (Just (A.ModuleHead _ _ _ x)) _ _ _) _ _ _) = x + moduleExports (ModuleInfo _ _ _ _) = error "Unsupported module type" + + -- Update the imports to reflect the changed module names in symToModule. + -- Update re-exports of the split module. + updateImports :: ModuleInfo -> String + updateImports oldInfo = + Foldable.fold (foldModule echo2 echo echo echo echo2 + (\ e pref s suff r -> r |> pref <> fixExport s (sExportSpec e) <> suff) echo2 + (\ i pref s suff r -> r |> pref <> updateImportDecl s i <> suff) + echo echo2 oldInfo mempty) + where + -- If we see the input module re-exported, replace with all the output modules + fixExport :: String -> S.ExportSpec -> String + fixExport _ (S.EModuleContents m) | m == inName = intercalate sep (List.map (prettyPrint . S.EModuleContents) (toList outNames)) + fixExport s _ = s + + sep = exportSep "\n , " oldInfo + + -- In this module, we need to import any module that declares a symbol + -- referenced here. + referenced :: Set S.Name + referenced = Set.map sName (gFind modDecls :: Set (A.Name SrcSpanInfo)) + -- Build a map from module name to the list of declarations that -- will be in that module. All of these declarations used to be -- in moduleName. moduleDeclMap :: Map S.ModuleName [(A.Decl SrcSpanInfo, String)] - moduleDeclMap = foldDecls (\ d pref s suff r -> Set.fold (\ sym mp -> insertWith (++) (symbolToModule (declName' m sym)) [(d, pref <> s <> suff)] mp) r (symbols d)) ignore2 m Map.empty - - -- Build a new module given its name and the list of - -- declarations it should contain. - newModule :: S.ModuleName -> ModuleResult - newModule name'@(S.ModuleName modName) = - (if member name' univ then Modified else Created) name' $ - case Map.lookup name' moduleDeclMap of - Nothing -> - -- Build a module that re-exports a symbol - Foldable.fold (foldHeader echo2 echo (\ _n pref _ suff r -> r |> pref <> modName <> suff) echo m mempty) <> - Foldable.fold (foldExports echo2 ignore ignore2 m mempty) <> - doSeps (Foldable.fold (foldExports ignore2 - (\ e pref s suff r -> if setAny isReExported (Set.map (declName' m) (symbols e)) then r |> [(pref, s <> suff)] else r) - (\ s r -> r |> [("", s)]) m mempty)) <> - Foldable.fold (foldImports (\ _i pref s suff r -> r |> pref <> s <> suff) m mempty) - Just modDecls -> - -- Change the module name in the header - Foldable.fold (foldHeader echo2 echo (\ _n pref _ suff r -> r |> pref <> modName <> suff) echo m mempty) <> - -- If the module has an export list use its outline - (let mh = let (A.Module _ x _ _ _, _, _) = m in x - me = maybe Nothing (\ h -> let (A.ModuleHead _ _ _ x) = h in x) mh in - maybe "\n ( " (\ _ -> Foldable.fold $ foldExports (<|) ignore ignore2 m mempty) me <> - intercalate "\n , " (nub (List.map (prettyPrintWithMode defaultMode) (newExports modDecls))) <> "\n" <> - maybe " ) where\n" (\ _ -> Foldable.fold $ foldExports ignore2 ignore (<|) m mempty) me) <> - -- The prefix of the imports section - fromMaybe "" (foldImports (\ _i pref _ _ r -> maybe (Just pref) Just r) m Nothing) <> - unlines (List.map (prettyPrintWithMode defaultMode) (elems (newImports modDecls))) <> "\n" <> - -- Grab the old imports - fromMaybe "" (foldImports (\ _i pref s suff r -> Just (maybe (s <> suff) (\ l -> l <> pref <> s <> suff) r)) m Nothing) <> - -- fromMaybe "" (foldDecls (\ _d pref _ _ r -> maybe (Just pref) Just r) ignore2 m text Nothing) <> - concatMap snd (reverse modDecls) - where - -- Build export specs of the symbols created by each declaration. - newExports :: [(A.Decl SrcSpanInfo, String)] -> [S.ExportSpec] - newExports xs = nub (concatMap (exports . fst) xs) - - newImports :: [(A.Decl SrcSpanInfo, String)] -> Map S.ModuleName S.ImportDecl - newImports xs = - mapWithKey toImportDecl (Map.delete name' - (Map.filter (\ pairs -> - let declared' = justs (Set.unions (List.map (symbols . fst) pairs)) in - not (Set.null (Set.intersection declared' (referenced xs)))) moduleDeclMap)) - -- In this module, we need to import any module that declares a symbol - -- referenced here. - referenced :: [(A.Decl SrcSpanInfo, String)] -> Set S.Name - referenced xs = Set.map sName (gFind xs :: Set (A.Name SrcSpanInfo)) - --- Re-construct a separated list -doSeps :: [(String, String)] -> String -doSeps [] = "" -doSeps ((_, hd) : tl) = hd <> concatMap (\ (a, b) -> a <> b) tl + moduleDeclMap = foldDecls (\ d pref s suff r -> Set.fold (\ sym mp -> insertWith (\ a b -> b ++ a) (symToModule sym) [(d, pref <> s <> suff)] mp) r (symbols d)) ignore2 inInfo Map.empty --- | Update the imports to reflect the changed module names in symbolToModule. -updateImports :: MonadClean m => ModuleInfo -> S.ModuleName -> (DeclName -> S.ModuleName) -> S.ModuleName -> m ModuleResult -updateImports m old symbolToModule name = - do path <- modulePath name - quietly $ qLnPutStr $ "updateImports " ++ show name - text' <- liftIO $ readFile path - parsed <- parseFileWithComments path - case parsed of - ParseOk (m', comments') -> - let text'' = Foldable.fold (foldModule echo2 echo echo echo echo2 echo echo2 - (\ i pref s suff r -> r |> pref <> updateImportDecl s i <> suff) - echo echo2 (m', text', comments') mempty) in - return $ if text' /= text'' then Modified name text'' else Unchanged name - ParseFailed _ _ -> error $ "Parse error in " ++ show name - where updateImportDecl :: String -> A.ImportDecl SrcSpanInfo -> String updateImportDecl s i = - if sModuleName (A.importModule i) == old - then intercalate "\n" (List.map prettyPrint (updateImportSpecs i (A.importSpecs i))) + if sModuleName (A.importModule i) == inName + then intercalate "\n" (List.map prettyPrint (updateImportSpecs i (A.importSpecs i) ++ instanceImports thisName eiMap)) else s updateImportSpecs :: A.ImportDecl SrcSpanInfo -> Maybe (A.ImportSpecList SrcSpanInfo) -> [S.ImportDecl] -- No spec list, import all the split modules - updateImportSpecs i Nothing = List.map (\ x -> (sImportDecl i) {S.importModule = x}) (Map.elems moduleMap) + updateImportSpecs i Nothing = List.map (\ x -> (sImportDecl i) {S.importModule = x}) (Set.toList moduleNames) -- (Map.elems moduleMap) -- If flag is True this is a "hiding" import updateImportSpecs i (Just (A.ImportSpecList _ flag specs)) = - concatMap (\ spec -> let xs = mapMaybe (\ sym -> Map.lookup (declName' m sym) moduleMap) (toList (symbols spec)) in + concatMap (\ spec -> let xs = List.map symToModule (toList (symbols spec)) in List.map (\ x -> (sImportDecl i) {S.importModule = x, S.importSpecs = Just (flag, [sImportSpec spec])}) xs) specs - moduleMap = symbolToModuleMap symbolToModule m + moduleNames :: Set S.ModuleName + moduleNames = + s + where + s = foldExports ignore2 (\ e _ _ _ r -> Set.fold (Set.insert . symToModule) r (symbols e)) ignore2 inInfo s' + s' = foldDecls (\ d _ _ _ r -> Set.fold (Set.insert . symToModule) r (symbols d)) ignore2 inInfo Set.empty -symbolToModuleMap :: (DeclName -> S.ModuleName) -> ModuleInfo -> Map DeclName S.ModuleName -symbolToModuleMap symbolToModule m = - mp' +-- | Combine the suffix of each export with the prefix of the following +-- export to make a list of all the separators. Discards the first +-- prefix and the last suffix, if all the remaining separators are +-- equal return it, otherwise return the default argument. +exportSep :: String -> ModuleInfo -> String +exportSep defsep info = + case seps of + [] -> defsep + (_ : xs) -> case (group . sort) xs of + [[x]] -> x -- We could choose the most common one here + _ -> defsep where - mp' = foldExports ignore2 (\ e _ _ _ r -> Set.fold f r (symbols e)) ignore2 m mp - mp = foldDecls (\ d _ _ _ r -> Set.fold f r (symbols d)) ignore2 m Map.empty - f sym mp'' = - Map.insert - (declName' m sym) - (symbolToModule (declName' m sym)) - mp'' + seps = foldModule ignore2 ignore ignore ignore ignore2 + (\ _ pref _ suff r -> case r of + [] -> [suff] + (suff' : xs) -> suff : (pref ++ suff') : xs) + ignore2 ignore ignore ignore2 info [] --- | What module should this symbol be moved to? -defaultSymbolToModule :: S.ModuleName -- ^ Parent module name - -> DeclName -- ^ Declared symbol +-- | Return a list of the names declared in this module, Nothing +-- denotes one or more instances. +declared :: ModuleInfo -> Set (Maybe S.Name) +declared m = foldDecls (\ d _pref _s _suff r -> Set.union (symbols d) r) ignore2 m Set.empty + +-- | Return a list of the names expored by this module, Nothing +-- denotes instances. +exported :: ModuleInfo -> Set (Maybe S.Name) +exported m = + case hasExportList m of + False -> declared m + True -> union (foldExports ignore2 (\ e _pref _s _suff r -> Set.union (symbols e) r) ignore2 m Set.empty) + -- Any instances declared are exported regardless of the export list + (if member Nothing (declared m) then singleton Nothing else Set.empty) + where + hasExportList :: ModuleInfo -> Bool + hasExportList (ModuleInfo (A.Module _ Nothing _ _ _) _ _ _) = False + hasExportList (ModuleInfo (A.Module _ (Just (A.ModuleHead _ _ _ Nothing)) _ _ _) _ _ _) = False + hasExportList _ = True + +instanceImports :: S.ModuleName -> Map S.ModuleName (Set S.ImportDecl) -> [S.ImportDecl] +instanceImports name eiMap = maybe [] toList (Map.lookup name eiMap) + +data DeclClass + = Exported S.Name + | Internal S.Name + | ReExported S.Name + | Instance + | Unknown S.Name + deriving (Eq, Ord, Show) + +-- | Classify the symbols in a module. +declClass :: ModuleInfo -> Maybe S.Name -> DeclClass +declClass info@(ModuleInfo m _ _ _) mName = + unknown mName $ Map.lookup mName mp + where + unknown :: Maybe S.Name -> Maybe DeclClass -> DeclClass + unknown _ (Just x) = x + unknown Nothing _ = error "declClass Nothing" + unknown (Just x) _ = Unknown x + mp = Map.fromSet declClass' (union declaredSymbols exportedSymbols) + declClass' Nothing = Instance + declClass' x@(Just name) = + if member x exportedSymbols + then if member x declaredSymbols + then Exported name + else ReExported name -- Exported but not declared - must come from an import + else Internal name -- Not exported + declaredSymbols = foldDecls (\ d _pref _s _suff r -> Set.union (symbols d) r) ignore2 info Set.empty + exportedSymbols = + case hasExportList (sModule m) of + False -> declaredSymbols + True -> union (foldExports ignore2 (\ e _pref _s _suff r -> Set.union (symbols e) r) ignore2 info Set.empty) + -- Any instances declared are exported regardless of the export list + (if member Nothing declaredSymbols then singleton Nothing else Set.empty) + where + hasExportList :: S.Module -> Bool + hasExportList (S.Module _ _ _ _ Nothing _ _) = False + hasExportList _ = True + +isReExported :: DeclClass -> Bool +isReExported (ReExported _) = True +isReExported _ = False + +-- | This can be used to build function parameter of splitModule, it +-- determines which module should a symbol be moved to. +defaultSymbolToModule :: ModuleInfo -- ^ Parent module name + -> Maybe S.Name -> S.ModuleName -defaultSymbolToModule (S.ModuleName parentModuleName) name = - S.ModuleName (parentModuleName <.> case name of - Instance -> "Instances" - ReExported _ -> "ReExported" - Internal x -> "Internal" <.> f x - Exported x -> f x) +defaultSymbolToModule info name = + S.ModuleName (parentModuleName <.> + case declClass info name of + Instance -> "Instances" + ReExported _ -> "ReExported" + Internal x -> "Internal" <.> f x + Unknown x -> "Unknown" <.> f x + Exported x -> f x) where + S.ModuleName parentModuleName = moduleName info f (S.Symbol s) = g s f (S.Ident s) = g s -- Any symbol that starts with a letter is converted to a module name @@ -300,16 +350,21 @@ g (c : s) | isAlpha c = toUpper c : List.filter isAlphaNum s g _ = "OtherSymbols" +-- Default is "import Main ()" +instance Default S.ImportDecl where + def = S.ImportDecl {S.importLoc = SrcLoc ".hs" 1 1, + S.importModule = S.ModuleName "Main", + S.importQualified = False, + S.importSrc = False, + S.importPkg = Nothing, + S.importAs = Nothing, + S.importSpecs = Just (False, [])} + -- | Build an import of the symbols created by a declaration. toImportDecl :: S.ModuleName -> [(A.Decl SrcSpanInfo, String)] -> S.ImportDecl toImportDecl (S.ModuleName modName) decls = - S.ImportDecl {S.importLoc = def, - S.importModule = S.ModuleName modName, - S.importQualified = False, - S.importSrc = False, - S.importPkg = Nothing, - S.importAs = Nothing, - S.importSpecs = Just (False, nub (concatMap (imports . fst) decls))} + def { S.importModule = S.ModuleName modName + , S.importSpecs = Just (False, nub (concatMap (imports . fst) decls)) } justs :: Ord a => Set (Maybe a) -> Set a justs = Set.fold (\ mx s -> maybe s (`Set.insert` s) mx) Set.empty @@ -317,10 +372,6 @@ setAny :: Ord a => (a -> Bool) -> Set a -> Bool setAny f s = not (Set.null (Set.filter f s)) -setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b -setMapMaybe p s = Set.fold f Set.empty s - where f x s' = maybe s' (\ y -> Set.insert y s') (p x) - -setMapM_ :: (Monad m, Ord b) => (a -> m b) -> Set a -> m () -setMapM_ f s = do _ <- Set.mapM f s - return () +-- setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b +-- setMapMaybe p s = Set.fold f Set.empty s +-- where f x s' = maybe s' (\ y -> Set.insert y s') (p x) diff --git a/Language/Haskell/Modules/Util/SrcLoc.hs b/Language/Haskell/Modules/Util/SrcLoc.hs --- a/Language/Haskell/Modules/Util/SrcLoc.hs +++ b/Language/Haskell/Modules/Util/SrcLoc.hs @@ -10,18 +10,15 @@ , textSpan , srcPairText , makeTree - , tests ) where import Control.Monad.State (get, put, runState, State) -import Data.Default (def, Default) import Data.List (groupBy, partition, sort) import Data.Set (Set, toList) import Data.Tree (Tree(Node), unfoldTree) import qualified Language.Haskell.Exts.Annotated.Syntax as A (Decl(..), ExportSpec(..), ExportSpecList(..), ImportDecl(ImportDecl), ModuleHead(..), ModuleName(..), ModulePragma(..), WarningText(..)) import Language.Haskell.Exts.SrcLoc (SrcLoc(..), SrcSpan(..), SrcSpanInfo(..)) import Prelude hiding (rem) -import Test.HUnit (assertEqual, Test(TestCase, TestList)) -- | A version of lines that preserves the presence or absence of a -- terminating newline @@ -153,9 +150,9 @@ endLoc :: HasSpanInfo x => x -> SrcLoc endLoc x = let (SrcSpan f _ _ b e) = srcSpan x in SrcLoc f b e -textEndLoc :: String -> SrcLoc -textEndLoc text = - def {srcLine = length ls, srcColumn = length (last ls) + 1} +textEndLoc :: FilePath -> String -> SrcLoc +textEndLoc path text = + SrcLoc {srcFilename = path, srcLine = length ls, srcColumn = length (last ls) + 1} where ls = lines' text -- | Update a SrcLoc to move it from l past the string argument. @@ -164,30 +161,13 @@ increaseSrcLoc ('\n' : s) (SrcLoc f y _) = increaseSrcLoc s (SrcLoc f (y + 1) 1) increaseSrcLoc (_ : s) (SrcLoc f y x) = increaseSrcLoc s (SrcLoc f y (x + 1)) -tests :: Test -tests = TestList [test1, test2, test3, test4, test5] - -test1 :: Test -test1 = TestCase (assertEqual "srcPairTextTail1" "hi\tjkl\n" (snd (srcPairText (SrcLoc ".hs" 1 10) (SrcLoc ".hs" 2 2) "abc\tdef\nghi\tjkl\n"))) -test2 :: Test -test2 = TestCase (assertEqual "srcPairTextTail2" "kl\n" (snd (srcPairText (SrcLoc ".hs" 1 10) (SrcLoc ".hs" 2 9) "abc\tdef\nghi\tjkl\n"))) -test3 :: Test -test3 = TestCase (assertEqual "srcPairTextHead1" "abc\tdef\ng" (fst (srcPairText (SrcLoc ".hs" 1 10) (SrcLoc ".hs" 2 2) "abc\tdef\nghi\tjkl\n"))) -test4 :: Test -test4 = TestCase (assertEqual "srcPairTextHead21" "abc\tdef\nghi\tj" (fst (srcPairText (SrcLoc ".hs" 1 10) (SrcLoc ".hs" 2 9) "abc\tdef\nghi\tjkl\n"))) -test5 :: Test -test5 = TestCase (assertEqual "srcPairTextTail3" - "{-# OPTIONS_GHC -fno-warn-orphans #-}\nmodule Debian.Repo.Orphans where\n\nimport Data.Text (Text)\nimport qualified Debian.Control.Text as T\n\nderiving instance Show (T.Field' Text)\nderiving instance Ord (T.Field' Text)\nderiving instance Show T.Paragraph\nderiving instance Ord T.Paragraph\n" - (snd - (srcPairText - (SrcLoc ".hs" 1 77) - (SrcLoc ".hs" 2 1) - "\n{-# OPTIONS_GHC -fno-warn-orphans #-}\nmodule Debian.Repo.Orphans where\n\nimport Data.Text (Text)\nimport qualified Debian.Control.Text as T\n\nderiving instance Show (T.Field' Text)\nderiving instance Ord (T.Field' Text)\nderiving instance Show T.Paragraph\nderiving instance Ord T.Paragraph\n"))) - -textSpan :: String -> SrcSpanInfo -textSpan s = let end = textEndLoc s in - SrcSpanInfo (def {srcSpanStartLine = 1, srcSpanStartColumn = 1, srcSpanEndLine = srcLine end, srcSpanEndColumn = srcColumn end}) [] +textSpan :: FilePath -> String -> SrcSpanInfo +textSpan path s = + let end = textEndLoc path s in + SrcSpanInfo (SrcSpan {srcSpanFilename = path, srcSpanStartLine = 1, srcSpanStartColumn = 1, srcSpanEndLine = srcLine end, srcSpanEndColumn = srcColumn end}) [] +-- | Given a beginning and end location, and a string which starts at +-- the beginning location, return a (beforeend,afterend) pair. srcPairText :: SrcLoc -> SrcLoc -> String -> (String, String) srcPairText b0 e0 s0 = fst $ runState f (b0, e0, "", s0) @@ -206,28 +186,16 @@ -- was present. case s of "" -> return (r, s) - ('\t' : s') -> put (b {srcColumn = ((srcColumn b + 7) `div` 8) * 8}, e, r ++ "\t", s') >> f (c : s') -> put (b {srcColumn = srcColumn b + 1}, e, r ++ [c], s') >> f _ -> error "Impossible: span stopped at the wrong character" (_, True) -> case s of [] -> error $ "srcPairText: " ++ show (b0, e0, s0) - ('\t' : s') -> put (b {srcColumn = ((srcColumn b + 7) `div` 8) * 8}, e, r ++ ['\t'], s') >> f (c : s') -> put (b {srcColumn = srcColumn b + 1}, e, r ++ [c], s') >> f _ -> return (r, s) -instance Default SrcLoc where - def = SrcLoc ".hs" 1 1 - -instance Default SrcSpanInfo where - def = SrcSpanInfo {srcInfoSpan = def, srcInfoPoints = def} - -instance Default SrcSpan where - def = SrcSpan {srcSpanFilename = ".hs", srcSpanStartLine = 1, srcSpanEndLine = 1, srcSpanStartColumn = 1, srcSpanEndColumn = 1} - -- | Build a tree of SrcSpanInfo - makeTree :: (HasSpanInfo a, Show a, Eq a, Ord a) => Set a -> Tree a makeTree s = case findRoots (toList s) of diff --git a/Language/Haskell/Modules/Util/Symbols.hs b/Language/Haskell/Modules/Util/Symbols.hs --- a/Language/Haskell/Modules/Util/Symbols.hs +++ b/Language/Haskell/Modules/Util/Symbols.hs @@ -9,21 +9,20 @@ , tests ) where -import Data.Default (def) import Data.List (sort) import Data.Maybe (mapMaybe) import Data.Set as Set (empty, insert, Set, toList) import Language.Haskell.Exts.Annotated.Simplify (sName) import qualified Language.Haskell.Exts.Annotated.Syntax as A (ClassDecl(..), ConDecl(..), Decl(..), DeclHead(..), Exp(..), ExportSpec(..), FieldDecl(..), GadtDecl(..), ImportSpec(..), InstHead(..), Match(..), Name(..), Pat(..), PatField(..), QName(..), QualConDecl(..), Rhs(..), RPat(..), Type(..)) import Language.Haskell.Exts.Pretty (prettyPrint) -import Language.Haskell.Exts.SrcLoc (SrcSpanInfo) +import Language.Haskell.Exts.SrcLoc (SrcSpan(..), SrcSpanInfo(..)) import qualified Language.Haskell.Exts.Syntax as S (CName(..), ExportSpec(..), ImportSpec(..), Name(..), QName(..)) import Language.Haskell.Modules.Util.SrcLoc () import Test.HUnit (assertEqual, Test(TestCase, TestList)) -- | Do a fold over the names that are declared in a declaration (not -- every name that appears, just the ones that the declaration is --- causing to exist - what's the word for that?. Reify!) +-- causing to exist - what's the word for that? Reify!) class FoldDeclared a where foldDeclared :: forall r. (Maybe S.Name -> r -> r) -> r -> a -> r @@ -201,3 +200,6 @@ test3 = TestCase (assertEqual "Pat" "pvar" (prettyPrint (A.PVar def (A.Ident def "pvar") :: A.Pat SrcSpanInfo))) test4 :: Test test4 = TestCase (assertEqual "Pat" "unqual pvar" (prettyPrint (A.PApp def (A.UnQual def (A.Ident def "unqual")) [A.PVar def (A.Ident def "pvar")] :: A.Pat SrcSpanInfo))) + +def :: SrcSpanInfo +def = SrcSpanInfo (SrcSpan "test" 1 1 1 1) [] diff --git a/Language/Haskell/Modules/Util/Test.hs b/Language/Haskell/Modules/Util/Test.hs --- a/Language/Haskell/Modules/Util/Test.hs +++ b/Language/Haskell/Modules/Util/Test.hs @@ -4,120 +4,100 @@ , diff , diff' , rsync - , findModules - , findPaths + , findHsModules + , findHsFiles ) where import Control.Monad (foldM) import Data.List as List (filter, isPrefixOf, isSuffixOf, map) -import Data.Set as Set (empty, fromList, insert, map, Set) -import qualified Language.Haskell.Exts.Syntax as S (ModuleName(..)) import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents) import System.Exit (ExitCode) import System.FilePath (()) import System.Process (readProcess, readProcessWithExitCode) -repoModules :: Set S.ModuleName +repoModules :: [String] repoModules = - Set.fromList - [S.ModuleName "Debian.Repo.Sync", - S.ModuleName "Debian.Repo.Slice", - S.ModuleName "Debian.Repo.SourcesList", - S.ModuleName "Debian.Repo.PackageIndex", - S.ModuleName "Debian.Repo.Types", - S.ModuleName "Debian.Repo.Types.Slice", - S.ModuleName "Debian.Repo.Types.Repository", - S.ModuleName "Debian.Repo.Types.PackageIndex", - S.ModuleName "Debian.Repo.Types.Release", - S.ModuleName "Debian.Repo.Types.AptImage", - S.ModuleName "Debian.Repo.Types.Repo", - S.ModuleName "Debian.Repo.Types.AptBuildCache", - S.ModuleName "Debian.Repo.Types.EnvPath", - S.ModuleName "Debian.Repo.Types.AptCache", - S.ModuleName "Debian.Repo.Orphans", - S.ModuleName "Debian.Repo.Types", - S.ModuleName "Debian.Repo.AptImage", - S.ModuleName "Debian.Repo.Package", - S.ModuleName "Debian.Repo.Monads.Top", - S.ModuleName "Debian.Repo.Monads.Apt", - S.ModuleName "Debian.Repo.AptCache", - S.ModuleName "Tmp.File", - S.ModuleName "Text.Format"] + [ "Debian.Repo.Sync" + , "Debian.Repo.Slice" + , "Debian.Repo.SourcesList" + , "Debian.Repo.PackageIndex" + , "Debian.Repo.Types" + , "Debian.Repo.Types.Slice" + , "Debian.Repo.Types.Repository" + , "Debian.Repo.Types.PackageIndex" + , "Debian.Repo.Types.Release" + , "Debian.Repo.Types.AptImage" + , "Debian.Repo.Types.Repo" + , "Debian.Repo.Types.AptBuildCache" + , "Debian.Repo.Types.EnvPath" + , "Debian.Repo.Types.AptCache" + , "Debian.Repo.Orphans" + , "Debian.Repo.Types" + , "Debian.Repo.AptImage" + , "Debian.Repo.Package" + , "Debian.Repo.Monads.Top" + , "Debian.Repo.Monads.Apt" + , "Debian.Repo.AptCache" + , "Tmp.File" + , "Text.Format" ] -logicModules :: Set S.ModuleName +logicModules :: [String] logicModules = - Set.fromList - [ S.ModuleName "Data.Boolean.SatSolver" - , S.ModuleName "Data.Boolean" - , S.ModuleName "Data.Logic.Resolution" - , S.ModuleName "Data.Logic.KnowledgeBase" - , S.ModuleName "Data.Logic.Types.FirstOrder" - , S.ModuleName "Data.Logic.Types.Common" - , S.ModuleName "Data.Logic.Types.Harrison.Formulas.FirstOrder" - , S.ModuleName "Data.Logic.Types.Harrison.Formulas.Propositional" - , S.ModuleName "Data.Logic.Types.Harrison.Prop" - , S.ModuleName "Data.Logic.Types.Harrison.Equal" - , S.ModuleName "Data.Logic.Types.Harrison.FOL" - , S.ModuleName "Data.Logic.Types.Propositional" - , S.ModuleName "Data.Logic.Types.FirstOrderPublic" - , S.ModuleName "Data.Logic.Harrison.Unif" - , S.ModuleName "Data.Logic.Harrison.Meson" - , S.ModuleName "Data.Logic.Harrison.Herbrand" - , S.ModuleName "Data.Logic.Harrison.Formulas.FirstOrder" - , S.ModuleName "Data.Logic.Harrison.Formulas.Propositional" - , S.ModuleName "Data.Logic.Harrison.Tests" - , S.ModuleName "Data.Logic.Harrison.Resolution" - , S.ModuleName "Data.Logic.Harrison.DefCNF" - , S.ModuleName "Data.Logic.Harrison.Skolem" - , S.ModuleName "Data.Logic.Harrison.Prop" - , S.ModuleName "Data.Logic.Harrison.DP" - , S.ModuleName "Data.Logic.Harrison.Lib" - , S.ModuleName "Data.Logic.Harrison.PropExamples" - , S.ModuleName "Data.Logic.Harrison.Prolog" - , S.ModuleName "Data.Logic.Harrison.Tableaux" - , S.ModuleName "Data.Logic.Harrison.Equal" - , S.ModuleName "Data.Logic.Harrison.Normal" - , S.ModuleName "Data.Logic.Harrison.FOL" - , S.ModuleName "Data.Logic.Tests.TPTP" - , S.ModuleName "Data.Logic.Tests.Common" - , S.ModuleName "Data.Logic.Tests.Harrison.Unif" - , S.ModuleName "Data.Logic.Tests.Harrison.Meson" - , S.ModuleName "Data.Logic.Tests.Harrison.Resolution" - , S.ModuleName "Data.Logic.Tests.Harrison.Common" - , S.ModuleName "Data.Logic.Tests.Harrison.Skolem" - , S.ModuleName "Data.Logic.Tests.Harrison.Prop" - , S.ModuleName "Data.Logic.Tests.Harrison.Main" - , S.ModuleName "Data.Logic.Tests.Harrison.Equal" - , S.ModuleName "Data.Logic.Tests.Harrison.FOL" - , S.ModuleName "Data.Logic.Tests.Main" - , S.ModuleName "Data.Logic.Tests.Logic" - , S.ModuleName "Data.Logic.Tests.Data" - , S.ModuleName "Data.Logic.Tests.HUnit" - , S.ModuleName "Data.Logic.Tests.Chiou0" - , S.ModuleName "Data.Logic.Failing" - , S.ModuleName "Data.Logic.Instances.SatSolver" - , S.ModuleName "Data.Logic.Instances.TPTP" - , S.ModuleName "Data.Logic.Instances.Chiou" - , S.ModuleName "Data.Logic.Instances.PropLogic" - , S.ModuleName "Data.Logic.Normal.Clause" - , S.ModuleName "Data.Logic.Normal.Implicative" - , S.ModuleName "Data.Logic.Classes.FirstOrder" - , S.ModuleName "Data.Logic.Classes.Variable" - , S.ModuleName "Data.Logic.Classes.Apply" - , S.ModuleName "Data.Logic.Classes.Negate" - , S.ModuleName "Data.Logic.Classes.Pretty" - , S.ModuleName "Data.Logic.Classes.Arity" - , S.ModuleName "Data.Logic.Classes.Skolem" - , S.ModuleName "Data.Logic.Classes.Combine" - , S.ModuleName "Data.Logic.Classes.Constants" - , S.ModuleName "Data.Logic.Classes.Equals" - , S.ModuleName "Data.Logic.Classes.Propositional" - , S.ModuleName "Data.Logic.Classes.Atom" - , S.ModuleName "Data.Logic.Classes.Formula" - , S.ModuleName "Data.Logic.Classes.ClauseNormalForm" - , S.ModuleName "Data.Logic.Classes.Term" - , S.ModuleName "Data.Logic.Classes.Literal" - , S.ModuleName "Data.Logic.Satisfiable" ] + [ "Data.Boolean.SatSolver" + , "Data.Boolean" + , "Data.Logic.Resolution" + , "Data.Logic.KnowledgeBase" + , "Data.Logic.Types.FirstOrder" + , "Data.Logic.Types.Common" + , "Data.Logic.Types.Harrison.Formulas.FirstOrder" + , "Data.Logic.Types.Harrison.Formulas.Propositional" + , "Data.Logic.Types.Harrison.Prop" + , "Data.Logic.Types.Harrison.Equal" + , "Data.Logic.Types.Harrison.FOL" + , "Data.Logic.Types.Propositional" + , "Data.Logic.Types.FirstOrderPublic" + , "Data.Logic.Harrison.Unif" + , "Data.Logic.Harrison.Meson" + , "Data.Logic.Harrison.Herbrand" + , "Data.Logic.Harrison.Formulas.FirstOrder" + , "Data.Logic.Harrison.Formulas.Propositional" + -- , "Data.Logic.Harrison.Tests" + , "Data.Logic.Harrison.Resolution" + , "Data.Logic.Harrison.DefCNF" + , "Data.Logic.Harrison.Skolem" + , "Data.Logic.Harrison.Prop" + , "Data.Logic.Harrison.DP" + , "Data.Logic.Harrison.Lib" + , "Data.Logic.Harrison.PropExamples" + , "Data.Logic.Harrison.Prolog" + , "Data.Logic.Harrison.Tableaux" + , "Data.Logic.Harrison.Equal" + , "Data.Logic.Harrison.Normal" + , "Data.Logic.Harrison.FOL" + , "Data.Logic.Failing" + , "Data.Logic.Instances.SatSolver" + -- , "Data.Logic.Instances.TPTP" + , "Data.Logic.Instances.Chiou" + , "Data.Logic.Instances.PropLogic" + , "Data.Logic.Normal.Clause" + , "Data.Logic.Normal.Implicative" + , "Data.Logic.Classes.FirstOrder" + , "Data.Logic.Classes.Variable" + , "Data.Logic.Classes.Apply" + , "Data.Logic.Classes.Negate" + , "Data.Logic.Classes.Pretty" + , "Data.Logic.Classes.Arity" + , "Data.Logic.Classes.Skolem" + , "Data.Logic.Classes.Combine" + , "Data.Logic.Classes.Constants" + , "Data.Logic.Classes.Equals" + , "Data.Logic.Classes.Propositional" + , "Data.Logic.Classes.Atom" + , "Data.Logic.Classes.Formula" + , "Data.Logic.Classes.ClauseNormalForm" + , "Data.Logic.Classes.Term" + , "Data.Logic.Classes.Literal" + , "Data.Logic.Satisfiable" ] diff :: FilePath -> FilePath -> IO (ExitCode, String, String) diff a b = @@ -136,16 +116,16 @@ rsync a b = readProcess "rsync" ["-aHxS", "--delete", a ++ "/", b] "" >> return () -- | Find the paths of all the files below the directory @top@. -findPaths :: FilePath -> IO (Set FilePath) -findPaths top = - doPath empty top +findHsFiles :: [FilePath] -> IO [FilePath] +findHsFiles tops = + foldM doPath [] tops where doPath r path = do dir <- doesDirectoryExist path reg <- doesFileExist path case () of _ | dir -> doDirectory r path - _ | reg && isSuffixOf ".hs" path -> return (insert path r) + _ | reg && isSuffixOf ".hs" path -> return (path : r) _ -> return r doDirectory r path = getDirectoryContents path >>= foldM doPath r . List.map (path ) . filter (\ x -> x /= "." && x /= "..") @@ -155,9 +135,9 @@ -- MonadClean and use the value of sourceDirs to remove prefixes from -- the module paths. And then it should look at the module text to -- see what the module name really is. -findModules :: FilePath -> IO (Set S.ModuleName) -findModules top = - findPaths top >>= return . Set.map asModuleName +findHsModules :: [FilePath] -> IO [String] +findHsModules tops = + findHsFiles tops >>= return . List.map asModuleName where asModuleName path = - S.ModuleName (List.map (\ c -> if c == '/' then '.' else c) (take (length path - 3) path)) + List.map (\ c -> if c == '/' then '.' else c) (take (length path - 3) path) diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -2,32 +2,31 @@ {-# OPTIONS -Wall #-} import Control.Exception (SomeException, try) -import Control.Monad.State (StateT) import Data.List (isPrefixOf) -import Data.Set as Set (Set) import Language.Haskell.Exts.Annotated (defaultParseMode, exactPrint, parseFileWithComments, ParseResult(ParseOk)) import Language.Haskell.Exts.Annotated.Syntax as A (Module) import Language.Haskell.Exts.Comments (Comment) import Language.Haskell.Exts.Extension (Extension(..)) import Language.Haskell.Exts.SrcLoc (SrcSpanInfo) import Language.Haskell.Exts.Syntax (ModuleName(ModuleName)) -import Language.Haskell.Modules (mergeModules, splitModuleDecls) -import Language.Haskell.Modules.Common (withCurrentDirectory) -import Language.Haskell.Modules.Internal (modifyParams, MonadClean, Params(extensions, moduVerse), runMonadClean) -import Language.Haskell.Modules.Util.QIO (noisily, qLnPutStr) +import Language.Haskell.Modules (CleanT, mergeModules, modifyExtensions, MonadClean, noisily, putModule, runCleanT, splitModuleDecls, withCurrentDirectory) import Language.Haskell.Modules.Util.Test (diff', logicModules, rsync) +import System.Environment (getArgs) import System.Exit (ExitCode(ExitSuccess, ExitFailure), exitWith) import System.Process (system) import Test.HUnit (assertEqual, Counts(..), runTestTT, Test(TestList, TestCase, TestLabel)) import qualified Tests.Fold as Fold (tests) import qualified Tests.Imports as Imports (tests) import qualified Tests.Merge as Merge (tests) -import qualified Tests.Split as Split (tests) +import qualified Tests.Split as Split (slow, tests) +import qualified Tests.SrcLoc as SrcLoc (tests) main :: IO () main = - do _ <- system "[ -d testdata ] || tar xfz testdata.tar.gz" - counts <- runTestTT (TestList [TestLabel "Main" Main.tests]) + do args <- getArgs + _ <- system "[ -d testdata ] || tar xfz testdata.tar.gz" + counts <- runTestTT (TestList $ [TestLabel "Main" Main.tests] ++ + if elem "--slow" args then [TestLabel "Slow" Main.slow] else []) putStrLn (show counts) case (errors counts + failures counts) of 0 -> exitWith ExitSuccess @@ -46,16 +45,21 @@ tests :: Test tests = TestList [ Main.test1 - , TestLabel "Merge" Merge.tests + , TestLabel "SrcLoc" SrcLoc.tests , TestLabel "Fold" Fold.tests , TestLabel "Imports" Imports.tests - , TestLabel "Split" Split.tests -- If split-merge-merge fails try split and split-merge. - , Main.logictest "split" test2a - , Main.logictest "split-merge" test2b - , Main.logictest "split-merge-merge" test2c + , TestLabel "Split" Split.tests + , TestLabel "Merge" Merge.tests ] +slow :: Test +slow = TestList [ Main.logictest "split-merge-merge" test2c + , Main.logictest "split-merge" test2b + , Main.logictest "split" test2a + , Split.slow + ] + test1 :: Test test1 = TestLabel "exactPrint" $ TestCase @@ -67,53 +71,47 @@ where test parsed comments text = return (exactPrint parsed comments, text) -logictest :: String -> (Set ModuleName -> StateT Params IO ()) -> Test +-- logictest :: String -> ([String] -> CleanT m ()) -> Test +logictest :: String -> ([String] -> CleanT IO ()) -> Test logictest s f = TestLabel s $ TestCase $ do _ <- rsync "testdata/logic" "tmp" - _ <- withCurrentDirectory "tmp" $ runMonadClean $ f logicModules + _ <- withCurrentDirectory "tmp" $ runCleanT $ noisily $ f logicModules (code, out, err) <- diff' ("testdata/" ++ s ++ "-expected") "tmp" let out' = unlines (filter (not . isPrefixOf "Binary files") . map (takeWhile (/= '\t')) $ (lines out)) assertEqual s (ExitSuccess, "", "") (code, out', err) -test2a :: MonadClean m => Set ModuleName -> m () +test2a :: MonadClean m => [String] -> m () test2a u = - do modifyParams (\ p -> p {extensions = extensions p ++ [MultiParamTypeClasses], - moduVerse = Just u}) - qLnPutStr "Splitting module Literal" - splitModuleDecls (ModuleName "Data.Logic.Classes.Literal") + do modifyExtensions (++ [MultiParamTypeClasses]) + -- We *must* clean the split results, or there will be + -- circular imports created when we merge. + mapM_ putModule u + _ <- splitModuleDecls "Data/Logic/Classes/Literal.hs" return () -test2b :: MonadClean m => Set ModuleName -> m () +test2b :: MonadClean m => [String] -> m () test2b u = - do modifyParams (\ p -> p {extensions = extensions p ++ [MultiParamTypeClasses], - moduVerse = Just u}) - qLnPutStr "Splitting module Literal" - splitModuleDecls (ModuleName "Data.Logic.Classes.Literal") - qLnPutStr "Merging FirstOrder, fromFirstOrder, fromLiteral into FirstOrder" - -- modifyParams (\ p -> p {testMode = True}) + do modifyExtensions (++ [MultiParamTypeClasses]) + mapM_ putModule u + _ <- splitModuleDecls "Data/Logic/Classes/Literal.hs" _ <- mergeModules [ModuleName "Data.Logic.Classes.FirstOrder", ModuleName "Data.Logic.Classes.Literal.FromFirstOrder", ModuleName "Data.Logic.Classes.Literal.FromLiteral"] (ModuleName "Data.Logic.Classes.FirstOrder") - noisily (qLnPutStr "merge2") return () -test2c :: MonadClean m => Set ModuleName -> m () +test2c :: MonadClean m => [String] -> m () test2c u = - do modifyParams (\ p -> p {extensions = extensions p ++ [MultiParamTypeClasses], - moduVerse = Just u}) - qLnPutStr "Splitting module Literal" - splitModuleDecls (ModuleName "Data.Logic.Classes.Literal") - qLnPutStr "Merging FirstOrder, fromFirstOrder, fromLiteral into FirstOrder" + do modifyExtensions (++ [MultiParamTypeClasses]) + mapM_ putModule u + _ <- splitModuleDecls "Data/Logic/Classes/Literal.hs" _ <- mergeModules [ModuleName "Data.Logic.Classes.FirstOrder", ModuleName "Data.Logic.Classes.Literal.FromFirstOrder", ModuleName "Data.Logic.Classes.Literal.FromLiteral"] (ModuleName "Data.Logic.Classes.FirstOrder") - noisily (qLnPutStr "Merging remaining split modules into Literal") - -- modifyParams (\ p -> p {testMode = True}) _ <- mergeModules [ModuleName "Data.Logic.Classes.Literal.Literal", ModuleName "Data.Logic.Classes.Literal.ZipLiterals", diff --git a/Tests/Fold.hs b/Tests/Fold.hs --- a/Tests/Fold.hs +++ b/Tests/Fold.hs @@ -1,16 +1,16 @@ module Tests.Fold where -import Control.Monad.Trans (liftIO) import Data.Foldable (fold) import Data.Monoid (Monoid(mempty)) import Data.Sequence as Seq (filter, fromList, Seq, zip, (|>)) import Data.Set.Extra as Set (fromList) import Data.Tree (Tree(..)) -import Language.Haskell.Exts.Annotated (ParseResult(..)) import Language.Haskell.Exts.SrcLoc (SrcLoc(..), SrcSpan(..), SrcSpanInfo(..)) import Language.Haskell.Modules.Common (withCurrentDirectory) -import Language.Haskell.Modules.Fold (echo, echo2, foldDecls, foldModule, ModuleInfo) -import Language.Haskell.Modules.Internal (parseFileWithComments, runMonadClean) +import Language.Haskell.Modules.Fold (echo, echo2, foldDecls, foldModule) +import Language.Haskell.Modules.Internal (runCleanT) +import Language.Haskell.Modules.ModuVerse (ModuleInfo(..), parseModule) +import Language.Haskell.Modules.SourceDirs (pathKey) import Language.Haskell.Modules.Util.SrcLoc (HasSpanInfo(..), makeTree) import Test.HUnit (assertEqual, Test(TestList, TestCase, TestLabel)) @@ -21,21 +21,19 @@ test1 = TestLabel "test1" $ TestCase $ withCurrentDirectory "testdata/debian" $ do let path = "Debian/Repo/Orphans.hs" - text <- liftIO $ readFile path - ParseOk (m, comments) <- runMonadClean $ parseFileWithComments path - let (output, original) = test (m, text, comments) + mi <- runCleanT $ pathKey path >>= parseModule + let (output, original) = test mi assertEqual "echo" original output where test :: ModuleInfo -> (String, String) - test m@(_, text, _) = (fold (foldModule echo2 echo echo echo echo2 echo echo2 echo echo echo2 m mempty), text) + test m@(ModuleInfo _ text _ _) = (fold (foldModule echo2 echo echo echo echo2 echo echo2 echo echo echo2 m mempty), text) test1b :: Test test1b = TestLabel "test1b" $ TestCase $ withCurrentDirectory "testdata/debian" $ do let path = "Debian/Repo/Sync.hs" - text <- liftIO $ readFile path - ParseOk (m, comments) <- runMonadClean $ parseFileWithComments path - let output = test (m, text, comments) + mi <- runCleanT $ pathKey path >>= parseModule + let output = test mi assertEqual "echo" mempty (Seq.filter (\ (a, b) -> a /= b) (Seq.zip expected output)) where expected :: Seq (String, String, String, String) @@ -77,23 +75,21 @@ test3 = TestLabel "test3" $ TestCase $ withCurrentDirectory "testdata" $ do let path = "Equal.hs" - text <- liftIO $ readFile path - ParseOk (m, comments) <- runMonadClean $ parseFileWithComments path - let (output, original) = test (m, text, comments) + mi <- runCleanT $ pathKey path >>= parseModule + let (output, original) = test mi assertEqual "echo" original output where test :: ModuleInfo -> (String, String) - test m@(_, text, _) = (fold (foldModule echo2 echo echo echo echo2 echo echo2 echo echo echo2 m mempty), text) + test m@(ModuleInfo _ text _ _) = (fold (foldModule echo2 echo echo echo echo2 echo echo2 echo echo echo2 m mempty), text) test5 :: Test test5 = TestLabel "fold5" $ TestCase $ do let path = "testdata/fold5.hs" -- "testdata/logic/Data/Logic/Classes/Literal.hs" - text <- liftIO $ readFile path - ParseOk (m, comments) <- runMonadClean $ parseFileWithComments path + mi <- runCleanT $ pathKey path >>= parseModule -- let actual = map f (adjustSpans text comments (spans m)) -- assertEqual "spans" original actual - let actual = foldDecls (\ _ a b c r -> r ++ [(a, b, c)]) (\ s r -> r ++ [("", s, "")]) (m, text, comments) [] + let actual = foldDecls (\ _ a b c r -> r ++ [(a, b, c)]) (\ s r -> r ++ [("", s, "")]) mi [] assertEqual "spans" expected actual where expected = [("","a = 1 where","\n"), @@ -104,9 +100,8 @@ test5b = TestLabel "test5b" $ TestCase $ do let path = "testdata/logic/Data/Logic/Classes/Literal.hs" - text <- liftIO $ readFile path - ParseOk (m, comments) <- runMonadClean $ parseFileWithComments path - let actual = foldDecls (\ _ a b c r -> r ++ [(a, b, c)]) (\ s r -> r ++ [("", s, "")]) (m, text, comments) [] + mi <- runCleanT $ pathKey path >>= parseModule + let actual = foldDecls (\ _ a b c r -> r ++ [(a, b, c)]) (\ s r -> r ++ [("", s, "")]) mi [] assertEqual "spans" expected actual where expected = [("\n-- |Literals are the building blocks of the clause and implicative normal\n-- |forms. They support negation and must include True and False elements.\n", @@ -164,8 +159,7 @@ test7 :: Test test7 = TestCase $ - do text <- readFile "testdata/Fold7.hs" - ParseOk (m, comments) <- runMonadClean $ parseFileWithComments "testdata/Fold7.hs" + do mi <- runCleanT $ pathKey "testdata/Fold7.hs" >>= parseModule let actual = foldModule (\ s r -> r |> (s, "", "")) (\ _ b s a r -> r |> (b, s, a)) (\ _ b s a r -> r |> (b, s, a)) @@ -176,7 +170,7 @@ (\ _ b s a r -> r |> (b, s, a)) (\ _ b s a r -> r |> (b, s, a)) (\ s r -> r |> (s, "", "")) - (m, text, comments) mempty + mi mempty assertEqual "fold7" expected actual where expected = Seq.fromList $ diff --git a/Tests/Imports.hs b/Tests/Imports.hs --- a/Tests/Imports.hs +++ b/Tests/Imports.hs @@ -3,10 +3,7 @@ import Language.Haskell.Exts.Extension (Extension(FlexibleInstances, StandaloneDeriving, TypeSynonymInstances)) import qualified Language.Haskell.Exts.Syntax as S (ModuleName(ModuleName)) -import Language.Haskell.Modules.Common (modulePathBase, withCurrentDirectory) -import Language.Haskell.Modules.Imports (cleanImports) -import Language.Haskell.Modules.Internal (modifyParams, Params(extensions, sourceDirs), runMonadClean) -import Language.Haskell.Modules.Params (modifyTestMode) +import Language.Haskell.Modules (cleanImports, modifyExtensions, modifyTestMode, modulePathBase, putDirs, runCleanT, withCurrentDirectory) import Language.Haskell.Modules.Util.Test (diff, rsync) import System.Exit (ExitCode(..)) import System.FilePath (()) @@ -14,15 +11,15 @@ import Test.HUnit (assertEqual, Test(..)) tests :: Test -tests = TestLabel "Clean" (TestList [test1, test2, test3, test4, test5, test6]) +tests = TestLabel "Clean" (TestList [test1, test2, test3, test4, test5, test6, test7]) test1 :: Test test1 = TestLabel "imports1" $ TestCase (do rsync "testdata/debian" "tmp" let name = S.ModuleName "Debian.Repo.Types.PackageIndex" - let base = modulePathBase name - _ <- withCurrentDirectory "tmp" (runMonadClean (cleanImports base)) + let base = modulePathBase "hs" name + _ <- withCurrentDirectory "tmp" (runCleanT (cleanImports [base])) (code, out, err) <- readProcessWithExitCode "diff" ["-ru", "testdata/debian" base, "tmp" base] "" assertEqual "cleanImports" (ExitFailure 1, @@ -50,8 +47,8 @@ TestLabel "Imports.test2" $ TestCase (do rsync "testdata/debian" "tmp" let name = S.ModuleName "Debian.Repo.PackageIndex" - base = modulePathBase name - _ <- withCurrentDirectory "tmp" (runMonadClean (cleanImports base)) + base = modulePathBase "hs" name + _ <- withCurrentDirectory "tmp" (runCleanT (cleanImports [base])) (code, out, err) <- readProcessWithExitCode "diff" ["-ru", "testdata/debian" base, "tmp" base] "" assertEqual "cleanImports" (ExitSuccess, "", "") (code, out, err)) @@ -60,7 +57,7 @@ test3 = TestLabel "imports3" $ TestCase (rsync "testdata/imports3" "tmp" >> - runMonadClean (modifyParams (\ p -> p {sourceDirs = ["tmp"]}) >> cleanImports "tmp/NotMain.hs") >> + runCleanT (putDirs ["tmp"] >> cleanImports ["NotMain.hs"]) >> assertEqual "module name" () ()) -- | Preserve imports with a "hiding" clause @@ -68,7 +65,7 @@ test4 = TestLabel "imports4" $ TestCase (rsync "testdata/imports4" "tmp" >> - runMonadClean (modifyParams (\ p -> p {sourceDirs = ["tmp"]}) >> cleanImports "tmp/Hiding.hs") >> + runCleanT (putDirs ["tmp"] >> cleanImports ["Hiding.hs"]) >> -- Need to check the text of Hiding.hs, but at least this verifies that there was no crash assertEqual "module name" () ()) @@ -77,9 +74,10 @@ test5 = TestLabel "imports5" $ TestCase (do _ <- rsync "testdata/imports5" "tmp" - _ <- runMonadClean (modifyParams (\ p -> p {extensions = extensions p ++ [StandaloneDeriving, TypeSynonymInstances, FlexibleInstances], - sourceDirs = ["tmp"]}) >> - cleanImports "tmp/Deriving.hs") + _ <- runCleanT + (putDirs ["tmp"] >> + modifyExtensions (++ [StandaloneDeriving, TypeSynonymInstances, FlexibleInstances]) >> + cleanImports ["Deriving.hs"]) (code, out, err) <- diff "testdata/imports5" "tmp" assertEqual "standalone deriving" (ExitFailure 1, @@ -101,6 +99,15 @@ test6 = TestLabel "imports6" $ TestCase (do _ <- rsync "testdata/imports6" "tmp" - _ <- withCurrentDirectory "tmp" (runMonadClean (modifyTestMode (const True) >> cleanImports "EndComment.hs")) + _ <- withCurrentDirectory "tmp" (runCleanT (modifyTestMode (const True) >> cleanImports ["EndComment.hs"])) (_, out, _) <- readProcessWithExitCode "diff" ["-ru", "imports6-expected", "tmp"] "" assertEqual "comment at end" "" out) + +-- Clean a file with tabs +test7 :: Test +test7 = + TestLabel "imports7" $ TestCase + (do _ <- rsync "testdata/imports7" "tmp" + _ <- withCurrentDirectory "tmp" (runCleanT (putDirs [".", ".."] >> modifyTestMode (const True) >> cleanImports ["CLI.hs"])) + out <- diff "testdata/imports7-expected" "tmp" + assertEqual "CLI" (ExitSuccess, "", "") out) diff --git a/Tests/Merge.hs b/Tests/Merge.hs --- a/Tests/Merge.hs +++ b/Tests/Merge.hs @@ -1,22 +1,23 @@ module Tests.Merge where +import Control.Monad as List (mapM_) import qualified Language.Haskell.Exts.Syntax as S (ModuleName(ModuleName)) -import Language.Haskell.Modules.Common (withCurrentDirectory) -import Language.Haskell.Modules.Internal (modifyParams, Params(moduVerse, sourceDirs), runMonadClean) -import Language.Haskell.Modules.Merge (mergeModules) +import Language.Haskell.Modules (mergeModules, modifyTestMode, noisily, putDirs, putModule, runCleanT, withCurrentDirectory, findHsModules) import Language.Haskell.Modules.Util.Test (diff, repoModules, rsync) -import System.Exit (ExitCode(ExitSuccess)) +import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import Test.HUnit (assertEqual, Test(TestCase, TestList)) tests :: Test -tests = TestList [test1, test2, test3] +tests = TestList [test1, test2, test3, test4, test5, test6] test1 :: Test test1 = TestCase $ do _ <- rsync "testdata/debian" "tmp" - _result <- runMonadClean $ - do modifyParams (\ p -> p {sourceDirs = ["tmp"], moduVerse = Just repoModules}) + _result <- runCleanT $ noisily $ noisily $ noisily $ + do putDirs ["tmp"] + modifyTestMode (const True) + mapM_ putModule repoModules mergeModules [S.ModuleName "Debian.Repo.AptCache", S.ModuleName "Debian.Repo.AptImage"] (S.ModuleName "Debian.Repo.Cache") @@ -27,8 +28,10 @@ test2 = TestCase $ do _ <- rsync "testdata/debian" "tmp" - _result <- runMonadClean $ - do modifyParams (\ p -> p {sourceDirs = ["tmp"], moduVerse = Just repoModules}) + _result <- runCleanT $ + do putDirs ["tmp"] + modifyTestMode (const True) + mapM_ putModule repoModules mergeModules [S.ModuleName "Debian.Repo.Types.Slice", S.ModuleName "Debian.Repo.Types.Repo", S.ModuleName "Debian.Repo.Types.EnvPath"] (S.ModuleName "Debian.Repo.Types.Common") @@ -40,8 +43,9 @@ TestCase $ do _ <- rsync "testdata/debian" "tmp" _result <- withCurrentDirectory "tmp" $ - runMonadClean $ - do modifyParams (\ p -> p {moduVerse = Just repoModules}) + runCleanT $ + do modifyTestMode (const True) + mapM_ putModule repoModules mergeModules [S.ModuleName "Debian.Repo.Types.Slice", S.ModuleName "Debian.Repo.Types.Repo", @@ -49,3 +53,40 @@ (S.ModuleName "Debian.Repo.Types.Slice") (code, out, err) <- diff "testdata/merge3-expected" "tmp" assertEqual "mergeModules3" (ExitSuccess, "", "") (code, out, err) + +test4 :: Test +test4 = + TestCase $ + do _ <- rsync "testdata/merge4" "tmp" + _ <- withCurrentDirectory "tmp" $ runCleanT $ + do mapM_ putModule ["In1", "In2", "M1"] + mergeModules [S.ModuleName "In1", S.ModuleName "In2"] (S.ModuleName "Out") + (code, out, err) <- diff "testdata/merge4-expected" "tmp" + assertEqual "mergeModules4" (ExitSuccess, "", "") (code, out, err) + +test5 :: Test +test5 = + TestCase $ + do _ <- rsync "testdata/merge5" "tmp" + _ <- withCurrentDirectory "tmp" $ runCleanT $ noisily $ noisily $ noisily $ + do modifyTestMode (const True) + List.mapM_ putModule + ["Apt.AptIO", "Apt.AptIOT", "Apt.AptState", + "Apt.InitState", "Apt.Instances", "Apt.MonadApt"] + mergeModules [S.ModuleName "Apt.AptIO", S.ModuleName "Apt.AptIOT", S.ModuleName "Apt.AptState", + S.ModuleName "Apt.InitState", S.ModuleName "Apt.Instances", S.ModuleName "Apt.MonadApt"] + (S.ModuleName "Apt") + (code, out, err) <- diff "testdata/merge5-expected" "tmp" + assertEqual "mergeModules5" (ExitFailure 1,"Only in tmp: Apt\n","") (code, out, err) + +test6 :: Test +test6 = + TestCase $ + do _ <- rsync "testdata/merge6" "tmp" + _ <- withCurrentDirectory "tmp" $ + findHsModules ["Test.hs", "A.hs", "B/C.hs", "B/D.hs"] >>= \ modules -> + runCleanT $ noisily $ noisily $ noisily $ + do mapM_ putModule modules + mergeModules [S.ModuleName "B.C", S.ModuleName "A"] (S.ModuleName "A") + (code, out, err) <- diff "testdata/merge6-expected" "tmp" + assertEqual "merge6" (ExitSuccess, "", "") (code, out, err) diff --git a/Tests/Split.hs b/Tests/Split.hs --- a/Tests/Split.hs +++ b/Tests/Split.hs @@ -1,93 +1,123 @@ module Tests.Split where -import Data.Set as Set (empty, singleton) +import Control.Monad as List (mapM_) import qualified Language.Haskell.Exts.Syntax as S (ModuleName(..), Name(Ident)) -import Language.Haskell.Modules.Common (withCurrentDirectory) -import Language.Haskell.Modules.Internal (modifyParams, Params(moduVerse, sourceDirs, testMode), runMonadClean) -import Language.Haskell.Modules.Params (modifyModuVerse, modifyTestMode) -import Language.Haskell.Modules.Split (DeclName(..), splitModule, splitModuleDecls) -import Language.Haskell.Modules.Util.QIO (noisily) -import Language.Haskell.Modules.Util.Test (diff, repoModules) +import Language.Haskell.Modules (modifyTestMode, noisily, putDirs, putModule, runCleanT, splitModule, splitModuleDecls, withCurrentDirectory, findHsModules) +import Language.Haskell.Modules.Util.Test (diff, repoModules, rsync) import Prelude hiding (writeFile) -import System.Cmd (system) import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import Test.HUnit (assertEqual, Test(TestCase, TestList, TestLabel)) tests :: Test -tests = TestList [split1, split2a, split2b, split4, split4b, split4c] +tests = TestList [split2a, split2b, split4, split4b, split4c, split5, split6] +slow :: Test +slow = TestList [split1] + split1 :: Test split1 = TestCase $ - do _ <- system "rsync -aHxS --delete testdata/debian/ tmp" - runMonadClean $ noisily $ noisily $ - do modifyParams (\ p -> p {sourceDirs = ["tmp"], moduVerse = Just repoModules}) - splitModuleDecls (S.ModuleName "Debian.Repo.Package") + do _ <- rsync "testdata/debian" "tmp" + _ <- runCleanT $ noisily $ noisily $ + do putDirs ["tmp"] + mapM_ putModule repoModules + splitModuleDecls "Debian/Repo/Package.hs" (code, out, err) <- diff "testdata/split1-expected" "tmp" - assertEqual "splitModule" (ExitSuccess, "", "") {- (ExitFailure 1, "diff -ru '--exclude=*~' '--exclude=*.imports' testdata/split1-expected/Debian/Repo/Package/BinaryPackagesOfIndex.hs tmp/Debian/Repo/Package/BinaryPackagesOfIndex.hs\n--- testdata/split1-expected/Debian/Repo/Package/BinaryPackagesOfIndex.hs\n+++ tmp/Debian/Repo/Package/BinaryPackagesOfIndex.hs\n@@ -22,4 +22,4 @@\n binaryPackagesOfIndex repo release index =\n case packageIndexArch index of\n Source -> return (Right [])\n- _ -> liftIO $ getPackages repo release index -- >>= return . either Left (Right . List.map (toBinaryPackage index . packageInfo))\n\\ No newline at end of file\n+ _ -> liftIO $ getPackages repo release index \n\\ No newline at end of file\n", "") -} (code, out, err) + assertEqual "splitModule" (ExitSuccess, "", "") (code, out, err) split2a :: Test split2a = TestCase $ - do _ <- system "rsync -aHxS --delete testdata/split2/ tmp" - runMonadClean $ - do modifyParams (\ p -> p {testMode = True, - sourceDirs = ["tmp"], - -- extensions = NoImplicitPrelude : extensions p, - moduVerse = Just (singleton (S.ModuleName "Split"))}) - splitModuleDecls (S.ModuleName "Split") + do _ <- rsync "testdata/split2" "tmp" + _ <- runCleanT $ noisily $ noisily $ + do modifyTestMode (const True) + putDirs ["tmp"] + putModule "Split" + splitModuleDecls "Split.hs" (code, out, err) <- diff "testdata/split2-expected" "tmp" assertEqual "split2" (ExitSuccess, "", "") (code, out, err) split2b :: Test split2b = TestCase $ - do _ <- system "rsync -aHxS --delete testdata/split2/ tmp" - runMonadClean $ - do modifyParams (\ p -> p {testMode = False, - sourceDirs = ["tmp"], - -- extensions = NoImplicitPrelude : extensions p, - moduVerse = Just (singleton (S.ModuleName "Split"))}) - splitModuleDecls (S.ModuleName "Split") + do _ <- rsync "testdata/split2" "tmp" + _ <- runCleanT $ noisily $ noisily $ + do putDirs ["tmp"] + putModule "Split" + splitModuleDecls "Split.hs" (code, out, err) <- diff "testdata/split2-clean-expected" "tmp" -- The output of splitModule is "correct", but it will not be -- accepted by GHC until the fix for -- http://hackage.haskell.org/trac/ghc/ticket/8011 is -- available. - assertEqual "split2-clean" (ExitFailure 1,"diff -ru '--exclude=*~' '--exclude=*.imports' testdata/split2-clean-expected/Split/Clean.hs tmp/Split/Clean.hs\n--- testdata/split2-clean-expected/Split/Clean.hs\n+++ tmp/Split/Clean.hs\n@@ -7,7 +7,7 @@\n \n \n import Data.Char (isAlphaNum)\n-import URL (ToURL(toURL), URLT)\n+import URL (ToURL(URLT, toURL))\n \n clean :: (ToURL url, Show (URLT url)) => url -> String\n clean = filter isAlphaNum . show . toURL\n", "") (code, out, err) + assertEqual "split2-clean" (ExitFailure 1,"diff -ru '--exclude=*~' '--exclude=*.imports' testdata/split2-clean-expected/Split/Clean.hs tmp/Split/Clean.hs\n--- testdata/split2-clean-expected/Split/Clean.hs\n+++ tmp/Split/Clean.hs\n@@ -6,7 +6,7 @@\n ) where\n \n import Data.Char (isAlphaNum)\n-import URL (ToURL(toURL), URLT)\n+import URL (ToURL(URLT, toURL))\n \n clean :: (ToURL url, Show (URLT url)) => url -> String\n clean = filter isAlphaNum . show . toURL\n", "") (code, out, err) split4 :: Test split4 = TestLabel "Split4" $ TestCase $ - do _ <- system "rsync -aHxs --delete testdata/split4/ tmp" - withCurrentDirectory "tmp" $ - runMonadClean $ modifyTestMode (const True) >> modifyModuVerse (const Set.empty) >> splitModuleDecls (S.ModuleName "Split4") + do _ <- rsync "testdata/split4" "tmp" + _ <- withCurrentDirectory "tmp" $ + runCleanT $ noisily $ noisily $ modifyTestMode (const True) >> putModule "Split4" >> splitModuleDecls "Split4.hs" result <- diff "testdata/split4-expected" "tmp" assertEqual "Split4" (ExitSuccess, "", "") result split4b :: Test split4b = TestLabel "Split4b" $ TestCase $ - do _ <- system "rsync -aHxs --delete testdata/split4/ tmp" - withCurrentDirectory "tmp" $ - runMonadClean $ modifyTestMode (const True) >> modifyModuVerse (const Set.empty) >> splitModule f (S.ModuleName "Split4") + do _ <- rsync "testdata/split4" "tmp" + _ <- withCurrentDirectory "tmp" $ + runCleanT $ noisily $ noisily $ + modifyTestMode (const True) >> + putModule "Split4" >> + splitModule f "Split4.hs" result <- diff "testdata/split4b-expected" "tmp" assertEqual "Split4" (ExitSuccess, "", "") result where - f :: S.ModuleName -> DeclName -> S.ModuleName - f (S.ModuleName parent) (Exported (S.Ident "getPackages")) = S.ModuleName (parent ++ ".A") - f (S.ModuleName parent) _ = S.ModuleName (parent ++ ".B") + f :: Maybe S.Name -> S.ModuleName + f (Just (S.Ident "getPackages")) = S.ModuleName ("Split4.A") + f _ = S.ModuleName ("Split4.B") split4c :: Test split4c = TestLabel "Split4b" $ TestCase $ - do _ <- system "rsync -aHxs --delete testdata/split4/ tmp" - withCurrentDirectory "tmp" $ - runMonadClean $ modifyTestMode (const True) >> modifyModuVerse (const Set.empty) >> splitModule f (S.ModuleName "Split4") + do _ <- rsync "testdata/split4" "tmp" + _ <- withCurrentDirectory "tmp" $ + runCleanT $ noisily $ noisily $ + modifyTestMode (const True) >> + putModule "Split4" >> + splitModule f "Split4.hs" result <- diff "testdata/split4c-expected" "tmp" assertEqual "Split4" (ExitSuccess, "", "") result where - f :: S.ModuleName -> DeclName -> S.ModuleName - f (S.ModuleName parent) (Exported (S.Ident "getPackages")) = S.ModuleName (parent ++ ".A") - f (S.ModuleName parent) _ = S.ModuleName parent + f :: Maybe S.Name -> S.ModuleName + f (Just (S.Ident "getPackages")) = S.ModuleName ("Split4.A") + f _ = S.ModuleName "Split4" + +-- Test what happens when a split module is re-exported +split5 :: Test +split5 = + TestLabel "Split5" $ TestCase $ + do _ <- rsync "testdata/split5" "tmp" + _ <- withCurrentDirectory "tmp" $ + runCleanT $ noisily $ noisily $ + List.mapM_ putModule ["A", "B", "C", "D", "E"] >> + modifyTestMode (const True) >> + splitModuleDecls "B.hs" + result <- diff "testdata/split5-expected" "tmp" + assertEqual "Split5" (ExitSuccess, "", "") result + +split6 :: Test +split6 = + TestLabel "Split6" $ TestCase $ + do _ <- rsync "testdata/debian" "tmp" + _ <- withCurrentDirectory "tmp" $ + findHsModules ["Debian", "Text", "Tmp"] >>= \ modules -> + runCleanT $ noisily $ noisily $ + mapM putModule modules >> + splitModule f "Debian/Repo/Monads/Apt.hs" + result <- diff "testdata/split6-expected" "tmp" + assertEqual "Split6" (ExitSuccess, "", "") result + where + f (Just (S.Ident "countTasks")) = S.ModuleName "IO" + f _ = S.ModuleName "Debian.Repo.Monads.Apt" diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,33 @@ +haskell-module-management (0.13) unstable; urgency=low + + * Changed cleanImports and cleanResults functions to take a list of + paths and process multiple files at once. This changed reduced the + run time of test suite from 15 minutes to 30 seconds. + * Rename runMonadClean -> runCleanT + * Simplify splitModule function signatures + + -- David Fox Sun, 14 Jul 2013 10:41:51 -0700 + +haskell-module-management (0.12.1) unstable; urgency=low + + * Have pathKey and modulePath search the SourceDirs list for files. + * Fix handling of tabs - I thought haskell-src-exts worked in expanded + tab coordinates, it does not. + * Update re-exports split modules. + * Add an extraImports parameter to force a module to import certain + other modules despite what --dump-minimal-imports says. This is + sometimes needed to get access to required instances. + + -- David Fox Wed, 10 Jul 2013 15:07:28 -0700 + +haskell-module-management (0.12) unstable; urgency=low + + * splitModule and splitModuleDecls now take a FilePath instead of + a module name. + * Substantial improvements to mergeModules + + -- David Fox Thu, 04 Jul 2013 07:15:23 -0700 + haskell-module-management (0.11.1) unstable; urgency=low * Export defaultSymbolToModule diff --git a/module-management.cabal b/module-management.cabal --- a/module-management.cabal +++ b/module-management.cabal @@ -1,5 +1,5 @@ Name: module-management -Version: 0.11.1 +Version: 0.13 Synopsis: Clean up module imports, split and merge modules Description: Clean up module imports, split and merge modules. Homepage: http://src.seereason.com/module-management @@ -20,18 +20,20 @@ ghc-Options: -Wall -O2 Exposed-Modules: Language.Haskell.Modules, - Language.Haskell.Modules.Fold, Language.Haskell.Modules.Common, + Language.Haskell.Modules.Fold, Language.Haskell.Modules.Imports, Language.Haskell.Modules.Merge, + Language.Haskell.Modules.ModuVerse, Language.Haskell.Modules.Params, + Language.Haskell.Modules.SourceDirs, Language.Haskell.Modules.Split, + Language.Haskell.Modules.Util.DryIO, Language.Haskell.Modules.Util.QIO, + Language.Haskell.Modules.Util.SrcLoc, Language.Haskell.Modules.Util.Symbols, - Language.Haskell.Modules.Util.Test, Language.Haskell.Modules.Util.Temp, - Language.Haskell.Modules.Util.SrcLoc, - Language.Haskell.Modules.Util.DryIO + Language.Haskell.Modules.Util.Test Other-Modules: Language.Haskell.Modules.Internal, Tests.Fold, diff --git a/scripts/CLI.hs b/scripts/CLI.hs --- a/scripts/CLI.hs +++ b/scripts/CLI.hs @@ -1,21 +1,18 @@ {-# OPTIONS_GHC -Wall #-} module Main where +import Control.Monad as List (mapM_) import Control.Monad.Trans (MonadIO(liftIO)) import Data.List (intercalate, isPrefixOf) -import Data.Maybe (fromMaybe) -import Data.Set (Set, union, toList, empty, size, unions, singleton) +import Data.Set.Extra as Set (Set, toList) import Language.Haskell.Exts.Syntax (ModuleName(ModuleName)) -import Language.Haskell.Modules (runMonadClean, cleanImports, splitModuleDecls, mergeModules, - modifyModuVerse, modifySourceDirs) -import Language.Haskell.Modules.Internal (getParams, Params(..)) -import Language.Haskell.Modules.Params (MonadClean) -import Language.Haskell.Modules.Util.QIO (noisily, quietly) -import Language.Haskell.Modules.Util.Test (findModules) -import System.IO (stdin, stderr, hGetLine, hPutStr, hPutStrLn) +import Language.Haskell.Modules +import Language.Haskell.Modules.ModuVerse (getNames) +import Language.Haskell.Modules.SourceDirs (getDirs) +import System.IO (hGetLine, hPutStr, hPutStrLn, stderr, stdin) main :: IO () -main = runMonadClean (noisily cli) +main = runCleanT (noisily cli) cli :: MonadClean m => m () cli = liftIO (hPutStr stderr " > " >> hGetLine stdin) >>= cmd . words @@ -50,40 +47,39 @@ verse :: MonadClean m => [String] -> m () verse [] = - do modules <- getParams >>= return . moduVerse + do modules <- getNames liftIO $ hPutStrLn stderr ("Usage: verse ...\n" ++ "Add the module or all the modules below a directory to the moduVerse\n" ++ - "Currently:\n " ++ showVerse (fromMaybe empty modules)) + "Currently:\n " ++ showVerse modules) verse args = do new <- mapM (liftIO . find) args - modifyModuVerse (union (unions new)) - modules <- getParams >>= return . moduVerse - liftIO (hPutStrLn stderr $ "moduVerse updated:\n " ++ showVerse (fromMaybe empty modules)) + List.mapM_ (List.mapM_ putModule) new + modules <- getNames + liftIO (hPutStrLn stderr $ "moduVerse updated:\n " ++ showVerse modules) where - find :: String -> IO (Set ModuleName) find s = - do ms <- liftIO (findModules s) - case size ms of - 0 -> return (singleton (ModuleName s)) + do ms <- liftIO (findHsModules [s]) + case ms of + [] -> return [s] _ -> return ms showVerse :: Set ModuleName -> String showVerse modules = "[ " ++ intercalate "\n , " (map unModuleName (toList modules)) ++ " ]" dir :: MonadClean m => [FilePath] -> m () -dir [] = modifySourceDirs (const []) +dir [] = putDirs [] dir xs = - do modifySourceDirs (++ xs) - xs' <- getParams >>= return . sourceDirs + do modifyDirs (++ xs) + xs' <- getDirs liftIO (hPutStrLn stderr $ "sourceDirs updated:\n [ " ++ intercalate "\n , " xs' ++ " ]") clean :: MonadClean m => [FilePath] -> m () clean [] = liftIO $ hPutStrLn stderr "Usage: clean ..." -clean args = mapM_ cleanImports args +clean args = cleanImports args >> return () -split :: MonadClean m => [String] -> m () -split [arg] = splitModuleDecls (ModuleName arg) -split _ = liftIO $ hPutStrLn stderr "Usage: split " +split :: MonadClean m => [FilePath] -> m () +split [arg] = splitModuleDecls arg >> return () +split _ = liftIO $ hPutStrLn stderr "Usage: split " merge :: MonadClean m => [String] -> m () merge args = diff --git a/testdata.tar.gz b/testdata.tar.gz Binary files a/testdata.tar.gz and b/testdata.tar.gz differ