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 @@ -80,8 +80,8 @@ setSpanEnd :: SrcLoc -> SrcSpan -> SrcSpan setSpanEnd loc sp = sp {srcSpanEndLine = srcLine loc, srcSpanEndColumn = srcColumn loc} -setSpanStart :: SrcLoc -> SrcSpan -> SrcSpan -setSpanStart loc sp = sp {srcSpanStartLine = srcLine loc, srcSpanStartColumn = srcColumn loc} +-- setSpanStart :: SrcLoc -> SrcSpan -> SrcSpan +-- setSpanStart loc sp = sp {srcSpanStartLine = srcLine loc, srcSpanStartColumn = srcColumn loc} -- | The spans returned by haskell-src-exts may put comments and -- whitespace in the suffix string of a declaration, we want them in @@ -212,8 +212,8 @@ do let l' = srcLoc sp case l <= l' of True -> - let (p, s) = srcPairText l l' tl in - put (s, l', sps, f p r) + let (b, a) = srcPairText l l' tl in + put (a, l', sps, f b r) False -> return () _ -> error $ "foldModule - out of spans: " ++ show p doList :: (HasSpanInfo a, Show a) => (a -> String -> String -> String -> r -> r) -> [a] -> State (String, SrcLoc, [SrcSpanInfo], r) () @@ -255,6 +255,7 @@ w' = case span (/= '\n') w of (w'', '\n' : _) -> w'' ++ ['\n'] (w'', "") -> w'' + _ -> error "Impossible: span stopped on the wrong char" l' = increaseSrcLoc w' l -- | Do just the header portion of 'foldModule'. 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 @@ -4,6 +4,7 @@ ( DeclName(..) , splitModule , splitModuleDecls + , defaultSymbolToModule ) where import Control.Exception (throw) @@ -20,7 +21,7 @@ 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 qualified Language.Haskell.Exts.Annotated as A (Decl, ImportDecl(..), ImportSpecList(..), Module(Module), ModuleHead(ModuleHead), Name) +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.Pretty (defaultMode, prettyPrint, prettyPrintWithMode) import Language.Haskell.Exts.SrcLoc (SrcSpanInfo(..)) @@ -51,14 +52,7 @@ (parsed, comments) <- parseFileWithComments path >>= return . fromParseResult return (parsed, text, comments) --- | Do splitModuleBy with a custom symbol to module mapping -splitModule :: MonadClean m => (DeclName -> S.ModuleName) -> S.ModuleName -> m () -splitModule symbolToModule old = parseModule old >>= splitModuleBy symbolToModule old --- | 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) old m - -- | 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 @@ -73,7 +67,7 @@ -- (.+.) = b + c -- @ -- --- After running @splitModule@ the @Start@ module will be gone. The +-- 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@. @@ -84,11 +78,23 @@ -- 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@. -splitModuleBy :: MonadClean m => (DeclName -> S.ModuleName) -> S.ModuleName -> ModuleInfo -> m () +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 + +-- | 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 + +splitModuleBy :: MonadClean m => + (S.ModuleName -> DeclName -> S.ModuleName) + -> S.ModuleName -- ^ Parent module name + -> ModuleInfo -> m () splitModuleBy symbolToModule old m = do univ <- moduVerseCheck - m <- parseModule old - changes <- doSplit symbolToModule univ m >>= return . collisionCheck univ + 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 where @@ -100,16 +106,16 @@ where illegal = Set.intersection univ (created s) created :: Set ModuleResult -> Set S.ModuleName - created = setMapMaybe (\ x -> case x of Created m _ -> Just m; _ -> Nothing) + 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 (Created m' _) = doClean' m' + doClean (Modified m' _) = doClean' m' doClean (Removed _) = return () doClean (Unchanged _) = return () - doClean' m = + doClean' m' = do flag <- getParams >>= return . not . testMode - when flag (modulePath m >>= cleanImports >> return ()) + when flag (modulePath m' >>= cleanImports >> return ()) -- This returns a set of maybe because there may be instance -- declarations, in which case we want an Instances module to @@ -126,20 +132,20 @@ (if member Nothing (declared m) then singleton Nothing else Set.empty) where hasExportList :: ModuleInfo -> Bool - hasExportList m@(A.Module _ Nothing _ _ _, _, _) = False - hasExportList m@(A.Module _ (Just (A.ModuleHead _ _ _ Nothing)) _ _ _, _, _) = False + hasExportList (A.Module _ Nothing _ _ _, _, _) = False + hasExportList (A.Module _ (Just (A.ModuleHead _ _ _ Nothing)) _ _ _, _, _) = False hasExportList _ = True -newModuleNames :: (DeclName -> S.ModuleName) -> S.ModuleName -> ModuleInfo -> Set S.ModuleName -newModuleNames symbolToModule old m = +newModuleNames :: (DeclName -> S.ModuleName) -> ModuleInfo -> Set S.ModuleName +newModuleNames symbolToModule m = Set.map (symbolToModule . declName' m) (union (declared m) (exported m)) declName' :: ModuleInfo -> Maybe S.Name -> DeclName declName' m = - declName (reExported m) (internal m) + declName where - declName :: (S.Name -> Bool) -> (S.Name -> Bool) -> Maybe S.Name -> DeclName - declName reExported internal name = + declName :: Maybe S.Name -> DeclName + declName name = case name of Nothing -> Instance Just name' -> @@ -148,26 +154,31 @@ else if internal name' then Internal name' else Exported name' - internal :: ModuleInfo -> S.Name -> Bool - internal m name = member (Just name) (difference (declared m) (exported m)) - reExported :: ModuleInfo -> S.Name -> Bool - reExported m name = member (Just name) (difference (exported m) (declared m)) + 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)) -- | 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) - updated <- Set.mapM (updateImports m (sModuleName moduleName) symbolToModule) (Set.delete old univ) - let moduleNames = newModuleNames symbolToModule old m - let split = union (Set.map newModule moduleNames) - (if member old moduleNames then Set.empty else singleton (Removed old)) - return $ union split updated + 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 @@ -210,18 +221,18 @@ where -- Build export specs of the symbols created by each declaration. newExports :: [(A.Decl SrcSpanInfo, String)] -> [S.ExportSpec] - newExports modDecls = nub (concatMap (exports . fst) modDecls) + newExports xs = nub (concatMap (exports . fst) xs) newImports :: [(A.Decl SrcSpanInfo, String)] -> Map S.ModuleName S.ImportDecl - newImports modDecls = + 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 modDecls)))) moduleDeclMap)) + 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 modDecls = Set.map sName (gFind modDecls :: Set (A.Name SrcSpanInfo)) + referenced xs = Set.map sName (gFind xs :: Set (A.Name SrcSpanInfo)) -- Re-construct a separated list doSeps :: [(String, String)] -> String @@ -272,7 +283,9 @@ mp'' -- | What module should this symbol be moved to? -defaultSymbolToModule :: S.ModuleName -> DeclName -> S.ModuleName +defaultSymbolToModule :: S.ModuleName -- ^ Parent module name + -> DeclName -- ^ Declared symbol + -> S.ModuleName defaultSymbolToModule (S.ModuleName parentModuleName) name = S.ModuleName (parentModuleName <.> case name of Instance -> "Instances" diff --git a/Language/Haskell/Modules/Util/QIO.hs b/Language/Haskell/Modules/Util/QIO.hs --- a/Language/Haskell/Modules/Util/QIO.hs +++ b/Language/Haskell/Modules/Util/QIO.hs @@ -9,7 +9,7 @@ , noisily , qIO , qPutStr - -- , qPutStrLn + , qPutStrLn , qLnPutStr ) where 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 @@ -208,6 +208,7 @@ "" -> 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) diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -2,8 +2,9 @@ {-# OPTIONS -Wall #-} import Control.Exception (SomeException, try) +import Control.Monad.State (StateT) import Data.List (isPrefixOf) -import Data.Set as Set (delete, fromList, Set, union) +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) @@ -66,7 +67,7 @@ where test parsed comments text = return (exactPrint parsed comments, text) --- logictest :: MonadClean m => String -> (Set ModuleName -> m ()) -> Test +logictest :: String -> (Set ModuleName -> StateT Params IO ()) -> Test logictest s f = TestLabel s $ TestCase $ do _ <- rsync "testdata/logic" "tmp" @@ -91,23 +92,13 @@ splitModuleDecls (ModuleName "Data.Logic.Classes.Literal") qLnPutStr "Merging FirstOrder, fromFirstOrder, fromLiteral into FirstOrder" -- modifyParams (\ p -> p {testMode = True}) - mergeModules - [ModuleName "Data.Logic.Classes.FirstOrder", - ModuleName "Data.Logic.Classes.Literal.FromFirstOrder", - ModuleName "Data.Logic.Classes.Literal.FromLiteral"] - (ModuleName "Data.Logic.Classes.FirstOrder") + _ <- 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 () - where - u' = union (fromList [ModuleName "Data.Logic.Classes.Literal.Internal.FixityLiteral", - ModuleName "Data.Logic.Classes.Literal.FoldAtomsLiteral", - ModuleName "Data.Logic.Classes.Literal.FromFirstOrder", - ModuleName "Data.Logic.Classes.Literal.FromLiteral", - ModuleName "Data.Logic.Classes.Literal.Literal", - ModuleName "Data.Logic.Classes.Literal.PrettyLit", - ModuleName "Data.Logic.Classes.Literal.ToPropositional", - ModuleName "Data.Logic.Classes.Literal.ZipLiterals"]) - (delete (ModuleName "Data.Logic.Classes.Literal") u) test2c :: MonadClean m => Set ModuleName -> m () test2c u = @@ -116,19 +107,19 @@ qLnPutStr "Splitting module Literal" splitModuleDecls (ModuleName "Data.Logic.Classes.Literal") qLnPutStr "Merging FirstOrder, fromFirstOrder, fromLiteral into FirstOrder" - mergeModules - [ModuleName "Data.Logic.Classes.FirstOrder", - ModuleName "Data.Logic.Classes.Literal.FromFirstOrder", - ModuleName "Data.Logic.Classes.Literal.FromLiteral"] - (ModuleName "Data.Logic.Classes.FirstOrder") + _ <- 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", - ModuleName "Data.Logic.Classes.Literal.ToPropositional", - ModuleName "Data.Logic.Classes.Literal.PrettyLit", - ModuleName "Data.Logic.Classes.Literal.Internal.FixityLiteral", - ModuleName "Data.Logic.Classes.Literal.FoldAtomsLiteral"] - (ModuleName "Data.Logic.Classes.Literal") + _ <- mergeModules + [ModuleName "Data.Logic.Classes.Literal.Literal", + ModuleName "Data.Logic.Classes.Literal.ZipLiterals", + ModuleName "Data.Logic.Classes.Literal.ToPropositional", + ModuleName "Data.Logic.Classes.Literal.PrettyLit", + ModuleName "Data.Logic.Classes.Literal.Internal.FixityLiteral", + ModuleName "Data.Logic.Classes.Literal.FoldAtomsLiteral"] + (ModuleName "Data.Logic.Classes.Literal") return () diff --git a/Tests/Imports.hs b/Tests/Imports.hs --- a/Tests/Imports.hs +++ b/Tests/Imports.hs @@ -23,7 +23,7 @@ let name = S.ModuleName "Debian.Repo.Types.PackageIndex" let base = modulePathBase name _ <- withCurrentDirectory "tmp" (runMonadClean (cleanImports base)) - (code, diff, err) <- readProcessWithExitCode "diff" ["-ru", "testdata/debian" base, "tmp" base] "" + (code, out, err) <- readProcessWithExitCode "diff" ["-ru", "testdata/debian" base, "tmp" base] "" assertEqual "cleanImports" (ExitFailure 1, ["@@ -22,13 +22,13 @@", @@ -43,7 +43,7 @@ " import System.Posix.Types (FileOffset)", " import Text.PrettyPrint.ANSI.Leijen ((<>), Doc, Pretty(pretty), text)"], "") - (code, drop 2 (lines diff), err)) + (code, drop 2 (lines out), err)) test2 :: Test test2 = @@ -52,8 +52,8 @@ let name = S.ModuleName "Debian.Repo.PackageIndex" base = modulePathBase name _ <- withCurrentDirectory "tmp" (runMonadClean (cleanImports base)) - (code, diff, err) <- readProcessWithExitCode "diff" ["-ru", "testdata/debian" base, "tmp" base] "" - assertEqual "cleanImports" (ExitSuccess, "", "") (code, diff, err)) + (code, out, err) <- readProcessWithExitCode "diff" ["-ru", "testdata/debian" base, "tmp" base] "" + assertEqual "cleanImports" (ExitSuccess, "", "") (code, out, err)) -- | Can we handle a Main module in a file named something other than Main.hs? test3 :: Test @@ -80,7 +80,7 @@ _ <- runMonadClean (modifyParams (\ p -> p {extensions = extensions p ++ [StandaloneDeriving, TypeSynonymInstances, FlexibleInstances], sourceDirs = ["tmp"]}) >> cleanImports "tmp/Deriving.hs") - (code, diff, err) <- diff "testdata/imports5" "tmp" + (code, out, err) <- diff "testdata/imports5" "tmp" assertEqual "standalone deriving" (ExitFailure 1, (unlines @@ -94,7 +94,7 @@ " deriving instance Show (Field' String)", " deriving instance Show Paragraph"]), "") - (code, unlines (drop 3 (lines diff)), err)) + (code, unlines (drop 3 (lines out)), err)) -- | Comment at EOF test6 :: Test @@ -102,5 +102,5 @@ TestLabel "imports6" $ TestCase (do _ <- rsync "testdata/imports6" "tmp" _ <- withCurrentDirectory "tmp" (runMonadClean (modifyTestMode (const True) >> cleanImports "EndComment.hs")) - (code, diff, err) <- readProcessWithExitCode "diff" ["-ru", "imports6-expected", "tmp"] "" - assertEqual "comment at end" "" diff) + (_, out, _) <- readProcessWithExitCode "diff" ["-ru", "imports6-expected", "tmp"] "" + assertEqual "comment at end" "" out) diff --git a/Tests/Split.hs b/Tests/Split.hs --- a/Tests/Split.hs +++ b/Tests/Split.hs @@ -14,7 +14,7 @@ import Test.HUnit (assertEqual, Test(TestCase, TestList, TestLabel)) tests :: Test -tests = TestList [split1, split2a, split2b, split4, split4b] +tests = TestList [split1, split2a, split2b, split4, split4b, split4c] split1 :: Test split1 = @@ -59,7 +59,7 @@ split4 :: Test split4 = TestLabel "Split4" $ TestCase $ - do system "rsync -aHxs --delete testdata/split4/ tmp" + do _ <- system "rsync -aHxs --delete testdata/split4/ tmp" withCurrentDirectory "tmp" $ runMonadClean $ modifyTestMode (const True) >> modifyModuVerse (const Set.empty) >> splitModuleDecls (S.ModuleName "Split4") result <- diff "testdata/split4-expected" "tmp" @@ -68,13 +68,26 @@ split4b :: Test split4b = TestLabel "Split4b" $ TestCase $ - do system "rsync -aHxs --delete testdata/split4/ tmp" + do _ <- system "rsync -aHxs --delete testdata/split4/ tmp" withCurrentDirectory "tmp" $ runMonadClean $ modifyTestMode (const True) >> modifyModuVerse (const Set.empty) >> splitModule f (S.ModuleName "Split4") result <- diff "testdata/split4b-expected" "tmp" assertEqual "Split4" (ExitSuccess, "", "") result where - f :: DeclName -> S.ModuleName - f x@(Exported (S.Ident "getPackages")) = S.ModuleName "Split4.A" - f x = S.ModuleName "Split4.B" + 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") + +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") + 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 diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +haskell-module-management (0.11.1) unstable; urgency=low + + * Export defaultSymbolToModule + * Allow moduleSplit to leave some symbols in the original module + + -- David Fox Tue, 02 Jul 2013 10:31:13 -0700 + haskell-module-management (0.11) unstable; urgency=low * Rename splitModule -> splitModuleDecls 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 +Version: 0.11.1 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 diff --git a/testdata.tar.gz b/testdata.tar.gz Binary files a/testdata.tar.gz and b/testdata.tar.gz differ