module-management (empty) → 0.9.3
raw patch · 16 files changed
+2481/−0 lines, 16 filesdep +Cabaldep +HUnitdep +MonadCatchIO-mtlsetup-changed
Dependencies added: Cabal, HUnit, MonadCatchIO-mtl, applicative-extras, base, bytestring, containers, data-default, directory, filepath, haskell-src-exts, mtl, pretty, process, pureMD5, set-extra, syb, system-fileio, temporary
Files
- Language/Haskell/Modules.hs +71/−0
- Language/Haskell/Modules/Common.hs +46/−0
- Language/Haskell/Modules/Fold.hs +330/−0
- Language/Haskell/Modules/Imports.hs +352/−0
- Language/Haskell/Modules/Internal.hs +191/−0
- Language/Haskell/Modules/Merge.hs +236/−0
- Language/Haskell/Modules/Params.hs +56/−0
- Language/Haskell/Modules/Split.hs +315/−0
- Language/Haskell/Modules/Util/DryIO.hs +72/−0
- Language/Haskell/Modules/Util/QIO.hs +48/−0
- Language/Haskell/Modules/Util/SrcLoc.hs +290/−0
- Language/Haskell/Modules/Util/Symbols.hs +203/−0
- Language/Haskell/Modules/Util/Temp.hs +23/−0
- Language/Haskell/Modules/Util/Test.hs +155/−0
- Setup.hs +16/−0
- module-management.cabal +77/−0
+ Language/Haskell/Modules.hs view
@@ -0,0 +1,71 @@+-- | This package provides three functions. The 'cleanImports'+-- function uses ghc's -ddump-minimal-imports flag to generate+-- minimized and explicit imports and re-insert them into the module.+--+-- The 'splitModule' moves each declaration of a module into a+-- separate new module, and may also create three additional modules:+-- ReExported (for identifiers that were re-exported from other+-- imports), Instances (for declarations that don't result in an+-- identifier to export), and OtherSymbols (for declarations that+-- can't be turned into a module name.)+--+-- In addition to creating new modules, 'splitModule' also scans the+-- a set of modules (known as the moduVerse) and updates their imports+-- to account for the new locations of the symbols. The moduVerse is+-- stored in MonadClean's state, and is updated as modules are created+-- and destroyed by 'splitModule' and 'catModules'.+--+-- The 'catModules' function is the inverse operation of 'splitModule',+-- it merges two or more modules into a new or existing module, updating+-- imports of the moduVerse elements as necessary.+--+-- There are several features worth noting. The 'Params' type in the+-- state of 'MonadClean' has a 'removeEmptyImports' field, which is+-- True by default. This determines whether imports that turn into+-- empty lists are preserved or not - if your program needs instances+-- from a such an import, you will either want to set this flag to+-- False or (better) add an empty import list to the import.+--+-- These are the important entry points:+--+-- * 'cleanImports'+--+-- * 'splitModule'+--+-- * 'mergeModules'+--+-- * 'runMonadClean'+--+-- Examples:+--+-- * 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:+--+-- @findModules \"Language\" >>= \\ modules -> runMonadClean $+-- let mn = Language.Haskell.Exts.Syntax.ModuleName in+-- modifyModuVerse (const modules) >>+-- splitModule (mn \"Language.Haskell.Modules.Common\") >>+-- mergeModules (map mn [\"Language.Haskell.Modules.Common.WithCurrentDirectory\",+-- \"Language.Haskell.Modules.Common.ModulePathBase\"])+-- (mn \"Language.Haskell.Modules.Common\"))@+module Language.Haskell.Modules+ ( cleanImports+ , splitModule+ , mergeModules+ , module Language.Haskell.Modules.Params+ , module Language.Haskell.Modules.Fold+ , module Language.Haskell.Modules.Util.QIO+ , findModules+ , findPaths+ ) where++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.Split (splitModule)+import Language.Haskell.Modules.Util.QIO (noisily, quietly)+import Language.Haskell.Modules.Util.Test (findModules, findPaths)
+ Language/Haskell/Modules/Common.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE BangPatterns, FlexibleInstances, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Language.Haskell.Modules.Common+ ( groupBy'+ , mapNames+ , modulePathBase+ , withCurrentDirectory+ ) where++import Control.Exception (bracket)+import Data.Default (def, Default)+import Data.List (groupBy, sortBy)+import qualified Language.Haskell.Exts.Annotated.Syntax as A (Name(..))+import qualified Language.Haskell.Exts.Syntax as S (ModuleName(..), Name(..))+import System.Directory (getCurrentDirectory, setCurrentDirectory)+import System.FilePath ((<.>))++-- | Convert a compare function into an (==)+toEq :: Ord a => (a -> a -> Ordering) -> (a -> a -> Bool)+toEq cmp a b =+ case cmp a b of+ EQ -> True+ _ -> False++-- | Combine sortBy and groupBy+groupBy' :: Ord a => (a -> a -> Ordering) -> [a] -> [[a]]+groupBy' cmp xs = groupBy (toEq cmp) $ sortBy cmp xs++mapNames :: Default a => [S.Name] -> [A.Name a]+mapNames [] = []+mapNames (S.Ident x : more) = A.Ident def x : mapNames more+mapNames (S.Symbol x : more) = A.Symbol def x : mapNames more++-- | Construct the base of a module path.+modulePathBase :: S.ModuleName -> FilePath+modulePathBase (S.ModuleName name) =+ map f name <.> "hs"+ where+ f '.' = '/'+ f c = c++withCurrentDirectory :: FilePath -> IO a -> IO a+withCurrentDirectory path action =+ bracket (getCurrentDirectory >>= \ save -> setCurrentDirectory path >> return save)+ setCurrentDirectory+ (const action)
+ Language/Haskell/Modules/Fold.hs view
@@ -0,0 +1,330 @@+-- | 'foldModule' is a utility function used to implement the clean, split, and merge operations.+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}+module Language.Haskell.Modules.Fold+ ( foldModule+ , foldHeader+ , foldExports+ , foldImports+ , foldDecls+ , echo+ , echo2+ , ignore+ , ignore2+ , tests+ ) where++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.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.SrcLoc (SrcLoc(..), SrcSpan(..), SrcSpanInfo(..))+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 Test.HUnit (assertEqual, Test(TestList, TestCase, TestLabel))++type Module = A.Module SrcSpanInfo+--type ModuleHead = A.ModuleHead SrcSpanInfo+type ModulePragma = A.ModulePragma SrcSpanInfo+type ModuleName = A.ModuleName SrcSpanInfo+type WarningText = A.WarningText SrcSpanInfo+type ExportSpec = A.ExportSpec SrcSpanInfo+type ImportDecl = A.ImportDecl SrcSpanInfo+type Decl = A.Decl SrcSpanInfo++class Spans a where+ spans :: a -> [SrcSpanInfo]++instance Spans (A.Module SrcSpanInfo) where+ spans (A.Module _sp mh ps is ds) =+ concatMap spans ps ++ maybe [] spans mh ++ concatMap spans is ++ concatMap spans ds+ spans _ = error "spans XML module"++instance Spans (A.ModuleHead SrcSpanInfo) where+ spans (A.ModuleHead _ n mw me) = spans n ++ maybe [] spans mw ++ maybe [] spans me++instance Spans (A.ExportSpecList SrcSpanInfo) where+ spans (A.ExportSpecList _ es) = concatMap spans es++instance Spans (A.ExportSpec SrcSpanInfo) where spans x = [fixSpan $ spanInfo x]+instance Spans (A.ModulePragma SrcSpanInfo) where spans x = [fixSpan $ spanInfo x]+instance Spans (A.ImportDecl SrcSpanInfo) where spans x = [fixSpan $ spanInfo x]+instance Spans (A.Decl SrcSpanInfo) where spans x = [fixSpan $ spanInfo x]+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?+fixSpan :: SrcSpanInfo -> SrcSpanInfo+fixSpan sp =+ if srcSpanEndColumn (srcInfoSpan sp) == 0+ then sp {srcInfoSpan = (srcInfoSpan sp) {srcSpanEndColumn = 1}}+ else sp++-- | 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+-- passed the AST value, the text of the space and comments leading up+-- to the element, and the text for the element. Note that not+-- everything passed to the "pre" argument of the functions will be+-- comments and space - for example, the "module" keyword will be+-- passed in the pre argument to the ModuleName function.+foldModule :: forall r. (Show r) =>+ (String -> r -> r) -- ^ Receives the space before the first pragma.+ -> (ModulePragma -> String -> String -> String -> r -> r) -- ^ Called once for each pragma. In this and the similar arguments below, the three string arguments contain+ -- the comments and space preceding the construct, the text of the construct and the space following it.+ -> (ModuleName -> String -> String -> String -> r -> r) -- ^ Called with the module name.+ -> (WarningText -> String -> String -> String -> r -> r) -- ^ Called with the warning text between module name and export list+ -> (String -> r -> r) -- ^ Called with the export list open paren+ -> (ExportSpec -> String -> String -> String -> r -> r) -- ^ Called with each export specifier+ -> (String -> r -> r) -- ^ Called with the export list close paren and "where" keyword+ -> (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+ -> 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)+ 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+ 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 =+ do p <- get+ case p of+ (tl, l, sps@(sp : _)) ->+ 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+ _ -> 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++ 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+ 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+ s = srcPairTextHead (srcLoc sp) l' tl'+ tl'' = srcPairTextTail (srcLoc sp) l' tl'+ l'' = adjust tl'' l'+ post = srcPairTextHead l' l'' tl''+ tl''' = srcPairTextTail l' l'' tl''+ put (tl''', l'', sps')+ return $ f x pre s post r++ -- Move to just past the first 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 =+ l'+ where+ w = takeWhile isSpace a+ w' = case span (/= '\n') w of+ (w'', '\n' : _) -> w'' ++ ['\n']+ (w'', "") -> w''+ l' = increaseSrcLoc w' l++ -- Move to just past the last 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 =+ l'+ where+ w = takeWhile isSpace a+ w' = take (length (takeWhile (elem '\n') (tails w))) w+ l' = increaseSrcLoc w' l++-- | Do just the header portion of 'foldModule'.+foldHeader :: forall r. (Show r) =>+ (String -> r -> r)+ -> (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++-- | 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++-- | 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++-- | 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++-- | 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++-- | Similar to 'echo', but used for the two argument separator functions+echo2 :: Monoid m => m -> m -> 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+ignore _ _ _ _ r = r++-- | 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, 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+ 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)++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]"),+ (" ( ","","",""),+ ("","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\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 []+ 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 <- runMonadClean $ parseFile path+ let (output, original) = test m text+ 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)++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)
+ Language/Haskell/Modules/Imports.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE PackageImports, ScopedTypeVariables, StandaloneDeriving, TupleSections #-}+{-# OPTIONS_GHC -Wall #-}+module Language.Haskell.Modules.Imports+ ( cleanImports+ -- , cleanBuildImports+ , tests+ ) 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 (foldDecls, foldExports, foldHeader, foldImports)+import Language.Haskell.Modules.Internal (getParams, markForDelete, modifyParams, ModuleResult(..), MonadClean, Params(..), parseFile, runMonadClean, scratchDir)+import Language.Haskell.Modules.Util.DryIO (replaceFile, tildeBackup)+import Language.Haskell.Modules.Util.QIO (qPutStrLn, quietly)+import Language.Haskell.Modules.Util.Symbols (symbols)+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(..))++{-+-- | This is designed to be called from the postConf script of your+-- Setup file, it cleans up the imports of all the source files in the+-- package.++cleanBuildImports :: LocalBuildInfo -> IO ()+cleanBuildImports lbi =+ mapM (toFilePath srcDirs) (maybe [] exposedModules (library (localPkgDescr lbi))) >>= \ libPaths ->+ runMonadClean (Distribution.Simple.LocalBuildInfo.scratchDir lbi) $ mapM_ clean (libPaths ++ exePaths)+ where+ clean path = cleanImports path >>= liftIO . putStrLn . either show (\ text -> path ++ ": " ++ maybe "no changes" (\ _ -> " updated") text)+ exePaths = map modulePath (executables (localPkgDescr lbi))+ srcDirs = case (maybe [] hsSourceDirs . fmap libBuildInfo . library . localPkgDescr $ lbi) of+ [] -> ["."]+ xs -> xs+ toFilePath :: [FilePath] -> D.ModuleName -> IO FilePath+ toFilePath [] m = error $ "Missing module: " ++ intercalate "." (D.components m)+ toFilePath (dir : dirs) m =+ let path = (dir </> intercalate "/" (D.components m) <.> "hs") in+ doesFileExist path >>= \ exists ->+ if exists then return path else toFilePath dirs m+-}++-- | Clean up the imports of a source file.+cleanImports :: MonadClean m => FilePath -> m ModuleResult+cleanImports path =+ do source <- parseFile path+ case source of+ ParseOk (m@(A.Module _ h _ imports _decls)) ->+ 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"+ ParseFailed _loc msg -> error ("cleanImports: - parse of " ++ path ++ " failed: " ++ msg)+ where+ isHiddenImport (A.ImportDecl {A.importSpecs = Just (A.ImportSpecList _ True _)}) = True+ isHiddenImport _ = False++-- | Run ghc with -ddump-minimal-imports and capture the resulting .imports file.+dumpImports :: MonadClean m => FilePath -> m ()+dumpImports path =+ do scratch <- scratchDir <$> getParams+ liftIO $ createDirectoryIfMissing True scratch+ let cmd = "ghc"+ args <- hsFlags <$> getParams+ dirs <- sourceDirs <$> getParams+ exts <- extensions <$> getParams+ let args' = args ++ ["--make", "-c", "-ddump-minimal-imports", "-outputdir", scratch, "-i" ++ intercalate ":" dirs, path] ++ map (("-X" ++) . show) exts+ (code, _out, err) <- liftIO $ readProcessWithExitCode cmd args' ""+ case code of+ ExitSuccess -> quietly (qPutStrLn (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+-- file, and if all goes well insert the new imports into the old+-- 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 path name@(S.ModuleName name') m extraImports =+ do let importsPath = name' <.> ".imports"+ markForDelete importsPath+ result <-+ 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)))+ case result of+ ParseOk newImports -> updateSource path m newImports name extraImports+ _ -> error ("checkImports: parse of " ++ importsPath ++ " failed - " ++ show result)++-- | 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 =+ 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)+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 ""+ -- Surround newPretty with the same prefix and suffix as oldPretty+ newPretty = fromMaybe "" (foldImports (\ _ pref _ _ r -> maybe (Just pref) Just r) m sourceText Nothing) <>+ intercalate "\n" (map (prettyPrintWithMode (defaultMode {layout = PPInLine})) newImports) <>+ foldImports (\ _ _ _ suff _ -> suff) m sourceText "" 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 "" +++ newPretty <>+ foldDecls (\ _ pref s suff r -> r <> pref <> s <> suff) (\ r s -> r <> s) m sourceText "")++-- | Final touch-ups - sort and merge similar imports.+fixNewImports :: Bool -- ^ If true, imports that turn into empty lists will be removed+ -> A.Module SrcSpanInfo+ -> [A.ImportDecl SrcSpanInfo]+ -> [A.ImportDecl SrcSpanInfo]+ -> [A.ImportDecl SrcSpanInfo]+fixNewImports remove m oldImports imports =+ filter importPred $ map expandSDTypes $ map mergeDecls $ groupBy (\ a b -> importMergable a b == EQ) $ sortBy importMergable imports+ where+ -- mergeDecls :: [ImportDecl] -> ImportDecl+ mergeDecls [] = error "mergeDecls"+ mergeDecls xs@(x : _) = x {A.importSpecs = mergeSpecLists (catMaybes (map A.importSpecs xs))}+ where+ -- Merge a list of specs for the same module+ -- mergeSpecLists :: [ImportSpecList] -> Maybe ImportSpecList+ mergeSpecLists (A.ImportSpecList loc flag specs : ys) =+ Just (A.ImportSpecList loc flag (mergeSpecs (sortBy compareSpecs (nub (concat (specs : map (\ (A.ImportSpecList _ _ specs') -> specs') ys))))))+ mergeSpecLists [] = error "mergeSpecLists"+ -- unimplemented, should merge Foo and Foo(..) into Foo(..), and the like+ mergeSpecs ys = nubBy equalSpecs ys+ expandSDTypes :: A.ImportDecl SrcSpanInfo -> A.ImportDecl SrcSpanInfo+ expandSDTypes i@(A.ImportDecl {A.importSpecs = Just (A.ImportSpecList l f specs)}) =+ i {A.importSpecs = Just (A.ImportSpecList l f (map (expandSpec i) specs))}+ expandSDTypes i = i+ expandSpec i s =+ if not (A.importQualified i) && member (Nothing, sName n) sdTypes ||+ maybe False (\ mn -> (member (Just (sModuleName mn), sName n) sdTypes)) (A.importAs i) ||+ member (Just (sModuleName (A.importModule i)), sName n) sdTypes+ then s'+ else s+ where+ n = case s of+ (A.IVar _ x) -> x+ (A.IAbs _ x) -> x+ (A.IThingAll _ x) -> x+ (A.IThingWith _ x _) -> x+ s' = case s of+ (A.IVar l x) -> A.IThingAll l x+ (A.IAbs l x) -> A.IThingAll l x+ (A.IThingWith l x _) -> A.IThingAll l x+ (A.IThingAll _ _) -> s++ -- Eliminate imports that became empty+ -- importPred :: ImportDecl -> Bool+ importPred (A.ImportDecl _ mn _ _ _ _ (Just (A.ImportSpecList _ _ []))) =+ not remove || maybe False (isEmptyImport . A.importSpecs) (find ((== (unModuleName mn)) . unModuleName . A.importModule) oldImports)+ where+ isEmptyImport (Just (A.ImportSpecList _ _ [])) = True+ isEmptyImport _ = False+ importPred _ = True++ 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) =+ unions (map derivDeclTypes decls)+ where+ -- derivDeclTypes :: Decl -> Set (Maybe S.ModuleName, S.Name)+ derivDeclTypes (A.DerivDecl _ _ (A.IHead _ _ xs)) = unions (map derivDeclTypes' xs) -- Just (moduleName, sName x)+ derivDeclTypes (A.DerivDecl a b (A.IHParen _ x)) = derivDeclTypes (A.DerivDecl a b x)+ derivDeclTypes (A.DerivDecl _ _ (A.IHInfix _ x _op y)) = union (derivDeclTypes' x) (derivDeclTypes' y)+ derivDeclTypes _ = empty+ -- derivDeclTypes' :: Type -> Set (Maybe S.ModuleName, S.Name)+ derivDeclTypes' (A.TyForall _ _ _ x) = derivDeclTypes' x -- qualified type+ derivDeclTypes' (A.TyFun _ x y) = union (derivDeclTypes' x) (derivDeclTypes' y) -- function type+ derivDeclTypes' (A.TyTuple _ _ xs) = unions (map derivDeclTypes' xs) -- tuple type, possibly boxed+ derivDeclTypes' (A.TyList _ x) = derivDeclTypes' x -- list syntax, e.g. [a], as opposed to [] a+ derivDeclTypes' (A.TyApp _ x y) = union (derivDeclTypes' x) (derivDeclTypes' y) -- application of a type constructor+ derivDeclTypes' (A.TyVar _ _) = empty -- type variable+ derivDeclTypes' (A.TyCon _ (A.Qual _ m n)) = singleton (Just (sModuleName m), sName n) -- named type or type constructor+ -- Unqualified names refer to imports without "qualified" or "as" values.+ derivDeclTypes' (A.TyCon _ (A.UnQual _ n)) = singleton (Nothing, sName n)+ derivDeclTypes' (A.TyCon _ _) = empty+ derivDeclTypes' (A.TyParen _ x) = derivDeclTypes' x -- type surrounded by parentheses+ derivDeclTypes' (A.TyInfix _ x _op y) = union (derivDeclTypes' x) (derivDeclTypes' y) -- infix type constructor+ derivDeclTypes' (A.TyKind _ x _) = derivDeclTypes' x -- type with explicit kind signature++-- | Compare the two import declarations ignoring the things that are+-- actually being imported. Equality here indicates that the two+-- imports could be merged.+importMergable :: A.ImportDecl SrcSpanInfo -> A.ImportDecl SrcSpanInfo -> Ordering+importMergable a b =+ case (compare `on` noSpecs) a' b' of+ EQ -> EQ+ specOrdering ->+ case (compare `on` S.importModule) a' b' of+ EQ -> specOrdering+ moduleNameOrdering -> moduleNameOrdering+ where+ a' = sImportDecl a+ b' = sImportDecl b+ -- Return a version of an ImportDecl with an empty spec list and no+ -- source locations. This will distinguish "import Foo as F" from+ -- "import Foo", but will let us group imports that can be merged.+ -- Don't merge hiding imports with regular imports.+ noSpecs :: S.ImportDecl -> S.ImportDecl+ noSpecs x = x { S.importLoc = def,+ S.importSpecs = case S.importSpecs x of+ Just (True, _) -> Just (True, []) -- hiding+ Just (False, _) -> Nothing+ Nothing -> Nothing }++-- | Be careful not to try to compare objects with embeded SrcSpanInfo.+unModuleName :: A.ModuleName SrcSpanInfo -> String+unModuleName (A.ModuleName _ x) = x++-- Compare function used to sort the symbols within an import.+compareSpecs :: A.ImportSpec SrcSpanInfo -> A.ImportSpec SrcSpanInfo -> Ordering+compareSpecs a b =+ case compare (map (map toLower . nameString) $ catMaybes $ toList $ symbols a) (map (map toLower . nameString) $ catMaybes $ toList $ symbols b) of+ EQ -> compare (sImportSpec a) (sImportSpec b)+ x -> x++equalSpecs :: A.ImportSpec SrcSpanInfo -> A.ImportSpec SrcSpanInfo -> Bool+equalSpecs a b = compareSpecs a b == EQ++-- dropSuffix :: Eq a => [a] -> [a] -> [a]+-- dropSuffix suf x = if isSuffixOf suf x then take (length x - length suf) x else x++-- dropPrefix :: Eq a => [a] -> [a] -> [a]+-- dropPrefix pre x = if isPrefixOf pre x then drop (length x) x else x++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])++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))
+ Language/Haskell/Modules/Internal.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings, PackageImports, ScopedTypeVariables, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.Haskell.Modules.Internal+ ( runMonadClean+ , modifyParams+ , parseFileWithComments+ , parseFile+ , modulePath+ , markForDelete+ , Params(..)+ , MonadClean(getParams, putParams)+ , ModuleResult(..)+ , doResult+ ) where++import Control.Applicative ((<$>))+import Control.Exception (SomeException, try)+import "MonadCatchIO-mtl" Control.Monad.CatchIO as IO (catch, MonadCatchIO, throw)+import Control.Monad.State (MonadState(get, put), StateT(runStateT))+import Control.Monad.Trans (liftIO, MonadIO)+import Data.Set (empty, insert, Set, toList)+import qualified Language.Haskell.Exts.Annotated as A (Module, parseFileWithComments, parseFileWithMode)+import Language.Haskell.Exts.Comments (Comment)+import Language.Haskell.Exts.Extension (Extension)+import qualified Language.Haskell.Exts.Parser as Exts (defaultParseMode, ParseMode(extensions), ParseResult)+import Language.Haskell.Exts.SrcLoc (SrcSpanInfo)+import qualified Language.Haskell.Exts.Syntax as S (ModuleName)+import Language.Haskell.Modules.Common (modulePathBase)+import 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.Temp (withTempDirectory)+import Prelude hiding (writeFile)+import System.Directory (doesFileExist, getCurrentDirectory, removeFile)+import System.FilePath ((</>), dropExtension, takeDirectory)+import System.IO.Error (isDoesNotExistError)++-- | This contains the information required to run the state monad for+-- import cleaning and module spliting/mergeing.+data Params+ = Params+ { scratchDir :: FilePath+ -- ^ Location of the temporary directory for ghc output.+ , dryRun :: Bool+ -- ^ None of the operations that modify the modules will actually+ -- be performed if this is ture.+ , verbosity :: Int+ -- ^ Increase or decrease the amount of progress reporting.+ , extensions :: [Extension]+ -- ^ Supply compiler extensions. These are provided to the module+ -- parser and to GHC when it does the minimal import dumping.+ , hsFlags :: [String]+ -- ^ Extra flags to pass to GHC.+ , sourceDirs :: [FilePath]+ -- ^ Top level directories to search for source files and+ -- imports. These directories would be the value used in the+ -- hs-source-dirs parameter of a cabal file, and passed to ghc+ -- via the -i option.+ , moduVerse :: Maybe (Set S.ModuleName)+ -- ^ The set of modules that splitModules and catModules will+ -- check for imports of symbols that moved.+ , junk :: Set FilePath+ -- ^ Paths added to this list are removed as the state monad+ -- finishes.+ , removeEmptyImports :: Bool+ -- ^ If true, remove any import that became empty due to the+ -- clean. THe import might still be required because of the+ -- instances it contains, but usually it is not. Note that this+ -- option does not affect imports that started empty and end+ -- empty.+ , testMode :: Bool+ -- ^ For testing, do not run cleanImports on the results of the+ -- splitModule and catModules operations.+ } deriving (Eq, Ord, Show)++class (MonadIO m, MonadCatchIO m, Functor m) => MonadClean m where+ getParams :: m Params+ putParams :: Params -> m ()++modifyParams :: MonadClean m => (Params -> Params) -> m ()+modifyParams f = getParams >>= putParams . f++instance (MonadCatchIO m, Functor m) => MonadClean (StateT Params m) where+ getParams = get+ putParams = put++instance MonadClean m => MonadVerbosity m where+ getVerbosity = getParams >>= return . verbosity+ putVerbosity v = modifyParams (\ p -> p {verbosity = v})++instance MonadClean m => MonadDryRun m where+ dry = getParams >>= return . dryRun+ putDry x = modifyParams (\ p -> p {dryRun = x})++-- | Create the environment required to do import cleaning and module+-- splitting/merging. This environment, StateT Params m a, is an+-- instance of MonadClean.+runMonadClean :: MonadCatchIO m => StateT Params m a -> m a+runMonadClean action =+ withTempDirectory "." "scratch" $ \ scratch ->+ do (result, params) <- runStateT action (Params {scratchDir = scratch,+ dryRun = False,+ verbosity = 0,+ hsFlags = [],+ extensions = Exts.extensions Exts.defaultParseMode,+ sourceDirs = ["."],+ moduVerse = Nothing,+ junk = empty,+ removeEmptyImports = True,+ testMode = False})+ mapM_ (\ x -> liftIO (try (removeFile x)) >>= \ (_ :: Either SomeException ()) -> return ()) (toList (junk params))+ return result++-- | Run 'A.parseFileWithComments' with the extensions stored in the state.+parseFileWithComments :: MonadClean m => FilePath -> m (Exts.ParseResult (A.Module SrcSpanInfo, [Comment]))+parseFileWithComments path =+ do exts <- getParams >>= return . extensions+ liftIO (A.parseFileWithComments (Exts.defaultParseMode {Exts.extensions = exts}) path)++-- | Run 'A.parseFileWithMode' with the extensions stored in the state.+parseFile :: MonadClean m => FilePath -> m (Exts.ParseResult (A.Module SrcSpanInfo))+parseFile path =+ do exts <- getParams >>= return . extensions+ liftIO (A.parseFileWithMode (Exts.defaultParseMode {Exts.extensions = exts}) path)++-- | Search the path directory list for a source file that already exists.+findSourcePath :: MonadClean m => FilePath -> m FilePath+findSourcePath path =+ findFile =<< (sourceDirs <$> getParams)+ where+ findFile (dir : dirs) =+ do let x = dir </> path+ exists <- liftIO $ doesFileExist x+ if exists then return x else findFile dirs+ findFile [] =+ do -- Just building an error message here+ here <- liftIO getCurrentDirectory+ dirs <- sourceDirs <$> getParams+ liftIO . throw . userError $ "findSourcePath failed, cwd=" ++ here ++ ", dirs=" ++ show dirs ++ ", path=" ++ path++-- | Search the path directory list, preferring an already existing file, but+-- if there is none construct one using the first element of the directory list.+modulePath :: MonadClean m => S.ModuleName -> m FilePath+modulePath name =+ findSourcePath (modulePathBase name) `catch` (\ (_ :: IOError) -> makePath)+ where+ makePath =+ do dirs <- sourceDirs <$> getParams+ case dirs of+ [] -> return (modulePathBase name) -- should this be an error?+ (d : _) -> return $ d </> modulePathBase name++markForDelete :: MonadClean m => FilePath -> m ()+markForDelete x = modifyParams (\ p -> p {junk = insert x (junk p)})++data ModuleResult+ = Unchanged S.ModuleName+ | Removed S.ModuleName+ | Modified S.ModuleName String+ | Created S.ModuleName String+ deriving (Show, Eq, Ord)++-- | It is tempting to put import cleaning into these operations, but+-- that needs to be done after all of these operations are completed+-- so that all the compiles required for import cleaning succeed. On+-- the other hand, we might be able to maintain the moduVerse here.+doResult :: MonadClean m => ModuleResult -> m ModuleResult+doResult x@(Unchanged _name) =+ do quietly (qPutStrLn ("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)+ return x++doResult x@(Modified name text) =+ do path <- modulePath name+ qPutStr ("catModules: modifying " ++ show path)+ quietly (qPutStr (" new text: " ++ show text))+ qPutStr "\n"+ replaceFile tildeBackup path text+ return x++doResult x@(Created name text) =+ do path <- modulePath name+ qPutStr ("catModules: creating " ++ show path)+ quietly (qPutStr (" containing " ++ show text))+ qPutStr "\n"+ createDirectoryIfMissing True (takeDirectory . dropExtension $ path)+ replaceFile tildeBackup path text+ return x
+ Language/Haskell/Modules/Merge.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# 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.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.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.Imports (cleanImports)+import Language.Haskell.Modules.Internal (doResult, getParams, modifyParams, modulePath, ModuleResult(..), MonadClean, Params(sourceDirs, moduVerse, testMode), parseFile, runMonadClean)+import Language.Haskell.Modules.Util.Test (diff, repoModules)+import System.Cmd (system)+import System.Exit (ExitCode(ExitSuccess))+import Test.HUnit (assertEqual, Test(TestCase, TestList))++-- | Merge the declarations from several modules into a single new+-- one, updating the imports of the modules in the moduVerse to+-- reflect the change. It *is* permissable to use one of the input+-- modules as the output module. Note that circular imports can be+-- created by this operation.+mergeModules :: MonadClean m => [S.ModuleName] -> S.ModuleName -> m (Set ModuleResult)+mergeModules inputs output =+ do Just univ <- getParams >>= return . moduVerse+ let univ' = union univ (Set.fromList (output : inputs))+ inputInfo <- loadModules inputs+ result <- Set.mapM (doModule inputInfo inputs output) univ' >>= Set.mapM doResult+ -- The inputs disappear and the output appears. If the output is one+ -- of the inputs, it does not disappear.+ modifyParams (\ p -> p {moduVerse = fmap (\ s -> Set.insert output (Set.difference s (Set.fromList inputs))) (moduVerse p)})+ Set.mapM clean result+ where+ clean x =+ do flag <- getParams >>= return . not . testMode+ case x of+ (Modified name _) | flag -> modulePath name >>= cleanImports+ _ -> return x++-- Process one of the modules in the moduVerse and return the result.+-- The output module may not (yet) be an element of the moduVerse, in+-- that case choose the first input modules to convert into the output+-- module.+doModule :: MonadClean m => Map S.ModuleName (A.Module SrcSpanInfo, String) -> [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)+ return $ case () of+ _ | name == output -> Modified name (doOutput inputInfo inputs output (m, text))+ | elem name inputs -> Removed name+ _ -> let text' = doOther inputs output (m, text) 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) =+ 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 "" <>+ -- 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)++-- | 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 ""++fixModuleExport :: [S.ModuleName] -> S.ModuleName -> S.ExportSpec -> Maybe String+fixModuleExport inputs output x =+ case x of+ S.EModuleContents y+ | elem y inputs -> Just (prettyPrint (S.EModuleContents output))+ _ -> Nothing++fixModuleImport :: [S.ModuleName] -> S.ModuleName -> S.ImportDecl -> Maybe String+fixModuleImport inputs output x =+ case x of+ S.ImportDecl {S.importModule = y}+ | elem y inputs -> Just (prettyPrint (x {S.importModule = output}))+ _ -> Nothing++mergeExports :: Map S.ModuleName (A.Module SrcSpanInfo, String) -> S.ModuleName -> Maybe [S.ExportSpec]+mergeExports old new =+ Just (concatMap mergeExports' (Map.toAscList old))+ where+ mergeExports' (_, (A.Module _ Nothing _ _ _, _)) = error "mergeModules: no explicit export list"+ mergeExports' (_, (A.Module _ (Just (A.ModuleHead _ _ _ Nothing)) _ _ _, _)) = error "mergeModules: no explicit export list"+ mergeExports' (_, (A.Module _ (Just (A.ModuleHead _ _ _ (Just (A.ExportSpecList _ e)))) _ _ _, _)) = updateModuleContentsExports old new (List.map sExportSpec e)+ mergeExports' (_, _) = error "mergeExports'"++updateModuleContentsExports :: Map S.ModuleName (A.Module SrcSpanInfo, String) -> S.ModuleName -> [S.ExportSpec] -> [S.ExportSpec]+updateModuleContentsExports old new es =+ foldl f [] es+ where+ f :: [S.ExportSpec] -> S.ExportSpec -> [S.ExportSpec]+ f ys (S.EModuleContents m) =+ let e' = S.EModuleContents (if Map.member m old then new else m) in+ ys ++ if elem e' ys then [] else [e']+ f ys e = ys ++ [e]++moduleImports :: Map S.ModuleName (A.Module SrcSpanInfo, String) -> S.ModuleName -> String+moduleImports old name =+ let (Just (m, text)) = 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"++-- | Grab the declarations out of the old modules, fix any+-- qualified symbol references, prettyprint and return.+--+-- Bug: If we cat two modules A and B, and A imported a symbol from B+-- and referenced that symbol with a qualifier from an "as" import, the+-- as qualifier needs to be changed to a full qualifier.+--+-- 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 oldmap new name =+ let (Just (m@(A.Module _ _ _ imports _), text)) = 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)))+ echo2+ m text "" <> "\n"+ where+ f (A.ImportDecl _ m _ _ _ (Just a) _specs) mp =+ case Map.lookup (sModuleName m) oldmap of+ Just x -> Map.insert (sModuleName a) x mp+ _ -> mp+ f _ mp = mp++-- | Change any ModuleName in 'old' to 'new'. Note that this will+-- probably mess up the location information, so the result (if+-- different from the original) should be prettyprinted, not+-- exactPrinted.+fixReferences :: (Data a, Typeable a) => Map S.ModuleName (A.Module SrcSpanInfo, String) -> S.ModuleName -> a -> a+fixReferences oldmap new x =+ everywhere (mkT moveModuleName) x+ where+ moveModuleName :: S.ModuleName -> S.ModuleName+ moveModuleName name@(S.ModuleName _) = if Map.member name oldmap then new else name++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++loadModules :: MonadClean m => [S.ModuleName] -> m (Map S.ModuleName (A.Module SrcSpanInfo, String))+loadModules names = List.mapM loadModule names >>= return . Map.fromList . zip names++loadModule :: MonadClean m => S.ModuleName -> m (A.Module SrcSpanInfo, String)+loadModule name =+ do path <- modulePath name+ text <- liftIO $ readFile path+ m <- parseFile path >>= return . fromParseResult+ return (m, text)
+ Language/Haskell/Modules/Params.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings, PackageImports, ScopedTypeVariables, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Language.Haskell.Modules.Params+ ( MonadClean+ , runMonadClean+ , modifyDryRun+ , modifyExtensions+ , modifyModuVerse+ , modifyHsFlags+ , modifySourceDirs+ , modifyRemoveEmptyImports+ , modifyTestMode+ ) where++import Data.Maybe (fromMaybe)+import Data.Set (empty, Set)+import Language.Haskell.Exts.Extension (Extension)+import qualified Language.Haskell.Exts.Syntax as S (ModuleName)+import Language.Haskell.Modules.Internal (modifyParams, MonadClean, Params(dryRun, extensions, hsFlags, moduVerse, removeEmptyImports, sourceDirs, testMode), runMonadClean)+import 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)})++-- | Modify the list of directories that will be searched for source files. 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)})++-- | If TestMode is turned on no import cleaning will occur after a+-- split or cat. Default is False.+modifyTestMode :: MonadClean m => (Bool -> Bool) -> m ()+modifyTestMode f = modifyParams (\ p -> p {testMode = f (testMode p)})
+ Language/Haskell/Modules/Split.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE ScopedTypeVariables, TupleSections #-}+{-# OPTIONS_GHC -Wall #-}+module Language.Haskell.Modules.Split+ ( splitModule+ , tests+ ) 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.Fold (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.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))++setAny :: (a -> Bool) -> Set a -> Bool+setAny f s = not (Set.null (Set.filter f s))++setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b+setMapMaybe p s = Set.fold f Set.empty s+ where f x s' = maybe s' (\ y -> Set.insert y s') (p x)++setMapM_ :: (Monad m, Ord b) => (a -> m b) -> Set a -> m ()+setMapM_ f s = do _ <- Set.mapM f s+ return ()++-- | 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.+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+ -- Write the new modules+ setMapM_ doResult newFiles+ -- Clean the new modules+ setMapM_ doClean newFiles+ -- We have created some new modules, add them to the moduVerse+ modifyParams (\ p -> p {moduVerse = Just (Set.delete old (union (created newFiles) univ))})+ where+ collisionCheck univ s =+ if not (Set.null illegal)+ then error ("One or more module to be created by splitModule already exists: " ++ show (Set.toList illegal))+ else s+ where+ illegal = Set.intersection univ (created s)+ created :: Set ModuleResult -> Set S.ModuleName+ created = setMapMaybe (\ x -> case x of Created m _ -> Just m; _ -> Nothing)+ -- Make sure this isn't trying to clobber a module that exists (other than 'old'.)+ doClean :: MonadClean m => ModuleResult -> m ()+ doClean (Created m _) = doClean' m+ doClean (Modified m _) = doClean' m+ doClean (Removed _) = return ()+ doClean (Unchanged _) = return ()+ doClean' m =+ do flag <- getParams >>= return . not . testMode+ when flag (modulePath m >>= cleanImports >> return ())++justs :: Ord a => Set (Maybe a) -> Set a+justs = Set.fold (\ mx s -> maybe s (`Set.insert` s) mx) Set.empty++-- | 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 _))) _ _ _) =+ Set.mapM (updateImports (sModuleName moduleName) symbolToModule) univ' >>= return . union splitModules+ where+ -- 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 :: 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++ -- 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++ exported :: Set S.Name+ exported = foldExports ignore2 (\ e _pref _s _suff r -> Set.union (justs (symbols e)) r) ignore2 m text Set.empty++ reExported :: Set S.Name+ reExported = difference exported (justs declared)++ internal :: Set S.Name+ internal = difference (justs declared) exported++ univ' = Set.delete old univ++ newModuleNames :: Set S.ModuleName+ newModuleNames = Set.map (subModuleName reExported internal old) (union declared (Set.map Just exported))++ -- The modules created from 'old'+ splitModules :: Set ModuleResult+ splitModules =+ 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 text mp+ mp = foldDecls (\ d _ _ _ r -> Set.fold f r (symbols d)) ignore2 m text 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+ newModule name'@(S.ModuleName modName) =+ (if member name' univ then Modified else Created) name' $+ case Map.lookup name' moduleDeclMap of+ Nothing ->+ -- Build a module that re-exports a symbol+ 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 ""+ Just modDecls ->+ -- Change the module name in the header+ foldHeader echo2 echo (\ _n pref _ suff r -> r <> pref <> modName <> suff) echo m text "" <>+ " ( " {-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) <>+ 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 "" (foldDecls (\ _d pref _ _ r -> maybe (Just pref) Just r) ignore2 m text Nothing) <>+ concatMap snd (reverse modDecls) <> "\n"+ where+ -- Build export specs of the symbols created by each declaration.+ newExports modDecls = nub (concatMap (exports . fst) modDecls)+ -- newImports :: Map ModuleName ImportDecl+ newImports modDecls =+ mapWithKey toImportDecl (Map.delete name'+ (Map.filter (\ pairs ->+ let declared = justs (Set.unions (List.map (symbols . fst) pairs)) in+ not (Set.null (Set.intersection declared (referenced modDecls)))) moduleDeclMap))+ -- 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'"++-- 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 =+ do path <- modulePath name+ text' <- liftIO $ readFile path+ parsed <- parseFile path+ case parsed of+ ParseOk m' ->+ 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+ return $ if text' /= text'' then Modified name text'' else Unchanged name+ ParseFailed _ _ -> error $ "Parse error in " ++ show name+ where+ updateImportDecl :: String -> A.ImportDecl SrcSpanInfo -> String+ updateImportDecl s i =+ if sModuleName (A.importModule i) == old+ then intercalate "\n" (List.map prettyPrint (updateImportSpecs i (A.importSpecs i)))+ else s++ updateImportSpecs :: A.ImportDecl SrcSpanInfo -> Maybe (A.ImportSpecList SrcSpanInfo) -> [S.ImportDecl]+ -- No spec list, import all the split modules+ updateImportSpecs i Nothing = List.map (\ x -> (sImportDecl i) {S.importModule = x}) (Map.elems 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+ List.map (\ x -> (sImportDecl i) {S.importModule = x, S.importSpecs = Just (flag, [sImportSpec spec])}) xs) specs++{-+splitModule' :: S.ModuleName -> ParseResult (A.Module SrcSpanInfo) -> String -> Map S.ModuleName String+splitModule' _ (ParseOk (A.Module _ _ _ _ [])) _ = empty -- No declarations - nothing to split+splitModule' _ (ParseOk (A.Module _ _ _ _ [_])) _ = empty -- One declaration - nothing to split+splitModule' (S.ModuleName s) (ParseFailed _ _) _ = throw $ userError $ "Parse of " ++ s ++ " failed"+splitModule' (S.ModuleName s) (ParseOk (A.Module _ Nothing _ _ _)) _ = throw $ userError $ "splitModule: " ++ s ++ " has no explicit header"+splitModule' (S.ModuleName s) (ParseOk (A.Module _ (Just (A.ModuleHead _ _ _ Nothing)) _ _ _)) _ = throw $ userError $ "splitModule: " ++ s ++ " has no explicit export list"+splitModule' _ (ParseOk (m@(A.Module _ (Just (A.ModuleHead _ moduleName _ (Just _))) _ _ _))) text =+ {- Map.insert name newReExporter $ -} newModules+ where+ -- Build a map from module name to the list of declarations that will be in that module.+ moduleToDecls :: Map S.ModuleName [(A.Decl SrcSpanInfo, String)]+ moduleToDecls = foldDecls (\ d pref s suff r -> foldr (\ sym mp -> insertWith (++) (subModuleName old sym) [(d, pref <> s <> suff)] mp) r (symbols d))+ ignore2 m text Map.empty++ -- Build the new modules+ newModules :: Map S.ModuleName String+ newModules = mapWithKey newModule moduleToDecls+{- newReExporter =+ foldHeader echo2 echo echo echo m text "" <>+ foldExports echo2 echo echo2 m text ""+ fromMaybe "" (foldImports (\ _i pref s suff r -> maybe (Just (pref <> s <> suff)) (Just . (<> (pref <> s <> suff))) r) m text Nothing) <>+ "\n" <>+ unlines (List.map (prettyPrintWithMode defaultMode) (elems (mapWithKey toImportDecl moduleToDecls))) -}+splitModule' _ _ _ = error "splitModule'"+-}++-- | 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 =+ S.ModuleName (moduleName <.> f (case name of+ Nothing -> "Instances"+ Just (S.Symbol s) -> s+ Just (S.Ident s) -> s))+ where+ f x =+ case name of+ Nothing -> "Instances"+ Just name' | member name' reExported -> "ReExported"+ Just name' ->+ (if member name' internal then "Internal." else "") <>+ case x of+ -- Any symbol that starts with a letter is converted to a module name+ -- by capitalizing and keeping the remaining alphaNum characters.+ (c : s) | isAlpha c -> toUpper c : List.filter isAlphaNum s+ _ -> "OtherSymbols"++-- | Build an import of the symbols created by a declaration.+toImportDecl :: S.ModuleName -> [(A.Decl SrcSpanInfo, String)] -> S.ImportDecl+toImportDecl (S.ModuleName modName) decls =+ S.ImportDecl {S.importLoc = def,+ S.importModule = S.ModuleName modName,+ S.importQualified = False,+ S.importSrc = False,+ S.importPkg = Nothing,+ S.importAs = Nothing,+ S.importSpecs = Just (False, nub (concatMap (imports . fst) decls))}++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" (ExitSuccess, "", "") (code, out, err)++test2 :: Test+test2 =+ TestCase $+ do _ <- system "rsync -aHxS --delete testdata/split2/ testdata/copy"+ runMonadClean $ noisily $ noisily $+ 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 $ noisily $ noisily $+ 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)
+ Language/Haskell/Modules/Util/DryIO.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE BangPatterns, FlexibleInstances, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Language.Haskell.Modules.Util.DryIO+ ( MonadDryRun(..)+ , dryIO+ , dryIO'+ , tildeBackup+ , noBackup+ , readFileMaybe+ , replaceFile+ , replaceFileIfDifferent+ , removeFileIfPresent+ , createDirectoryIfMissing+ , writeFile+ ) where++import Control.Applicative ((<$>))+import Control.Exception (catch, throw)+import Control.Monad.Trans (liftIO, MonadIO)+import Prelude hiding (writeFile)+import System.Directory (removeFile, renameFile)+import qualified System.Directory as IO (createDirectoryIfMissing)+import qualified System.IO as IO (writeFile)+import System.IO.Error (isDoesNotExistError)++tildeBackup :: FilePath -> Maybe FilePath+tildeBackup = Just . (++ "~")++noBackup :: FilePath -> Maybe FilePath+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)++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))++replaceFileIfDifferent :: MonadDryRun m => FilePath -> String -> m Bool+replaceFileIfDifferent path newText =+ do oldText <- liftIO $ readFileMaybe path+ if oldText == Just newText then return False else replaceFile tildeBackup path newText >> return True++-- | Replace the file at path with the given text, moving the original+-- to the location returned by passing path to backup. If backup is+-- the identity function you're going to have a bad time.+replaceFile :: MonadDryRun m => (FilePath -> Maybe FilePath) -> FilePath -> String -> m ()+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)+ write = IO.writeFile path text++createDirectoryIfMissing :: MonadDryRun m => Bool -> String -> m ()+createDirectoryIfMissing flag path =+ dryIO' (putStrLn $ "dry run: createDirectoryIfMissing " ++ show flag ++ " " ++ path) (IO.createDirectoryIfMissing flag path)++writeFile :: MonadDryRun m => FilePath -> String -> m ()+writeFile path text =+ dryIO' (putStrLn $ "dry run: writeFIle " ++ path) (IO.writeFile path text)++class MonadIO m => MonadDryRun m where+ dry :: m Bool+ putDry :: Bool -> m ()++dryIO :: MonadDryRun m => IO () -> m ()+dryIO action = dryIO' (return ()) action++dryIO' :: MonadDryRun m => IO a -> IO a -> m a+dryIO' d action =+ do flag <- dry+ if flag then liftIO d else liftIO action
+ Language/Haskell/Modules/Util/QIO.hs view
@@ -0,0 +1,48 @@+-- | IO operations predicated on the verbosity value managed by the+-- methods of MonadVerbosity. Noisily increases this value and+-- quietly decreases it, and the q* operations only happen when the+-- value is greater than zero.+module Language.Haskell.Modules.Util.QIO+ ( MonadVerbosity(getVerbosity, putVerbosity)+ , modifyVerbosity+ , quietly+ , noisily+ , qIO+ , qPutStr+ , qPutStrLn+ ) where++import Control.Monad (when)+import Control.Monad.Trans (liftIO, MonadIO)++class MonadIO m => MonadVerbosity m where+ getVerbosity :: m Int+ putVerbosity :: Int -> m ()++modifyVerbosity :: MonadVerbosity m => (Int -> Int) -> m ()+modifyVerbosity f = getVerbosity >>= putVerbosity . f++quietly :: MonadVerbosity m => m a -> m a+quietly action =+ do modifyVerbosity (\x->x-1)+ result <- action+ modifyVerbosity (+ 1)+ return result++noisily :: MonadVerbosity m => m a -> m a+noisily action =+ do modifyVerbosity (+ 1)+ result <- action+ modifyVerbosity (\x->x-1)+ return result++qIO :: MonadVerbosity m => m () -> m ()+qIO action =+ 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
+ Language/Haskell/Modules/Util/SrcLoc.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE BangPatterns, FlexibleInstances, ScopedTypeVariables, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Language.Haskell.Modules.Util.SrcLoc+ ( HasSpanInfo(..)+ , srcSpan+ , srcLoc+ , endLoc+ , textEndLoc+ , increaseSrcLoc+ , textSpan+ , srcPairTextHead+ , srcPairTextTail+ , makeTree+ , tests+ ) where++import Data.Default (def, Default)+import Data.List (groupBy, partition, sort)+import Data.Set (Set, toList)+import Data.Tree (Tree(Node), unfoldTree)+import qualified Language.Haskell.Exts.Annotated.Syntax as A (Decl(..), ExportSpec(..), ExportSpecList(..), ImportDecl(ImportDecl), ModuleHead(..), ModuleName(..), ModulePragma(..), WarningText(..))+import Language.Haskell.Exts.SrcLoc (SrcLoc(..), SrcSpan(..), SrcSpanInfo(..))+import Prelude hiding (rem)+import Test.HUnit (assertEqual, Test(TestCase, TestList))++-- | A version of lines that preserves the presence or absence of a+-- terminating newline+lines' :: String -> [String]+lines' s =+ -- Group characters into strings containing either only newlines or no newlines,+ -- and then transform the newline only strings into empty lines.+ bol (groupBy (\ a b -> a /= '\n' && b /= '\n') s)+ where+ -- If we are at beginning of line and see a newline, insert an empty+ bol ("\n" : xs) = "" : bol xs+ -- If we are at beginning of line and see something else, call end of line+ bol (x : xs) = x : eol xs+ -- If we see EOF at bol insert a trailing empty+ bol [] = [""]+ -- If we are seeking end of line and see a newline, go to beginning of line+ eol ("\n" : xs) = bol xs+ -- This shouldn't happen+ eol (x : xs) = x : eol xs+ eol [] = []++-- type Module = A.Module SrcSpanInfo+type ModuleHead = A.ModuleHead SrcSpanInfo+type ModulePragma = A.ModulePragma SrcSpanInfo+type ModuleName = A.ModuleName SrcSpanInfo+type WarningText = A.WarningText SrcSpanInfo+type ExportSpecList = A.ExportSpecList SrcSpanInfo+type ExportSpec = A.ExportSpec SrcSpanInfo+type ImportDecl = A.ImportDecl SrcSpanInfo+-- type ImportSpecList = A.ImportSpecList SrcSpanInfo+-- type ImportSpec = A.ImportSpec SrcSpanInfo+type Decl = A.Decl SrcSpanInfo+-- type QName = A.QName SrcSpanInfo+-- type Name = A.Name SrcSpanInfo+-- type Type = A.Type SrcSpanInfo++class HasSpanInfo a where+ spanInfo :: a -> SrcSpanInfo++instance HasSpanInfo a => HasSpanInfo (Tree a) where+ spanInfo (Node x _) = spanInfo x++instance HasSpanInfo ModuleHead where+ spanInfo (A.ModuleHead x _ _ _) = x++instance HasSpanInfo ModuleName where+ spanInfo (A.ModuleName x _) = x++instance HasSpanInfo ModulePragma where+ spanInfo (A.LanguagePragma x _) = x+ spanInfo (A.OptionsPragma x _ _) = x+ spanInfo (A.AnnModulePragma x _) = x++instance HasSpanInfo WarningText where+ spanInfo (A.WarnText x _) = x+ spanInfo (A.DeprText x _) = x++instance HasSpanInfo ExportSpecList where+ spanInfo (A.ExportSpecList x _) = x++instance HasSpanInfo ExportSpec where+ spanInfo (A.EVar x _) = x+ spanInfo (A.EAbs x _) = x+ spanInfo (A.EThingAll x _) = x+ spanInfo (A.EThingWith x _ _) = x+ spanInfo (A.EModuleContents x _) = x++instance HasSpanInfo ImportDecl where+ spanInfo (A.ImportDecl x _ _ _ _ _ _) = x++instance HasSpanInfo Decl where+ spanInfo (A.TypeDecl l _ _) = l+ spanInfo (A.TypeFamDecl l _ _) = l+ spanInfo (A.DataDecl l _ _ _ _ _) = l+ spanInfo (A.GDataDecl l _ _ _ _ _ _) = l+ spanInfo (A.DataFamDecl l _ _ _) = l+ spanInfo (A.TypeInsDecl l _ _) = l+ spanInfo (A.DataInsDecl l _ _ _ _) = l+ spanInfo (A.GDataInsDecl l _ _ _ _ _) = l+ spanInfo (A.ClassDecl l _ _ _ _) = l+ spanInfo (A.InstDecl l _ _ _) = l+ spanInfo (A.DerivDecl l _ _) = l+ spanInfo (A.InfixDecl l _ _ _) = l+ spanInfo (A.DefaultDecl l _) = l+ spanInfo (A.SpliceDecl l _) = l+ spanInfo (A.TypeSig l _ _) = l+ spanInfo (A.FunBind l _) = l+ spanInfo (A.PatBind l _ _ _ _) = l+ spanInfo (A.ForImp l _ _ _ _ _) = l+ spanInfo (A.ForExp l _ _ _ _) = l+ spanInfo (A.RulePragmaDecl l _) = l+ spanInfo (A.DeprPragmaDecl l _) = l+ spanInfo (A.WarnPragmaDecl l _) = l+ spanInfo (A.InlineSig l _ _ _) = l+ spanInfo (A.InlineConlikeSig l _ _) = l+ spanInfo (A.SpecSig l _ _) = l+ spanInfo (A.SpecInlineSig l _ _ _ _) = l+ spanInfo (A.InstSig l _ _) = l+ spanInfo (A.AnnPragma l _) = l++instance HasSpanInfo SrcSpanInfo where+ spanInfo = id++{-+data SrcSpanInfo+ = SrcSpanInfo { srcInfoSpan :: SrcSpan+ , srcInfoPoints :: [SrcSpan] }++data SrcSpan+ = SrcSpan {srcSpanFilename :: String,+ srcSpanStartLine :: Int,+ srcSpanStartColumn :: Int,+ srcSpanEndLine :: Int,+ srcSpanEndColumn :: Int}++data SrcLoc+ = SrcLoc {srcFilename :: String, srcLine :: Int, srcColumn :: Int}+-}++srcSpan :: HasSpanInfo x => x -> SrcSpan+srcSpan = srcInfoSpan . spanInfo++srcLoc :: HasSpanInfo x => x -> SrcLoc+srcLoc x = let (SrcSpan f b e _ _) = srcSpan x in SrcLoc f b e++endLoc :: HasSpanInfo x => x -> SrcLoc+endLoc x = let (SrcSpan f _ _ b e) = srcSpan x in SrcLoc f b e++textEndLoc :: String -> SrcLoc+textEndLoc text =+ def {srcLine = length ls, srcColumn = length (last ls) + 1}+ where ls = lines' text++-- | Update a SrcLoc to move it from l past the string argument.+increaseSrcLoc :: String -> SrcLoc -> SrcLoc+increaseSrcLoc "" l = l+increaseSrcLoc ('\n' : s) (SrcLoc f y _) = increaseSrcLoc s (SrcLoc f (y + 1) 1)+increaseSrcLoc (_ : s) (SrcLoc f y x) = increaseSrcLoc s (SrcLoc f y (x + 1))++tests :: Test+tests = TestList [test1, test2, test3, test4, test5]++test1 :: Test+test1 = TestCase (assertEqual "srcPairTextTail1" "hi\tjkl\n" (srcPairTextTail (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"))+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"))+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"))+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+ (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"))++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+ 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++instance Default SrcLoc where+ def = SrcLoc "<unknown>.hs" 1 1++instance Default SrcSpanInfo where+ def = SrcSpanInfo {srcInfoSpan = def, srcInfoPoints = def}++instance Default SrcSpan where+ def = SrcSpan {srcSpanFilename = "<unknown>.hs", srcSpanStartLine = 1, srcSpanEndLine = 1, srcSpanStartColumn = 1, srcSpanEndColumn = 1}++-- | Build a tree of SrcSpanInfo ++makeTree :: (HasSpanInfo a, Show a, Eq a, Ord a) => Set a -> Tree a+makeTree s =+ case findRoots (toList s) of+ [] -> error "No roots"+ [root] -> unfoldTree f root+ roots -> error $ "Multiple roots: " ++ show roots+ where+ f x = (x, findChildren (toList s) x)++ -- The roots are the nodes that are not covered by any other node.+ findRoots :: (HasSpanInfo a, Eq a, Ord a) => [a] -> [a]+ findRoots [] = []+ findRoots (x : xs) =+ let (_children, other) = partition (\ y -> x `covers` y) xs+ (ancestors, cousins) = partition (\ y -> x `coveredBy` y) other in+ case ancestors of+ -- If there are no ancestors, x is a root, and there may be other roots among the cousins+ [] -> x : findRoots cousins+ -- If there are ancestors, there must be a root among them, and there still may be roots among the cousins.+ _ -> findRoots (ancestors ++ cousins)++ findChildren :: (HasSpanInfo a, Eq a, Ord a, Show a) => [a] -> a -> [a]+ findChildren u x = findRoots children where children = sort (filter (\ y -> x `covers` y && x /= y) u)++-- True if a covers b+covers :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> Bool+covers a b = srcLoc a <= srcLoc b && endLoc b <= endLoc a++-- True if a is covered by b+coveredBy :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> Bool+coveredBy = flip covers++{-+test3 = TestCase (assertEqual "covers1" True (covers (mkspan (29, 1) (29, 8)) (mkspan (29, 3) (29, 7))))+test4 = TestCase (assertEqual "covers2" False (covers (mkspan (29, 1) (29, 8)) (mkspan (29, 3) (29, 10))))+test5 = TestCase (assertEqual "roots1"+ [sp 5 10, sp 11 18]+ (findRoots [sp 5 10,+ sp 11 18,+ sp 6 7,+ sp 8 9,+ sp 12 15]))+-}
+ Language/Haskell/Modules/Util/Symbols.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Language.Haskell.Modules.Util.Symbols+ ( FoldDeclared(foldDeclared)+ , FoldMembers(foldMembers)+ , symbols+ , exports+ , imports+ , tests+ ) where++import Data.Default (def)+import Data.List (sort)+import Data.Maybe (mapMaybe)+import Data.Set as Set (empty, insert, Set, toList)+import Language.Haskell.Exts.Annotated.Simplify (sName)+import qualified Language.Haskell.Exts.Annotated.Syntax as A (ClassDecl(..), ConDecl(..), Decl(..), DeclHead(..), Exp(..), ExportSpec(..), FieldDecl(..), GadtDecl(..), ImportSpec(..), InstHead(..), Match(..), Name(..), Pat(..), PatField(..), QName(..), QualConDecl(..), Rhs(..), RPat(..), Type(..))+import Language.Haskell.Exts.Pretty (prettyPrint)+import Language.Haskell.Exts.SrcLoc (SrcSpanInfo)+import qualified Language.Haskell.Exts.Syntax as S (CName(..), ExportSpec(..), ImportSpec(..), Name(..), QName(..))+import Language.Haskell.Modules.Util.SrcLoc ()+import Test.HUnit (assertEqual, Test(TestCase, TestList))++-- | Do a fold over the names that are declared in a declaration (not+-- every name that appears, just the ones that the declaration is+-- causing to exist - what's the word for that?. Reify!)+class FoldDeclared a where+ foldDeclared :: forall r. (Maybe S.Name -> r -> r) -> r -> a -> r++instance FoldDeclared (A.Decl a) where+ foldDeclared f r (A.TypeDecl _ x _t) = foldDeclared f r x -- type x = ...+ foldDeclared f r (A.TypeFamDecl _ x _k) = foldDeclared f r x -- data family x = ...+ foldDeclared f r (A.DataDecl _ _ _ x _ _) = foldDeclared f r x -- data/newtype _ x = ...+ foldDeclared f r (A.GDataDecl _ _ _ x _ _ _) = foldDeclared f r x+ foldDeclared f r (A.DataFamDecl _ _ x _) = foldDeclared f r x+ foldDeclared f r (A.TypeInsDecl _ _ _) = f Nothing r -- type instance _ = ...+ foldDeclared f r (A.DataInsDecl _ _ _ _ _) = f Nothing r -- data instance _ = ...+ foldDeclared f r (A.GDataInsDecl _ _ _ _ _ _) = f Nothing r -- data or newtype instance, GADT style+ foldDeclared f r (A.ClassDecl _ _ x _ _) = foldDeclared f r x -- class context => x | fundeps where decls+ foldDeclared f r (A.InstDecl _ _ _ _) = f Nothing r -- type class instance+ foldDeclared f r (A.DerivDecl _ _ x) = foldDeclared f r x+ foldDeclared f r (A.InfixDecl _ _ _ _) = f Nothing r -- fixity+ foldDeclared f r (A.DefaultDecl _ _) = f Nothing r -- default (type1, type2 ...)+ foldDeclared f r (A.SpliceDecl _ _) = f Nothing r -- template haskell splice declaration+ foldDeclared f r (A.TypeSig _ xs _) = foldl (foldDeclared f) r xs+ foldDeclared f r (A.FunBind _ xs) = foldl (foldDeclared f) r xs+ foldDeclared f r (A.PatBind _ x _ _ _) = foldDeclared f r x+ foldDeclared _f _r (A.ForImp _ _ _ _ _ _) = error "Unimplemented FoldDeclared instance: ForImp"+ foldDeclared _ _r (A.ForExp _ _ _ _ _) = error "Unimplemented FoldDeclared instance: ForExp"+ foldDeclared f r (A.RulePragmaDecl _ _) = f Nothing r+ foldDeclared f r (A.DeprPragmaDecl _ _) = f Nothing r+ foldDeclared f r (A.WarnPragmaDecl _ _) = f Nothing r+ foldDeclared f r (A.InlineSig _ _ _ x) = foldDeclared f r x+ foldDeclared f r (A.InlineConlikeSig _ _ x) = foldDeclared f r x+ foldDeclared f r (A.SpecSig _ x _) = foldDeclared f r x+ foldDeclared f r (A.SpecInlineSig _ _ _ x _) = foldDeclared f r x+ foldDeclared f r (A.InstSig _ _ x) = foldDeclared f r x+ foldDeclared f r (A.AnnPragma _ _) = f Nothing r++instance FoldDeclared (A.DeclHead a) where+ foldDeclared f r (A.DHead _ x _) = foldDeclared f r x+ foldDeclared f r (A.DHInfix _ _ x _) = foldDeclared f r x+ foldDeclared f r (A.DHParen _ x) = foldDeclared f r x+instance FoldDeclared (A.ClassDecl a) where+ foldDeclared f r (A.ClsDecl _ x) = foldDeclared f r x -- ordinary declaration+ foldDeclared f r (A.ClsDataFam _ _ x _) = foldDeclared f r x -- declaration of an associated data type+ foldDeclared f r (A.ClsTyFam _ x _) = foldDeclared f r x -- declaration of an associated type synonym+ foldDeclared _ r (A.ClsTyDef _ _ _) = r -- default choice for an associated type synonym+instance FoldDeclared (A.InstHead a) where+ foldDeclared f r (A.IHead _ x _) = foldDeclared f r x+ foldDeclared f r (A.IHInfix _ _ x _) = foldDeclared f r x+ foldDeclared f r (A.IHParen _ x) = foldDeclared f r x+instance FoldDeclared (A.Match a) where+ foldDeclared f r (A.Match _ x _ _ _) = foldDeclared f r x+ foldDeclared f r (A.InfixMatch _ _ x _ _ _) = foldDeclared f r x+-- Can you declare something with a qualified name?+instance FoldDeclared (A.QName a) where+ foldDeclared f r (A.Qual _ _ x) = foldDeclared f r x+ foldDeclared f r (A.UnQual _ x) = foldDeclared f r x+ foldDeclared _ r (A.Special _ _) = r+instance FoldDeclared (A.Pat a) where+ foldDeclared f r (A.PVar _ x) = foldDeclared f r x -- variable+ foldDeclared _ r (A.PLit _ _) = r -- literal constant+ foldDeclared f r (A.PNeg _ x) = foldDeclared f r x -- negated pattern+ foldDeclared f r (A.PNPlusK _ x _) = foldDeclared f r x -- n+k pattern+ foldDeclared f r (A.PInfixApp _ p1 _qn p2) = let r' = foldDeclared f r p1 in foldDeclared f r' p2 -- pattern with an infix data constructor+ foldDeclared f r (A.PApp _ _ ps) = foldl (foldDeclared f) r ps -- data constructor and argument patterns+ foldDeclared f r (A.PTuple _ ps) = foldl (foldDeclared f) r ps -- tuple pattern+ foldDeclared f r (A.PList _ ps) = foldl (foldDeclared f) r ps -- list pattern+ foldDeclared f r (A.PParen _ x) = foldDeclared f r x -- parenthesized pattern+ foldDeclared f r (A.PRec _ _qn fs) = foldl (foldDeclared f) r fs -- labelled pattern, record style+ foldDeclared f r (A.PAsPat _ x y) = let r' = foldDeclared f r x in foldDeclared f r' y -- @-pattern+ foldDeclared _ r (A.PWildCard _) = r -- wildcard pattern: _+ foldDeclared f r (A.PIrrPat _ x) = foldDeclared f r x -- irrefutable pattern: ~pat+ foldDeclared f r (A.PatTypeSig _ x _) = foldDeclared f r x -- pattern with type signature+ foldDeclared f r (A.PViewPat _ _ x) = foldDeclared f r x -- view patterns of the form (exp -> pat)+ foldDeclared f r (A.PRPat _ rps) = foldl (foldDeclared f) r rps -- regular list pattern+ foldDeclared _f _r (A.PXTag _ _xn _pxs _mp _ps) = error "Unimplemented FoldDeclared instance: PXTag" -- XML element pattern+ foldDeclared _f _r (A.PXETag _ _xn _pxs _mp) = error "Unimplemented FoldDeclared instance: PXETag" -- XML singleton element pattern+ foldDeclared _f _r (A.PXPcdata _ _s) = error "Unimplemented FoldDeclared instance: XPcdata" -- XML PCDATA pattern+ foldDeclared _f _r (A.PXPatTag _ _p) = error "Unimplemented FoldDeclared instance: PXPatTag" -- XML embedded pattern+ foldDeclared _f _r (A.PXRPats _ _rps) = error "Unimplemented FoldDeclared instance: PXRPats" -- XML regular list pattern+ foldDeclared _f _r (A.PExplTypeArg _ _n _t) = error "Unimplemented FoldDeclared instance: PExplTypeArg" -- Explicit generics style type argument e.g. f {| Int |} x = ...+ foldDeclared _ r (A.PQuasiQuote _ _ _) = r -- quasi quote pattern: [$name| string |]+ foldDeclared f r (A.PBangPat _ x) = foldDeclared f r x -- strict (bang) pattern: f !x = ...+instance FoldDeclared (A.PatField a) where+ foldDeclared f r (A.PFieldPat _ _n x) = foldDeclared f r x -- ordinary label-pattern pair+ foldDeclared f r (A.PFieldPun _ x) = foldDeclared f r x -- record field pun+ foldDeclared _ r (A.PFieldWildcard _) = r+instance FoldDeclared (A.RPat a) where+ foldDeclared f r (A.RPOp _ x _) = foldDeclared f r x -- operator pattern, e.g. pat*+ foldDeclared f r (A.RPEither _ x y) = let r' = foldDeclared f r x in foldDeclared f r' y -- choice pattern, e.g. (1 | 2)+ foldDeclared f r (A.RPSeq _ xs) = foldl (foldDeclared f) r xs -- sequence pattern, e.g. (| 1, 2, 3 |)+ foldDeclared f r (A.RPGuard _ x _) = foldDeclared f r x -- guarded pattern, e.g. (| p | p < 3 |)+ foldDeclared f r (A.RPCAs _ n x) = let r' = foldDeclared f r n in foldDeclared f r' x -- non-linear variable binding, e.g. (foo@:(1 | 2))*+ foldDeclared f r (A.RPAs _ n x) = let r' = foldDeclared f r n in foldDeclared f r' x -- linear variable binding, e.g. foo@(1 | 2)+ foldDeclared f r (A.RPParen _ x) = foldDeclared f r x -- parenthesised pattern, e.g. (2*)+ foldDeclared f r (A.RPPat _ x) = foldDeclared f r x -- an ordinary pattern++instance FoldDeclared (A.Name l) where+ foldDeclared f r x = f (Just (sName x)) r++-- Something imported can be exported+instance FoldDeclared (A.ImportSpec l) where+ foldDeclared f r (A.IVar _ name) = foldDeclared f r name+ foldDeclared f r (A.IAbs _ name) = foldDeclared f r name+ foldDeclared f r (A.IThingAll _ name) = foldDeclared f r name+ foldDeclared f r (A.IThingWith _ name _) = foldDeclared f r name++instance FoldDeclared (A.ExportSpec l) where+ foldDeclared f r (A.EVar _ name) = foldDeclared f r name+ foldDeclared f r (A.EAbs _ name) = foldDeclared f r name+ foldDeclared f r (A.EThingAll _ name) = foldDeclared f r name+ foldDeclared f r (A.EThingWith _ name _) = foldDeclared f r name+ foldDeclared _ r (A.EModuleContents _ _) = r -- This probably won't work correctly++-- Return the set of symbols appearing in a construct. Some+-- constructs, such as instance declarations, declare no symbols, in+-- which case Nothing is returned. Some declare more than one.+symbols :: FoldDeclared a => a -> Set (Maybe S.Name)+symbols = foldDeclared insert empty++members :: FoldMembers a => a -> Set (Maybe S.Name)+members = foldMembers insert empty++justs :: Set (Maybe a) -> [a]+justs = mapMaybe id . toList++exports :: (FoldDeclared a, FoldMembers a) => a -> [S.ExportSpec]+exports x = case (justs (symbols x), justs (members x)) of+ ([n], []) -> [S.EVar (S.UnQual n)]+ ([n], ms) -> [S.EThingWith (S.UnQual n) (sort (map S.VarName ms))]+ ([], []) -> []+ ([], _) -> error "exports: members with no top level name"+ (ns, []) -> map (S.EVar . S.UnQual) ns+ (_ns, _ms) -> error "exports: multiple top level names and member names"++imports :: (FoldDeclared a, FoldMembers a) => a -> [S.ImportSpec]+imports x = case (justs (symbols x), justs (members x)) of+ ([n], []) -> [S.IVar n]+ ([n], ms) -> [S.IThingWith n (sort (map S.VarName ms))]+ ([], []) -> []+ ([], _ms) -> error "exports: members with no top level name"+ (ns, []) -> map S.IVar ns+ (_ns, _ms) -> error "exports: multiple top level names and member names"++-- | Fold over the declared members - e.g. the method names of a class declaration, the constructors of a data declaration.+class FoldMembers a where+ foldMembers :: forall r. (Maybe S.Name -> r -> r) -> r -> a -> r++instance FoldMembers (A.Decl a) where+ foldMembers f r (A.ClassDecl _ _ _ _ mxs) = maybe r (foldl (foldDeclared f) r) mxs -- class context => x | fundeps where decls+ foldMembers f r (A.DataDecl _ _ _ _ xs _) = foldl (foldDeclared f) r xs -- data/newtype _ x = ...+ foldMembers f r (A.GDataDecl _ _ _ _ _ xs _) = foldl (foldDeclared f) r xs+ foldMembers _ r _ = r++-- The following instances of FoldDeclared are only called by the FoldMembers instances. Hopefully.+instance FoldDeclared (A.QualConDecl l) where+ foldDeclared f r (A.QualConDecl _l _ _ x) = foldDeclared f r x++-- Constructors and field names+instance FoldDeclared (A.ConDecl l) where+ foldDeclared f r (A.ConDecl _ x _ts) = foldDeclared f r x -- ordinary data constructor+ foldDeclared f r (A.InfixConDecl _ _t1 x _t2) = foldDeclared f r x -- infix data constructor+ foldDeclared f r (A.RecDecl _ x fs) = let r' = foldDeclared f r x in foldl (foldDeclared f) r' fs -- record constructor++instance FoldDeclared (A.FieldDecl l) where+ foldDeclared f r (A.FieldDecl _ xs _) = foldl (foldDeclared f) r xs++instance FoldDeclared (A.GadtDecl l) where+ foldDeclared f r (A.GadtDecl _ x _) = foldDeclared f r x++tests :: Test+tests = TestList [test1, test2, test3, test4]++test1 :: Test+test1 = TestCase (assertEqual "DefaultDecl" " \ndefault (foo)" (prettyPrint (A.DefaultDecl def [A.TyVar def (A.Ident def "foo")] :: A.Decl SrcSpanInfo)))+test2 :: Test+test2 = TestCase (assertEqual "PatBind" "pvar :: typ = unqualrhs" (prettyPrint (A.PatBind def (A.PVar def (A.Ident def "pvar")) (Just (A.TyVar def (A.Ident def "typ"))) (A.UnGuardedRhs def (A.Var def (A.UnQual def (A.Ident def "unqualrhs")))) Nothing :: A.Decl SrcSpanInfo)))+test3 :: Test+test3 = TestCase (assertEqual "Pat" "pvar" (prettyPrint (A.PVar def (A.Ident def "pvar") :: A.Pat SrcSpanInfo)))+test4 :: Test+test4 = TestCase (assertEqual "Pat" "unqual pvar" (prettyPrint (A.PApp def (A.UnQual def (A.Ident def "unqual")) [A.PVar def (A.Ident def "pvar")] :: A.Pat SrcSpanInfo)))
+ Language/Haskell/Modules/Util/Temp.hs view
@@ -0,0 +1,23 @@+module Language.Haskell.Modules.Util.Temp+ ( withTempDirectory+ ) where++import qualified Control.Exception as IO (catch)+import 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)++-- | Adapted from 'System.IO.Temp.withTempDirectory' to work in MonadCatchIO instances.+withTempDirectory :: MonadCatchIO m =>+ FilePath -- ^ Temp directory to create the directory in+ -> String -- ^ Directory name template. See 'openTempFile'.+ -> (FilePath -> m a) -- ^ Callback that can use the directory+ -> m a+withTempDirectory targetDir template =+ IOT.bracket+ (liftIO $ Temp.createTempDirectory targetDir template)+ (liftIO . ignoringIOErrors . removeDirectoryRecursive)++ignoringIOErrors :: IO () -> IO ()+ignoringIOErrors ioe = ioe `IO.catch` (\e -> const (return ()) (e :: IOError))
+ Language/Haskell/Modules/Util/Test.hs view
@@ -0,0 +1,155 @@+module Language.Haskell.Modules.Util.Test+ ( repoModules+ , logicModules+ , diff+ , diff'+ , findModules+ , findPaths+ ) where++import Control.Monad (foldM)+import Data.List as List (filter, isPrefixOf, isSuffixOf, map)+import Data.Set as Set (empty, fromList, insert, map, Set)+import qualified Language.Haskell.Exts.Syntax as S (ModuleName(..))+import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)+import System.Exit (ExitCode)+import System.FilePath ((</>))+import System.Process (readProcessWithExitCode)++repoModules :: Set S.ModuleName+repoModules =+ Set.fromList+ [S.ModuleName "Debian.Repo.Sync",+ S.ModuleName "Debian.Repo.Slice",+ S.ModuleName "Debian.Repo.SourcesList",+ S.ModuleName "Debian.Repo.PackageIndex",+ S.ModuleName "Debian.Repo.Types",+ S.ModuleName "Debian.Repo.Types.Slice",+ S.ModuleName "Debian.Repo.Types.Repository",+ S.ModuleName "Debian.Repo.Types.PackageIndex",+ S.ModuleName "Debian.Repo.Types.Release",+ S.ModuleName "Debian.Repo.Types.AptImage",+ S.ModuleName "Debian.Repo.Types.Repo",+ S.ModuleName "Debian.Repo.Types.AptBuildCache",+ S.ModuleName "Debian.Repo.Types.EnvPath",+ S.ModuleName "Debian.Repo.Types.AptCache",+ S.ModuleName "Debian.Repo.Orphans",+ S.ModuleName "Debian.Repo.Types",+ S.ModuleName "Debian.Repo.AptImage",+ S.ModuleName "Debian.Repo.Package",+ S.ModuleName "Debian.Repo.Monads.Top",+ S.ModuleName "Debian.Repo.Monads.Apt",+ S.ModuleName "Debian.Repo.AptCache",+ S.ModuleName "Tmp.File",+ S.ModuleName "Text.Format"]++logicModules :: Set S.ModuleName+logicModules =+ Set.fromList+ [ S.ModuleName "Data.Boolean.SatSolver"+ , S.ModuleName "Data.Boolean"+ , S.ModuleName "Data.Logic.Resolution"+ , S.ModuleName "Data.Logic.KnowledgeBase"+ , S.ModuleName "Data.Logic.Types.FirstOrder"+ , S.ModuleName "Data.Logic.Types.Common"+ , S.ModuleName "Data.Logic.Types.Harrison.Formulas.FirstOrder"+ , S.ModuleName "Data.Logic.Types.Harrison.Formulas.Propositional"+ , S.ModuleName "Data.Logic.Types.Harrison.Prop"+ , S.ModuleName "Data.Logic.Types.Harrison.Equal"+ , S.ModuleName "Data.Logic.Types.Harrison.FOL"+ , S.ModuleName "Data.Logic.Types.Propositional"+ , S.ModuleName "Data.Logic.Types.FirstOrderPublic"+ , S.ModuleName "Data.Logic.Harrison.Unif"+ , S.ModuleName "Data.Logic.Harrison.Meson"+ , S.ModuleName "Data.Logic.Harrison.Herbrand"+ , S.ModuleName "Data.Logic.Harrison.Formulas.FirstOrder"+ , S.ModuleName "Data.Logic.Harrison.Formulas.Propositional"+ , S.ModuleName "Data.Logic.Harrison.Tests"+ , S.ModuleName "Data.Logic.Harrison.Resolution"+ , S.ModuleName "Data.Logic.Harrison.DefCNF"+ , S.ModuleName "Data.Logic.Harrison.Skolem"+ , S.ModuleName "Data.Logic.Harrison.Prop"+ , S.ModuleName "Data.Logic.Harrison.DP"+ , S.ModuleName "Data.Logic.Harrison.Lib"+ , S.ModuleName "Data.Logic.Harrison.PropExamples"+ , S.ModuleName "Data.Logic.Harrison.Prolog"+ , S.ModuleName "Data.Logic.Harrison.Tableaux"+ , S.ModuleName "Data.Logic.Harrison.Equal"+ , S.ModuleName "Data.Logic.Harrison.Normal"+ , S.ModuleName "Data.Logic.Harrison.FOL"+ , S.ModuleName "Data.Logic.Tests.TPTP"+ , S.ModuleName "Data.Logic.Tests.Common"+ , S.ModuleName "Data.Logic.Tests.Harrison.Unif"+ , S.ModuleName "Data.Logic.Tests.Harrison.Meson"+ , S.ModuleName "Data.Logic.Tests.Harrison.Resolution"+ , S.ModuleName "Data.Logic.Tests.Harrison.Common"+ , S.ModuleName "Data.Logic.Tests.Harrison.Skolem"+ , S.ModuleName "Data.Logic.Tests.Harrison.Prop"+ , S.ModuleName "Data.Logic.Tests.Harrison.Main"+ , S.ModuleName "Data.Logic.Tests.Harrison.Equal"+ , S.ModuleName "Data.Logic.Tests.Harrison.FOL"+ , S.ModuleName "Data.Logic.Tests.Main"+ , S.ModuleName "Data.Logic.Tests.Logic"+ , S.ModuleName "Data.Logic.Tests.Data"+ , S.ModuleName "Data.Logic.Tests.HUnit"+ , S.ModuleName "Data.Logic.Tests.Chiou0"+ , S.ModuleName "Data.Logic.Failing"+ , S.ModuleName "Data.Logic.Instances.SatSolver"+ , S.ModuleName "Data.Logic.Instances.TPTP"+ , S.ModuleName "Data.Logic.Instances.Chiou"+ , S.ModuleName "Data.Logic.Instances.PropLogic"+ , S.ModuleName "Data.Logic.Normal.Clause"+ , S.ModuleName "Data.Logic.Normal.Implicative"+ , S.ModuleName "Data.Logic.Classes.FirstOrder"+ , S.ModuleName "Data.Logic.Classes.Variable"+ , S.ModuleName "Data.Logic.Classes.Apply"+ , S.ModuleName "Data.Logic.Classes.Negate"+ , S.ModuleName "Data.Logic.Classes.Pretty"+ , S.ModuleName "Data.Logic.Classes.Arity"+ , S.ModuleName "Data.Logic.Classes.Skolem"+ , S.ModuleName "Data.Logic.Classes.Combine"+ , S.ModuleName "Data.Logic.Classes.Constants"+ , S.ModuleName "Data.Logic.Classes.Equals"+ , S.ModuleName "Data.Logic.Classes.Propositional"+ , S.ModuleName "Data.Logic.Classes.Atom"+ , S.ModuleName "Data.Logic.Classes.Formula"+ , S.ModuleName "Data.Logic.Classes.ClauseNormalForm"+ , S.ModuleName "Data.Logic.Classes.Term"+ , S.ModuleName "Data.Logic.Classes.Literal"+ , S.ModuleName "Data.Logic.Satisfiable" ]++diff :: FilePath -> FilePath -> IO (ExitCode, String, String)+diff a b =+ do (code, out, err) <- readProcessWithExitCode "diff" ["-ru", "--exclude=*~", "--exclude=*.imports", a, b] ""+ let out' = unlines (List.filter (not . isPrefixOf "Binary files") . List.map (takeWhile (/= '\t')) $ (lines out))+ return (code, out', err)++-- | Like diff, but ignores extra files in b.+diff' :: FilePath -> FilePath -> IO (ExitCode, String, String)+diff' a b =+ 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)++-- | 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))++findPaths :: FilePath -> IO (Set FilePath)+findPaths top =+ doPath empty top+ where+ doPath r path =+ do dir <- doesDirectoryExist path+ reg <- doesFileExist path+ case () of+ _ | dir -> doDirectory r path+ _ | reg && isSuffixOf ".hs" path -> return (insert path r)+ _ -> return r+ doDirectory r path =+ getDirectoryContents path >>= foldM doPath r . List.map (path </>) . filter (\ x -> x /= "." && x /= "..")
+ Setup.hs view
@@ -0,0 +1,16 @@+#!/usr/bin/runhaskell++import Distribution.Simple+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir))+-- import Language.Haskell.Imports.Clean (cleanBuildImports)+-- import Language.Haskell.Imports.Params (runParamsT)+import System.Cmd (system)+import System.Exit (ExitCode(ExitSuccess))+import System.Directory (setCurrentDirectory)+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"+ -- }
+ module-management.cabal view
@@ -0,0 +1,77 @@+Name: module-management+Version: 0.9.3+Synopsis: Clean up module imports, split and merge modules+Description: Clean up module imports, split and merge modules.+Homepage: https://src.seereason.com/module-management+License: BSD3+Author: David Fox+Maintainer: David Fox <dsf@seereason.com>+Category: Editor, Haskell, IDE+Stability: experimental+Build-type: Simple+Cabal-version: >=1.8++Library+ ghc-Options: -Wall -O2+ Exposed-Modules:+ Language.Haskell.Modules,+ Language.Haskell.Modules.Fold,+ Language.Haskell.Modules.Common,+ Language.Haskell.Modules.Imports,+ Language.Haskell.Modules.Merge,+ Language.Haskell.Modules.Params,+ Language.Haskell.Modules.Split,+ Language.Haskell.Modules.Util.QIO,+ Language.Haskell.Modules.Util.Symbols,+ Language.Haskell.Modules.Util.Test,+ Language.Haskell.Modules.Util.Temp,+ Language.Haskell.Modules.Util.SrcLoc,+ Language.Haskell.Modules.Util.DryIO+ Other-Modules:+ Language.Haskell.Modules.Internal+ Build-Depends:+ applicative-extras,+ base >= 4 && < 5,+ bytestring,+ Cabal,+ containers,+ data-default,+ directory,+ filepath,+ haskell-src-exts,+ HUnit,+ MonadCatchIO-mtl,+ mtl,+ pretty,+ process,+ pureMD5,+ set-extra >= 1.3.1,+ syb,+ 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