module-management 0.11 → 0.11.1

raw patch · 10 files changed

+115/−89 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Language/Haskell/Modules/Fold.hs +5/−4
• Language/Haskell/Modules/Split.hs +52/−39
• Language/Haskell/Modules/Util/QIO.hs +1/−1
• Language/Haskell/Modules/Util/SrcLoc.hs +1/−0
• Tests.hs +21/−30
• Tests/Imports.hs +8/−8
• Tests/Split.hs +19/−6
• debian/changelog +7/−0
• module-management.cabal +1/−1
• testdata.tar.gz binary

@@ -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'.

@@ -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"

@@ -9,7 +9,7 @@     , noisily     , qIO     , qPutStr-    -- , qPutStrLn+    , qPutStrLn     , qLnPutStr     ) where 

@@ -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)

@@ -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 ()

@@ -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)

@@ -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

@@ -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 <dsf@seereason.com>  Tue, 02 Jul 2013 10:31:13 -0700+ haskell-module-management (0.11) unstable; urgency=low    * Rename splitModule -> splitModuleDecls

@@ -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

binary file changed (634443 → 635072 bytes)