packages feed

module-management 0.15 → 0.15.1

raw patch · 19 files changed

+541/−477 lines, 19 files

Files

Language/Haskell/Modules.hs view
@@ -69,7 +69,17 @@ -- -- * Split a module where one of the result modules needs to import the instances: -----  @runCleanT $ putModule (ModuleName \"Main\") >> extraImport (ModuleName \"Main.GetPasteById\") (ModuleName \"Main.Instances\") >> splitModuleDecls \"Main.hs\"@+--   @runCleanT $+--      putModule (ModuleName \"Main\") >>+--      extraImport (ModuleName \"Main.GetPasteById\") (ModuleName \"Main.Instances\") >>+--      splitModuleDecls \"Main.hs\"@+--+-- * Use 'mergeModules' to rename a module:+--+--   @findHsModules [\"Language\", \"Tests.hs\", \"Tests\"] >>= \\ modules -> runCleanT $+--      mapM putModule modules >>+--      mergeModules [ModuleName \"Language.Haskell.Modules.Util.Symbols\"]+--                   (ModuleName \"Language.Haskell.Modules.Symbols\")@ module Language.Haskell.Modules     (     -- * Entry points
Language/Haskell/Modules/Common.hs view
@@ -39,6 +39,7 @@ groupBy' :: Ord a => (a -> a -> Ordering) -> [a] -> [[a]] groupBy' cmp xs = groupBy (toEq cmp) $ sortBy cmp xs +-- | Perform an action with the working directory set to @path@. withCurrentDirectory :: (MonadIO m, MonadBaseControl IO m) => FilePath -> m a -> m a withCurrentDirectory path action =     bracket (liftIO getCurrentDirectory >>= \ save -> liftIO (setCurrentDirectory path) >> return save)
Language/Haskell/Modules/Fold.hs view
@@ -24,7 +24,7 @@ import Language.Haskell.Exts.Comments (Comment(..)) import Language.Haskell.Exts.SrcLoc (SrcLoc(..), SrcSpan(..), SrcSpanInfo(..)) import Language.Haskell.Modules.ModuVerse (ModuleInfo(ModuleInfo))-import Language.Haskell.Modules.Util.SrcLoc (endLoc, HasSpanInfo(..), increaseSrcLoc, srcLoc, srcPairText)+import Language.Haskell.Modules.SrcLoc (endLoc, HasSpanInfo(..), increaseSrcLoc, srcLoc, srcPairText)  --type Module = A.Module SrcSpanInfo --type ModuleHead = A.ModuleHead SrcSpanInfo
Language/Haskell/Modules/Imports.hs view
@@ -25,11 +25,11 @@ import Language.Haskell.Modules.Fold (foldDecls, foldExports, foldHeader, foldImports) import Language.Haskell.Modules.ModuVerse (findModule, getExtensions, loadModule, ModuleInfo(..), moduleName, parseModule) import Language.Haskell.Modules.Params (markForDelete, MonadClean(getParams), Params(hsFlags, removeEmptyImports, scratchDir, testMode))-import Language.Haskell.Modules.SourceDirs (modifyDirs, pathKey, APath(..), PathKey(..), PathKey(unPathKey), SourceDirs(getDirs, putDirs))+import Language.Haskell.Modules.SourceDirs (APath(..), modifyDirs, pathKey, PathKey(..), PathKey(unPathKey), SourceDirs(getDirs, putDirs))+import Language.Haskell.Modules.SrcLoc (srcLoc)+import Language.Haskell.Modules.Symbols (symbols) import Language.Haskell.Modules.Util.DryIO (replaceFile, tildeBackup) import Language.Haskell.Modules.Util.QIO (qLnPutStr, quietly)-import Language.Haskell.Modules.Util.SrcLoc (srcLoc)-import Language.Haskell.Modules.Util.Symbols (symbols) import System.Directory (createDirectoryIfMissing, getCurrentDirectory) import System.Exit (ExitCode(..)) import System.Process (readProcessWithExitCode, showCommandForUser)@@ -57,13 +57,33 @@           if exists then return path else toFilePath dirs m -} --- | Clean up the imports of a source file.+-- | Clean up the imports of a source file.  This means:+--+--    * All import lines get an explict list of symbols+--+--    * Imports of unused symbols are removed+--+--    * Imports of modules whose symbol list becomse empty are+--      removed, unless the 'removeEmptyImports' flag is set to+--      @False@.  However, imports that started out with an empty+--      import list @()@ are retained+--+--    * Repeated imports are merged+--+--    * Imports are alphabetized by module name+--+--    * Imported symbols are alphabetized by symbol name+--+--    * Imported constructors and field accessors are alphabetized cleanImports :: MonadClean m => [FilePath] -> m [ModuleResult] cleanImports paths =     do keys <- mapM (pathKey . APath) paths >>= return . fromList        dumpImports keys        mapM (\ key -> parseModule key >>= checkImports) (toList keys) +-- | Do import cleaning in response to the values returned by the+-- split and merge operations.  Module import lists are cleaned if the+-- module is modified or created. cleanResults :: MonadClean m => [ModuleResult] -> m [ModuleResult] cleanResults results =     do mode <- getParams >>= return . testMode@@ -88,7 +108,7 @@       -- turn it back into Created.       toCreated (JustModified name key) = JustCreated name key       toCreated x@(JustCreated {}) = x-      toCreated _ = error "toCreated"+      toCreated x = error $ "toCreated: " ++ show x       -- Update the cached version of the now modified module and then       -- clean its import list.       doModule key =
Language/Haskell/Modules/ModuVerse.hs view
@@ -81,13 +81,14 @@                    , sourceDirs_ = ["."] }  -- | From hsx2hs, but removing Arrows because it makes test case fold3c and others fail.+-- The TransformListComp makes group, by, and using into keywords. hseExtensions :: [Extension] hseExtensions =     [ RecursiveDo, ParallelListComp, MultiParamTypeClasses, FunctionalDependencies, RankNTypes, ExistentialQuantification     , ScopedTypeVariables, ImplicitParams, FlexibleContexts, FlexibleInstances, EmptyDataDecls, KindSignatures     , BangPatterns, TemplateHaskell, ForeignFunctionInterface, {- Arrows, -} Generics, NamedFieldPuns, PatternGuards     , MagicHash, TypeFamilies, StandaloneDeriving, TypeOperators, RecordWildCards, GADTs, UnboxedTuples-    , PackageImports, QuasiQuotes, TransformListComp, ViewPatterns, XmlSyntax, RegularPatterns ]+    , PackageImports, QuasiQuotes, {-TransformListComp,-} ViewPatterns, XmlSyntax, RegularPatterns ]  getNames :: ModuVerse m => m (Set S.ModuleName) getNames = getModuVerse >>= return . Set.fromList . keys . fromMaybe (error "No modules in ModuVerse, use putModule") . moduleNames_@@ -121,6 +122,9 @@ getExtensions :: ModuVerse m => m [Extension] getExtensions = getModuVerse >>= return . extensions_ +-- | Modify the list of extensions passed to GHC when dumping the+-- minimal imports.  Note that GHC will also use the extensions in the+-- module's LANGUAGE pragma, so this can usually be left alone. modifyExtensions :: ModuVerse m => ([Extension] -> [Extension]) -> m () modifyExtensions f = modifyModuVerse (\ s -> s {extensions_ = f (extensions_ s)})
Language/Haskell/Modules/Params.hs view
@@ -92,8 +92,8 @@     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.+-- splitting/merging.  This environment, @StateT Params m a@, is an+-- instance of 'MonadClean'. runCleanT :: (MonadIO m, MonadBaseControl IO m) => CleanT m a -> m a runCleanT action =     withTempDirectory "." "scratch" $ \ scratch ->@@ -134,7 +134,9 @@ modifyDryRun f = modifyParams (\ p -> p {dryRun = f (dryRun p)})  -- | If TestMode is turned on no import cleaning will occur after a--- split or cat.  Default is False.+-- split or cat.  Default is False.  Note that the modules produced+-- with this option will often fail to compile to to circular imports.+-- (Does this seem counterintuitive to anyone else?) modifyTestMode :: MonadClean m => (Bool -> Bool) -> m () modifyTestMode f = modifyParams (\ p -> p {testMode = f (testMode p)})
Language/Haskell/Modules/SourceDirs.hs view
@@ -8,10 +8,6 @@     , PathKey(..)     , APath(..)     , pathKey-#if 0-    , pathKey-    , pathKeyMaybe-#endif     , Path(..)     , modulePath     , modulePathBase@@ -26,8 +22,13 @@  class (MonadIO m, MonadBaseControl IO m) => SourceDirs m where     putDirs :: [FilePath] -> m ()+    -- ^ Set the list of directories that will be searched for+    -- imported modules.  Similar to the Hs-Source-Dirs field in the+    -- cabal file.     getDirs :: m [FilePath] +-- | Modify the list of directories that will be searched for imported+-- modules. modifyDirs :: SourceDirs m => ([FilePath] -> [FilePath]) -> m () modifyDirs f = getDirs >>= putDirs . f @@ -56,7 +57,12 @@                (d : _) -> return . APath $ d </> unRelPath path       path = modulePathBase ext name --- | Construct the base of a module path.+-- | Derive a relative FilePath from a module name based on the file+-- type inferred by the extension.  Thus, @modulePathBase "hs"+-- (ModuleName "System.Control.Monad")@ returns+-- @"System/Control/Monad.hs"@, while @modulePathBase "imports"+-- (ModuleName "System.Control.Monad")@ returns+-- @"System.Control.Monad.imports"@. modulePathBase :: String -> S.ModuleName -> RelPath modulePathBase ext (S.ModuleName name) =     RelPath (base <.> ext)
Language/Haskell/Modules/Split.hs view
@@ -28,12 +28,32 @@ import Language.Haskell.Modules.Imports (cleanResults) import Language.Haskell.Modules.ModuVerse (findModule, getNames, ModuleInfo(..), moduleName, parseModule) import Language.Haskell.Modules.Params (MonadClean(getParams), Params(extraImports))-import Language.Haskell.Modules.SourceDirs (modulePathBase, APath(..), pathKey)+import Language.Haskell.Modules.SourceDirs (APath(..), modulePathBase, pathKey)+import Language.Haskell.Modules.Symbols (exports, imports, members, symbols) import Language.Haskell.Modules.Util.QIO (qLnPutStr, quietly)-import Language.Haskell.Modules.Util.Symbols (exports, imports, symbols, members) import Prelude hiding (writeFile) import System.FilePath ((<.>)) +-- | Split the declarations of the module in the input file into new+-- modules as specified by the 'symToModule' function, which maps+-- symbol name's to module names.  It is permissable for the output+-- function to map one or more symbols to the original module.  The+-- modules will be written into files whose names are constructed from+-- the module name in the usual way, but with a prefix taken from the+-- first element of the list of directories in the 'SourceDirs' list.+-- This list is just @["."]@ by default.+splitModule :: MonadClean m =>+               (Maybe S.Name -> S.ModuleName)+            -- ^ Map each symbol name to the module it will be moved+            -- to.  The name @Nothing@ is used for instance+            -- declarations.+            -> FilePath+            -- ^ The file containing the input module.+            -> m [ModuleResult]+splitModule symToModule path =+    do info <- pathKey (APath path) >>= parseModule+       splitModuleBy symToModule info+ -- | Split each of a module's declarations into a new module.  Update -- the imports of all the modules in the moduVerse to reflect the split. -- For example, if you have a module like@@ -59,23 +79,22 @@ -- If we had imported and then re-exported a symbol in Start it would -- go into a module named @Start.ReExported@.  Any instance declarations -- would go into @Start.Instances@.-splitModule :: MonadClean m =>-               (Maybe S.Name -> S.ModuleName)-               -- ^ Map declaration to new module name.   The name @Nothing@-               -- is used for instance declarations.-            -> FilePath-            -> m [ModuleResult]-splitModule symToModule path =-    do info <- pathKey (APath path) >>= parseModule-       splitModuleBy symToModule info---- | Do splitModuleBy with the default symbol to module mapping (was splitModule)-splitModuleDecls :: MonadClean m => FilePath -> m [ModuleResult]+splitModuleDecls :: MonadClean m =>+                    FilePath+                 -- ^ The file containing the input module.+                 -> m [ModuleResult] splitModuleDecls path =     do info <- pathKey (APath path) >>= parseModule        splitModuleBy (defaultSymbolToModule info) info -splitModuleBy :: MonadClean m => (Maybe S.Name -> S.ModuleName) -> ModuleInfo -> m [ModuleResult]+-- | Do splitModuleBy with the default symbol to module mapping (was splitModule)+splitModuleBy :: MonadClean m =>+                 (Maybe S.Name -> S.ModuleName)+              -- ^ Function mapping symbol names of the input module+              -- to destination module name.+              -> ModuleInfo+              -- ^ The parsed input module.+              -> m [ModuleResult] splitModuleBy _ (ModuleInfo (A.XmlPage {}) _ _ _) = error "XmlPage" splitModuleBy _ (ModuleInfo (A.XmlHybrid {}) _ _ _) = error "XmlPage" splitModuleBy _ m@(ModuleInfo (A.Module _ _ _ _ []) _ _ key) = return [Unchanged (moduleName m) key] -- No declarations - nothing to split@@ -96,12 +115,6 @@             -- Clean the new modules after all edits are finished             cleanResults changes'     where--{-    collisionCheck univ s =-          if (not $ Set.null $ Set.intersection univ $ Set.filter isCreated s)-          then error ("One or more module to be created by splitModule already exists: " ++ show (Set.toList illegal))-          else s -}-       outNames = Set.map symToModule (union (declared inInfo) (exported inInfo))  doModule :: MonadClean m =>@@ -325,8 +338,8 @@ isReExported (ReExported _) = True isReExported _ = False --- | This can be used to build function parameter of splitModule, it--- determines which module should a symbol be moved to.+-- | This can be used to build the function parameter of 'splitModule',+-- it determines which module should a symbol be moved to. defaultSymbolToModule :: ModuleInfo    -- ^ Parent module name                       -> Maybe S.Name                       -> S.ModuleName
+ Language/Haskell/Modules/SrcLoc.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE BangPatterns, FlexibleInstances, ScopedTypeVariables, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Language.Haskell.Modules.SrcLoc+    ( HasSpanInfo(..)+    , srcSpan+    , srcLoc+    , endLoc+    , textEndLoc+    , increaseSrcLoc+    , textSpan+    , srcPairText+    , makeTree+    ) where++import Control.Monad.State (get, put, runState, State)+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)++-- | 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 SrcSpan where+    spanInfo x = SrcSpanInfo x []++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 :: FilePath -> String -> SrcLoc+textEndLoc path text =+    SrcLoc {srcFilename = path, 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))++textSpan :: FilePath -> String -> SrcSpanInfo+textSpan path s =+    let end = textEndLoc path s in+    SrcSpanInfo (SrcSpan {srcSpanFilename = path, srcSpanStartLine = 1, srcSpanStartColumn = 1, srcSpanEndLine = srcLine end, srcSpanEndColumn = srcColumn end}) []++-- | Given a beginning and end location, and a string which starts at+-- the beginning location, return a (beforeend,afterend) pair.+srcPairText :: SrcLoc -> SrcLoc -> String -> (String, String)+srcPairText b0 e0 s0 =+    fst $ runState f (b0, e0, "", s0)+    where+      f :: State (SrcLoc, SrcLoc, String, String) (String, String)+      f = do (b, e, r, s) <- get+             case (srcLine b < srcLine e, srcColumn b < srcColumn e) of+               (True, _) ->+                   case span (/= '\n') s of+                     (r', '\n' : s') ->+                         put (b {srcLine = srcLine b + 1, srcColumn = 1}, e, r ++ r' ++ "\n", s') >> f+                     (_, "") ->+                        -- This should not happen, but if the last line+                        -- lacks a newline terminator, haskell-src-exts+                        -- will set the end location as if the terminator+                        -- was present.+                        case s of+                          "" -> return (r, s)+                          (c : s') -> put (b {srcColumn = srcColumn b + 1}, e, r ++ [c], s') >> f+                     _ -> error "Impossible: span stopped at the wrong character"+               (_, True) ->+                   case s of+                     [] -> error $ "srcPairText: " ++ show (b0, e0, s0)+                     (c : s') -> put (b {srcColumn = srcColumn b + 1}, e, r ++ [c], s') >> f+               _ ->+                   return (r, s)++-- | Build a tree of SrcSpanInfo +makeTree :: (HasSpanInfo a, Show a, Eq a, Ord a) => Set a -> Tree a+makeTree s =+    case findRoots (toList s) of+      [] -> error "No roots"+      [root] -> unfoldTree f root+      roots -> error $ "Multiple roots: " ++ show roots+    where+      f x = (x, findChildren (toList s) x)++      -- The roots are the nodes that are not covered by any other node.+      findRoots :: (HasSpanInfo a, Eq a, Ord a) => [a] -> [a]+      findRoots [] = []+      findRoots (x : xs) =+          let (_children, other) = partition (\ y -> x `covers` y) xs+              (ancestors, cousins) = partition (\ y -> x `coveredBy` y) other in+          case ancestors of+            -- If there are no ancestors, x is a root, and there may be other roots among the cousins+            [] -> x : findRoots cousins+            -- If there are ancestors, there must be a root among them, and there still may be roots among the cousins.+            _ -> findRoots (ancestors ++ cousins)++      findChildren :: (HasSpanInfo a, Eq a, Ord a, Show a) => [a] -> a -> [a]+      findChildren u x = findRoots children where children = sort (filter (\ y -> x `covers` y && x /= y) u)++-- True if a covers b+covers :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> Bool+covers a b = srcLoc a <= srcLoc b && endLoc b <= endLoc a++-- True if a is covered by b+coveredBy :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> Bool+coveredBy = flip covers++{-+test3 = TestCase (assertEqual "covers1" True (covers (mkspan (29, 1) (29, 8)) (mkspan (29, 3) (29, 7))))+test4 = TestCase (assertEqual "covers2" False (covers (mkspan (29, 1) (29, 8)) (mkspan (29, 3) (29, 10))))+test5 = TestCase (assertEqual "roots1"+                                  [sp 5 10, sp 11 18]+                                  (findRoots [sp 5 10,+                                              sp 11 18,+                                              sp 6 7,+                                              sp 8 9,+                                              sp 12 15]))+-}
+ Language/Haskell/Modules/Symbols.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Language.Haskell.Modules.Symbols+    ( FoldDeclared(foldDeclared)+    , FoldMembers(foldMembers)+    , symbols+    , members+    , exports+    , imports+    ) where++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(..), ExportSpec(..), FieldDecl(..), GadtDecl(..), ImportSpec(..), InstHead(..), Match(..), Name, Pat(..), PatField(..), QName(..), QualConDecl(..), RPat(..))+import qualified Language.Haskell.Exts.Syntax as S (CName(..), ExportSpec(..), ImportSpec(..), Name(..), QName(..))++-- | 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+              y -> error $ "exports: multiple top level names and member names: " ++ show y++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+              y -> error $ "imports: multiple top level names and member names: " ++ show y++-- | 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
Language/Haskell/Modules/Util/QIO.hs view
@@ -23,6 +23,7 @@ modifyVerbosity :: MonadVerbosity m => (Int -> Int) -> m () modifyVerbosity f = getVerbosity >>= putVerbosity . f +-- | Decrease the amount of progress reporting during an action. quietly :: MonadVerbosity m => m a -> m a quietly action =     do modifyVerbosity (\x->x-1)@@ -30,6 +31,7 @@        modifyVerbosity (+ 1)        return result +-- | Increase the amount of progress reporting during an action. noisily :: MonadVerbosity m => m a -> m a noisily action =     do modifyVerbosity (+ 1)
− Language/Haskell/Modules/Util/SrcLoc.hs 
@@ -1,241 +0,0 @@-{-# LANGUAGE BangPatterns, FlexibleInstances, ScopedTypeVariables, UndecidableInstances #-}-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}-module Language.Haskell.Modules.Util.SrcLoc-    ( HasSpanInfo(..)-    , srcSpan-    , srcLoc-    , endLoc-    , textEndLoc-    , increaseSrcLoc-    , textSpan-    , srcPairText-    , makeTree-    ) where--import Control.Monad.State (get, put, runState, State)-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)---- | 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 SrcSpan where-    spanInfo x = SrcSpanInfo x []--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 :: FilePath -> String -> SrcLoc-textEndLoc path text =-    SrcLoc {srcFilename = path, 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))--textSpan :: FilePath -> String -> SrcSpanInfo-textSpan path s =-    let end = textEndLoc path s in-    SrcSpanInfo (SrcSpan {srcSpanFilename = path, srcSpanStartLine = 1, srcSpanStartColumn = 1, srcSpanEndLine = srcLine end, srcSpanEndColumn = srcColumn end}) []---- | Given a beginning and end location, and a string which starts at--- the beginning location, return a (beforeend,afterend) pair.-srcPairText :: SrcLoc -> SrcLoc -> String -> (String, String)-srcPairText b0 e0 s0 =-    fst $ runState f (b0, e0, "", s0)-    where-      f :: State (SrcLoc, SrcLoc, String, String) (String, String)-      f = do (b, e, r, s) <- get-             case (srcLine b < srcLine e, srcColumn b < srcColumn e) of-               (True, _) ->-                   case span (/= '\n') s of-                     (r', '\n' : s') ->-                         put (b {srcLine = srcLine b + 1, srcColumn = 1}, e, r ++ r' ++ "\n", s') >> f-                     (_, "") ->-                        -- This should not happen, but if the last line-                        -- lacks a newline terminator, haskell-src-exts-                        -- will set the end location as if the terminator-                        -- was present.-                        case s of-                          "" -> return (r, s)-                          (c : s') -> put (b {srcColumn = srcColumn b + 1}, e, r ++ [c], s') >> f-                     _ -> error "Impossible: span stopped at the wrong character"-               (_, True) ->-                   case s of-                     [] -> error $ "srcPairText: " ++ show (b0, e0, s0)-                     (c : s') -> put (b {srcColumn = srcColumn b + 1}, e, r ++ [c], s') >> f-               _ ->-                   return (r, s)---- | Build a tree of SrcSpanInfo -makeTree :: (HasSpanInfo a, Show a, Eq a, Ord a) => Set a -> Tree a-makeTree s =-    case findRoots (toList s) of-      [] -> error "No roots"-      [root] -> unfoldTree f root-      roots -> error $ "Multiple roots: " ++ show roots-    where-      f x = (x, findChildren (toList s) x)--      -- The roots are the nodes that are not covered by any other node.-      findRoots :: (HasSpanInfo a, Eq a, Ord a) => [a] -> [a]-      findRoots [] = []-      findRoots (x : xs) =-          let (_children, other) = partition (\ y -> x `covers` y) xs-              (ancestors, cousins) = partition (\ y -> x `coveredBy` y) other in-          case ancestors of-            -- If there are no ancestors, x is a root, and there may be other roots among the cousins-            [] -> x : findRoots cousins-            -- If there are ancestors, there must be a root among them, and there still may be roots among the cousins.-            _ -> findRoots (ancestors ++ cousins)--      findChildren :: (HasSpanInfo a, Eq a, Ord a, Show a) => [a] -> a -> [a]-      findChildren u x = findRoots children where children = sort (filter (\ y -> x `covers` y && x /= y) u)---- True if a covers b-covers :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> Bool-covers a b = srcLoc a <= srcLoc b && endLoc b <= endLoc a---- True if a is covered by b-coveredBy :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> Bool-coveredBy = flip covers--{--test3 = TestCase (assertEqual "covers1" True (covers (mkspan (29, 1) (29, 8)) (mkspan (29, 3) (29, 7))))-test4 = TestCase (assertEqual "covers2" False (covers (mkspan (29, 1) (29, 8)) (mkspan (29, 3) (29, 10))))-test5 = TestCase (assertEqual "roots1"-                                  [sp 5 10, sp 11 18]-                                  (findRoots [sp 5 10,-                                              sp 11 18,-                                              sp 6 7,-                                              sp 8 9,-                                              sp 12 15]))--}
− Language/Haskell/Modules/Util/Symbols.hs 
@@ -1,187 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}-module Language.Haskell.Modules.Util.Symbols-    ( FoldDeclared(foldDeclared)-    , FoldMembers(foldMembers)-    , symbols-    , members-    , exports-    , imports-    ) where--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(..), ExportSpec(..), FieldDecl(..), GadtDecl(..), ImportSpec(..), InstHead(..), Match(..), Name, Pat(..), PatField(..), QName(..), QualConDecl(..), RPat(..))-import qualified Language.Haskell.Exts.Syntax as S (CName(..), ExportSpec(..), ImportSpec(..), Name(..), QName(..))---- | 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-              y -> error $ "exports: multiple top level names and member names: " ++ show y--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-              y -> error $ "imports: multiple top level names and member names: " ++ show y---- | 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/Fold.hs view
@@ -15,7 +15,7 @@ import Language.Haskell.Modules.ModuVerse (ModuleInfo(..), parseModule) import Language.Haskell.Modules.Params (runCleanT) import Language.Haskell.Modules.SourceDirs (pathKey, APath(..))-import Language.Haskell.Modules.Util.SrcLoc (HasSpanInfo(..), makeTree)+import Language.Haskell.Modules.SrcLoc (HasSpanInfo(..), makeTree) import Test.HUnit (assertEqual, Test(TestList, TestCase, TestLabel))  deriving instance Eq (Exts.ParseResult (A.Module SrcSpanInfo, [A.Comment]))
Tests/SrcLoc.hs view
@@ -3,7 +3,7 @@ module Tests.SrcLoc where  import Language.Haskell.Exts.SrcLoc (SrcLoc(..))-import Language.Haskell.Modules.Util.SrcLoc (srcPairText)+import Language.Haskell.Modules.SrcLoc (srcPairText) import Prelude hiding (rem) import Test.HUnit (assertEqual, Test(TestCase, TestList))
Tests/Symbols.hs view
@@ -9,13 +9,13 @@     ) where  import Data.Set (fromList)-import Language.Haskell.Exts.Annotated.Syntax as A -- (Decl(DefaultDecl, PatBind), Exp(Var), Name(Ident), Pat(PApp, PVar), QName(UnQual), Rhs(UnGuardedRhs), Type(TyVar))-import Language.Haskell.Exts.Parser (parse, fromParseResult)+import Language.Haskell.Exts.Annotated.Syntax as A (Decl(DefaultDecl, PatBind), Exp(Var), Name(Ident), Pat(PApp, PVar), QName(UnQual), Rhs(UnGuardedRhs), Type(TyVar))+import Language.Haskell.Exts.Parser (fromParseResult, parse) import Language.Haskell.Exts.Pretty (prettyPrint) import Language.Haskell.Exts.SrcLoc (SrcSpan(..), SrcSpanInfo(..))-import qualified Language.Haskell.Exts.Syntax as S-import Language.Haskell.Modules.Util.SrcLoc ()-import Language.Haskell.Modules.Util.Symbols (symbols, members)+import qualified Language.Haskell.Exts.Syntax as S (Name(Ident))+import Language.Haskell.Modules.Symbols (members, symbols)+import Language.Haskell.Modules.SrcLoc () import Test.HUnit (assertEqual, Test(TestCase, TestList))  tests :: Test
debian/changelog view
@@ -1,3 +1,9 @@+haskell-module-management (0.15.1) unstable; urgency=low++  * Documentation updates.++ -- David Fox <dsf@seereason.com>  Wed, 24 Jul 2013 09:45:11 -0700+ haskell-module-management (0.15) unstable; urgency=low    * Implement parsing of files which need the XmlSyntax extension (e.g. files
module-management.cabal view
@@ -1,5 +1,5 @@ Name:               module-management-Version:            0.15+Version:            0.15.1 Synopsis:           Clean up module imports, split and merge modules Description:        Clean up module imports, split and merge modules. Homepage:           http://src.seereason.com/module-management@@ -28,10 +28,10 @@     Language.Haskell.Modules.Params,     Language.Haskell.Modules.SourceDirs,     Language.Haskell.Modules.Split,+    Language.Haskell.Modules.SrcLoc,+    Language.Haskell.Modules.Symbols,     Language.Haskell.Modules.Util.DryIO,     Language.Haskell.Modules.Util.QIO,-    Language.Haskell.Modules.Util.SrcLoc,-    Language.Haskell.Modules.Util.Symbols,     Language.Haskell.Modules.Util.Temp,     Language.Haskell.Modules.Util.Test   Other-Modules:
testdata.tar.gz view

binary file changed (548457 → 548457 bytes)