diff --git a/Language/Haskell/Modules.hs b/Language/Haskell/Modules.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules.hs @@ -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) diff --git a/Language/Haskell/Modules/Common.hs b/Language/Haskell/Modules/Common.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Common.hs @@ -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) diff --git a/Language/Haskell/Modules/Fold.hs b/Language/Haskell/Modules/Fold.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Fold.hs @@ -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 ".hs" 5 5) -> + -- (SrcLoc ".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 ".hs" 5 5) -> + -- (SrcLoc ".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 = ".hs", + srcSpanStartLine = a, + srcSpanStartColumn = b, + srcSpanEndLine = c, + srcSpanEndColumn = d}, srcInfoPoints = []} + +test4 :: Test +test4 = TestCase (assertEqual "test4" (SrcLoc ".hs" 2 24 < SrcLoc ".hs" 29 7) True) diff --git a/Language/Haskell/Modules/Imports.hs b/Language/Haskell/Modules/Imports.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Imports.hs @@ -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)) diff --git a/Language/Haskell/Modules/Internal.hs b/Language/Haskell/Modules/Internal.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Internal.hs @@ -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 diff --git a/Language/Haskell/Modules/Merge.hs b/Language/Haskell/Modules/Merge.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Merge.hs @@ -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) diff --git a/Language/Haskell/Modules/Params.hs b/Language/Haskell/Modules/Params.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Params.hs @@ -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)}) diff --git a/Language/Haskell/Modules/Split.hs b/Language/Haskell/Modules/Split.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Split.hs @@ -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) diff --git a/Language/Haskell/Modules/Util/DryIO.hs b/Language/Haskell/Modules/Util/DryIO.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Util/DryIO.hs @@ -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 diff --git a/Language/Haskell/Modules/Util/QIO.hs b/Language/Haskell/Modules/Util/QIO.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Util/QIO.hs @@ -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 diff --git a/Language/Haskell/Modules/Util/SrcLoc.hs b/Language/Haskell/Modules/Util/SrcLoc.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Util/SrcLoc.hs @@ -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 ".hs" 1 10) (SrcLoc ".hs" 2 2) "abc\tdef\nghi\tjkl\n")) +test2 :: Test +test2 = TestCase (assertEqual "srcPairTextTail2" "kl\n" (srcPairTextTail (SrcLoc ".hs" 1 10) (SrcLoc ".hs" 2 9) "abc\tdef\nghi\tjkl\n")) +test3 :: Test +test3 = TestCase (assertEqual "srcPairTextHead1" "abc\tdef\ng" (srcPairTextHead (SrcLoc ".hs" 1 10) (SrcLoc ".hs" 2 2) "abc\tdef\nghi\tjkl\n")) +test4 :: Test +test4 = TestCase (assertEqual "srcPairTextHead21" "abc\tdef\nghi\tj" (srcPairTextHead (SrcLoc ".hs" 1 10) (SrcLoc ".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 ".hs" 1 77) + (SrcLoc ".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 ".hs" 1 1 + +instance Default SrcSpanInfo where + def = SrcSpanInfo {srcInfoSpan = def, srcInfoPoints = def} + +instance Default SrcSpan where + def = SrcSpan {srcSpanFilename = ".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])) +-} diff --git a/Language/Haskell/Modules/Util/Symbols.hs b/Language/Haskell/Modules/Util/Symbols.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Util/Symbols.hs @@ -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))) diff --git a/Language/Haskell/Modules/Util/Temp.hs b/Language/Haskell/Modules/Util/Temp.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Util/Temp.hs @@ -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)) diff --git a/Language/Haskell/Modules/Util/Test.hs b/Language/Haskell/Modules/Util/Test.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Modules/Util/Test.hs @@ -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 /= "..") diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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" + -- } diff --git a/module-management.cabal b/module-management.cabal new file mode 100644 --- /dev/null +++ b/module-management.cabal @@ -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 +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