module-management 0.9.3.1 → 0.10

raw patch · 14 files changed

+717/−259 lines, 14 filesdep +Extradep +ansi-wl-pprintdep +debiandep ~basedep ~set-extranew-component:exe:hmmnew-component:exe:testsbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: Extra, ansi-wl-pprint, debian, module-management, process-progress, regex-compat

Dependency ranges changed: base, set-extra

API changes (from Hackage documentation)

Files

• Language/Haskell/Modules.hs +9/−4
• Language/Haskell/Modules/Fold.hs +241/−97
• Language/Haskell/Modules/Imports.hs +38/−26
• Language/Haskell/Modules/Internal.hs +3/−3
• Language/Haskell/Modules/Merge.hs +39/−38
• Language/Haskell/Modules/Params.hs +34/−25
• Language/Haskell/Modules/Split.hs +51/−30
• Language/Haskell/Modules/Util/SrcLoc.hs +8/−0
• Language/Haskell/Modules/Util/Temp.hs +2/−1
• Language/Haskell/Modules/Util/Test.hs +13/−9
• Tests.hs +133/−0
• module-management.cabal +54/−26
• scripts/CLI.hs +92/−0
• testdata.tar.gz binary

@@ -34,15 +34,19 @@ -- -- * 'mergeModules' ----- * 'runMonadClean'+-- * 'runMonadClean' - Sets up the environment for splitting and merging --+-- * 'Language.Haskell.Modules.Params' - Functions to control modes of operation+-- -- Examples: ----- * Clean up the import lists of all the modules under @./Language@:+-- * Use @cleanImports@ to clean up the import lists of all the modules under @./Language@: -- --    @findPaths \"Language\" >>= runMonadClean . mapM cleanImports . toList@ ----- * Split up the module Common and then merge two of the pieces back in:+-- * Use @splitModule@ to split up module+--   @Language.Haskell.Modules.Common@, and then merge two of the pieces+--   back in. -- --   @findModules \"Language\" >>= \\ modules -> runMonadClean $ --      let mn = Language.Haskell.Exts.Syntax.ModuleName in@@ -65,7 +69,8 @@ import Language.Haskell.Modules.Fold (echo, echo2, foldDecls, foldExports, foldHeader, foldImports, foldModule, ignore, ignore2) import Language.Haskell.Modules.Imports (cleanImports) import Language.Haskell.Modules.Merge (mergeModules)-import Language.Haskell.Modules.Params (modifyDryRun, modifyExtensions, modifyHsFlags, modifyModuVerse, modifyRemoveEmptyImports, modifySourceDirs, modifyTestMode, runMonadClean)+import Language.Haskell.Modules.Params (runMonadClean, modifyDryRun, modifyExtensions, modifyHsFlags, modifyModuVerse,+                                        modifyRemoveEmptyImports, modifySourceDirs, modifyTestMode) import Language.Haskell.Modules.Split (splitModule) import Language.Haskell.Modules.Util.QIO (noisily, quietly) import Language.Haskell.Modules.Util.Test (findModules, findPaths)

@@ -2,7 +2,9 @@ {-# LANGUAGE BangPatterns, CPP, FlexibleInstances, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Language.Haskell.Modules.Fold-    ( foldModule+    ( ModuleInfo+    , ModuleMap+    , foldModule     , foldHeader     , foldExports     , foldImports@@ -14,20 +16,26 @@     , tests     ) 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.List (tails)+import Data.Map (Map)+import Data.Maybe (mapMaybe) import Data.Monoid ((<>), Monoid) 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.Internal (parseFile, runMonadClean)-import Language.Haskell.Modules.Util.SrcLoc (endLoc, HasSpanInfo(..), increaseSrcLoc, makeTree, srcLoc, srcPairTextHead, srcPairTextTail)+import Language.Haskell.Modules.Internal (parseFileWithComments, runMonadClean)+import Language.Haskell.Modules.Util.SrcLoc (endLoc, HasSpanInfo(..), increaseSrcLoc, makeTree, srcLoc, srcPairTextHead, srcPairTextTail, srcPairTextPair) import Test.HUnit (assertEqual, Test(TestList, TestCase, TestLabel))  type Module = A.Module SrcSpanInfo@@ -60,13 +68,97 @@ instance Spans (A.ModuleName SrcSpanInfo) where spans x = [fixSpan $ spanInfo x] instance Spans (A.WarningText SrcSpanInfo) where spans x = [fixSpan $ spanInfo x] --- This happens.  Is it a bug in haskell-src-exts?+type ModuleInfo = (Module, String, [Comment])+type ModuleMap = Map S.ModuleName ModuleInfo++-- This happens, a span with end column 0, even though column+-- numbering begins at 1.  Is it a bug in haskell-src-exts? fixSpan :: SrcSpanInfo -> SrcSpanInfo fixSpan sp =     if srcSpanEndColumn (srcInfoSpan sp) == 0     then sp {srcInfoSpan = (srcInfoSpan sp) {srcSpanEndColumn = 1}}     else sp +data St+    = St { loc_ :: SrcLoc+         , text_ :: String+         , comms_ :: [Comment]+         , sps_ :: [SrcSpanInfo] }+      deriving (Show)++setSpanEnd :: SrcLoc -> SrcSpan -> SrcSpan+setSpanEnd loc sp = sp {srcSpanEndLine = srcLine loc, srcSpanEndColumn = srcColumn loc}+setSpanStart :: SrcLoc -> SrcSpan -> SrcSpan+setSpanStart loc sp = sp {srcSpanStartLine = srcLine loc, srcSpanStartColumn = srcColumn loc}++-- | The spans returned by haskell-src-exts may put comments and+-- whitespace in the suffix string of a declaration, we want them in+-- the prefix string of the following declaration where possible.+adjustSpans :: String -> [Comment] -> [SrcSpanInfo] -> [SrcSpanInfo]+adjustSpans _ _ [] = []+adjustSpans _ _ [x] = [x]+adjustSpans text comments sps =+    fst $ runState f (St def text comments sps)+    where+      f = do st <- get+             let b = loc_ st+             case sps_ st of+               (ss1 : ssis) ->+                   do skip+                      st' <- get+                      let e = loc_ st'+                      case e >= endLoc ss1 of+                        True ->+                            -- We reached the end of ss1, so the segment from b to e is+                            -- trailing comments and space, some of which may belong in+                            -- the following span.+                            do put (st' {sps_ = ssis})+                               sps' <- f+                               let ss1' = ss1 {srcInfoSpan = setSpanEnd b (srcInfoSpan ss1)}+                               return (ss1' : sps')+                        False ->+                           -- If we weren't able to skip to the end of+                           -- the span, we encountered real text.+                           -- Move past one char and try again.+                           do case text_ st' of+                                "" -> return (sps_ st') -- error $ "Ran out of text\n st=" ++ show st ++ "\n st'=" ++ show st'+                                (c : t') -> do put (st' {text_ = t', loc_ = increaseSrcLoc [c] e})+                                               f+               sss -> return sss++      -- loc is the current position in the input file, text+      -- is the text starting at that location.+      skip :: State St ()+      skip = do loc1 <- loc_ <$> get+                skipWhite+                skipComment+                loc2 <- loc_ <$> get+                -- Repeat until failure+                when (loc1 /= loc2) skip++      skipWhite :: State St ()+      skipWhite = do st <- get+                     case span isSpace (text_ st) of+                       ("", _) -> return ()+                       (space, t') ->+                           let loc' = increaseSrcLoc space (loc_ st) in+                           put (st {loc_ = loc', text_ = t'})++      skipComment :: State St ()+      skipComment = do st <- get+                       case comms_ st of+                         (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+                                   ("", _) -> return ()+                                   (comm, t') ->+                                       let loc' = increaseSrcLoc comm (loc_ st) in+                                       put (st {loc_ = loc',+                                                text_ = t',+                                                comms_ = cs})+                         _ -> return () -- No comments, or we didn't reach it+ -- | Given the result of parseModuleWithComments and the original -- module text, this does a fold over the parsed module contents, -- calling the seven argument functions in order.  Each function is@@ -87,92 +179,96 @@            -> (ImportDecl -> String -> String -> String -> r -> r) -- ^ Called with each import declarator            -> (Decl -> String -> String -> String -> r -> r) -- ^ Called with each top level declaration            -> (String -> r -> r) -- ^ Called with comments following the last declaration-           -> Module -- ^ Parsed module-           -> String -- ^ Original text file+           -> ModuleInfo -- ^ Parsed module            -> r -- ^ Fold initialization value            -> r -- ^ Result-foldModule _ _ _ _ _ _ _ _ _ _ (A.XmlPage _ _ _ _ _ _ _) _ _ = error "XmlPage: unsupported"-foldModule _ _ _ _ _ _ _ _ _ _ (A.XmlHybrid _ _ _ _ _ _ _ _ _) _ _ = error "XmlHybrid: unsupported"-foldModule topf pragmaf namef warnf pref exportf postf importf declf sepf m@(A.Module _ mh ps is ds) text r0 =-    fst $ runState (doModule r0) (text, def, spans m)+foldModule _ _ _ _ _ _ _ _ _ _ (A.XmlPage _ _ _ _ _ _ _, _, _) _ = error "XmlPage: unsupported"+foldModule _ _ _ _ _ _ _ _ _ _ (A.XmlHybrid _ _ _ _ _ _ _ _ _, _, _) _ = error "XmlHybrid: unsupported"+foldModule topf pragmaf namef warnf pref exportf postf importf declf sepf (m@(A.Module _ mh ps is ds), text, comments) r0 =+    (\ (_, (_, _, _, r)) -> r) $ runState doModule (text, def, spans m, r0)     where-      doModule r =-          doSep topf r >>=-          doList pragmaf ps >>=-          maybe return doHeader mh >>=-          doList importf is >>=-          doList declf ds >>=-          doTail sepf-      doHeader (A.ModuleHead sp n mw me) r =-          doItem namef n r >>=-          maybe return (doItem warnf) mw >>=-          doSep pref >>=-          maybe return (\ (A.ExportSpecList _ es) -> doList exportf es) me >>=-          doClose postf sp-      doClose f sp r =-          do (tl, l, sps) <- get+      doModule =+          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 declf ds+             doTail sepf+      doHeader (A.ModuleHead sp n mw me) =+          do doItem namef n+             maybe (return ()) (doItem warnf) mw+             doSep pref+             maybe (return ()) (\ (A.ExportSpecList _ es) -> doList exportf es) me+             doClose postf sp+      doClose f sp =+          do (tl, l, sps, r) <- get              case l < endLoc sp of-               True -> do put (srcPairTextTail l (endLoc sp) tl, endLoc sp, sps)-                          return (f (srcPairTextHead l (endLoc sp) tl) r)-               False -> return r-      doTail f r =-          do (tl, _, _) <- get-             return $ f tl r-      doSep :: (String -> r -> r) -> r -> State (String, SrcLoc, [SrcSpanInfo]) r-      doSep f r =+               True -> put (srcPairTextTail l (endLoc sp) tl,+                            endLoc sp,+                            sps,+                            f (srcPairTextHead l (endLoc sp) tl) r)+               False -> return ()+      doTail f =+          do (tl, l, sps, r) <- get+             put (tl, l, sps, f tl r)+      doSep :: (String -> r -> r) -> State (String, SrcLoc, [SrcSpanInfo], r) ()+      doSep f =           do p <- get              case p of-               (tl, l, sps@(sp : _)) ->+               (tl, l, sps@(sp : _), r) ->                    do let l' = srcLoc sp                       case l <= l' of                         True ->-                            do put (srcPairTextTail l l' tl, l', sps)-                               return $ f (srcPairTextHead l l' tl) r-                        False -> return r+                            do put (srcPairTextTail l l' tl,+                                    l',+                                    sps,+                                    f (srcPairTextHead l l' tl) r)+                        False -> return ()                _ -> error $ "foldModule - out of spans: " ++ show p-      doList :: (HasSpanInfo a, Show a) => (a -> String -> String -> String -> r -> r) -> [a] -> r -> State (String, SrcLoc, [SrcSpanInfo]) r-      doList _ [] r = return r-      doList f (x : xs) r = doItem f x r >>= doList f xs+      doList :: (HasSpanInfo a, Show a) => (a -> String -> String -> String -> r -> r) -> [a] -> State (String, SrcLoc, [SrcSpanInfo], r) ()+      doList _ [] = return ()+      doList f (x : xs) = doItem f x >> doList f xs -      doItem :: (HasSpanInfo a, Show a) => (a -> String -> String -> String -> r -> r) -> a -> r -> State (String, SrcLoc, [SrcSpanInfo]) r-      doItem f x r =-          do (tl, l, (sp : sps')) <- get+      doItem :: (HasSpanInfo a, Show a) => (a -> String -> String -> String -> r -> r) -> a -> State (String, SrcLoc, [SrcSpanInfo], r) ()+      doItem f x =+          do (tl, l, (sp : sps'), r) <- get              let -- Another haskell-src-exts bug?  If a module ends                  -- with no newline, endLoc will be at the beginning                  -- of the following (nonexistant) line.-                 l' = endLoc sp                  pre = srcPairTextHead l (srcLoc sp) tl                  tl' = srcPairTextTail l (srcLoc sp) tl+                 l' = endLoc sp                  s = srcPairTextHead (srcLoc sp) l' tl'                  tl'' = srcPairTextTail (srcLoc sp) l' tl'-                 l'' = adjust tl'' l'+                 l'' = adjust1 tl'' l'                  post = srcPairTextHead l' l'' tl''                  tl''' = srcPairTextTail l' l'' tl''-             put (tl''', l'', sps')-             return $ f x pre s post r+             put (tl''', l'', sps', f x pre s post r) -      -- Move to just past the first newline in the leading whitespace+      -- Move to just past the last newline in the leading whitespace       -- adjust "\n  \n  hello\n" (SrcLoc "<unknown>.hs" 5 5) ->-      --   (SrcLoc "<unknown>.hs" 6 1)-      _adjust2 :: String -> SrcLoc -> SrcLoc-      _adjust2 a l =+      --   (SrcLoc "<unknown>.hs" 7 1)+      _adjust :: String -> SrcLoc -> SrcLoc+      _adjust a l =           l'           where             w = takeWhile isSpace a-            w' = case span (/= '\n') w of-                   (w'', '\n' : _) -> w'' ++ ['\n']-                   (w'', "") -> w''+            w' = take (length (takeWhile (elem '\n') (tails w))) w             l' = increaseSrcLoc w' l -      -- Move to just past the last newline in the leading whitespace+      -- Move to just past the first newline in the leading whitespace       -- adjust "\n  \n  hello\n" (SrcLoc "<unknown>.hs" 5 5) ->-      --   (SrcLoc "<unknown>.hs" 7 1)-      adjust :: String -> SrcLoc -> SrcLoc-      adjust a l =+      --   (SrcLoc "<unknown>.hs" 6 1)+      adjust1 :: String -> SrcLoc -> SrcLoc+      adjust1 a l =           l'           where             w = takeWhile isSpace a-            w' = take (length (takeWhile (elem '\n') (tails w))) w+            w' = case span (/= '\n') w of+                   (w'', '\n' : _) -> w'' ++ ['\n']+                   (w'', "") -> w''             l' = increaseSrcLoc w' l  -- | Do just the header portion of 'foldModule'.@@ -181,33 +277,33 @@            -> (ModulePragma -> String -> String -> String -> r -> r)            -> (ModuleName -> String -> String -> String -> r -> r)            -> (WarningText -> String -> String -> String -> r -> r)-           -> Module -> String -> r -> r-foldHeader topf pragmaf namef warnf m text r0 =-    foldModule topf pragmaf namef warnf ignore2 ignore ignore2 ignore ignore ignore2 m text r0+           -> ModuleInfo -> r -> r+foldHeader topf pragmaf namef warnf m r0 =+    foldModule topf pragmaf namef warnf ignore2 ignore ignore2 ignore ignore ignore2 m r0  -- | Do just the exports portion of 'foldModule'. foldExports :: forall r. (Show r) =>                (String -> r -> r)             -> (ExportSpec -> String -> String -> String -> r -> r)             -> (String -> r -> r)-            -> Module -> String -> r -> r-foldExports pref exportf postf m text r0 =-    foldModule ignore2 ignore ignore ignore pref exportf postf ignore ignore ignore2 m text r0+            -> ModuleInfo -> r -> r+foldExports pref exportf postf m r0 =+    foldModule ignore2 ignore ignore ignore pref exportf postf ignore ignore ignore2 m r0  -- | Do just the imports portion of 'foldModule'. foldImports :: forall r. (Show r) =>                (ImportDecl -> String -> String -> String -> r -> r)-            -> Module -> String -> r -> r-foldImports importf m text r0 =-    foldModule ignore2 ignore ignore ignore ignore2 ignore ignore2 importf ignore ignore2 m text r0+            -> ModuleInfo -> r -> r+foldImports importf m r0 =+    foldModule ignore2 ignore ignore ignore ignore2 ignore ignore2 importf ignore ignore2 m r0  -- | Do just the declarations portion of 'foldModule'. foldDecls :: forall r. (Show r) =>              (Decl -> String -> String -> String -> r -> r)           -> (String -> r -> r)-          -> Module -> String -> r -> r-foldDecls declf sepf m text r0 =-    foldModule ignore2 ignore ignore ignore ignore2 ignore ignore2 ignore declf sepf m text r0+          -> ModuleInfo -> r -> r+foldDecls declf sepf m r0 =+    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@@ -226,31 +322,32 @@ ignore2 _ r = r  tests :: Test-tests = TestLabel "Clean" (TestList [test1, test1b, test3, test4, test6])+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 <- runMonadClean $ parseFile path-       let (output, original) = test m text+       ParseOk (m, comments) <- runMonadClean $ parseFileWithComments path+       let (output, original) = test (m, text, comments)        assertEqual "echo" original output     where-      test :: Module -> String -> (String, String)-      test m text = (foldModule echo2 echo echo echo echo2 echo echo2 echo echo echo2 m text "", text)+      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 <- runMonadClean $ parseFile path-       let output = test m text-       assertEqual "echo"-                   [("-- Comment above module head\nmodule ","","",""),-                    ("","Debian.Repo.Sync","","[2.8:2.24]"),-                    (" ","{-# WARNING \"this is a warning\" #-}","\n","[2.25:2.60]"),+       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]"),@@ -260,17 +357,15 @@                     ("","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\n","[16.1:16.57]"),-                    ("-- 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\n-- Comment between two decls\n","","[20.1:29.0]"),-                    ("","foo :: Int","\n","[29.1:29.11]"),-                    ("","foo = 1","\n\n","[30.1:30.8]"),-                    ("{-\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","","","")]-                   output-    where-      test :: Module -> String -> [(String, String, String, String)]-      test m text =-          foldModule tailf pragmaf namef warningf tailf exportf tailf importf declf tailf m text []+                    ("","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))]@@ -295,12 +390,61 @@     TestLabel "test3" $ TestCase $ withCurrentDirectory "testdata" $     do let path = "Equal.hs"        text <- liftIO $ readFile path-       ParseOk m <- runMonadClean $ parseFile path-       let (output, original) = test m text+       ParseOk (m, comments) <- runMonadClean $ parseFileWithComments path+       let (output, original) = test (m, text, comments)        assertEqual "echo" original output     where-      test :: Module -> String -> (String, String)-      test m text = (foldModule echo2 echo echo echo echo2 echo echo2 echo echo echo2 m text "", text)+      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"

@@ -24,8 +24,9 @@ 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 (foldDecls, foldExports, foldHeader, foldImports)-import Language.Haskell.Modules.Internal (getParams, markForDelete, modifyParams, ModuleResult(..), MonadClean, Params(..), parseFile, runMonadClean, scratchDir)+import Language.Haskell.Modules.Fold (ModuleInfo, foldDecls, foldExports, foldHeader, foldImports)+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.Symbols (symbols)@@ -62,16 +63,17 @@ -- | Clean up the imports of a source file. cleanImports :: MonadClean m => FilePath -> m ModuleResult cleanImports path =-    do source <- parseFile path+    do text <- liftIO $ readFile path+       source <- parseFileWithComments path        case source of-         ParseOk (m@(A.Module _ h _ imports _decls)) ->+         ParseOk (m@(A.Module _ h _ imports _decls), comments) ->              do let name = case h of                              Just (A.ModuleHead _ x _ _) -> sModuleName x                              _ -> S.ModuleName "Main"                     hiddenImports = filter isHiddenImport imports-                dumpImports path >> checkImports path name m hiddenImports-         ParseOk (A.XmlPage {}) -> error "cleanImports: XmlPage"-         ParseOk (A.XmlHybrid {}) -> error "cleanImports: XmlHybrid"+                dumpImports path >> checkImports path name (m, text, comments) hiddenImports+         ParseOk (A.XmlPage {}, _) -> error "cleanImports: XmlPage"+         ParseOk (A.XmlHybrid {}, _) -> error "cleanImports: XmlHybrid"          ParseFailed _loc msg -> error ("cleanImports: - parse of " ++ path ++ " failed: " ++ msg)     where       isHiddenImport (A.ImportDecl {A.importSpecs = Just (A.ImportSpecList _ True _)}) = True@@ -97,7 +99,7 @@ -- source file.  We also need to modify the imports of any names -- that are types that appear in standalone instance derivations so -- their members are imported too.-checkImports :: MonadClean m => FilePath -> S.ModuleName -> A.Module SrcSpanInfo -> [A.ImportDecl SrcSpanInfo] -> m ModuleResult+checkImports :: MonadClean m => FilePath -> S.ModuleName -> ModuleInfo -> [A.ImportDecl SrcSpanInfo] -> m ModuleResult checkImports path name@(S.ModuleName name') m extraImports =     do let importsPath = name' <.> ".imports"        markForDelete importsPath@@ -112,37 +114,36 @@  -- | If all the parsing went well and the new imports differ from the -- old, update the source file with the new imports.-updateSource :: MonadClean m => FilePath -> A.Module SrcSpanInfo -> A.Module SrcSpanInfo -> S.ModuleName -> [A.ImportDecl SrcSpanInfo] -> m ModuleResult-updateSource path (m@(A.Module _ _ _ oldImports _)) (A.Module _ _ _ newImports _) name extraImports =+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-       text <- liftIO $ readFile path        maybe (qPutStrLn ("cleanImports: no changes to " ++ path) >> return (Unchanged name))              (\ text' ->                   qPutStrLn ("cleanImports: modifying " ++ path) >>                   replaceFile tildeBackup path text' >>                   return (Modified name text'))-             (replaceImports (fixNewImports remove m oldImports (newImports ++ extraImports)) m text)+             (replaceImports (fixNewImports remove m oldImports (newImports ++ extraImports)) m) updateSource _ _ _ _ _ = error "updateSource"  -- | Compare the old and new import sets and if they differ clip out -- the imports from the sourceText and insert the new ones.-replaceImports :: [A.ImportDecl SrcSpanInfo] -> A.Module SrcSpanInfo -> String -> Maybe String-replaceImports newImports m sourceText =-    let oldPretty = foldImports (\ _ pref s suff r -> r <> pref <> s <> suff) m sourceText ""+replaceImports :: [A.ImportDecl SrcSpanInfo] -> ModuleInfo -> Maybe String+replaceImports newImports m =+    let oldPretty = foldImports (\ _ pref s suff r -> r <> pref <> s <> suff) m ""         -- Surround newPretty with the same prefix and suffix as oldPretty-        newPretty = fromMaybe "" (foldImports (\ _ pref _ _ r -> maybe (Just pref) Just r) m sourceText Nothing) <>+        newPretty = fromMaybe "" (foldImports (\ _ pref _ _ r -> maybe (Just pref) Just r) m Nothing) <>                     intercalate "\n" (map (prettyPrintWithMode (defaultMode {layout = PPInLine})) newImports) <>-                    foldImports (\ _ _ _ suff _ -> suff) m sourceText "" in+                    foldImports (\ _ _ _ suff _ -> suff) m "" 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 sourceText "" ++-               foldExports (\ s r -> r <> s) (\ _ pref s suff r -> r <> pref <> s <> suff) (\ s r -> r <> s) m sourceText "" +++    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 "" ++                newPretty <>-               foldDecls  (\ _ pref s suff r -> r <> pref <> s <> suff) (\ r s -> r <> s) m sourceText "")+               foldDecls  (\ _ pref s suff r -> r <> pref <> s <> suff) (\ r s -> s <> r) m "")  -- | Final touch-ups - sort and merge similar imports. fixNewImports :: Bool         -- ^ If true, imports that turn into empty lists will be removed-              -> A.Module SrcSpanInfo+              -> ModuleInfo               -> [A.ImportDecl SrcSpanInfo]               -> [A.ImportDecl SrcSpanInfo]               -> [A.ImportDecl SrcSpanInfo]@@ -194,10 +195,10 @@       sdTypes :: Set (Maybe S.ModuleName, S.Name)       sdTypes = standaloneDerivingTypes m -standaloneDerivingTypes :: A.Module SrcSpanInfo -> Set (Maybe S.ModuleName, S.Name)-standaloneDerivingTypes (A.XmlPage _ _ _ _ _ _ _) = error "standaloneDerivingTypes A.XmlPage"-standaloneDerivingTypes (A.XmlHybrid _ _ _ _ _ _ _ _ _) = error "standaloneDerivingTypes A.XmlHybrid"-standaloneDerivingTypes (A.Module _ _ _ _ decls) =+standaloneDerivingTypes :: ModuleInfo -> Set (Maybe S.ModuleName, S.Name)+standaloneDerivingTypes (A.XmlPage _ _ _ _ _ _ _, _, _) = error "standaloneDerivingTypes A.XmlPage"+standaloneDerivingTypes (A.XmlHybrid _ _ _ _ _ _ _ _ _, _, _) = error "standaloneDerivingTypes A.XmlHybrid"+standaloneDerivingTypes (A.Module _ _ _ _ decls, _, _) =     unions (map derivDeclTypes decls)     where       -- derivDeclTypes :: Decl -> Set (Maybe S.ModuleName, S.Name)@@ -270,7 +271,7 @@ nameString (S.Symbol s) = s  tests :: Test-tests = TestLabel "Clean" (TestList [test1, test2, test3, test4, test5])+tests = TestLabel "Clean" (TestList [test1, test2, test3, test4, test5, test6])  test1 :: Test test1 =@@ -350,3 +351,14 @@                          " 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)

@@ -99,7 +99,7 @@     withTempDirectory "." "scratch" $ \ scratch ->     do (result, params) <- runStateT action (Params {scratchDir = scratch,                                                      dryRun = False,-                                                     verbosity = 0,+                                                     verbosity = 1,                                                      hsFlags = [],                                                      extensions = Exts.extensions Exts.defaultParseMode,                                                      sourceDirs = ["."],@@ -175,7 +175,7 @@  doResult x@(Modified name text) =     do path <- modulePath name-       qPutStr ("catModules: modifying " ++ show path)+       qPutStr ("modifying " ++ show path)        quietly (qPutStr (" new text: " ++ show text))        qPutStr "\n"        replaceFile tildeBackup path text@@ -183,7 +183,7 @@  doResult x@(Created name text) =     do path <- modulePath name-       qPutStr ("catModules: creating " ++ show path)+       qPutStr ("creating " ++ show path)        quietly (qPutStr (" containing " ++ show text))        qPutStr "\n"        createDirectoryIfMissing True (takeDirectory . dropExtension $ path)

@@ -19,14 +19,15 @@ 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 (echo, echo2, foldDecls, foldExports, foldHeader, foldImports, ignore, ignore2)+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), parseFile, runMonadClean)+import Language.Haskell.Modules.Internal (doResult, getParams, modifyParams, modulePath, ModuleResult(..), MonadClean, Params(sourceDirs, moduVerse, testMode), parseFileWithComments, runMonadClean) import Language.Haskell.Modules.Util.Test (diff, repoModules) import System.Cmd (system) import System.Exit (ExitCode(ExitSuccess))@@ -58,42 +59,42 @@ -- The output module may not (yet) be an element of the moduVerse, in -- that case choose the first input modules to convert into the output -- module.-doModule :: MonadClean m => Map S.ModuleName (A.Module SrcSpanInfo, String) -> [S.ModuleName] -> S.ModuleName -> S.ModuleName -> m ModuleResult+doModule :: MonadClean m => Map S.ModuleName (A.Module SrcSpanInfo, String, [Comment]) -> [S.ModuleName] -> S.ModuleName -> S.ModuleName -> m ModuleResult doModule inputInfo inputs@(first : _) output name =     do -- The new module will be based on the existing module, unless        -- name equals output and output does not exist        let oldName = if name == output && not (Map.member name inputInfo) then first else name-       (m, text) <- maybe (loadModule oldName) return (Map.lookup name inputInfo)+       (m, text, comments) <- maybe (loadModule oldName) return (Map.lookup name inputInfo)        return $ case () of-         _ | name == output -> Modified name (doOutput inputInfo inputs output (m, text))+         _ | name == output -> Modified name (doOutput inputInfo inputs output (m, text, comments))            | elem name inputs -> Removed name-         _ -> let text' = doOther inputs output (m, text) in+         _ -> let text' = doOther inputs output (m, text, comments) in               if text /= text' then Modified name text' else Unchanged name doModule _ [] _ _ = error "doModule: no inputs"  -- | Create the output module, the destination of the merge.-doOutput :: Map S.ModuleName (A.Module SrcSpanInfo, String) -> [S.ModuleName] -> S.ModuleName -> (A.Module SrcSpanInfo, String) -> String-doOutput inputInfo inNames outName (m, text) =+doOutput :: Map S.ModuleName ModuleInfo -> [S.ModuleName] -> S.ModuleName -> ModuleInfo -> String+doOutput inputInfo inNames outName m =     header ++ exports ++ imports ++ decls     where-      header = foldHeader echo2 echo (\ _ pref _ suff r -> r <> pref <> prettyPrint outName <> suff) echo m text "" <>-               foldExports (\ s r -> r <> s <> maybe "" (intercalate ", " . List.map (prettyPrint)) (mergeExports inputInfo outName) <> "\n") ignore ignore2 m text ""-      exports = fromMaybe "" (foldExports ignore2 (\ _e pref _ _ r -> maybe (Just pref) Just r) ignore2 m text Nothing)-      imports = foldExports ignore2 ignore (\ s r -> r <> s {-where-}) m text "" <>+      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 ""+      exports = fromMaybe "" (foldExports ignore2 (\ _e pref _ _ r -> maybe (Just pref) Just r) ignore2 m Nothing)+      imports = foldExports ignore2 ignore (\ s r -> r <> s {-where-}) m "" <>                 -- Insert the new imports just after the first "pre" string of the imports-                (fromMaybe "" (foldImports (\ _ pref _ _ r -> maybe (Just (pref <> unlines (List.map (moduleImports inputInfo) inNames))) Just r) m text Nothing)) <>-                (foldImports (\ _i pref s suff r -> r <> pref <> s <> suff) m text "")-      decls = fromMaybe "" (foldDecls (\ _d _ _ _ r -> Just (fromMaybe (unlines (List.map (moduleDecls inputInfo outName) inNames)) r)) (\ s r -> Just (maybe s (<> s) r)) m text Nothing)+                (fromMaybe "" (foldImports (\ _ pref _ _ r -> maybe (Just (pref <> unlines (List.map (moduleImports inputInfo) inNames))) Just r) m Nothing)) <>+                (foldImports (\ _i pref s suff r -> r <> pref <> s <> suff) m "")+      decls = fromMaybe "" (foldDecls (\ _d _ _ _ r -> Just (fromMaybe (unlines (List.map (moduleDecls inputInfo outName) inNames)) r)) (\ s r -> Just (maybe s (<> s) r)) m Nothing)  -- | Update a module that does not participate in the merge - this -- involves changing imports and exports of merged modules. -- (Shouldn't this also fix qualified symbols?)-doOther :: [S.ModuleName] -> S.ModuleName -> (A.Module SrcSpanInfo, String) -> String-doOther inputs output (m, text) =-    foldHeader echo2 echo echo echo m text "" <>-    foldExports echo2 (\ x pref s suff r -> r <> pref <> fromMaybe s (fixModuleExport inputs output (sExportSpec x)) <> suff) echo2 m text "" <>-    foldImports (\ x pref s suff r -> r <> pref <> fromMaybe s (fixModuleImport inputs output (sImportDecl x)) <> suff) m text "" <>-    foldDecls echo echo2 m text ""+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 ""  fixModuleExport :: [S.ModuleName] -> S.ModuleName -> S.ExportSpec -> Maybe String fixModuleExport inputs output x =@@ -109,16 +110,16 @@                 | elem y inputs -> Just (prettyPrint (x {S.importModule = output}))             _ -> Nothing -mergeExports :: Map S.ModuleName (A.Module SrcSpanInfo, String) -> S.ModuleName -> Maybe [S.ExportSpec]+mergeExports :: Map S.ModuleName (A.Module SrcSpanInfo, String, [Comment]) -> S.ModuleName -> Maybe [S.ExportSpec] mergeExports old new =     Just (concatMap mergeExports' (Map.toAscList old))     where-      mergeExports' (_, (A.Module _ Nothing _ _ _, _)) = error "mergeModules: no explicit export list"-      mergeExports' (_, (A.Module _ (Just (A.ModuleHead _ _ _ Nothing)) _ _ _, _)) = error "mergeModules: no explicit export list"-      mergeExports' (_, (A.Module _ (Just (A.ModuleHead _ _ _ (Just (A.ExportSpecList _ e)))) _ _ _, _)) = updateModuleContentsExports old new (List.map sExportSpec e)+      mergeExports' (_, (A.Module _ Nothing _ _ _, _, _)) = error "mergeModules: no explicit export list"+      mergeExports' (_, (A.Module _ (Just (A.ModuleHead _ _ _ Nothing)) _ _ _, _, _)) = error "mergeModules: no explicit export list"+      mergeExports' (_, (A.Module _ (Just (A.ModuleHead _ _ _ (Just (A.ExportSpecList _ e)))) _ _ _, _, _)) = updateModuleContentsExports old new (List.map sExportSpec e)       mergeExports' (_, _) = error "mergeExports'" -updateModuleContentsExports :: Map S.ModuleName (A.Module SrcSpanInfo, String) -> S.ModuleName -> [S.ExportSpec] -> [S.ExportSpec]+updateModuleContentsExports :: Map S.ModuleName (A.Module SrcSpanInfo, String, [Comment]) -> S.ModuleName -> [S.ExportSpec] -> [S.ExportSpec] updateModuleContentsExports old new es =     foldl f [] es     where@@ -128,15 +129,15 @@           ys ++ if elem e' ys then [] else [e']       f ys e = ys ++ [e] -moduleImports :: Map S.ModuleName (A.Module SrcSpanInfo, String) -> S.ModuleName -> String+moduleImports :: Map S.ModuleName ModuleInfo -> S.ModuleName -> String moduleImports old name =-    let (Just (m, text)) = Map.lookup name old in+    let (Just m) = Map.lookup name old in     foldImports (\ x pref s suff r ->                     r                     -- If this is the first import, omit the prefix, it includes the ") where" text.                     <> (if r == "" then "" else pref)                     <> if Map.member (sModuleName (A.importModule x)) old then "" else (s <> suff))-                m text "" <> "\n"+                m "" <> "\n"  -- | Grab the declarations out of the old modules, fix any -- qualified symbol references, prettyprint and return.@@ -148,17 +149,17 @@ -- In terms of what is going on right here, if m imports any of the -- modules in oldmap with an "as" qualifier, identifiers using the -- module name in the "as" qualifier must use new instead.-moduleDecls :: Map S.ModuleName (A.Module SrcSpanInfo, String) -> S.ModuleName -> S.ModuleName -> String+moduleDecls :: Map S.ModuleName ModuleInfo -> S.ModuleName -> S.ModuleName -> String moduleDecls oldmap new name =-    let (Just (m@(A.Module _ _ _ imports _), text)) = Map.lookup name oldmap in+    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 "-- Declaration reformatted because module qualifiers changed\n" <> prettyPrint d'' <> "\n\n" else (s <> suff)))+                    (if d'' /= d' then prettyPrint d'' else s) <> suff)               echo2-              m text "" <> "\n"+              m "" <> "\n"     where       f (A.ImportDecl _ m _ _ _ (Just a) _specs) mp =           case Map.lookup (sModuleName m) oldmap of@@ -170,7 +171,7 @@ -- probably mess up the location information, so the result (if -- different from the original) should be prettyprinted, not -- exactPrinted.-fixReferences :: (Data a, Typeable a) => Map S.ModuleName (A.Module SrcSpanInfo, String) -> S.ModuleName -> a -> a+fixReferences :: (Data a, Typeable a) => Map S.ModuleName ModuleInfo -> S.ModuleName -> a -> a fixReferences oldmap new x =     everywhere (mkT moveModuleName) x     where@@ -225,12 +226,12 @@ -- junk :: String -> Bool -- junk s = isSuffixOf ".imports" s || isSuffixOf "~" s -loadModules :: MonadClean m => [S.ModuleName] -> m (Map S.ModuleName (A.Module SrcSpanInfo, String))+loadModules :: MonadClean m => [S.ModuleName] -> m (Map S.ModuleName ModuleInfo) loadModules names = List.mapM loadModule names >>= return . Map.fromList . zip names -loadModule :: MonadClean m => S.ModuleName -> m (A.Module SrcSpanInfo, String)+loadModule :: MonadClean m => S.ModuleName -> m ModuleInfo loadModule name =     do path <- modulePath name        text <- liftIO $ readFile path-       m <- parseFile path >>= return . fromParseResult-       return (m, text)+       (m, comments) <- parseFileWithComments path >>= return . fromParseResult+       return (m, text, comments)

@@ -1,14 +1,15 @@+-- | Functions to control the state variables of 'MonadClean'. {-# LANGUAGE FlexibleInstances, OverloadedStrings, PackageImports, ScopedTypeVariables, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.Modules.Params     ( MonadClean     , runMonadClean-    , modifyDryRun-    , modifyExtensions     , modifyModuVerse-    , modifyHsFlags-    , modifySourceDirs     , modifyRemoveEmptyImports+    , modifySourceDirs+    , modifyExtensions+    , modifyHsFlags+    , modifyDryRun     , modifyTestMode     ) where @@ -16,39 +17,47 @@ import Data.Set (empty, Set) import Language.Haskell.Exts.Extension (Extension) import qualified Language.Haskell.Exts.Syntax as S (ModuleName)-import Language.Haskell.Modules.Internal (modifyParams, MonadClean, Params(dryRun, extensions, hsFlags, moduVerse, removeEmptyImports, sourceDirs, testMode), runMonadClean)+import Language.Haskell.Modules.Internal (MonadClean, modifyParams, Params(dryRun, extensions, hsFlags, moduVerse, removeEmptyImports, sourceDirs, testMode), runMonadClean) import Prelude hiding (writeFile) --- | Controls whether file updates will actually be performed.--- Default is False.  (I recommend running in a directory controlled--- by a version control system so you don't have to worry about this.)-modifyDryRun :: MonadClean m => (Bool -> Bool) -> m ()-modifyDryRun f = modifyParams (\ p -> p {dryRun = f (dryRun p)})---- | Modify the extra extensions passed to the compiler and the--- parser.  Default value is the list in--- 'Language.Haskell.Exts.Parser.defaultParseMode'.-modifyExtensions :: MonadClean m => ([Extension] -> [Extension]) -> m ()-modifyExtensions f = modifyParams (\ p -> p {extensions = f (extensions p)})- -- | Modify the set of modules whose imports will be updated when -- modules are split or merged.  No default, it is an error to run -- splitModules or catModules without first setting this. modifyModuVerse :: MonadClean m => (Set S.ModuleName -> Set S.ModuleName) -> m () modifyModuVerse f = modifyParams (\ p -> p {moduVerse = Just (f (fromMaybe empty (moduVerse p)))}) --- | Modify the list of extra flags passed to GHC.-modifyHsFlags :: MonadClean m => ([String] -> [String]) -> m ()-modifyHsFlags f = modifyParams (\ p -> p {hsFlags = f (hsFlags p)})+-- | If this flag is set, imports that become empty are removed.+-- Sometimes this will lead to errors, specifically when an instance+-- in the removed import that was required is no longer be available.+-- (Note that this reflects a limitation of the+-- @-ddump-minimal-imports@ option of GHC.)  If this happens this flag+-- should be set.  Note that an import that is already empty when+-- @cleanImports@ runs will never be removed, on the assumption that+-- it was placed there only to import instances.  Default is True.+modifyRemoveEmptyImports :: MonadClean m => (Bool -> Bool) -> m ()+modifyRemoveEmptyImports f = modifyParams (\ p -> p {removeEmptyImports = f (removeEmptyImports p)}) --- | Modify the list of directories that will be searched for source files.  Default is [\".\"].+-- | Modify the list of directories that will be searched for source+-- files, in a similar way to the Hs-Source-Dirs field in a cabal+-- file.  Default is @[\".\"]@. modifySourceDirs :: MonadClean m => ([FilePath] -> [FilePath]) -> m () modifySourceDirs f = modifyParams (\ p -> p {sourceDirs = f (sourceDirs p)}) --- | Change the flag controlling whether imports that become empty will be--- removed.  Default is True.-modifyRemoveEmptyImports :: MonadClean m => (Bool -> Bool) -> m ()-modifyRemoveEmptyImports f = modifyParams (\ p -> p {removeEmptyImports = f (removeEmptyImports p)})+-- | Modify the extra extensions passed to the compiler and the+-- parser.  Default value is the list in+-- 'Language.Haskell.Exts.Parser.defaultParseMode'.+modifyExtensions :: MonadClean m => ([Extension] -> [Extension]) -> m ()+modifyExtensions f = modifyParams (\ p -> p {extensions = f (extensions p)})++-- | Modify the list of extra flags passed to GHC.  Default is @[]@.+modifyHsFlags :: MonadClean m => ([String] -> [String]) -> m ()+modifyHsFlags f = modifyParams (\ p -> p {hsFlags = f (hsFlags p)})++-- | Controls whether file updates will actually be performed.+-- Default is False.  (I recommend running in a directory controlled+-- by a version control system so you don't have to worry about this.)+modifyDryRun :: MonadClean m => (Bool -> Bool) -> m ()+modifyDryRun f = modifyParams (\ p -> p {dryRun = f (dryRun p)})  -- | If TestMode is turned on no import cleaning will occur after a -- split or cat.  Default is False.

@@ -22,10 +22,9 @@ 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.Fold (echo, echo2, foldDecls, foldExports, foldHeader, foldImports, foldModule, ignore, ignore2)+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), parseFile, runMonadClean)-import Language.Haskell.Modules.Util.QIO (noisily)+import Language.Haskell.Modules.Internal (doResult, modifyParams, modulePath, ModuleResult(..), MonadClean(getParams), Params(moduVerse, sourceDirs, testMode), parseFileWithComments, runMonadClean) import Language.Haskell.Modules.Util.Symbols (exports, imports, symbols) import Language.Haskell.Modules.Util.Test (diff, repoModules) import Prelude hiding (writeFile)@@ -47,13 +46,36 @@  -- | Split each of a module's declarations into a new module.  Update -- the imports of all the modules in the moduVerse to reflect the split.+-- For example, if you have a module like+--+-- @+-- module Start (a, b, (.+.)) where+-- import+-- a = 1 + a+-- b = 2+-- c = 3+-- c' = 4+-- (.+.) = b + c+-- @+--+-- After running @splitModule@ the @Start@ module will be gone.  The+-- @a@ and @b@ symbols will be in new modules named @Start.A@ and+-- @Start.B@.  Because they were not exported by @Start@, the @c@ and+-- @c'@ symbols will both be in a new module named @Start.Internal.C@.+-- And the @.+.@ symbol will be in a module named+-- @Start.OtherSymbols@.  Note that this module needs to import new+-- @Start.A@ and @Start.Internal.C@ modules.+--+-- If we had imported and then re-exported a symbol in Start it would+-- go into a module named @Start.ReExported@.  Any instance declarations+-- would go into @Start.Instances@. splitModule :: MonadClean m => S.ModuleName -> m () splitModule old =     do univ <- getParams >>= return . fromMaybe (error "moduVerse not set") . moduVerse        path <- modulePath old        text <- liftIO $ readFile path-       parsed <- parseFile path >>= return . fromParseResult-       newFiles <- doSplit text univ parsed >>= return . collisionCheck univ+       (parsed, comments) <- parseFileWithComments path >>= return . fromParseResult+       newFiles <- doSplit univ (parsed, text, comments) >>= return . collisionCheck univ        -- Write the new modules        setMapM_ doResult newFiles        -- Clean the new modules@@ -85,11 +107,11 @@ -- | Create the set of module results implied by the split - -- creations, removals, and modifications.  This includes the changes -- to the imports in modules that imported the original module.-doSplit :: MonadClean m => String -> Set S.ModuleName -> A.Module SrcSpanInfo -> m (Set ModuleResult)-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 text univ m@(A.Module _ (Just (A.ModuleHead _ moduleName _ (Just _))) _ _ _) =+doSplit :: MonadClean m => Set S.ModuleName -> ModuleInfo -> m (Set ModuleResult)+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     where       -- The name of the module to be split@@ -98,17 +120,16 @@       -- 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 text Map.empty+      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.       declared :: Set (Maybe S.Name)-      declared = foldDecls (\ d _pref _s _suff r -> Set.union (symbols d) r) ignore2 m text Set.empty+      declared = foldDecls (\ d _pref _s _suff r -> Set.union (symbols d) r) ignore2 m Set.empty        exported :: Set S.Name-      exported = foldExports ignore2 (\ e _pref _s _suff r -> Set.union (justs (symbols e)) r) ignore2 m text Set.empty+      exported = foldExports ignore2 (\ e _pref _s _suff r -> Set.union (justs (symbols e)) r) ignore2 m Set.empty        reExported :: Set S.Name       reExported = difference exported (justs declared)@@ -132,8 +153,8 @@       symbolToModule =           mp'           where-            mp' = foldExports ignore2 (\ e _ _ _ r -> Set.fold f r (symbols e)) ignore2 m text mp-            mp = foldDecls (\ d _ _ _ r -> Set.fold f r (symbols d)) ignore2 m text Map.empty+            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)@@ -149,21 +170,21 @@           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 text "" <>-                foldExports echo2 ignore ignore2 m text "" <>-                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 text []) <>-                foldImports (\ _i pref s suff r -> r <> pref <> s <> suff) m text ""+                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 ""             Just modDecls ->                 -- Change the module name in the header-                foldHeader echo2 echo (\ _n pref _ suff r -> r <> pref <> modName <> suff) echo m text "" <>+                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 ""-} <>                 -- The prefix of the imports section-                fromMaybe "" (foldImports (\ _i pref _ _ r -> maybe (Just pref) Just r) m text Nothing) <>+                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 text Nothing) <>+                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"               where@@ -178,7 +199,7 @@                 -- 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'"+doSplit _ _ = error "splitModule'"  -- Re-construct a separated list doSeps :: [(String, String)] -> String@@ -190,12 +211,12 @@ updateImports old symbolToModule name =     do path <- modulePath name        text' <- liftIO $ readFile path-       parsed <- parseFile path+       parsed <- parseFileWithComments path        case parsed of-         ParseOk m' ->+         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' "" in+                          echo echo2 (m', text', comments') "" in              return $ if text' /= text'' then Modified name text'' else Unchanged name          ParseFailed _ _ -> error $ "Parse error in " ++ show name     where@@ -282,13 +303,13 @@            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" (ExitSuccess, "", "") (code, out, err)+         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 $ noisily $ noisily $+       runMonadClean $          do modifyParams (\ p -> p {testMode = True,                                     sourceDirs = ["testdata/copy"],                                     -- extensions = NoImplicitPrelude : extensions p,@@ -301,7 +322,7 @@ test3 =     TestCase $     do _ <- system "rsync -aHxS --delete testdata/split2/ testdata/copy"-       runMonadClean $ noisily $ noisily $+       runMonadClean $          do modifyParams (\ p -> p {testMode = False,                                     sourceDirs = ["testdata/copy"],                                     -- extensions = NoImplicitPrelude : extensions p,

@@ -10,6 +10,7 @@     , textSpan     , srcPairTextHead     , srcPairTextTail+    , srcPairTextPair     , makeTree     , tests     ) where@@ -61,6 +62,9 @@ class HasSpanInfo a where     spanInfo :: a -> SrcSpanInfo +instance HasSpanInfo SrcSpan where+    spanInfo x = SrcSpanInfo x []+ instance HasSpanInfo a => HasSpanInfo (Tree a) where     spanInfo (Node x _) = spanInfo x @@ -233,6 +237,10 @@                 ('\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)  instance Default SrcLoc where     def = SrcLoc "<unknown>.hs" 1 1

@@ -1,9 +1,10 @@+{-# LANGUAGE PackageImports #-} module Language.Haskell.Modules.Util.Temp     ( withTempDirectory     ) where  import qualified Control.Exception as IO (catch)-import Control.Monad.CatchIO as IOT (bracket, MonadCatchIO)+import "MonadCatchIO-mtl" Control.Monad.CatchIO as IOT (bracket, MonadCatchIO) import Control.Monad.Trans (liftIO, MonadIO) import System.Directory (removeDirectoryRecursive) import qualified System.IO.Temp as Temp (createTempDirectory)

@@ -131,15 +131,7 @@        let out' = unlines (List.filter (not . isPrefixOf "Binary files") . List.map (takeWhile (/= '\t')) $ (lines out))        return (code, out', err) --- | Convenience function for building the moduVerse, searches for--- files in a directory hierarchy, with a filter predicate.-findModules :: FilePath -> IO (Set S.ModuleName)-findModules top =-    findPaths top >>= return . Set.map asModuleName-    where-      asModuleName path =-          S.ModuleName (List.map (\ c -> if c == '/' then '.' else c) (take (length path - 3) path))-+-- | Find the paths of all the files below the directory @top@. findPaths :: FilePath -> IO (Set FilePath) findPaths top =     doPath empty top@@ -153,3 +145,15 @@                _ -> return r       doDirectory r path =           getDirectoryContents path >>= foldM doPath r . List.map (path </>) . filter (\ x -> x /= "." && x /= "..")++-- | Convenience function for building the moduVerse, searches for+-- modules in a directory hierarchy.  FIXME: This should be in+-- MonadClean and use the value of sourceDirs to remove prefixes from+-- the module paths.  And then it should look at the module text to+-- see what the module name really is.+findModules :: FilePath -> IO (Set S.ModuleName)+findModules top =+    findPaths top >>= return . Set.map asModuleName+    where+      asModuleName path =+          S.ModuleName (List.map (\ c -> if c == '/' then '.' else c) (take (length path - 3) path))

@@ -0,0 +1,133 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# OPTIONS -Wall #-}++import Control.Exception (SomeException, try)+import Data.List (isPrefixOf)+import Data.Set as Set (Set, fromList, union, delete)+import Language.Haskell.Exts.Annotated (defaultParseMode, exactPrint, parseFileWithComments, ParseResult(ParseOk))+import Language.Haskell.Exts.Annotated.Syntax as A (Module)+import Language.Haskell.Exts.Comments (Comment)+import Language.Haskell.Exts.Extension (Extension(..))+import Language.Haskell.Exts.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 Language.Haskell.Modules.Common (withCurrentDirectory)+import qualified Language.Haskell.Modules.Fold as Fold (tests)+import qualified Language.Haskell.Modules.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 System.Exit (ExitCode(ExitSuccess, ExitFailure), exitWith)+import System.Process (readProcess)+import Test.HUnit (assertEqual, Counts(..), runTestTT, Test(TestList, TestCase, TestLabel))++main :: IO ()+main =+    do 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" $+    do text <- try (readFile path)+       source <- try (parseFileWithComments defaultParseMode path)+       case (text, source) of+         (Right text', Right (ParseOk (m, comments))) ->+             f m comments text'+         (Right _, Right _) -> error "parse failure"+         (Left (e :: SomeException), _) -> error $ "failure: " ++ show e+         (_, Left (e :: SomeException)) -> error $ "failure: " ++ show e++tests :: Test+tests = TestList [ Main.test1+                 , TestLabel "Merge" Merge.tests+                 , TestLabel "Fold" Fold.tests+                 , TestLabel "Imports" Imports.tests+                 , TestLabel "Split" Split.tests+                 -- If split-merge-merge fails try split and split-merge.+                 , Main.logictest "split" test2a+                 , Main.logictest "split-merge" test2b+                 , Main.logictest "split-merge-merge" test2c+                 ]++test1 :: Test+test1 =+    TestLabel "exactPrint" $ TestCase+    (withTestData test "Debian/Repo/Package.hs" >>= \ (output, text) ->+     assertEqual+     "exactPrint"+     text+     output)+    where+      test parsed comments text = return (exactPrint parsed comments, text)++-- 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"+       let out' = unlines (filter (not . isPrefixOf "Binary files") . map (takeWhile (/= '\t')) $ (lines out))+       assertEqual s (ExitSuccess, "", "") (code, out', err)++test2a :: MonadClean m => Set ModuleName -> m ()+test2a u =+         do modifyParams (\ p -> p {extensions = extensions p ++ [MultiParamTypeClasses],+                                    moduVerse = Just u})+            qPutStrLn "\nSplitting module Literal"+            splitModule (ModuleName "Data.Logic.Classes.Literal")+            return ()++test2b :: MonadClean m => Set ModuleName -> m ()+test2b u =+         do modifyParams (\ p -> p {extensions = extensions p ++ [MultiParamTypeClasses],+                                    moduVerse = Just u})+            qPutStrLn "\nSplitting module Literal"+            splitModule (ModuleName "Data.Logic.Classes.Literal")+            qPutStrLn "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")+            return ()+    where+      u' = union (fromList [ModuleName "Data.Logic.Classes.Literal.Internal.FixityLiteral",+                            ModuleName "Data.Logic.Classes.Literal.FoldAtomsLiteral",+                            ModuleName "Data.Logic.Classes.Literal.FromFirstOrder",+                            ModuleName "Data.Logic.Classes.Literal.FromLiteral",+                            ModuleName "Data.Logic.Classes.Literal.Literal",+                            ModuleName "Data.Logic.Classes.Literal.PrettyLit",+                            ModuleName "Data.Logic.Classes.Literal.ToPropositional",+                            ModuleName "Data.Logic.Classes.Literal.ZipLiterals"])+                 (delete (ModuleName "Data.Logic.Classes.Literal") u)++test2c :: MonadClean m => Set ModuleName -> m ()+test2c u =+         do modifyParams (\ p -> p {extensions = extensions p ++ [MultiParamTypeClasses],+                                    moduVerse = Just u})+            qPutStrLn "\nSplitting module Literal"+            splitModule (ModuleName "Data.Logic.Classes.Literal")+            qPutStrLn "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")+            -- modifyParams (\ p -> p {testMode = True})+            mergeModules+              [ModuleName "Data.Logic.Classes.Literal.Literal",+               ModuleName "Data.Logic.Classes.Literal.ZipLiterals",+               ModuleName "Data.Logic.Classes.Literal.ToPropositional",+               ModuleName "Data.Logic.Classes.Literal.PrettyLit",+               ModuleName "Data.Logic.Classes.Literal.Internal.FixityLiteral",+               ModuleName "Data.Logic.Classes.Literal.FoldAtomsLiteral"]+              (ModuleName "Data.Logic.Classes.Literal")+            return ()

@@ -1,5 +1,5 @@ Name:               module-management-Version:            0.9.3.1+Version:            0.10 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,12 @@ Stability:          experimental Build-type:         Simple Cabal-version:      >=1.8+Extra-Source-Files: testdata.tar.gz +Flag build-tests+  Description: build the test executable+  Default: True+ Library   ghc-Options:      -Wall -O2   Exposed-Modules:@@ -50,28 +55,51 @@     system-fileio,     temporary --- Executable tests---   Build-Depends:---     ansi-wl-pprint,---     base,---     bytestring,---     Cabal,---     containers,---     data-default,---     debian,---     directory,---     Extra,---     filepath,---     HUnit,---     haskell-src-exts,---     module-management,---     MonadCatchIO-mtl,---     mtl,---     process,---     process-progress,---     pureMD5,---     regex-compat,---     set-extra,---     syb,---     system-fileio---   Main-is: Tests.hs+Executable hmm+  Main-is: scripts/CLI.hs+  Build-Depends:+    base,+    containers,+    data-default,+    directory,+    filepath,+    haskell-src-exts,+    HUnit,+    module-management,+    MonadCatchIO-mtl,+    mtl,+    process,+    set-extra,+    syb,+    temporary++Executable tests+  Main-is: Tests.hs+  if flag (build-tests)+    Buildable: True+    Build-Depends:+      ansi-wl-pprint,+      base,+      bytestring,+      Cabal,+      containers,+      data-default,+      debian,+      directory,+      Extra,+      filepath,+      HUnit,+      haskell-src-exts,+      module-management,+      MonadCatchIO-mtl,+      mtl,+      process,+      process-progress,+      pureMD5,+      regex-compat,+      set-extra,+      syb,+      system-fileio,+      temporary+  else+    Buildable: False

@@ -0,0 +1,92 @@+{-# OPTIONS_GHC -Wall #-}+module Main where++import Control.Monad.Trans (MonadIO(liftIO))+import Data.List (intercalate, isPrefixOf)+import Data.Maybe (fromMaybe)+import Data.Set (Set, union, toList, empty, size, unions, singleton)+import Language.Haskell.Exts.Syntax (ModuleName(ModuleName))+import Language.Haskell.Modules (runMonadClean, cleanImports, splitModule, mergeModules,+                                 modifyModuVerse, modifySourceDirs)+import Language.Haskell.Modules.Internal (getParams, Params(..))+import Language.Haskell.Modules.Params (MonadClean)+import Language.Haskell.Modules.Util.QIO (noisily, quietly)+import Language.Haskell.Modules.Util.Test (findModules)+import System.IO (stdin, stderr, hGetLine, hPutStr, hPutStrLn)++main :: IO ()+main = runMonadClean (noisily cli)++cli :: MonadClean m => m ()+cli = liftIO (hPutStr stderr " > " >> hGetLine stdin) >>= cmd . words++cmd :: MonadClean m => [String] -> m ()+cmd [] = cli+cmd (s : args) =+    case filter (any (== s) . fst) cmds of+      [(_, f)] -> f+      -- No exact matches - look for prefix matches+      [] -> case filter (any (isPrefixOf s) . fst) cmds of+              [(_, f)] -> f+              [] -> liftIO (hPutStrLn stderr $+                              show s ++ " invalid - expected " ++ intercalate ", " (concatMap fst cmds)) >> cli+              xs -> liftIO (hPutStrLn stderr $+                              show s ++ " ambiguous - expected " ++ intercalate ", " (concatMap fst xs)) >> cli+      _ -> error $ "Internal error - multiple definitions for " ++ show s+    where+      cmds =+          [(["quit", "exit", "bye", "."],	liftIO (hPutStrLn stderr "Exiting")),+           (["v"],				liftIO (hPutStrLn stderr "Increasing verbosity level") >> noisily cli),+           (["q"],				liftIO (hPutStrLn stderr "Decreasing verbosity level") >> quietly cli),+           (["help"],				liftIO (hPutStrLn stderr "help text") >> cli),+           (["verse"],				verse args >> cli),+           (["clean"],				clean args >> cli),+           (["dir"],				dir args >> cli),+           (["split"],				split args >> cli),+           (["merge"],				merge args >> cli)]++unModuleName :: ModuleName -> String+unModuleName (ModuleName x) = x++verse :: MonadClean m => [String] -> m ()+verse [] =+    do modules <- getParams >>= return . moduVerse+       liftIO $ hPutStrLn stderr ("Usage: verse <pathormodule1> <pathormodule2> ...\n" +++                                  "Add the module or all the modules below a directory to the moduVerse\n" +++                                  "Currently:\n  " ++ showVerse (fromMaybe empty modules))+verse args =+    do new <- mapM (liftIO . find) args+       modifyModuVerse (union (unions new))+       modules <- getParams >>= return . moduVerse+       liftIO (hPutStrLn stderr $ "moduVerse updated:\n  " ++ showVerse (fromMaybe empty modules))+    where+      find :: String -> IO (Set ModuleName)+      find s =+          do ms <- liftIO (findModules s)+             case size ms of+               0 -> return (singleton (ModuleName s))+               _ -> return ms++showVerse :: Set ModuleName -> String+showVerse modules = "[ " ++ intercalate "\n  , " (map unModuleName (toList modules)) ++ " ]"++dir :: MonadClean m => [FilePath] -> m ()+dir [] = modifySourceDirs (const [])+dir xs =+    do modifySourceDirs (++ xs)+       xs' <- getParams >>= return . sourceDirs+       liftIO (hPutStrLn stderr $ "sourceDirs updated:\n  [ " ++ intercalate "\n  , " xs' ++ " ]")++clean :: MonadClean m => [FilePath] -> m ()+clean [] = liftIO $ hPutStrLn stderr "Usage: clean <modulepath1> <modulepath2> ..."+clean args = mapM_ cleanImports args++split :: MonadClean m => [String] -> m ()+split [arg] = splitModule (ModuleName arg)+split _ = liftIO $ hPutStrLn stderr "Usage: split <modulename>"++merge :: MonadClean m => [String] -> m ()+merge args =+    case splitAt (length args - 1) args of+      (inputs, [output]) -> mergeModules (map ModuleName inputs) (ModuleName output) >> return ()+      _ -> liftIO $ hPutStrLn stderr "Usage: merge <inputmodulename1> <inputmodulename2> ... <outputmodulename>"

binary file changed (absent → 632992 bytes)