module-management 0.10 → 0.10.1

raw patch · 18 files changed

+846/−535 lines, 18 filessetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Language/Haskell/Modules/Fold.hs +16/−174
• Language/Haskell/Modules/Imports.hs +17/−106
• Language/Haskell/Modules/Internal.hs +8/−10
• Language/Haskell/Modules/Merge.hs +14/−63
• Language/Haskell/Modules/Split.hs +74/−85
• Language/Haskell/Modules/Util/DryIO.hs +5/−5
• Language/Haskell/Modules/Util/QIO.hs +12/−4
• Language/Haskell/Modules/Util/SrcLoc.hs +35/−61
• Language/Haskell/Modules/Util/Test.hs +5/−1
• Setup.hs +5/−4
• Tests.hs +20/−19
• Tests/Fold.hs +202/−0
• Tests/Imports.hs +126/−0
• Tests/Merge.hs +69/−0
• Tests/Split.hs +85/−0
• debian/changelog +146/−0
• module-management.cabal +7/−3
• testdata.tar.gz binary

@@ -13,7 +13,6 @@     , echo2     , ignore     , ignore2-    , tests     ) where  import Control.Applicative ((<$>))@@ -26,6 +25,7 @@ import Data.Map (Map) import Data.Maybe (mapMaybe) import Data.Monoid ((<>), Monoid)+import Data.Sequence (Seq, (|>)) import Data.Set.Extra as Set (fromList) import Data.Tree (Tree(..)) import Language.Haskell.Exts.Annotated (ParseResult(..))@@ -35,7 +35,7 @@ import qualified Language.Haskell.Exts.Syntax as S (ModuleName) import Language.Haskell.Modules.Common (withCurrentDirectory) import Language.Haskell.Modules.Internal (parseFileWithComments, runMonadClean)-import Language.Haskell.Modules.Util.SrcLoc (endLoc, HasSpanInfo(..), increaseSrcLoc, makeTree, srcLoc, srcPairTextHead, srcPairTextTail, srcPairTextPair)+import Language.Haskell.Modules.Util.SrcLoc (endLoc, HasSpanInfo(..), increaseSrcLoc, makeTree, srcLoc, srcPairText, srcPairText) import Test.HUnit (assertEqual, Test(TestList, TestCase, TestLabel))  type Module = A.Module SrcSpanInfo@@ -150,7 +150,7 @@                          (Comment _ csp _ : cs)                              | srcLoc csp <= loc_ st ->                                  -- We reached the comment, skip past it and discard-                                 case srcPairTextPair (loc_ st) (endLoc csp) (text_ st) of+                                 case srcPairText (loc_ st) (endLoc csp) (text_ st) of                                    ("", _) -> return ()                                    (comm, t') ->                                        let loc' = increaseSrcLoc comm (loc_ st) in@@ -191,9 +191,9 @@           do doSep topf              doList pragmaf ps              maybe (return ()) doHeader mh-             doList importf is              (tl, l, sps, r) <- get              put (tl, l, adjustSpans text comments sps, r)+             doList importf is              doList declf ds              doTail sepf       doHeader (A.ModuleHead sp n mw me) =@@ -205,10 +205,9 @@       doClose f sp =           do (tl, l, sps, r) <- get              case l < endLoc sp of-               True -> put (srcPairTextTail l (endLoc sp) tl,-                            endLoc sp,-                            sps,-                            f (srcPairTextHead l (endLoc sp) tl) r)+               True ->+                   let (p, s) = srcPairText l (endLoc sp) tl in+                   put (s, endLoc sp, sps, f p r)                False -> return ()       doTail f =           do (tl, l, sps, r) <- get@@ -221,10 +220,8 @@                    do let l' = srcLoc sp                       case l <= l' of                         True ->-                            do put (srcPairTextTail l l' tl,-                                    l',-                                    sps,-                                    f (srcPairTextHead l l' tl) r)+                            let (p, s) = srcPairText l l' tl in+                            put (s, l', sps, f p 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) ()@@ -237,14 +234,11 @@              let -- Another haskell-src-exts bug?  If a module ends                  -- with no newline, endLoc will be at the beginning                  -- of the following (nonexistant) line.-                 pre = srcPairTextHead l (srcLoc sp) tl-                 tl' = srcPairTextTail l (srcLoc sp) tl+                 (pre, tl') = srcPairText l (srcLoc sp) tl                  l' = endLoc sp-                 s = srcPairTextHead (srcLoc sp) l' tl'-                 tl'' = srcPairTextTail (srcLoc sp) l' tl'+                 (s, tl'') = srcPairText (srcLoc sp) l' tl'                  l'' = adjust1 tl'' l'-                 post = srcPairTextHead l' l'' tl''-                 tl''' = srcPairTextTail l' l'' tl''+                 (post, tl''') = srcPairText l' l'' tl''              put (tl''', l'', sps', f x pre s post r)        -- Move to just past the last newline in the leading whitespace@@ -306,12 +300,12 @@     foldModule ignore2 ignore ignore ignore ignore2 ignore ignore2 ignore declf sepf m r0  -- | This can be passed to foldModule to include the original text in the result-echo :: Monoid m => t -> m -> m -> m -> m -> m-echo _ pref s suff r = r <> pref <> s <> suff+echo :: Monoid m => t -> m -> m -> m -> Seq m -> Seq m+echo _ pref s suff r = r |> pref <> s <> suff  -- | Similar to 'echo', but used for the two argument separator functions-echo2 :: Monoid m => m -> m -> m-echo2 s r = r <> s+echo2 :: Monoid m => m -> Seq m -> Seq m+echo2 s r = r |> s  -- | This can be passed to foldModule to omit the original text from the result. ignore :: t -> m -> m -> m -> r -> r@@ -320,155 +314,3 @@ -- | Similar to 'ignore', but used for the two argument separator functions ignore2 :: m -> r -> r ignore2 _ r = r--tests :: Test-tests = TestLabel "Clean" (TestList [test1, test1b, test3, test4, test5, test5b, test6])--test1 :: Test-test1 =-    TestLabel "test1" $ TestCase $ withCurrentDirectory "testdata/original" $-    do let path = "Debian/Repo/Orphans.hs"-       text <- liftIO $ readFile path-       ParseOk (m, comments) <- runMonadClean $ parseFileWithComments path-       let (output, original) = test (m, text, comments)-       assertEqual "echo" original output-    where-      test :: ModuleInfo -> (String, String)-      test m@(_, text, _) = (foldModule echo2 echo echo echo echo2 echo echo2 echo echo echo2 m "", text)--test1b :: Test-test1b =-    TestLabel "test1b" $ TestCase $ withCurrentDirectory "testdata/original" $-    do let path = "Debian/Repo/Sync.hs"-       text <- liftIO $ readFile path-       ParseOk (m, comments) <- runMonadClean $ parseFileWithComments path-       let output = test (m, text, comments)-       assertEqual "echo" [] (mapMaybe (\ (a, b) -> if a == b then Nothing else Just (a, b)) (zip expected output))-    where-      expected =   [("-- Comment above module head\nmodule ","","",""),-                    ("","Debian.Repo.Sync"," ","[2.8:2.24]"),-                    ("","{-# WARNING \"this is a warning\" #-}","\n","[2.25:2.60]"),-                    ("    ( ","","",""),-                    ("","rsync","\n","[3.7:3.12]"),-                    ("    , ","foo","\n","[4.7:4.10]"),-                    ("    -- Comment after last export\n    ) where","","",""),-                    ("\n\n-- Comment before first import\n\n","import Control.Monad.Trans (MonadIO)","\n","[10.1:10.37]"),-                    ("","import qualified Data.ByteString as B (empty)","\n","[11.1:11.46]"),-                    ("","import System.Exit (ExitCode)","\n","[12.1:12.30]"),-                    ("","import System.FilePath (dropTrailingPathSeparator)","\n","[13.1:13.51]"),-                    ("-- Comment between two imporrts\n","import System.Process (proc)","\n","[15.1:15.29]"),-                    ("","import System.Process.Progress (keepResult, runProcessF)","\n","[16.1:16.57]"),-                    ("\n-- Comment before first decl\n","rsync :: (Functor m, MonadIO m) => [String] -> FilePath -> FilePath -> m ExitCode","\n","[19.1:19.82]"),-                    ("","rsync extra source dest =\n    do result <- runProcessF (proc \"rsync\" ([\"-aHxSpDt\", \"--delete\"] ++ extra ++\n                                            [dropTrailingPathSeparator source ++ \"/\",\n                                             dropTrailingPathSeparator dest])) B.empty >>= return . keepResult\n       case result of\n         [x] -> return x\n         _ -> error \"Missing or multiple exit codes\"","\n","[20.1:29.0]"),-                    ("\n-- Comment between two decls\n","foo :: Int","\n","[29.1:29.11]"),-                    ("","foo = 1","\n","[30.1:30.8]"),-                    ("\n{-\nhandleExit 1 = \"Syntax or usage error\"\nhandleExit 2 = \"Protocol incompatibility\"\nhandleExit 3 = \"Errors selecting input/output files, dirs\"\nhandleExit 4 = \"Requested action not supported: an attempt was made to manipulate 64-bit files on a platform that cannot support them; or an option was specified that is supported by the client and not by the server.\"\nhandleExit 5 = \"Error starting client-server protocol\"\nhandleExit 6 = \"Daemon unable to append to log-file\"\nhandleExit 10 = \"Error in socket I/O\"\nhandleExit 11 = \"Error in file I/O\"\nhandleExit 12 = \"Error in rsync protocol data stream\"\nhandleExit 13 = \"Errors with program diagnostics\"\nhandleExit 14 = \"Error in IPC code\"\nhandleExit 20 = \"Received SIGUSR1 or SIGINT\"\nhandleExit 21 = \"Some error returned by waitpid()\"\nhandleExit 22 = \"Error allocating core memory buffers\"\nhandleExit 23 = \"Partial transfer due to error\"\nhandleExit 24 = \"Partial transfer due to vanished source files\"\nhandleExit 25 = \"The --max-delete limit stopped deletions\"\nhandleExit 30 = \"Timeout in data send/receive\"\nhandleExit 35 = \"Timeout waiting for daemon connection\"\n-}\n","","","")]-      test :: ModuleInfo -> [(String, String, String, String)]-      test m =-          foldModule tailf pragmaf namef warningf tailf exportf tailf importf declf tailf m []-          where-            pragmaf :: ModulePragma -> String -> String -> String -> [(String, String, String, String)] -> [(String, String, String, String)]-            pragmaf x pref s suff r = r ++ [(pref, s, suff,int (spanInfo x))]-            namef :: ModuleName -> String -> String -> String -> [(String, String, String, String)] -> [(String, String, String, String)]-            namef x pref s suff r = r ++ [(pref, s, suff,int (spanInfo x))]-            warningf :: WarningText -> String -> String -> String -> [(String, String, String, String)] -> [(String, String, String, String)]-            warningf x pref s suff r = r ++ [(pref, s, suff,int (spanInfo x))]-            exportf :: ExportSpec -> String -> String -> String -> [(String, String, String, String)] -> [(String, String, String, String)]-            exportf x pref s suff r = r ++ [(pref, s, suff,int (spanInfo x))]-            importf :: ImportDecl -> String -> String -> String -> [(String, String, String, String)] -> [(String, String, String, String)]-            importf x pref s suff r = r ++ [(pref, s, suff,int (spanInfo x))]-            declf :: Decl -> String -> String -> String -> [(String, String, String, String)] -> [(String, String, String, String)]-            declf x pref s suff r = r ++ [(pref, s, suff,int (spanInfo x))]-            tailf :: String -> [(String, String, String, String)] -> [(String, String, String, String)]-            tailf s r = r ++ [(s, "", "", "")]--int :: HasSpanInfo a => a -> String-int x = let (SrcSpanInfo (SrcSpan _ a b c d) _) = spanInfo x in "[" ++ show a ++ "." ++ show b ++ ":" ++ show c ++ "." ++ show d ++ "]"--test3 :: Test-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)-       assertEqual "echo" original output-    where-      test :: ModuleInfo -> (String, String)-      test m@(_, text, _) = (foldModule echo2 echo echo echo echo2 echo echo2 echo echo echo2 m "", text)--test5 :: Test-test5 =-    TestLabel "test5" $ TestCase $-    do let path = "testdata/test5.hs" -- "testdata/logic/Data/Logic/Classes/Literal.hs"-       text <- liftIO $ readFile path-       ParseOk (m, comments) <- runMonadClean $ parseFileWithComments path-       -- 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) []-       assertEqual "spans" expected actual-    where-      expected = [("","a = 1 where","\n"),-                  ("\n{- This makes bad things happen. -}\n\n","b = ()","\n"),-                  ("","","")]--test5b :: Test-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) []-       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",-                   "class (Negatable lit, Constants lit, HasFixity atom, Formula lit atom, Ord lit) => Literal lit atom | lit -> atom where\n    foldLiteral :: (lit -> r) -> (Bool -> r) -> (atom -> r) -> lit -> r",-                   "\n"),-                  ("\n","zipLiterals :: Literal lit atom =>\n               (lit -> lit -> Maybe r)\n            -> (Bool -> Bool -> Maybe r)\n            -> (atom -> atom -> Maybe r)\n            -> lit -> lit -> Maybe r","\n"),-                  ("",-                   "zipLiterals neg tf at fm1 fm2 =\n    foldLiteral neg' tf' at' fm1\n    where\n      neg' p1 = foldLiteral (neg p1) (\\ _ -> Nothing) (\\ _ -> Nothing) fm2\n      tf' x1 = foldLiteral (\\ _ -> Nothing) (tf x1) (\\ _ -> Nothing) fm2\n      at' a1 = foldLiteral (\\ _ -> Nothing) (\\ _ -> Nothing) (at a1) fm2",-                   "\n"),-                  ("\n{- This makes bad things happen.\n-- | We can use an fof type as a lit, but it must not use some constructs.\ninstance FirstOrderFormula fof atom v => Literal fof atom v where\n    foldLiteral neg tf at fm = foldFirstOrder qu co tf at fm\n        where qu = error \"instance Literal FirstOrderFormula\"\n              co ((:~:) x) = neg x\n              co _ = error \"instance Literal FirstOrderFormula\"\n    atomic = Data.Logic.Classes.FirstOrder.atomic\n-}\n\n-- |Just like Logic.FirstOrder.convertFOF except it rejects anything\n-- with a construct unsupported in a normal logic formula,\n-- i.e. quantifiers and formula combinators other than negation.\n",-                   "fromFirstOrder :: forall formula atom v lit atom2.\n                  (Formula lit atom2, FOF.FirstOrderFormula formula atom v, Literal lit atom2) =>\n                  (atom -> atom2) -> formula -> Failing lit",-                   "\n"),-                  ("",-                   "fromFirstOrder ca formula =\n    FOF.foldFirstOrder (\\ _ _ _ -> Failure [\"fromFirstOrder\"]) co (Success . fromBool) (Success . atomic . ca) formula\n    where\n      co :: Combination formula -> Failing lit\n      co ((:~:) f) =  fromFirstOrder ca f >>= return . (.~.)\n      co _ = Failure [\"fromFirstOrder\"]",-                   "\n"),-                  ("\n","fromLiteral :: forall lit atom v fof atom2. (Literal lit atom, FOF.FirstOrderFormula fof atom2 v) =>\n               (atom -> atom2) -> lit -> fof","\n"),-                  ("","fromLiteral ca lit = foldLiteral (\\ p -> (.~.) (fromLiteral ca p)) fromBool (atomic . ca) lit","\n"),-                  ("\n","toPropositional :: forall lit atom pf atom2. (Literal lit atom, P.PropositionalFormula pf atom2) =>\n                   (atom -> atom2) -> lit -> pf","\n"),-                  ("","toPropositional ca lit = foldLiteral (\\ p -> (.~.) (toPropositional ca p)) fromBool (atomic . ca) lit","\n"),-                  ("\n{-\nprettyLit :: forall lit atom term v p f. (Literal lit atom v, Apply atom p term, Term term v f) =>\n              (v -> Doc)\n           -> (p -> Doc)\n           -> (f -> Doc)\n           -> Int\n           -> lit\n           -> Doc\nprettyLit pv pp pf _prec lit =\n    foldLiteral neg tf at lit\n    where\n      neg :: lit -> Doc\n      neg x = if negated x then text {-\"\172\"-} \"~\" <> prettyLit pv pp pf 5 x else prettyLit pv pp pf 5 x\n      tf = text . ifElse \"true\" \"false\"\n      at = foldApply (\\ pr ts -> \n                        pp pr <> case ts of\n                                   [] -> empty\n                                   _ -> parens (hcat (intersperse (text \",\") (map (prettyTerm pv pf) ts))))\n                   (\\ x -> text $ if x then \"true\" else \"false\")\n      -- parensIf False = id\n      -- parensIf _ = parens . nest 1\n-}\n\n","prettyLit :: forall lit atom v. (Literal lit atom) =>\n              (Int -> atom -> Doc)\n           -> (v -> Doc)\n           -> Int\n           -> lit\n           -> Doc","\n"),-                  ("","prettyLit pa pv pprec lit =\n    parensIf (pprec > prec) $ foldLiteral co tf at lit\n    where\n      co :: lit -> Doc\n      co x = if negated x then text {-\"\172\"-} \"~\" <> prettyLit pa pv 5 x else prettyLit pa pv 5 x\n      tf x = text (if x then \"true\" else \"false\")\n      at = pa 6\n      parensIf False = id\n      parensIf _ = parens . nest 1\n      Fixity prec _ = fixityLiteral lit","\n"),-                  ("\n","fixityLiteral :: (Literal formula atom) => formula -> Fixity","\n"),-                  ("","fixityLiteral formula =\n    foldLiteral neg tf at formula\n    where\n      neg _ = Fixity 5 InfixN\n      tf _ = Fixity 10 InfixN\n      at = fixity","\n"),-                  ("\n","foldAtomsLiteral :: Literal lit atom => (r -> atom -> r) -> r -> lit -> r","\n"),-                  ("","foldAtomsLiteral f i lit = foldLiteral (foldAtomsLiteral f i) (const i) (f i) lit","\n"),-                  ("","","")]--test6 :: Test-test6 = TestCase (assertEqual "tree1"-                              (Node {rootLabel = sp 2 20,-                                     subForest = [Node {rootLabel = sp 5 10,-                                                        subForest = [Node {rootLabel = sp 6 7, subForest = []},-                                                                     Node {rootLabel = sp 8 9, subForest = []}]},-                                                  Node {rootLabel = sp 11 18,-                                                        subForest = [Node {rootLabel = sp 12 15, subForest = []}]}]})-                              (makeTree (fromList-                                         [sp 2 20,-                                          sp 5 10,-                                          sp 11 18,-                                          sp 6 7,-                                          sp 8 9,-                                          sp 12 15])))-    where-      sp a b = mkspan (29, a) (29, b)-      mkspan (a, b) (c, d) =-          SrcSpanInfo {srcInfoSpan = SrcSpan {srcSpanFilename = "<unknown>.hs",-                                              srcSpanStartLine = a,-                                              srcSpanStartColumn = b,-                                              srcSpanEndLine = c,-                                              srcSpanEndColumn = d}, srcInfoPoints = []}--test4 :: Test-test4 = TestCase (assertEqual "test4" (SrcLoc "<unknown>.hs" 2 24 < SrcLoc "<unknown>.hs" 29 7) True)

@@ -2,8 +2,6 @@ {-# OPTIONS_GHC -Wall #-} module Language.Haskell.Modules.Imports     ( cleanImports-    -- , cleanBuildImports-    , tests     ) where  import Control.Applicative ((<$>))@@ -11,10 +9,12 @@ 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.Maybe (catMaybes, fromMaybe)-import Data.Monoid ((<>))+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 Language.Haskell.Exts.Annotated.Simplify as S (sImportDecl, sImportSpec, sModuleName, sName)@@ -28,7 +28,7 @@ import Language.Haskell.Modules.Internal (getParams, markForDelete, modifyParams, ModuleResult(..), MonadClean, Params(..), parseFile, parseFileWithComments, runMonadClean, scratchDir) import Language.Haskell.Modules.Params (modifyTestMode) import Language.Haskell.Modules.Util.DryIO (replaceFile, tildeBackup)-import Language.Haskell.Modules.Util.QIO (qPutStrLn, quietly)+import Language.Haskell.Modules.Util.QIO (qLnPutStr, quietly) import Language.Haskell.Modules.Util.Symbols (symbols) import System.Cmd (system) import System.Directory (createDirectoryIfMissing, getCurrentDirectory)@@ -91,7 +91,7 @@        let args' = args ++ ["--make", "-c", "-ddump-minimal-imports", "-outputdir", scratch, "-i" ++ intercalate ":" dirs, path] ++ map (("-X" ++) . show) exts        (code, _out, err) <- liftIO $ readProcessWithExitCode cmd args' ""        case code of-         ExitSuccess -> quietly (qPutStrLn (showCommandForUser cmd args' ++ " -> Ok")) >> return ()+         ExitSuccess -> quietly (qLnPutStr (showCommandForUser cmd args' ++ " -> Ok")) >> return ()          ExitFailure _ -> error ("dumpImports: compile failed\n " ++ showCommandForUser cmd args' ++ " ->\n" ++ err)  -- | Parse the import list generated by GHC, parse the original source@@ -107,7 +107,7 @@            bracket (getParams >>= return . extensions)                    (\ saved -> modifyParams (\ p -> p {extensions = saved}))                    (\ saved -> modifyParams (\ p -> p {extensions = PackageImports : saved}) >>-                               parseFile importsPath `catch` (\ (e :: IOError) -> liftIO (getCurrentDirectory >>= \ here -> throw . userError $ here ++ ": " ++ show e)))+                               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)@@ -117,9 +117,9 @@ 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 =     do remove <- removeEmptyImports <$> getParams-       maybe (qPutStrLn ("cleanImports: no changes to " ++ path) >> return (Unchanged name))+       maybe (qLnPutStr ("cleanImports: no changes to " ++ path) >> return (Unchanged name))              (\ text' ->-                  qPutStrLn ("cleanImports: modifying " ++ path) >>+                  qLnPutStr ("cleanImports: modifying " ++ path) >>                   replaceFile tildeBackup path text' >>                   return (Modified name text'))              (replaceImports (fixNewImports remove m oldImports (newImports ++ extraImports)) m)@@ -129,17 +129,21 @@ -- the imports from the sourceText and insert the new ones. replaceImports :: [A.ImportDecl SrcSpanInfo] -> ModuleInfo -> Maybe String replaceImports newImports m =-    let oldPretty = foldImports (\ _ pref s suff r -> r <> pref <> s <> suff) m ""+    let oldPretty = fold (foldImports (\ _ pref s suff r -> r |> (pref <> s <> suff)) m mempty)         -- Surround newPretty with the same prefix and suffix as oldPretty         newPretty = fromMaybe "" (foldImports (\ _ pref _ _ r -> maybe (Just pref) Just r) m Nothing) <>                     intercalate "\n" (map (prettyPrintWithMode (defaultMode {layout = PPInLine})) newImports) <>-                    foldImports (\ _ _ _ suff _ -> suff) m "" in+                    foldImports (\ _ _ _ suff _ -> suff) m mempty in     if oldPretty == newPretty     then Nothing-    else Just (foldHeader (\ s r -> r <> s) (\ _ pref s suff r -> r <> pref <> s <> suff) (\ _ pref s suff r -> r <> pref <> s <> suff) (\ _ pref s suff r -> r <> pref <> s <> suff) m "" ++-               foldExports (\ s r -> r <> s) (\ _ pref s suff r -> r <> pref <> s <> suff) (\ s r -> r <> s) m "" +++    else Just (fold (foldHeader (\ s r -> r |> s) (\ _ pref s suff r -> r |> (pref <> s <> suff))+                                (\ _ pref s suff r -> r |> pref <> s <> suff)+                                (\ _ pref s suff r -> r |> pref <> s <> suff) m mempty) +++               fold (foldExports (\ s r -> r |> s)+                                 (\ _ pref s suff r -> r |> pref <> s <> suff)+                                 (\ s r -> r |> s) m mempty) ++                newPretty <>-               foldDecls  (\ _ pref s suff r -> r <> pref <> s <> suff) (\ r s -> s <> r) m "")+               fold (foldDecls  (\ _ pref s suff r -> r |> pref <> s <> suff) (\ r s -> s |> r) m mempty))  -- | Final touch-ups - sort and merge similar imports. fixNewImports :: Bool         -- ^ If true, imports that turn into empty lists will be removed@@ -269,96 +273,3 @@ nameString :: S.Name -> String nameString (S.Ident s) = s nameString (S.Symbol s) = s--tests :: Test-tests = TestLabel "Clean" (TestList [test1, test2, test3, test4, test5, test6])--test1 :: Test-test1 =-    TestLabel "Imports.test1" $ TestCase-      (do _ <- system "rsync -aHxS --delete testdata/original/ testdata/copy"-          let name = S.ModuleName "Debian.Repo.Types.PackageIndex"-          let base = modulePathBase name-          _ <- withCurrentDirectory "testdata/copy" (runMonadClean (cleanImports base))-          (code, diff, err) <- readProcessWithExitCode "diff" ["-ru", "testdata/original" </> base, "testdata/copy" </> base] ""-          assertEqual "cleanImports"-                         (ExitFailure 1,-                          ["@@ -22,13 +22,13 @@",-                           "     , prettyPkgVersion",-                           "     ) where",-                           " ",-                           "-import Data.Text (Text, map)",-                           "+import Data.Text (Text)",-                           " import Debian.Arch (Arch(..))",-                           " import qualified Debian.Control.Text as T (Paragraph)",-                           " import Debian.Relation (BinPkgName(..), SrcPkgName(..))",-                           " import qualified Debian.Relation as B (PkgName, Relations)",-                           " import Debian.Release (Section(..))",-                           "-import Debian.Repo.Orphans ({- instances -})",-                           "+import Debian.Repo.Orphans ()",-                           " import Debian.Version (DebianVersion, prettyDebianVersion)",-                           " import System.Posix.Types (FileOffset)",-                           " import Text.PrettyPrint.ANSI.Leijen ((<>), Doc, Pretty(pretty), text)"],-                          "")-                          (code, drop 2 (lines diff), err))--test2 :: Test-test2 =-    TestLabel "Imports.test2" $ TestCase-      (do _ <- system "rsync -aHxS --delete testdata/original/ testdata/copy"-          let name = S.ModuleName "Debian.Repo.PackageIndex"-              base = modulePathBase name-          _ <- withCurrentDirectory "testdata/copy" (runMonadClean (cleanImports base))-          (code, diff, err) <- readProcessWithExitCode "diff" ["-ru", "testdata/original" </> base, "testdata/copy" </> base] ""-          assertEqual "cleanImports" (ExitSuccess, "", "") (code, diff, err))---- | Can we handle a Main module in a file named something other than Main.hs?-test3 :: Test-test3 =-    TestLabel "Imports.test3" $ TestCase-      (runMonadClean (modifyParams (\ p -> p {sourceDirs = ["testdata"]}) >> cleanImports "testdata/NotMain.hs") >>-       assertEqual "module name" () ())---- | Preserve imports with a "hiding" clause-test4 :: Test-test4 =-    TestLabel "Imports.test4" $ TestCase-      (system "cp testdata/HidingOrig.hs testdata/Hiding.hs" >>-       runMonadClean (modifyParams (\ p -> p {sourceDirs = ["testdata"]}) >> cleanImports "testdata/Hiding.hs") >>-       -- Need to check the text of Hiding.hs, but at least this verifies that there was no crash-       assertEqual "module name" () ())---- | Preserve imports used by a standalone deriving declaration-test5 :: Test-test5 =-    TestLabel "Imports.test5" $ TestCase-      (do _ <- system "cp testdata/DerivingOrig.hs testdata/Deriving.hs"-          _ <- runMonadClean (modifyParams (\ p -> p {extensions = extensions p ++ [StandaloneDeriving, TypeSynonymInstances, FlexibleInstances],-                                                  sourceDirs = ["testdata"]}) >>-                          cleanImports "testdata/Deriving.hs")-          (code, diff, err) <- readProcessWithExitCode "diff" ["-ru", "testdata/DerivingOrig.hs", "testdata/Deriving.hs"] ""-          assertEqual "standalone deriving"-                      (ExitFailure 1,-                       (unlines-                        ["@@ -1,7 +1,6 @@",-                         " module Deriving where",-                         " ",-                         "-import Data.Text (Text)",-                         "-import Debian.Control (Paragraph(..), Paragraph'(..), Field'(..))",-                         "+import Debian.Control (Field'(..), Paragraph(..))",-                         " ",-                         " deriving instance Show (Field' String)",-                         " deriving instance Show Paragraph"]),-                       "")-                      (code, unlines (drop 2 (lines diff)), err))---- | Comment at EOF-test6 :: Test-test6 =-    TestLabel "Imports.test6" $ TestCase-      (do -- _ <- system "rsync -aHxS --delete testdata/logic/ testdata/copy"-          _ <- system "cp testdata/EndCommentOrig.hs testdata/EndComment.hs"-          let path = "EndComment.hs" -- "Data/Logic/Harrison/Tableaux.hs"-          _ <- withCurrentDirectory "testdata" (runMonadClean (modifyTestMode (const True) >> cleanImports "EndComment.hs"))-          (code, diff, err) <- readProcessWithExitCode "diff" ["-ru", "testdata/EndCommentClean.hs", "testdata" </> "EndComment.hs"] ""-          assertEqual "comment at end" "" diff)

@@ -27,7 +27,7 @@ import qualified Language.Haskell.Exts.Syntax as S (ModuleName) import Language.Haskell.Modules.Common (modulePathBase) import Language.Haskell.Modules.Util.DryIO (createDirectoryIfMissing, MonadDryRun(..), removeFileIfPresent, replaceFile, tildeBackup)-import Language.Haskell.Modules.Util.QIO (MonadVerbosity(..), qPutStr, qPutStrLn, quietly)+import Language.Haskell.Modules.Util.QIO (MonadVerbosity(..), qPutStr, qLnPutStr, quietly) import Language.Haskell.Modules.Util.Temp (withTempDirectory) import Prelude hiding (writeFile) import System.Directory (doesFileExist, getCurrentDirectory, removeFile)@@ -141,7 +141,7 @@ -- 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) `catch` (\ (_ :: IOError) -> makePath)+    findSourcePath (modulePathBase name) `IO.catch` (\ (_ :: IOError) -> makePath)     where       makePath =           do dirs <- sourceDirs <$> getParams@@ -165,27 +165,25 @@ -- the other hand, we might be able to maintain the moduVerse here. doResult :: MonadClean m => ModuleResult -> m ModuleResult doResult x@(Unchanged _name) =-    do quietly (qPutStrLn ("unchanged: " ++ show _name))+    do quietly (qLnPutStr ("unchanged: " ++ show _name))        return x doResult x@(Removed name) =     do path <- modulePath name        -- I think this event handler is redundant.-       removeFileIfPresent path `catch` (\ (e :: IOError) -> if isDoesNotExistError e then return () else throw e)+       removeFileIfPresent path `IO.catch` (\ (e :: IOError) -> if isDoesNotExistError e then return () else throw e)        return x  doResult x@(Modified name text) =     do path <- modulePath name-       qPutStr ("modifying " ++ show path)-       quietly (qPutStr (" new text: " ++ show text))-       qPutStr "\n"+       qLnPutStr ("modifying " ++ show path)+       (quietly . quietly . quietly . qPutStr $ " new text: " ++ show text)        replaceFile tildeBackup path text        return x  doResult x@(Created name text) =     do path <- modulePath name-       qPutStr ("creating " ++ show path)-       quietly (qPutStr (" containing " ++ show text))-       qPutStr "\n"+       qLnPutStr ("creating " ++ show path)+       (quietly . quietly . quietly . qPutStr $ " containing " ++ show text)        createDirectoryIfMissing True (takeDirectory . dropExtension $ path)        replaceFile tildeBackup path text        return x

@@ -2,19 +2,17 @@ {-# OPTIONS_GHC -Wall #-} module Language.Haskell.Modules.Merge     ( mergeModules-    , tests-    , test1-    , test2-    , test3     ) where  import Control.Monad as List (mapM) import Control.Monad.Trans (liftIO)+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.Monoid ((<>))+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)@@ -77,8 +75,8 @@ doOutput inputInfo inNames outName m =     header ++ exports ++ imports ++ decls     where-      header = foldHeader echo2 echo (\ _ pref _ suff r -> r <> pref <> prettyPrint outName <> suff) echo m "" <>-               foldExports (\ s r -> r <> s <> maybe "" (intercalate ", " . List.map (prettyPrint)) (mergeExports inputInfo outName) <> "\n") ignore ignore2 m ""+      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@@ -91,10 +89,10 @@ -- (Shouldn't this also fix qualified symbols?) doOther :: [S.ModuleName] -> S.ModuleName -> ModuleInfo -> String doOther inputs output m =-    foldHeader echo2 echo echo echo m "" <>-    foldExports echo2 (\ x pref s suff r -> r <> pref <> fromMaybe s (fixModuleExport inputs output (sExportSpec x)) <> suff) echo2 m "" <>-    foldImports (\ x pref s suff r -> r <> pref <> fromMaybe s (fixModuleImport inputs output (sImportDecl x)) <> suff) m "" <>-    foldDecls echo echo2 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 =@@ -153,13 +151,11 @@ moduleDecls oldmap new name =     let (Just m@(A.Module _ _ _ imports _, _, _)) = Map.lookup name oldmap in     let oldmap' = foldr f oldmap imports in-    foldDecls (\ d pref s suff r ->-                    let d' = sDecl d-                        d'' = fixReferences oldmap' new d' in-                    r <> pref <>-                    (if d'' /= d' then prettyPrint d'' else s) <> suff)-              echo2-              m "" <> "\n"+    fold (foldDecls (\ d pref s suff r ->+                         let d' = sDecl d+                             d'' = fixReferences oldmap' new d' in+                         r |> pref <> (if d'' /= d' then prettyPrint d'' else s) <> suff)+                    echo2 m mempty)     where       f (A.ImportDecl _ m _ _ _ (Just a) _specs) mp =           case Map.lookup (sModuleName m) oldmap of@@ -177,51 +173,6 @@     where       moveModuleName :: S.ModuleName -> S.ModuleName       moveModuleName name@(S.ModuleName _) = if Map.member name oldmap then new else name--tests :: Test-tests = TestList [test1, test2, test3]--test1 :: Test-test1 =-    TestCase $-      do _ <- system "rsync -aHxS --delete testdata/original/ testdata/copy"-         _result <- runMonadClean $-           do modifyParams (\ p -> p {sourceDirs = ["testdata/copy"], moduVerse = Just repoModules})-              mergeModules-                     [S.ModuleName "Debian.Repo.AptCache", S.ModuleName "Debian.Repo.AptImage"]-                     (S.ModuleName "Debian.Repo.Cache")-              -- mapM_ (removeFileIfPresent . ("testdata/copy" </>)) junk-         (code, out, err) <- diff "testdata/mergeresult1" "testdata/copy"-         assertEqual "mergeModules1" (ExitSuccess, "", "") (code, out, err)--test2 :: Test-test2 =-    TestCase $-      do _ <- system "rsync -aHxS --delete testdata/original/ testdata/copy"-         _result <- runMonadClean $-           do modifyParams (\ p -> p {sourceDirs = ["testdata/copy"], moduVerse = Just 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")-              -- mapM_ (removeFileIfPresent . ("testdata/copy" </>)) junk-         (code, out, err) <- diff "testdata/mergeresult2" "testdata/copy"-         assertEqual "mergeModules2" (ExitSuccess, "", "") (code, out, err)--test3 :: Test-test3 =-    TestCase $-      do _ <- system "rsync -aHxS --delete testdata/original/ testdata/copy"-         _result <- withCurrentDirectory "testdata/copy" $-                   runMonadClean $-           do modifyParams (\ p -> p {moduVerse = Just 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.Slice")-              -- mapM_ (removeFileIfPresent . ("testdata/copy" </>)) junk-         (code, out, err) <- diff "testdata/mergeresult3" "testdata/copy"-         assertEqual "mergeModules3" (ExitSuccess, "", "") (code, out, err)  -- junk :: String -> Bool -- junk s = isSuffixOf ".imports" s || isSuffixOf "~" s

@@ -2,7 +2,6 @@ {-# OPTIONS_GHC -Wall #-} module Language.Haskell.Modules.Split     ( splitModule-    , tests     ) where  import Control.Exception (throw)@@ -10,10 +9,12 @@ import Control.Monad.Trans (liftIO) 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, insertWith, lookup, Map, mapWithKey) import Data.Maybe (fromMaybe, mapMaybe)-import Data.Monoid ((<>))+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))@@ -22,18 +23,28 @@ import Language.Haskell.Exts.Pretty (defaultMode, prettyPrint, prettyPrintWithMode) import Language.Haskell.Exts.SrcLoc (SrcSpanInfo(..)) import qualified Language.Haskell.Exts.Syntax as S (ImportDecl(..), ModuleName(..), Name(..))+import Language.Haskell.Modules.Common (withCurrentDirectory) import Language.Haskell.Modules.Fold (ModuleInfo, echo, echo2, foldDecls, foldExports, foldHeader, foldImports, foldModule, ignore, ignore2) import Language.Haskell.Modules.Imports (cleanImports) import Language.Haskell.Modules.Internal (doResult, modifyParams, modulePath, ModuleResult(..), MonadClean(getParams), Params(moduVerse, sourceDirs, testMode), parseFileWithComments, runMonadClean)+import Language.Haskell.Modules.Params (modifyModuVerse)+import Language.Haskell.Modules.Util.QIO (quietly, qLnPutStr) import Language.Haskell.Modules.Util.Symbols (exports, imports, symbols) import Language.Haskell.Modules.Util.Test (diff, repoModules) import Prelude hiding (writeFile) import System.Cmd (system) import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import System.FilePath ((<.>))-import Test.HUnit (assertEqual, Test(TestCase, TestList))+import Test.HUnit (assertEqual, Test(TestCase, TestList, TestLabel)) -setAny :: (a -> Bool) -> Set a -> Bool+data DeclName+    = Exported S.Name -- Maybe because...?+    | Internal S.Name+    | ReExported S.Name+    | Instance+    deriving (Eq, Ord, Show)++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@@ -71,7 +82,7 @@ -- would go into @Start.Instances@. splitModule :: MonadClean m => S.ModuleName -> m () splitModule old =-    do univ <- getParams >>= return . fromMaybe (error "moduVerse not set") . moduVerse+    do univ <- getParams >>= return . fromMaybe (error "moduVerse not set, use modifyModuVerse") . moduVerse        path <- modulePath old        text <- liftIO $ readFile path        (parsed, comments) <- parseFileWithComments path >>= return . fromParseResult@@ -111,17 +122,15 @@ 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 univ m@(A.Module _ (Just (A.ModuleHead _ moduleName _ (Just _))) _ _ _, _, _) =-    Set.mapM (updateImports (sModuleName moduleName) symbolToModule) univ' >>= return . union splitModules+doSplit univ m@(A.Module _ (Just (A.ModuleHead _ moduleName _ _)) _ _ _, _, _) =+    qLnPutStr ("Splitting " ++ show moduleName) >>+    Set.mapM (updateImports reExported internal (sModuleName moduleName) symbolToModule) univ' >>=+    return . union splitModules     where+      symbolToModule = defaultSymbolToModule m reExported internal old       -- The name of the module to be split       old = sModuleName moduleName-      -- 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 = foldDecls (\ d pref s suff r -> Set.fold (\ sym mp -> insertWith (++) (subModuleName reExported internal old sym) [(d, pref <> s <> suff)] mp) r (symbols d)) ignore2 m Map.empty-       -- 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.@@ -148,20 +157,6 @@           union (Set.map newModule newModuleNames)                 (if member old newModuleNames then Set.empty else singleton (Removed old)) -      -- Map from symbol name to the module that symbol will move to-      symbolToModule :: Map (Maybe S.Name) S.ModuleName-      symbolToModule =-          mp'-          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.insertWith-                   (\ a b -> if a /= b then error ("symbolToModule - two modules for " ++ show sym ++ ": " ++ show (a, b)) else a)-                   sym-                   (subModuleName reExported internal old sym)-                   mp''-       -- Build a new module given its name and the list of       -- declarations it should contain.       newModule :: S.ModuleName -> ModuleResult@@ -170,23 +165,28 @@           case Map.lookup name' moduleDeclMap of             Nothing ->                 -- Build a module that re-exports a symbol-                foldHeader echo2 echo (\ _n pref _ suff r -> r <> pref <> modName <> suff) echo m "" <>-                foldExports echo2 ignore ignore2 m "" <>-                doSeps (foldExports ignore2 (\ e pref s suff r -> r <> if setAny (`member` reExported) (justs (symbols e)) then [(pref, s <> suff)] else []) (\ s r -> r ++ [("", s)]) m []) <>-                foldImports (\ _i pref s suff r -> r <> pref <> s <> suff) m ""+                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 (`member` reExported) (justs (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-                foldHeader echo2 echo (\ _n pref _ suff r -> r <> pref <> modName <> suff) echo m "" <>-                "    ( " {-foldExports echo2 ignore ignore2 m text ""-} <>-                intercalate "\n    , " (nub (List.map (prettyPrintWithMode defaultMode) (newExports modDecls))) <>-                "\n    ) where" {-foldExports ignore2 ignore echo2 m text ""-} <>+                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) <> "\n"+                concatMap snd (reverse modDecls)               where                 -- Build export specs of the symbols created by each declaration.                 newExports modDecls = nub (concatMap (exports . fst) modDecls)@@ -199,24 +199,30 @@                 -- In this module, we need to import any module that declares a symbol                 -- referenced here.                 referenced modDecls = Set.map sName (gFind modDecls :: Set (A.Name SrcSpanInfo))-doSplit _ _ = error "splitModule'" +      -- 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 (++) (subModuleName reExported internal old sym) [(d, pref <> s <> suff)] mp) r (symbols d)) ignore2 m Map.empty+ -- Re-construct a separated list doSeps :: [(String, String)] -> String doSeps [] = "" doSeps ((_, hd) : tl) = hd <> concatMap (\ (a, b) -> a <> b) tl  -- | Update the imports to reflect the changed module names in symbolToModule.-updateImports :: MonadClean m => S.ModuleName -> Map (Maybe S.Name) S.ModuleName -> S.ModuleName -> m ModuleResult-updateImports old symbolToModule name =+updateImports :: MonadClean m => Set S.Name -> Set S.Name -> S.ModuleName -> Map DeclName S.ModuleName -> S.ModuleName -> m ModuleResult+updateImports reExported internal 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'' = foldModule echo2 echo echo echo echo2 echo echo2-                          (\ i pref s suff r -> r <> pref <> updateImportDecl s i <> suff)-                          echo echo2 (m', text', comments') "" in+             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@@ -231,7 +237,7 @@       updateImportSpecs i Nothing = List.map (\ x -> (sImportDecl i) {S.importModule = x}) (Map.elems symbolToModule)       -- If flag is True this is a "hiding" import       updateImportSpecs i (Just (A.ImportSpecList _ flag specs)) =-          concatMap (\ spec -> let xs = mapMaybe (\ sym -> Map.lookup sym symbolToModule) (toList (symbols spec)) in+          concatMap (\ spec -> let xs = mapMaybe (\ sym -> Map.lookup (declName reExported internal sym) symbolToModule) (toList (symbols spec)) in                                List.map (\ x -> (sImportDecl i) {S.importModule = x, S.importSpecs = Just (flag, [sImportSpec spec])}) xs) specs  {-@@ -261,6 +267,20 @@ splitModule' _ _ _ = error "splitModule'" -} +-- | Map from symbol name to the module that symbol will move to+defaultSymbolToModule :: ModuleInfo -> Set S.Name -> Set S.Name -> S.ModuleName -> Map DeclName S.ModuleName+defaultSymbolToModule m reExported internal old =+    mp'+    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.insertWith+            (\ a b -> if a /= b then error ("symbolToModule - two modules for " ++ show sym ++ ": " ++ show (a, b)) else a)+            (declName  reExported internal sym)+            (subModuleName reExported internal old sym)+            mp''+ -- | What module should this symbol be moved to? subModuleName :: Set S.Name -> Set S.Name -> S.ModuleName -> Maybe S.Name -> S.ModuleName subModuleName reExported internal (S.ModuleName moduleName) name =@@ -281,6 +301,18 @@                   (c : s) | isAlpha c -> toUpper c : List.filter isAlphaNum s                   _ -> "OtherSymbols" +declName :: Set S.Name -> Set S.Name -> Maybe S.Name -> DeclName+declName reExported internal name =+    case name of+      Nothing -> Instance+      Just name' ->+          if member name' reExported+          then ReExported name'+          else if member name' internal+               then Internal name'+               else Exported name'++ -- | Build an import of the symbols created by a declaration. toImportDecl :: S.ModuleName -> [(A.Decl SrcSpanInfo, String)] -> S.ImportDecl toImportDecl (S.ModuleName modName) decls =@@ -291,46 +323,3 @@                   S.importPkg = Nothing,                   S.importAs = Nothing,                   S.importSpecs = Just (False, nub (concatMap (imports . fst) decls))}--tests :: Test-tests = TestList [test1, test2, test3]--test1 :: Test-test1 =-    TestCase $-      do _ <- system "rsync -aHxS --delete testdata/original/ testdata/copy"-         runMonadClean $-           do modifyParams (\ p -> p {sourceDirs = ["testdata/copy"], moduVerse = Just repoModules})-              splitModule (S.ModuleName "Debian.Repo.Package")-         (code, out, err) <- diff "testdata/splitresult" "testdata/copy"-         assertEqual "splitModule" (ExitFailure 1, "diff -ru '--exclude=*~' '--exclude=*.imports' testdata/splitresult/Debian/Repo/Package/BinaryPackagesOfIndex.hs testdata/copy/Debian/Repo/Package/BinaryPackagesOfIndex.hs\n--- testdata/splitresult/Debian/Repo/Package/BinaryPackagesOfIndex.hs\n+++ testdata/copy/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+      _ -> liftIO $ getPackages repo release index \n", "") (code, out, err)--test2 :: Test-test2 =-    TestCase $-    do _ <- system "rsync -aHxS --delete testdata/split2/ testdata/copy"-       runMonadClean $-         do modifyParams (\ p -> p {testMode = True,-                                    sourceDirs = ["testdata/copy"],-                                    -- extensions = NoImplicitPrelude : extensions p,-                                    moduVerse = Just (singleton (S.ModuleName "Split"))})-            splitModule (S.ModuleName "Split")-       (code, out, err) <- diff "testdata/split2-result" "testdata/copy"-       assertEqual "split2" (ExitSuccess, "", "") (code, out, err)--test3 :: Test-test3 =-    TestCase $-    do _ <- system "rsync -aHxS --delete testdata/split2/ testdata/copy"-       runMonadClean $-         do modifyParams (\ p -> p {testMode = False,-                                    sourceDirs = ["testdata/copy"],-                                    -- extensions = NoImplicitPrelude : extensions p,-                                    moduVerse = Just (singleton (S.ModuleName "Split"))})-            splitModule (S.ModuleName "Split")-       (code, out, err) <- diff "testdata/split2-clean-result" "testdata/copy"-       -- 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-result/Split/Clean.hs testdata/copy/Split/Clean.hs\n--- testdata/split2-clean-result/Split/Clean.hs\n+++ testdata/copy/Split/Clean.hs\n@@ -6,7 +6,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)

@@ -15,7 +15,7 @@     ) where  import Control.Applicative ((<$>))-import Control.Exception (catch, throw)+import Control.Exception as E (catch, throw) import Control.Monad.Trans (liftIO, MonadIO) import Prelude hiding (writeFile) import System.Directory (removeFile, renameFile)@@ -30,10 +30,10 @@ noBackup = const Nothing  readFileMaybe :: FilePath -> IO (Maybe String)-readFileMaybe path = (Just <$> readFile path) `catch` (\ (e :: IOError) -> if isDoesNotExistError e then return Nothing else throw e)+readFileMaybe path = (Just <$> readFile path) `E.catch` (\ (e :: IOError) -> if isDoesNotExistError e then return Nothing else throw e)  removeFileIfPresent :: MonadDryRun m => FilePath -> m ()-removeFileIfPresent path = dryIO' (putStrLn $ "dry run: removeFileIfPresent " ++ path) (removeFile path `catch` (\ (e :: IOError) -> if isDoesNotExistError e then return () else throw e))+removeFileIfPresent path = dryIO' (putStrLn $ "dry run: removeFileIfPresent " ++ path) (removeFile path `E.catch` (\ (e :: IOError) -> if isDoesNotExistError e then return () else throw e))  replaceFileIfDifferent :: MonadDryRun m => FilePath -> String -> m Bool replaceFileIfDifferent path newText =@@ -47,8 +47,8 @@ replaceFile backup path text =     dryIO' (putStrLn $ "dry run: replaceFile " ++ path) (remove >> rename >> write)     where-      remove = maybe (return ()) removeFile (backup path) `catch` (\ (e :: IOError) -> if isDoesNotExistError e then return () else throw e)-      rename = maybe (return ()) (renameFile path) (backup path) `catch` (\ (e :: IOError) -> if isDoesNotExistError e then return () else throw e)+      remove = maybe (return ()) removeFile (backup path) `E.catch` (\ (e :: IOError) -> if isDoesNotExistError e then return () else throw e)+      rename = maybe (return ()) (renameFile path) (backup path) `E.catch` (\ (e :: IOError) -> if isDoesNotExistError e then return () else throw e)       write = IO.writeFile path text  createDirectoryIfMissing :: MonadDryRun m => Bool -> String -> m ()

@@ -9,7 +9,8 @@     , noisily     , qIO     , qPutStr-    , qPutStrLn+    -- , qPutStrLn+    , qLnPutStr     ) where  import Control.Monad (when)@@ -41,8 +42,15 @@     do v <- getVerbosity        when (v > 0) action -qPutStrLn :: MonadVerbosity m => String -> m ()-qPutStrLn = qIO . liftIO . putStrLn- qPutStr :: MonadVerbosity m => String -> m () qPutStr = qIO . liftIO . putStr++qPutStrLn :: MonadVerbosity m => String -> m ()+qPutStrLn s =+    qIO $ do v <- getVerbosity+             liftIO $ putStrLn (replicate (5 - min 5 v) ' ' ++ s)++qLnPutStr :: MonadVerbosity m => String -> m ()+qLnPutStr s =+    qIO $ do v <- getVerbosity+             liftIO $ putStr  ("\n" ++ replicate (5 - min 5 v) ' ' ++ s)

@@ -8,13 +8,12 @@     , textEndLoc     , increaseSrcLoc     , textSpan-    , srcPairTextHead-    , srcPairTextTail-    , srcPairTextPair+    , srcPairText     , makeTree     , tests     ) where +import Control.Monad.State (State, runState, get, put) import Data.Default (def, Default) import Data.List (groupBy, partition, sort) import Data.Set (Set, toList)@@ -169,78 +168,53 @@ tests = TestList [test1, test2, test3, test4, test5]  test1 :: Test-test1 = TestCase (assertEqual "srcPairTextTail1" "hi\tjkl\n" (srcPairTextTail (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.hs" 2 2) "abc\tdef\nghi\tjkl\n"))+test1 = TestCase (assertEqual "srcPairTextTail1" "hi\tjkl\n" (snd (srcPairText (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.hs" 2 2) "abc\tdef\nghi\tjkl\n"))) test2 :: Test-test2 = TestCase (assertEqual "srcPairTextTail2" "kl\n" (srcPairTextTail (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.hs" 2 9) "abc\tdef\nghi\tjkl\n"))+test2 = TestCase (assertEqual "srcPairTextTail2" "kl\n" (snd (srcPairText (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.hs" 2 9) "abc\tdef\nghi\tjkl\n"))) test3 :: Test-test3 = TestCase (assertEqual "srcPairTextHead1" "abc\tdef\ng" (srcPairTextHead (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.hs" 2 2) "abc\tdef\nghi\tjkl\n"))+test3 = TestCase (assertEqual "srcPairTextHead1" "abc\tdef\ng" (fst (srcPairText (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.hs" 2 2) "abc\tdef\nghi\tjkl\n"))) test4 :: Test-test4 = TestCase (assertEqual "srcPairTextHead21" "abc\tdef\nghi\tj" (srcPairTextHead (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.hs" 2 9) "abc\tdef\nghi\tjkl\n"))+test4 = TestCase (assertEqual "srcPairTextHead21" "abc\tdef\nghi\tj" (fst (srcPairText (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.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"-                              (srcPairTextTail+                              (snd+                               (srcPairText                                  (SrcLoc "<unknown>.hs" 1 77)                                  (SrcLoc "<unknown>.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"))+                                 "\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}) [] --- | Return the beginning portion of s which the span b thru e covers,--- assuming that the beginning of s is at position b - that is, that--- the prefix of s from (1,1) to b has already been removed.-srcPairTextHead :: SrcLoc -> SrcLoc -> String -> String-srcPairTextHead b0 e0 s0 =-    f b0 e0 [] s0+srcPairText :: SrcLoc -> SrcLoc -> String -> (String, String)+srcPairText b0 e0 s0 =+    fst $ runState f (b0, e0, "", s0)     where-      f b e r s =-          if srcLine b < srcLine e-          then case span (/= '\n') s of-                 (r', '\n' : s') ->-                     f (b {srcLine = srcLine b + 1, srcColumn = 1}) e ("\n" : r' : r) s'-                 (_, "") ->-                     -- This should not happen, but if the last line-                     -- lacks a newline terminator, haskell-src-exts-                     -- will set the end location as if the terminator-                     -- was present.-                     case s of-                       "" -> concat (reverse r)-                       ('\t' : s') -> f (b {srcColumn = ((srcColumn b + 7) `div` 8) * 8}) e (['\t'] : r) s'-                       (c : s') -> f (b {srcColumn = srcColumn b + 1}) e ([c] : r) s'-                 _ -> error $ "srcPairTextHead: " ++ show (b, e, s)-          else if srcColumn b < srcColumn e-               then case s of-                      [] -> error $ "srcPairTextHead: " ++ show (b0, e0, s0)-                      ('\t' : s') -> f (b {srcColumn = ((srcColumn b + 7) `div` 8) * 8}) e (['\t'] : r) s'-                      (c : s') -> f (b {srcColumn = srcColumn b + 1}) e ([c] : r) s'-               else concat (reverse r)---- | Like srcPairTextHead, but returns the tail of s instead of the head.-srcPairTextTail :: SrcLoc -> SrcLoc -> String -> String-srcPairTextTail b e s =-    if srcLine b < srcLine e-    then case dropWhile (/= '\n') s of-           ('\n' : s') -> srcPairTextTail (b {srcLine = srcLine b + 1, srcColumn = 1}) e s'-           -- This should not happen, but if the last line lacks a-           -- newline terminator, haskell-src-exts will set the end-           -- location as if the terminator was present.-           [] -> case s of-                   [] -> ""-                   ('\t' : s') -> srcPairTextTail (b {srcColumn = ((srcColumn b + 7) `div` 8) * 8}) e s'-                   (_ : s') -> srcPairTextTail (b {srcColumn = srcColumn b + 1}) e s'-           _ -> error $ "srcPairTextTail: b=" ++ show b ++ ", e=" ++ show e ++ ", s = " ++ show s-    else if srcColumn b < srcColumn e-         then case s of-                [] -> error $ "srcPairTextTail: b=" ++ show b ++ ", e=" ++ show e ++ ", s = " ++ show s-                ('\t' : s') -> srcPairTextTail (b {srcColumn = ((srcColumn b + 7) `div` 8) * 8}) e s'-                (_ : s') -> srcPairTextTail (b {srcColumn = srcColumn b + 1}) e s'-         else s---- | Shirley there's a more efficient way to do this?-srcPairTextPair :: SrcLoc -> SrcLoc -> String -> (String, String)-srcPairTextPair b e s = (srcPairTextHead b e s, srcPairTextTail b e s)+      f :: State (SrcLoc, SrcLoc, String, String) (String, String)+      f = do (b, e, r, s) <- get+             case (srcLine b < srcLine e, srcColumn b < srcColumn e) of+               (True, _) ->+                   case span (/= '\n') s of+                     (r', '\n' : s') ->+                         put (b {srcLine = srcLine b + 1, srcColumn = 1}, e, r ++ r' ++ "\n", s') >> f+                     (_, "") ->+                        -- This should not happen, but if the last line+                        -- lacks a newline terminator, haskell-src-exts+                        -- will set the end location as if the terminator+                        -- 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+               (_, 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 "<unknown>.hs" 1 1

@@ -3,6 +3,7 @@     , logicModules     , diff     , diff'+    , rsync     , findModules     , findPaths     ) where@@ -14,7 +15,7 @@ import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents) import System.Exit (ExitCode) import System.FilePath ((</>))-import System.Process (readProcessWithExitCode)+import System.Process (readProcess, readProcessWithExitCode)  repoModules :: Set S.ModuleName repoModules =@@ -130,6 +131,9 @@     do (code, out, err) <- readProcessWithExitCode "diff" ["-ru", "--unidirectional-new-file", "--exclude=*~", "--exclude=*.imports", a, b] ""        let out' = unlines (List.filter (not . isPrefixOf "Binary files") . List.map (takeWhile (/= '\t')) $ (lines out))        return (code, out', err)++rsync :: FilePath -> FilePath -> IO ()+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)

@@ -10,7 +10,8 @@ import System.FilePath ((</>))  main = defaultMainWithHooks simpleUserHooks-       -- {-       --   postBuild = \ _ _ _ lbi -> do code <- system (buildDir lbi </> "tests/tests")-       --                                 if code == ExitSuccess then putStrLn "Tests passed" else error "Tests failed"-       -- }+         { sDistHook = \ p l u f ->+             system "tar cfz testdata.tar.gz testdata" >> (sDistHook simpleUserHooks) p l u f+         -- , postBuild = \ _ _ _ lbi -> do code <- system (buildDir lbi </> "tests/tests")+         --                               if code == ExitSuccess then putStrLn "Tests passed" else error "Tests failed"+         }

@@ -11,28 +11,29 @@ import Language.Haskell.Exts.Syntax (ModuleName(ModuleName)) import Language.Haskell.Exts.SrcLoc (SrcSpanInfo) import Language.Haskell.Modules (splitModule, mergeModules)-import qualified Language.Haskell.Modules.Merge as Merge (tests)+import qualified Tests.Merge as Merge (tests) import Language.Haskell.Modules.Common (withCurrentDirectory)-import qualified Language.Haskell.Modules.Fold as Fold (tests)-import qualified Language.Haskell.Modules.Imports as Imports (tests)+import qualified Tests.Fold as Fold (tests)+import qualified Tests.Imports as Imports (tests) import Language.Haskell.Modules.Internal (MonadClean, Params(extensions, moduVerse), runMonadClean, modifyParams)-import qualified Language.Haskell.Modules.Split as Split (tests)-import Language.Haskell.Modules.Util.QIO (noisily, qPutStrLn)-import Language.Haskell.Modules.Util.Test (logicModules, diff')+import qualified Tests.Split as Split (tests)+import Language.Haskell.Modules.Util.QIO (noisily, qLnPutStr)+import Language.Haskell.Modules.Util.Test (logicModules, diff', rsync) import System.Exit (ExitCode(ExitSuccess, ExitFailure), exitWith)-import System.Process (readProcess)+import System.Process (system, readProcess) import Test.HUnit (assertEqual, Counts(..), runTestTT, Test(TestList, TestCase, TestLabel))  main :: IO () main =-    do counts <- runTestTT (TestList [TestLabel "Main" Main.tests])+    do _ <- system "[ -d testdata ] || tar xfz testdata.tar.gz"+       counts <- runTestTT (TestList [TestLabel "Main" Main.tests])        putStrLn (show counts)        case (errors counts + failures counts) of          0 -> exitWith ExitSuccess          _ -> exitWith (ExitFailure 1)  withTestData :: (A.Module SrcSpanInfo -> [Comment] -> String -> IO r) -> FilePath -> IO r-withTestData f path = withCurrentDirectory "testdata/original" $+withTestData f path = withCurrentDirectory "testdata/debian" $     do text <- try (readFile path)        source <- try (parseFileWithComments defaultParseMode path)        case (text, source) of@@ -68,9 +69,9 @@ -- logictest :: MonadClean m => String -> (Set ModuleName -> m ()) -> Test logictest s f =     TestLabel s $ TestCase $-    do _ <- readProcess "rsync" ["-aHxS", "--delete", {-"-v",-} "testdata/logic/", "testdata/copy"] ""-       _ <- withCurrentDirectory "testdata/copy" $ runMonadClean $ f logicModules-       (code, out, err) <- diff' ("testdata/" ++ s ++ "-result") "testdata/copy"+    do _ <- rsync "testdata/logic" "tmp"+       _ <- withCurrentDirectory "tmp" $ runMonadClean $ 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) @@ -78,7 +79,7 @@ test2a u =          do modifyParams (\ p -> p {extensions = extensions p ++ [MultiParamTypeClasses],                                     moduVerse = Just u})-            qPutStrLn "\nSplitting module Literal"+            qLnPutStr "Splitting module Literal"             splitModule (ModuleName "Data.Logic.Classes.Literal")             return () @@ -86,16 +87,16 @@ test2b u =          do modifyParams (\ p -> p {extensions = extensions p ++ [MultiParamTypeClasses],                                     moduVerse = Just u})-            qPutStrLn "\nSplitting module Literal"+            qLnPutStr "Splitting module Literal"             splitModule (ModuleName "Data.Logic.Classes.Literal")-            qPutStrLn "Merging FirstOrder, fromFirstOrder, fromLiteral into FirstOrder"+            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")-            noisily (qPutStrLn "merge2")+            noisily (qLnPutStr "merge2")             return ()     where       u' = union (fromList [ModuleName "Data.Logic.Classes.Literal.Internal.FixityLiteral",@@ -112,15 +113,15 @@ test2c u =          do modifyParams (\ p -> p {extensions = extensions p ++ [MultiParamTypeClasses],                                     moduVerse = Just u})-            qPutStrLn "\nSplitting module Literal"+            qLnPutStr "Splitting module Literal"             splitModule (ModuleName "Data.Logic.Classes.Literal")-            qPutStrLn "Merging FirstOrder, fromFirstOrder, fromLiteral into FirstOrder"+            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")-            noisily (qPutStrLn "Merging remaining split modules into Literal")+            noisily (qLnPutStr "Merging remaining split modules into Literal")             -- modifyParams (\ p -> p {testMode = True})             mergeModules               [ModuleName "Data.Logic.Classes.Literal.Literal",

@@ -0,0 +1,202 @@+module Tests.Fold where++import Control.Applicative ((<$>))+import Control.Monad (when)+import Control.Monad.State (get, put, runState, State)+import Control.Monad.Trans (liftIO)+import Data.Char (isSpace)+import Data.Default (Default(def))+import Data.Foldable (fold)+import Data.List (tails)+import Data.Map (Map)+import Data.Maybe (mapMaybe)+import Data.Monoid (Monoid, (<>), mempty)+import Data.Sequence as Seq (Seq, (|>), (<|), fromList, filter, zip)+import Data.Set.Extra as Set (fromList)+import Data.Tree (Tree(..))+import Language.Haskell.Exts.Annotated (ParseResult(..))+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.Common (withCurrentDirectory)+import Language.Haskell.Modules.Fold (ModuleInfo, ModuleMap, foldModule, foldDecls, echo, echo2, ignore2)+import Language.Haskell.Modules.Internal (parseFileWithComments, runMonadClean)+import Language.Haskell.Modules.Util.SrcLoc (endLoc, HasSpanInfo(..), increaseSrcLoc, makeTree, srcLoc, srcPairText, srcPairText)+import Language.Haskell.Modules.Util.Test (rsync)+import Test.HUnit (assertEqual, Test(TestList, TestCase, TestLabel))++tests :: Test+tests = TestLabel "Clean" (TestList [test1, test1b, test3, test4, test5, test5b, test6, test7])++test1 :: Test+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)+       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)++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)+       assertEqual "echo" mempty (Seq.filter (\ (a, b) -> a /= b) (Seq.zip expected output))+    where+      expected :: Seq (String, String, String, String)+      expected = Seq.fromList+                   [("-- Comment above module head\nmodule ","","",""),+                    ("","Debian.Repo.Sync"," ","[2.8:2.24]"),+                    ("","{-# WARNING \"this is a warning\" #-}","\n","[2.25:2.60]"),+                    ("    ( ","","",""),+                    ("","rsync","\n","[3.7:3.12]"),+                    ("    , ","foo","\n","[4.7:4.10]"),+                    ("    -- Comment after last export\n    ) where","","",""),+                    ("\n\n-- Comment before first import\n\n","import Control.Monad.Trans (MonadIO)","\n","[10.1:10.37]"),+                    ("","import qualified Data.ByteString as B (empty)","\n","[11.1:11.46]"),+                    ("","import System.Exit (ExitCode)","\n","[12.1:12.30]"),+                    ("","import System.FilePath (dropTrailingPathSeparator)","\n","[13.1:13.51]"),+                    ("-- Comment between two imporrts\n","import System.Process (proc)","\n","[15.1:15.29]"),+                    ("","import System.Process.Progress (keepResult, runProcessF)","\n","[16.1:16.57]"),+                    ("\n-- Comment before first decl\n","rsync :: (Functor m, MonadIO m) => [String] -> FilePath -> FilePath -> m ExitCode","\n","[19.1:19.82]"),+                    ("","rsync extra source dest =\n    do result <- runProcessF (proc \"rsync\" ([\"-aHxSpDt\", \"--delete\"] ++ extra ++\n                                            [dropTrailingPathSeparator source ++ \"/\",\n                                             dropTrailingPathSeparator dest])) B.empty >>= return . keepResult\n       case result of\n         [x] -> return x\n         _ -> error \"Missing or multiple exit codes\"","\n","[20.1:29.0]"),+                    ("\n-- Comment between two decls\n","foo :: Int","\n","[29.1:29.11]"),+                    ("","foo = 1","\n","[30.1:30.8]"),+                    ("\n{-\nhandleExit 1 = \"Syntax or usage error\"\nhandleExit 2 = \"Protocol incompatibility\"\nhandleExit 3 = \"Errors selecting input/output files, dirs\"\nhandleExit 4 = \"Requested action not supported: an attempt was made to manipulate 64-bit files on a platform that cannot support them; or an option was specified that is supported by the client and not by the server.\"\nhandleExit 5 = \"Error starting client-server protocol\"\nhandleExit 6 = \"Daemon unable to append to log-file\"\nhandleExit 10 = \"Error in socket I/O\"\nhandleExit 11 = \"Error in file I/O\"\nhandleExit 12 = \"Error in rsync protocol data stream\"\nhandleExit 13 = \"Errors with program diagnostics\"\nhandleExit 14 = \"Error in IPC code\"\nhandleExit 20 = \"Received SIGUSR1 or SIGINT\"\nhandleExit 21 = \"Some error returned by waitpid()\"\nhandleExit 22 = \"Error allocating core memory buffers\"\nhandleExit 23 = \"Partial transfer due to error\"\nhandleExit 24 = \"Partial transfer due to vanished source files\"\nhandleExit 25 = \"The --max-delete limit stopped deletions\"\nhandleExit 30 = \"Timeout in data send/receive\"\nhandleExit 35 = \"Timeout waiting for daemon connection\"\n-}\n","","","")]+      test :: ModuleInfo -> Seq (String, String, String, String)+      test m =+          foldModule tailf pragmaf namef warningf tailf exportf tailf importf declf tailf m mempty+          where+            pragmaf x pref s suff r = r |> (pref, s, suff,int (spanInfo x))+            namef x pref s suff r = r |> (pref, s, suff,int (spanInfo x))+            warningf x pref s suff r = r |> (pref, s, suff,int (spanInfo x))+            exportf x pref s suff r = r |> (pref, s, suff,int (spanInfo x))+            importf x pref s suff r = r |> (pref, s, suff,int (spanInfo x))+            declf x pref s suff r = r |> (pref, s, suff,int (spanInfo x))+            tailf s r = r |> (s, "", "", "")++int :: HasSpanInfo a => a -> String+int x = let (SrcSpanInfo (SrcSpan _ a b c d) _) = spanInfo x in "[" ++ show a ++ "." ++ show b ++ ":" ++ show c ++ "." ++ show d ++ "]"++test3 :: Test+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)+       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)++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+       -- 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) []+       assertEqual "spans" expected actual+    where+      expected = [("","a = 1 where","\n"),+                  ("\n{- This makes bad things happen. -}\n\n","b = ()","\n"),+                  ("","","")]++test5b :: Test+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) []+       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",+                   "class (Negatable lit, Constants lit, HasFixity atom, Formula lit atom, Ord lit) => Literal lit atom | lit -> atom where\n    foldLiteral :: (lit -> r) -> (Bool -> r) -> (atom -> r) -> lit -> r",+                   "\n"),+                  ("\n","zipLiterals :: Literal lit atom =>\n               (lit -> lit -> Maybe r)\n            -> (Bool -> Bool -> Maybe r)\n            -> (atom -> atom -> Maybe r)\n            -> lit -> lit -> Maybe r","\n"),+                  ("",+                   "zipLiterals neg tf at fm1 fm2 =\n    foldLiteral neg' tf' at' fm1\n    where\n      neg' p1 = foldLiteral (neg p1) (\\ _ -> Nothing) (\\ _ -> Nothing) fm2\n      tf' x1 = foldLiteral (\\ _ -> Nothing) (tf x1) (\\ _ -> Nothing) fm2\n      at' a1 = foldLiteral (\\ _ -> Nothing) (\\ _ -> Nothing) (at a1) fm2",+                   "\n"),+                  ("\n{- This makes bad things happen.\n-- | We can use an fof type as a lit, but it must not use some constructs.\ninstance FirstOrderFormula fof atom v => Literal fof atom v where\n    foldLiteral neg tf at fm = foldFirstOrder qu co tf at fm\n        where qu = error \"instance Literal FirstOrderFormula\"\n              co ((:~:) x) = neg x\n              co _ = error \"instance Literal FirstOrderFormula\"\n    atomic = Data.Logic.Classes.FirstOrder.atomic\n-}\n\n-- |Just like Logic.FirstOrder.convertFOF except it rejects anything\n-- with a construct unsupported in a normal logic formula,\n-- i.e. quantifiers and formula combinators other than negation.\n",+                   "fromFirstOrder :: forall formula atom v lit atom2.\n                  (Formula lit atom2, FOF.FirstOrderFormula formula atom v, Literal lit atom2) =>\n                  (atom -> atom2) -> formula -> Failing lit",+                   "\n"),+                  ("",+                   "fromFirstOrder ca formula =\n    FOF.foldFirstOrder (\\ _ _ _ -> Failure [\"fromFirstOrder\"]) co (Success . fromBool) (Success . atomic . ca) formula\n    where\n      co :: Combination formula -> Failing lit\n      co ((:~:) f) =  fromFirstOrder ca f >>= return . (.~.)\n      co _ = Failure [\"fromFirstOrder\"]",+                   "\n"),+                  ("\n","fromLiteral :: forall lit atom v fof atom2. (Literal lit atom, FOF.FirstOrderFormula fof atom2 v) =>\n               (atom -> atom2) -> lit -> fof","\n"),+                  ("","fromLiteral ca lit = foldLiteral (\\ p -> (.~.) (fromLiteral ca p)) fromBool (atomic . ca) lit","\n"),+                  ("\n","toPropositional :: forall lit atom pf atom2. (Literal lit atom, P.PropositionalFormula pf atom2) =>\n                   (atom -> atom2) -> lit -> pf","\n"),+                  ("","toPropositional ca lit = foldLiteral (\\ p -> (.~.) (toPropositional ca p)) fromBool (atomic . ca) lit","\n"),+                  ("\n{-\nprettyLit :: forall lit atom term v p f. (Literal lit atom v, Apply atom p term, Term term v f) =>\n              (v -> Doc)\n           -> (p -> Doc)\n           -> (f -> Doc)\n           -> Int\n           -> lit\n           -> Doc\nprettyLit pv pp pf _prec lit =\n    foldLiteral neg tf at lit\n    where\n      neg :: lit -> Doc\n      neg x = if negated x then text {-\"\172\"-} \"~\" <> prettyLit pv pp pf 5 x else prettyLit pv pp pf 5 x\n      tf = text . ifElse \"true\" \"false\"\n      at = foldApply (\\ pr ts -> \n                        pp pr <> case ts of\n                                   [] -> empty\n                                   _ -> parens (hcat (intersperse (text \",\") (map (prettyTerm pv pf) ts))))\n                   (\\ x -> text $ if x then \"true\" else \"false\")\n      -- parensIf False = id\n      -- parensIf _ = parens . nest 1\n-}\n\n","prettyLit :: forall lit atom v. (Literal lit atom) =>\n              (Int -> atom -> Doc)\n           -> (v -> Doc)\n           -> Int\n           -> lit\n           -> Doc","\n"),+                  ("","prettyLit pa pv pprec lit =\n    parensIf (pprec > prec) $ foldLiteral co tf at lit\n    where\n      co :: lit -> Doc\n      co x = if negated x then text {-\"\172\"-} \"~\" <> prettyLit pa pv 5 x else prettyLit pa pv 5 x\n      tf x = text (if x then \"true\" else \"false\")\n      at = pa 6\n      parensIf False = id\n      parensIf _ = parens . nest 1\n      Fixity prec _ = fixityLiteral lit","\n"),+                  ("\n","fixityLiteral :: (Literal formula atom) => formula -> Fixity","\n"),+                  ("","fixityLiteral formula =\n    foldLiteral neg tf at formula\n    where\n      neg _ = Fixity 5 InfixN\n      tf _ = Fixity 10 InfixN\n      at = fixity","\n"),+                  ("\n","foldAtomsLiteral :: Literal lit atom => (r -> atom -> r) -> r -> lit -> r","\n"),+                  ("","foldAtomsLiteral f i lit = foldLiteral (foldAtomsLiteral f i) (const i) (f i) lit","\n"),+                  ("","","")]++test6 :: Test+test6 = TestCase (assertEqual "tree1"+                              (Node {rootLabel = sp 2 20,+                                     subForest = [Node {rootLabel = sp 5 10,+                                                        subForest = [Node {rootLabel = sp 6 7, subForest = []},+                                                                     Node {rootLabel = sp 8 9, subForest = []}]},+                                                  Node {rootLabel = sp 11 18,+                                                        subForest = [Node {rootLabel = sp 12 15, subForest = []}]}]})+                              (makeTree (Set.fromList+                                         [sp 2 20,+                                          sp 5 10,+                                          sp 11 18,+                                          sp 6 7,+                                          sp 8 9,+                                          sp 12 15])))+    where+      sp a b = mkspan (29, a) (29, b)+      mkspan (a, b) (c, d) =+          SrcSpanInfo {srcInfoSpan = SrcSpan {srcSpanFilename = "<unknown>.hs",+                                              srcSpanStartLine = a,+                                              srcSpanStartColumn = b,+                                              srcSpanEndLine = c,+                                              srcSpanEndColumn = d}, srcInfoPoints = []}++test4 :: Test+test4 = TestCase (assertEqual "test4" (SrcLoc "<unknown>.hs" 2 24 < SrcLoc "<unknown>.hs" 29 7) True)++test7 :: Test+test7 =+    TestCase $+    do text <- readFile "testdata/Fold7.hs"+       ParseOk (m, comments) <- runMonadClean $ parseFileWithComments "testdata/Fold7.hs"+       let actual = foldModule (\ s r -> r |> (s, "", ""))+                               (\ _ b s a r -> r |> (b, s, a))+                               (\ _ b s a r -> r |> (b, s, a))+                               (\ _ b s a r -> r |> (b, s, a))+                               (\ s r -> r |> (s, "", ""))+                               (\ _ b s a r -> r |> (b, s, a))+                               (\ s r -> r |> (s, "", ""))+                               (\ _ b s a r -> r |> (b, s, a))+                               (\ _ b s a r -> r |> (b, s, a))+                               (\ s r -> r |> (s, "", ""))+                               (m, text, comments) mempty+       assertEqual "fold7" expected actual+    where+      expected = Seq.fromList $+             [ ("module ","","")+             , ("","Main"," ")+             , ("where\n\n-- | Get the contents of a package index\n","","")+            -- What we are getting+             , ("","binaryPackagesOfIndex repo release index =\n    liftIO $ getPackages repo release index"," "), ("-- >>= return . either Left (Right . List.map (toBinaryPackage index . packageInfo))\n\n","a=1","  ")+            -- What we want+             -- , ("","binaryPackagesOfIndex repo release index =\n    liftIO $ getPackages repo release index", " -- >>= return . either Left (Right . List.map (toBinaryPackage index . packageInfo))\n"), ("\n", "a=1","  ")+             , ("-- This is a comment too\n","","") ]

@@ -0,0 +1,126 @@+{-# LANGUAGE PackageImports #-}+module Tests.Imports 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.Function (on)+import Data.List (find, groupBy, intercalate, nub, nubBy, sortBy)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Monoid ((<>))+import Data.Set as Set (empty, member, Set, singleton, toList, union, unions)+import Language.Haskell.Exts.Annotated (ParseResult(..))+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 Language.Haskell.Exts.Extension (Extension(PackageImports, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances))+import Language.Haskell.Exts.Pretty (defaultMode, PPHsMode(layout), PPLayout(PPInLine), prettyPrintWithMode)+import Language.Haskell.Exts.SrcLoc (SrcSpanInfo)+import qualified Language.Haskell.Exts.Syntax as S (ImportDecl(importLoc, importModule, importSpecs), ModuleName(..), Name(..))+import Language.Haskell.Modules.Common (modulePathBase, withCurrentDirectory)+import Language.Haskell.Modules.Fold (ModuleInfo, foldDecls, foldExports, foldHeader, foldImports)+import Language.Haskell.Modules.Imports (cleanImports)+import Language.Haskell.Modules.Internal (getParams, markForDelete, modifyParams, ModuleResult(..), MonadClean, Params(..), parseFile, parseFileWithComments, runMonadClean, scratchDir)+import Language.Haskell.Modules.Params (modifyTestMode)+import Language.Haskell.Modules.Util.DryIO (replaceFile, tildeBackup)+import Language.Haskell.Modules.Util.Symbols (symbols)+import Language.Haskell.Modules.Util.Test (diff, rsync)+import System.Cmd (system)+import System.Directory (createDirectoryIfMissing, getCurrentDirectory)+import System.Exit (ExitCode(..))+import System.FilePath ((<.>), (</>))+import System.Process (readProcessWithExitCode, showCommandForUser)+import Test.HUnit (assertEqual, Test(..))++tests :: Test+tests = TestLabel "Clean" (TestList [test1, test2, test3, test4, test5, test6])++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))+          (code, diff, err) <- readProcessWithExitCode "diff" ["-ru", "testdata/debian" </> base, "tmp" </> base] ""+          assertEqual "cleanImports"+                         (ExitFailure 1,+                          ["@@ -22,13 +22,13 @@",+                           "     , prettyPkgVersion",+                           "     ) where",+                           " ",+                           "-import Data.Text (Text, map)",+                           "+import Data.Text (Text)",+                           " import Debian.Arch (Arch(..))",+                           " import qualified Debian.Control.Text as T (Paragraph)",+                           " import Debian.Relation (BinPkgName(..), SrcPkgName(..))",+                           " import qualified Debian.Relation as B (PkgName, Relations)",+                           " import Debian.Release (Section(..))",+                           "-import Debian.Repo.Orphans ({- instances -})",+                           "+import Debian.Repo.Orphans ()",+                           " import Debian.Version (DebianVersion, prettyDebianVersion)",+                           " import System.Posix.Types (FileOffset)",+                           " import Text.PrettyPrint.ANSI.Leijen ((<>), Doc, Pretty(pretty), text)"],+                          "")+                          (code, drop 2 (lines diff), err))++test2 :: Test+test2 =+    TestLabel "Imports.test2" $ TestCase+      (do rsync "testdata/debian" "tmp"+          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))++-- | Can we handle a Main module in a file named something other than Main.hs?+test3 :: Test+test3 =+    TestLabel "imports3" $ TestCase+      (rsync "testdata/imports3" "tmp" >>+       runMonadClean (modifyParams (\ p -> p {sourceDirs = ["tmp"]}) >> cleanImports "tmp/NotMain.hs") >>+       assertEqual "module name" () ())++-- | Preserve imports with a "hiding" clause+test4 :: Test+test4 =+    TestLabel "imports4" $ TestCase+      (rsync "testdata/imports4" "tmp" >>+       runMonadClean (modifyParams (\ p -> p {sourceDirs = ["tmp"]}) >> cleanImports "tmp/Hiding.hs") >>+       -- Need to check the text of Hiding.hs, but at least this verifies that there was no crash+       assertEqual "module name" () ())++-- | Preserve imports used by a standalone deriving declaration+test5 :: Test+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")+          (code, diff, err) <- diff "testdata/imports5" "tmp"+          assertEqual "standalone deriving"+                      (ExitFailure 1,+                       (unlines+                        ["@@ -1,7 +1,6 @@",+                         " module Deriving where",+                         " ",+                         "-import Data.Text (Text)",+                         "-import Debian.Control (Paragraph(..), Paragraph'(..), Field'(..))",+                         "+import Debian.Control (Field'(..), Paragraph(..))",+                         " ",+                         " deriving instance Show (Field' String)",+                         " deriving instance Show Paragraph"]),+                       "")+                      (code, unlines (drop 3 (lines diff)), err))++-- | Comment at EOF+test6 :: Test+test6 =+    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)

@@ -0,0 +1,69 @@+module Tests.Merge where++import Control.Monad as List (mapM)+import Control.Monad.Trans (liftIO)+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.Monoid ((<>))+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 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.Common (withCurrentDirectory)+import Language.Haskell.Modules.Fold (ModuleInfo, echo, echo2, foldDecls, foldExports, foldHeader, foldImports, ignore, ignore2)+import Language.Haskell.Modules.Imports (cleanImports)+import Language.Haskell.Modules.Internal (doResult, getParams, modifyParams, modulePath, ModuleResult(..), MonadClean, Params(sourceDirs, moduVerse, testMode), parseFileWithComments, runMonadClean)+import Language.Haskell.Modules.Merge (mergeModules)+import Language.Haskell.Modules.Util.Test (diff, rsync, repoModules)+import System.Cmd (system)+import System.Exit (ExitCode(ExitSuccess))+import Test.HUnit (assertEqual, Test(TestCase, TestList))++tests :: Test+tests = TestList [test1, test2, test3]++test1 :: Test+test1 =+    TestCase $+      do _ <- rsync "testdata/debian" "tmp"+         _result <- runMonadClean $+           do modifyParams (\ p -> p {sourceDirs = ["tmp"], moduVerse = Just repoModules})+              mergeModules+                     [S.ModuleName "Debian.Repo.AptCache", S.ModuleName "Debian.Repo.AptImage"]+                     (S.ModuleName "Debian.Repo.Cache")+         (code, out, err) <- diff "testdata/merge1-expected" "tmp"+         assertEqual "merge1" (ExitSuccess, "", "") (code, out, err)++test2 :: Test+test2 =+    TestCase $+      do _ <- rsync "testdata/debian" "tmp"+         _result <- runMonadClean $+           do modifyParams (\ p -> p {sourceDirs = ["tmp"], moduVerse = Just 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")+         (code, out, err) <- diff "testdata/merge2-expected" "tmp"+         assertEqual "merge2" (ExitSuccess, "", "") (code, out, err)++test3 :: Test+test3 =+    TestCase $+      do _ <- rsync "testdata/debian" "tmp"+         _result <- withCurrentDirectory "tmp" $+                   runMonadClean $+           do modifyParams (\ p -> p {moduVerse = Just 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.Slice")+         (code, out, err) <- diff "testdata/merge3-expected" "tmp"+         assertEqual "mergeModules3" (ExitSuccess, "", "") (code, out, err)

@@ -0,0 +1,85 @@+module Tests.Split where++import Control.Exception (throw)+import Control.Monad (when)+import Control.Monad.Trans (liftIO)+import Data.Char (isAlpha, isAlphaNum, toUpper)+import Data.Default (Default(def))+import Data.List as List (filter, intercalate, map, nub)+import Data.Map as Map (delete, elems, empty, filter, insertWith, lookup, Map, mapWithKey)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Monoid ((<>))+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 Language.Haskell.Exts.Annotated.Simplify (sImportDecl, sImportSpec, sModuleName, sName)+import Language.Haskell.Exts.Pretty (defaultMode, prettyPrint, prettyPrintWithMode)+import Language.Haskell.Exts.SrcLoc (SrcSpanInfo(..))+import qualified Language.Haskell.Exts.Syntax as S (ImportDecl(..), ModuleName(..), Name(..))+import Language.Haskell.Modules.Common (withCurrentDirectory)+import Language.Haskell.Modules.Fold (ModuleInfo, echo, echo2, foldDecls, foldExports, foldHeader, foldImports, foldModule, ignore, ignore2)+import Language.Haskell.Modules.Imports (cleanImports)+import Language.Haskell.Modules.Internal (doResult, modifyParams, modulePath, ModuleResult(..), MonadClean(getParams), Params(moduVerse, sourceDirs, testMode), parseFileWithComments, runMonadClean)+import Language.Haskell.Modules.Params (modifyModuVerse, modifyTestMode)+import Language.Haskell.Modules.Split (splitModule)+import Language.Haskell.Modules.Util.QIO (noisily)+import Language.Haskell.Modules.Util.Symbols (exports, imports, symbols)+import Language.Haskell.Modules.Util.Test (diff, repoModules)+import Prelude hiding (writeFile)+import System.Cmd (system)+import System.Exit (ExitCode(ExitSuccess, ExitFailure))+import System.FilePath ((<.>))+import Test.HUnit (assertEqual, Test(TestCase, TestList, TestLabel))++tests :: Test+tests = TestList [split1, split2a, split2b, split4]++split1 :: Test+split1 =+    TestCase $+      do _ <- system "rsync -aHxS --delete testdata/debian/ tmp"+         runMonadClean $ noisily $ noisily $+           do modifyParams (\ p -> p {sourceDirs = ["tmp"], moduVerse = Just repoModules})+              splitModule (S.ModuleName "Debian.Repo.Package")+         (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)++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"))})+            splitModule (S.ModuleName "Split")+       (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"))})+            splitModule (S.ModuleName "Split")+       (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)++split4 :: Test+split4 =+    TestLabel "Split4" $ TestCase $+    do system "rsync -aHxs --delete testdata/split4/ tmp"+       withCurrentDirectory "tmp" $+         runMonadClean $ modifyTestMode (const True) >> modifyModuVerse (const Set.empty) >> splitModule (S.ModuleName "Split4")+       result <- diff "testdata/split4-expected" "tmp"+       assertEqual "Split4" (ExitSuccess, "", "") result

@@ -0,0 +1,146 @@+haskell-module-management (0.10.1) unstable; urgency=low++  * Changes to compile under ghc-7.4.1+  * Formatting fix - eliminate extra newline added to split modules+  * Find a way to include the test data without listing hundreds of files+  * Add testdata tarball and debian/changelog to distribution+  * Performance fixes++ -- David Fox <dsf@seereason.com>  Sat, 29 Jun 2013 16:57:20 -0700++haskell-module-management (0.10) unstable; urgency=low++  * Extend documentation+  * Fix bug which moved comments after last deco to before the first decl+  * Add a rather nasty cli - Maybe shell commands are a better idea+  * Fix fold so space and comments are not associated with the previous+    decl, the now belong to the following decl.++ -- David Fox <dsf@seereason.com>  Sat, 29 Jun 2013 11:27:36 -0700++haskell-module-management (0.9.3.1) unstable; urgency=low++  * Fix the package home page URL.++ -- David Fox <dsf@seereason.com>  Thu, 27 Jun 2013 17:05:35 -0700++haskell-module-management (0.9.3) unstable; urgency=low++  * Clean up documentation for release.++ -- David Fox <dsf@seereason.com>  Thu, 27 Jun 2013 14:00:17 -0700++haskell-module-management (0.9.2) unstable; urgency=low++  * Add a simple CLI (from Cliff Beshers)+  * splitModule: Put instance declarations into an Instances module+  * splitModule: Put re-exports into a ReExported module+  * splitModule: Put previously private declarations into an Internal subdir+  * cleanImports: Fix the way imports of types that appear in standalone+    derivations are modified so their members become visible.++ -- David Fox <dsf@seereason.com>  Fri, 21 Jun 2013 12:39:52 -0700++haskell-module-management (0.9.1) unstable; urgency=low++  * Fix verbosity handling+  * Manage the set of existing modules when splits and cats occur+  * Handle files with no final newline+  * Speed up text handling++ -- David Fox <dsf@seereason.com>  Tue, 18 Jun 2013 07:13:29 -0700++haskell-module-management (0.9) unstable; urgency=low++  * Major revision++ -- David Fox <dsf@seereason.com>  Sun, 16 Jun 2013 10:29:13 -0700++haskell-module-management (0.8.4) unstable; urgency=low++  * Preserve imports required to re-export symbols in split modules.++ -- David Fox <dsf@seereason.com>  Wed, 12 Jun 2013 17:02:35 -0700++haskell-module-management (0.8.3) unstable; urgency=low++  * Make sure identifiers imported by "as" imports get updated when modules are catted++ -- David Fox <dsf@seereason.com>  Wed, 12 Jun 2013 15:31:38 -0700++haskell-module-management (0.8.2) unstable; urgency=low++  * Similar fix to the one in 0.8.1, but for the imports of a split+    module.++ -- David Fox <dsf@seereason.com>  Wed, 12 Jun 2013 13:27:58 -0700++haskell-module-management (0.8.1) unstable; urgency=low++  * Fix handling of declarations with top level and member symbols.  There+    are still some remaining issues with this when declaring multiple top+    level symbols in a single declaration.++ -- David Fox <dsf@seereason.com>  Wed, 12 Jun 2013 12:56:10 -0700++haskell-module-management (0.8) unstable; urgency=low++  * Clean up for release++ -- David Fox <dsf@seereason.com>  Sun, 09 Jun 2013 11:15:55 -0700++haskell-module-management (0.7.1) unstable; urgency=low++  * Preserve imports of constructors required for standalone deriving declarations++ -- David Fox <dsf@seereason.com>  Thu, 06 Jun 2013 11:23:59 -0700++haskell-module-management (0.7) unstable; urgency=low++  * Add an extensions_ field to Params, and a modifyExtensions+    to update the list of extensions used to parse each file.++ -- David Fox <dsf@seereason.com>  Wed, 05 Jun 2013 16:11:29 -0700++haskell-module-management (0.6.2) unstable; urgency=low++  * Preserve "hiding" imports in cleanImports.++ -- David Fox <dsf@seereason.com>  Wed, 05 Jun 2013 13:03:15 -0700++haskell-module-management (0.6.1) unstable; urgency=low++  * Fix how cleanImports handles modules that are not where their module+    name implies.++ -- David Fox <dsf@seereason.com>  Wed, 05 Jun 2013 09:20:36 -0700++haskell-module-management (0.6) unstable; urgency=low++  * Rename module heirarchy, add Exports.hs, generalize Cat.++ -- David Fox <dsf@seereason.com>  Sat, 01 Jun 2013 10:00:01 -0700++haskell-module-management (0.5) unstable; urgency=low++  * Add catModules.++ -- David Fox <dsf@seereason.com>  Sat, 25 May 2013 07:55:50 -0700++haskell-module-management (0.4) unstable; urgency=low++  * Now provides cleanImports, moveModule, splitModule, and foldModule.++ -- David Fox <dsf@seereason.com>  Thu, 23 May 2013 14:14:30 -0700++haskell-module-management (0.3) unstable; urgency=low++  * Sort and merge import declarations properly++ -- David Fox <dsf@seereason.com>  Tue, 14 May 2013 14:03:32 -0700++haskell-module-management (0.2) unstable; urgency=low++  * Debianization generated by cabal-debian++ -- David Fox <dsf@seereason.com>  Wed, 08 May 2013 10:00:45 -0700

@@ -1,5 +1,5 @@ Name:               module-management-Version:            0.10+Version:            0.10.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@@ -10,7 +10,7 @@ Stability:          experimental Build-type:         Simple Cabal-version:      >=1.8-Extra-Source-Files: testdata.tar.gz+Extra-Source-Files: testdata.tar.gz, debian/changelog  Flag build-tests   Description: build the test executable@@ -33,7 +33,11 @@     Language.Haskell.Modules.Util.SrcLoc,     Language.Haskell.Modules.Util.DryIO   Other-Modules:-    Language.Haskell.Modules.Internal+    Language.Haskell.Modules.Internal,+    Tests.Fold,+    Tests.Imports,+    Tests.Merge,+    Tests.Split   Build-Depends:     applicative-extras,     base >= 4 && < 5,

binary file changed (632992 → 634311 bytes)