packages feed

module-management 0.15.1 → 0.16

raw patch · 18 files changed

+797/−506 lines, 18 filesdep +cmdargsdep +haskelinedep +lens

Dependencies added: cmdargs, haskeline, lens, transformers-base

Files

Language/Haskell/Modules.hs view
@@ -69,17 +69,10 @@ -- -- * Split a module where one of the result modules needs to import the instances: -----   @runCleanT $+--  @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/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.SrcLoc (endLoc, HasSpanInfo(..), increaseSrcLoc, srcLoc, srcPairText)+import Language.Haskell.Modules.Util.SrcLoc (endLoc, HasSpanInfo(..), increaseSrcLoc, srcLoc, srcPairText)  --type Module = A.Module SrcSpanInfo --type ModuleHead = A.ModuleHead SrcSpanInfo
Language/Haskell/Modules/Imports.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PackageImports, ScopedTypeVariables, StandaloneDeriving, TupleSections #-}+{-# LANGUAGE CPP, PackageImports, ScopedTypeVariables, StandaloneDeriving, TupleSections #-} {-# OPTIONS_GHC -Wall #-} module Language.Haskell.Modules.Imports     ( cleanImports@@ -25,15 +25,19 @@ 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 (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.SourceDirs (modifyDirs, pathKey, APath(..), PathKey(..), PathKey(unPathKey), SourceDirs(getDirs, putDirs)) 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) +#if MIN_VERSION_haskell_src_exts(1,14,0)+import Language.Haskell.Exts.Extension (Extension(..))+#endif+ {- -- | 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@@ -108,7 +112,7 @@       -- turn it back into Created.       toCreated (JustModified name key) = JustCreated name key       toCreated x@(JustCreated {}) = x-      toCreated x = error $ "toCreated: " ++ show x+      toCreated _ = error "toCreated"       -- Update the cached version of the now modified module and then       -- clean its import list.       doModule key =@@ -126,12 +130,20 @@        exts <- getExtensions        let args' = args ++                    ["--make", "-c", "-ddump-minimal-imports", "-outputdir", scratch, "-i" ++ intercalate ":" dirs] ++-                   map (("-X" ++) . show) exts +++                   concatMap ppExtension exts ++                    map unPathKey (toList keys)        (code, _out, err) <- liftIO $ readProcessWithExitCode cmd args' ""        case code of          ExitSuccess -> quietly (qLnPutStr (showCommandForUser cmd args' ++ " -> Ok")) >> return ()          ExitFailure _ -> error ("dumpImports: compile failed\n " ++ showCommandForUser cmd args' ++ " ->\n" ++ err)++    where+#if MIN_VERSION_haskell_src_exts(1,14,0)+    ppExtension (EnableExtension x) = ["-X"++ show x]+    ppExtension _ = []+#else+    ppExtension = (:[]) . ("-X" ++) . show+#endif  -- | Parse the import list generated by GHC, parse the original source -- file, and if all goes well insert the new imports into the old
Language/Haskell/Modules/ModuVerse.hs view
@@ -32,8 +32,11 @@ import Data.Set as Set (fromList, Set) import qualified Language.Haskell.Exts.Annotated as A (Module(..), ModuleHead(..), ModuleName(..), parseFileWithComments) import Language.Haskell.Exts.Comments (Comment(..))+#if MIN_VERSION_haskell_src_exts(1,14,0)+import Language.Haskell.Exts.Extension (Extension(..), KnownExtension(..))+#else import Language.Haskell.Exts.Extension (Extension(..))-import Language.Haskell.Exts.Fixity (baseFixities)+#endif import qualified Language.Haskell.Exts.Parser as Exts (defaultParseMode, fromParseResult, ParseMode(extensions, parseFilename, fixities), ParseResult) import Language.Haskell.Exts.SrcLoc (SrcSpanInfo) import Language.Haskell.Exts.Syntax as S (ModuleName(..))@@ -41,6 +44,14 @@ import Language.Haskell.Modules.Util.QIO (MonadVerbosity, qLnPutStr, quietly) import System.IO.Error (isDoesNotExistError, isUserError) +#if MIN_VERSION_haskell_src_exts(1,14,0)+deriving instance Ord Extension+deriving instance Ord KnownExtension+nameToExtension x = EnableExtension x+#else+nameToExtension x = id x+#endif+ deriving instance Ord Comment  data ModuleInfo@@ -77,18 +88,21 @@ moduVerseInit =     ModuVerseState { moduleNames_ = Nothing                    , moduleInfo_ = Map.empty-                   , extensions_ = Exts.extensions Exts.defaultParseMode ++ [StandaloneDeriving] -- allExtensions+                   , extensions_ = Exts.extensions Exts.defaultParseMode ++ [nameToExtension StandaloneDeriving] -- allExtensions                    , 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 =+hseExtensions = map nameToExtension     [ 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, TupleSections+#if MIN_VERSION_haskell_src_exts(1,14,0)+    , ExplicitNamespaces+#endif+    ]  getNames :: ModuVerse m => m (Set S.ModuleName) getNames = getModuVerse >>= return . Set.fromList . keys . fromMaybe (error "No modules in ModuVerse, use putModule") . moduleNames_@@ -175,4 +189,4 @@ parseFileWithComments path =     liftIO (A.parseFileWithComments mode path)     where-      mode = Exts.defaultParseMode {Exts.extensions = hseExtensions, Exts.parseFilename = path, Exts.fixities = Just baseFixities}+      mode = Exts.defaultParseMode {Exts.extensions = hseExtensions, Exts.parseFilename = path, Exts.fixities = Nothing }
Language/Haskell/Modules/SourceDirs.hs view
@@ -8,6 +8,10 @@     , PathKey(..)     , APath(..)     , pathKey+#if 0+    , pathKey+    , pathKeyMaybe+#endif     , Path(..)     , modulePath     , modulePathBase
Language/Haskell/Modules/Split.hs view
@@ -28,9 +28,9 @@ 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 (APath(..), modulePathBase, pathKey)-import Language.Haskell.Modules.Symbols (exports, imports, members, symbols)+import Language.Haskell.Modules.SourceDirs (modulePathBase, APath(..), pathKey) 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 ((<.>))
− Language/Haskell/Modules/SrcLoc.hs 
@@ -1,241 +0,0 @@-{-# 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 
@@ -1,187 +0,0 @@-{-# 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/SrcLoc.hs view
@@ -0,0 +1,241 @@+{-# 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 view
@@ -0,0 +1,187 @@+{-# 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.SrcLoc (HasSpanInfo(..), makeTree)+import Language.Haskell.Modules.Util.SrcLoc (HasSpanInfo(..), makeTree) import Test.HUnit (assertEqual, Test(TestList, TestCase, TestLabel))  deriving instance Eq (Exts.ParseResult (A.Module SrcSpanInfo, [A.Comment]))
Tests/Imports.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE CPP, PackageImports #-} module Tests.Imports where -import Language.Haskell.Exts.Extension (Extension(FlexibleInstances, StandaloneDeriving, TypeSynonymInstances))+ import qualified Language.Haskell.Exts.Syntax as S (ModuleName(ModuleName)) import Language.Haskell.Modules (cleanImports, modifyExtensions, modifyTestMode, modulePathBase, putDirs, runCleanT, withCurrentDirectory) import Language.Haskell.Modules.SourceDirs (RelPath(unRelPath))@@ -11,6 +11,16 @@ import System.Process (readProcessWithExitCode) import Test.HUnit (assertEqual, Test(..)) +#if MIN_VERSION_haskell_src_exts(1,14,0)+import Language.Haskell.Exts.Extension (KnownExtension(FlexibleInstances, StandaloneDeriving, TypeSynonymInstances),Extension(EnableExtension))+nameToExtension x = EnableExtension x++#else+import Language.Haskell.Exts.Extension (Extension(FlexibleInstances, StandaloneDeriving, TypeSynonymInstances))+nameToExtension x = x++#endif+ tests :: Test tests = TestLabel "Clean" (TestList [test1, test2, test3, test4, test5, test6, test7]) @@ -77,7 +87,7 @@       (do _ <- rsync "testdata/imports5" "tmp"           _ <- runCleanT                  (putDirs ["tmp"] >>-                  modifyExtensions (++ [StandaloneDeriving, TypeSynonymInstances, FlexibleInstances]) >>+                  modifyExtensions (++ map nameToExtension [StandaloneDeriving, TypeSynonymInstances, FlexibleInstances]) >>                   cleanImports ["tmp/Deriving.hs"])           (code, out, err) <- diff "testdata/imports5" "tmp"           assertEqual "standalone deriving"
Tests/SrcLoc.hs view
@@ -3,7 +3,7 @@ module Tests.SrcLoc where  import Language.Haskell.Exts.SrcLoc (SrcLoc(..))-import Language.Haskell.Modules.SrcLoc (srcPairText)+import Language.Haskell.Modules.Util.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 (fromParseResult, parse)+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.Pretty (prettyPrint) import Language.Haskell.Exts.SrcLoc (SrcSpan(..), SrcSpanInfo(..))-import qualified Language.Haskell.Exts.Syntax as S (Name(Ident))-import Language.Haskell.Modules.Symbols (members, symbols)-import Language.Haskell.Modules.SrcLoc ()+import qualified Language.Haskell.Exts.Syntax as S+import Language.Haskell.Modules.Util.SrcLoc ()+import Language.Haskell.Modules.Util.Symbols (symbols, members) import Test.HUnit (assertEqual, Test(TestCase, TestList))  tests :: Test
debian/changelog view
@@ -1,3 +1,13 @@+haskell-module-management (0.16) unstable; urgency=low++  * Use haskeline in the hmm program (Adam Vogt)+  * use case insensitive completion when it is unambiguous (Adam Vogt)+  * Clean up issues involving fixities (Adam Vogt)+  * Preliminary support for cabal files (Adam Vogt)+  * And more by Adam...++ -- David Fox <dsf@seereason.com>  Fri, 16 Aug 2013 08:48:58 -0700+ haskell-module-management (0.15.1) unstable; urgency=low    * Documentation updates.
module-management.cabal view
@@ -1,5 +1,5 @@ Name:               module-management-Version:            0.15.1+Version:            0.16 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:@@ -41,6 +41,7 @@     Tests.Split     Tests.SrcLoc     Tests.Symbols+   Build-Depends:     applicative-extras,     base >= 4 && < 5,@@ -64,7 +65,8 @@     temporary  Executable hmm-  Main-is: scripts/CLI.hs+  Main-is: CLI.hs+  Hs-source-dirs: scripts   Build-Depends:     base,     containers,@@ -80,7 +82,14 @@     process,     set-extra,     syb,-    temporary+    temporary,+    haskeline == 0.7.*,+    transformers-base,+    Cabal,+    cmdargs,+    lens++  ghc-options: -O0  Executable tests   Main-is: Tests.hs
scripts/CLI.hs view
@@ -1,60 +1,294 @@-{-# OPTIONS_GHC -Wall #-}+{- # OPTIONS_GHC -Wall #-}+{-# LANGUAGE ViewPatterns, PatternGuards, DeriveDataTypeable #-} module Main where +import System.Console.Haskeline+import Control.Monad.State++import System.Environment+import System.Directory+import CLI.HaskelineTransAdapter () import Control.Monad as List (mapM_)-import Control.Monad.Trans (MonadIO(liftIO))-import Data.List (intercalate, isPrefixOf)+import Control.Monad.Trans (MonadIO(liftIO), MonadTrans(..))+import Data.List+import Data.Maybe (maybeToList)+import Data.Char (toLower)+import qualified Data.Set as S (member, toList, map) import Data.Set.Extra as Set (Set, toList)-import Language.Haskell.Modules+import Language.Haskell.Modules (cleanImports, CleanT, findHsModules, mergeModules, modifyDirs, ModuleName(..), MonadClean, noisily, putDirs, putModule, runCleanT, splitModuleDecls) import Language.Haskell.Modules.ModuVerse (getNames) import Language.Haskell.Modules.SourceDirs (getDirs)-import System.IO (hGetLine, hPutStr, hPutStrLn, stderr, stdin)+import Language.Haskell.Modules.Util.QIO (modifyVerbosity)+import System.Console.Haskeline (completeFilename, CompletionFunc, defaultSettings, getInputLine, InputT, noCompletion, runInputT, setComplete, simpleCompletion)+import System.IO (hPutStrLn, stderr) +import System.Console.CmdArgs+import Control.Lens+import Data.Maybe++import Control.Monad.Reader++import Distribution.PackageDescription (GenericPackageDescription)++import qualified CLI.Cabal as Cabal+import qualified Distribution.Verbosity+import Data.Data++import Data.Foldable(traverse_)+import System.Console.Haskeline.MonadException+import Control.Exception (fromException)++import System.Exit++data HMM = CLI+  { verbosity :: Int,+    verbosityCabal :: Int,+    caseSensitiveCompletion :: Bool,+    cabalFile :: Maybe FilePath,+    otherFiles :: [FilePath] }+    deriving (Data,Typeable,Show)++defaultHMM = CLI+  { Main.verbosity = fromEnum Loud+            &= enumHelp "module-management verbosity" (undefined :: Verbosity)+                        (Main.verbosity defaultHMM),+    verbosityCabal = fromEnum (maxBound :: Distribution.Verbosity.Verbosity)+            &= enumHelp "cabal file parser verbosity"+                        (undefined :: Distribution.Verbosity.Verbosity)+                        (verbosityCabal defaultHMM),+    caseSensitiveCompletion = False+            &= help "should completion of module names be case-sensitive?"+            &= name "s",+    cabalFile = Nothing+            &= typFile+            &= name "f"+            &= help ".cabal file to load. Modules listed there will be loaded\+                \ and when modules are split the .cabal file will be updated\+                \ when you quit or use the cabalWrite command",+    otherFiles = []+            &= typFile+            &= args }+++enumHelp item proxy def =+    help ("Level of "++item++". Takes values from " +++            rangeOfBounded (undefined `asTypeOf` proxy) +++            ". Default is "++ show def ++ ".")+rangeOfBounded proxy = show (fromEnum (minBound `asTypeOf` proxy))+    ++ " to "+    ++ show (fromEnum (maxBound `asTypeOf` proxy))+++toEnumBounded :: (Bounded e, Enum e) => Int -> e+toEnumBounded i =+    let r | i > iMax = maxBound+          | i < iMin = minBound+          | otherwise = toEnum i+        iMax = fromEnum (maxBound `asTypeOf` r)+        iMin = fromEnum (minBound `asTypeOf` r)+    in r+ main :: IO ()-main = runCleanT (noisily cli)+main = do+    conf <- cmdArgs defaultHMM+    args <- mapM canonicalizePath (otherFiles conf) -cli :: MonadClean m => m ()-cli = liftIO (hPutStr stderr " > " >> hGetLine stdin) >>= cmd . words+    pkgDesc' <-+        traverse (Cabal.readPackageDescription (toEnumBounded (verbosityCabal conf)))+            (cabalFile conf) -cmd :: MonadClean m => [String] -> m ()++    let initState = do+            traverse (dir . (".":) . Cabal.getSrcDirs) pkgDesc'+            modifyVerbosity $ \ _ -> Main.verbosity conf+            let modules0 = args ++ (map moduleNameToStr $ Cabal.getModules =<< maybeToList pkgDesc')+            when (not (null modules0)) $ verse modules0+++        execCmdM :: CmdM a -> IO (Maybe GenericPackageDescription)+        execCmdM x = runCleanT+            $ flip execStateT pkgDesc'+            $ flip runReaderT conf+            $ runInputT (setComplete ((lift . lift) `fmap` compl conf) defaultSettings) x++    pkgDesc' <- execCmdM $ do+        liftCT initState+        let step = cli+            loop = catch (do step; loop) $ \e @ SomeException {} -> case () of+                    _ | Just e <- fromException e -> throwIO (e `asTypeOf` ExitSuccess)+                      | Just (Callback _msg f) <- fromException e -> f loop+                    _ -> do+                        liftIO (print e)+                        loop+        loop++    -- this gets bypassed when the ExitCode is re-thrown.+    -- Should it be run on ExitFailures or just success?+    traverse_ (uncurry Cabal.writeGenericPackageDescription)+        $ liftM2 (,) (cabalFile conf) pkgDesc'+++-- | these versions of quietly and noisily play well with 'lift'+quietly', noisily' :: CmdM a -> CmdM a+quietly' act = do+    liftCT (modifyVerbosity (\x -> x - 1))+    r <- act+    liftCT (modifyVerbosity (+ 1))+    return r++noisily' act = do+    liftCT (modifyVerbosity (+ 1))+    r <- act+    liftCT (modifyVerbosity (\x -> x - 1))+    return r++compl ::  HMM -> CompletionFunc (CleanT IO)+compl conf (xs,ys) | cmd: _ <- words (reverse xs),+    matchingCommands <- filter (cmd `isPrefixOf`) commandNames = case matchingCommands of+        _:_:_ | Nothing <- stripPrefix " " =<< stripPrefix cmd (reverse xs) ->+                return ("", map simpleCompletion matchingCommands)+        [] -> return ("", map simpleCompletion commandNames)++        [x] | cmd `notElem` commandNames -> return ("", [simpleCompletion x])+            | takesModuleNames cmd -> do+                ns <- getNames+                let complAllModules = map (simpleCompletion . moduleNameToStr) (S.toList ns)+                    nsLower = S.map (ModuleName . map toLower . moduleNameToStr) ns+                    transform+                        | caseSensitiveCompletion conf = id+                        | nsLower == ns = map toLower+                        | otherwise = id+                return $ case span (/=' ') xs of+                    (reverse -> cw @ (_:_), rest) ->+                        case filter (isPrefixOf (transform cw) . transform)+                                        (moduleNameToStr `map` S.toList ns) of+                            -- this first case isn't really needed: it should do the same as the+                            -- next case but possibly be more efficient+                            _ | ModuleName cw `S.member` ns -> (rest, [simpleCompletion cw])+                            [modName] -> (rest, [simpleCompletion modName])+                            _ -> (rest, complAllModules)+                    _ -> (xs, complAllModules)+            | otherwise  -> completeFilename (xs,ys)+        _ -> noCompletion (xs,ys)+compl _ x = noCompletion x++moduleNameToStr :: ModuleName -> String+moduleNameToStr (ModuleName x) = x++takesModuleNames :: String -> Bool+takesModuleNames x = x `elem` ["merge"]+++cli :: CmdM ()+cli = cmd . concatMap words . maybeToList =<< getInputLine "> "++type CmdM a = InputT (ReaderT HMM (StateT (Maybe GenericPackageDescription) (CleanT IO))) a++askConf :: CmdM HMM+askConf = lift ask++liftCT :: CleanT IO a -> CmdM a+liftCT = lift . lift . lift++liftS :: StateT (Maybe GenericPackageDescription) (CleanT IO) a -> CmdM a+liftS  = lift . lift+++cmd :: [String] -> CmdM () cmd [] = cli cmd (s : args) =-    case filter (any (== s) . fst) cmds of-      [(_, f)] -> f-      -- No exact matches - look for prefix matches-      [] -> case filter (any (isPrefixOf s) . fst) cmds of-              [(_, f)] -> f-              [] -> liftIO (hPutStrLn stderr $-                              show s ++ " invalid - expected " ++ intercalate ", " (concatMap fst cmds)) >> cli-              xs -> liftIO (hPutStrLn stderr $-                              show s ++ " ambiguous - expected " ++ intercalate ", " (concatMap fst xs)) >> cli-      _ -> error $ "Internal error - multiple definitions for " ++ show s-    where-      cmds =-          [(["quit", "exit", "bye", "."],	liftIO (hPutStrLn stderr "Exiting")),-           (["v"],				liftIO (hPutStrLn stderr "Increasing verbosity level") >> noisily cli),-           (["q"],				liftIO (hPutStrLn stderr "Decreasing verbosity level") >> quietly cli),-           (["help"],				liftIO (hPutStrLn stderr "help text") >> cli),-           (["verse"],				verse args >> cli),-           (["clean"],				clean args >> cli),-           (["dir"],				dir args >> cli),-           (["split"],				split args >> cli),-           (["merge"],				merge args >> cli)]+      case filter (any (== s) . fst) cmds of+        [(_, f)] -> f+        -- No exact matches - look for prefix matches+        [] -> case filter (any (isPrefixOf s) . fst) cmds of+                [(_, f)] -> f+                [] -> liftIO (hPutStrLn stderr $+                                show s ++ " invalid - expected " ++ intercalate ", " (concatMap fst cmds)) >> cli+                xs -> liftIO (hPutStrLn stderr $+                                show s ++ " ambiguous - expected " ++ intercalate ", " (concatMap fst xs)) >> cli+        _ -> error $ "Internal error - multiple definitions for " ++ show s+        where+        cmds = cmds_ args ++data Callback = Callback String (CmdM () -> CmdM ()) deriving (Typeable)+instance Show Callback where+    show (Callback x _) = x+instance Exception Callback++commandNames :: [String]+commandNames = concatMap fst (cmds_ undefined)++cmds_ :: [String] -> [([String], CmdM ())]+cmds_ args =+          [(["quit", "exit", "bye", ".", "\EOT"], do+                liftIO (hPutStrLn stderr "Exiting")+                throwIO ExitSuccess),+           (["v"], throwIO . Callback "louder" $ \next -> do+                    liftIO (hPutStrLn stderr "Increasing Verbosity")+                    noisily' next),+           (["q"], throwIO . Callback "quieter" $ \next -> do+                    liftIO (hPutStrLn stderr "Decreasing Verbosity")+                    quietly' next),+           (["help"],  liftIO (hPutStrLn stderr "help text")),+           (["verse"], liftCT (verse args)),+           (["clean"], liftCT (clean args)),+           (["dir"],   liftCT (dir args)),+           (["split"], split args),+           (["merge"], merge args),+           (["cabalPrint"], cabalPrint),+           (["cabalRead"], cabalRead args),+           (["cabalWrite"], cabalWrite args)]++cabalPrint :: CmdM ()+cabalPrint = do+    pkgDesc <- liftS get+    liftIO $ putStrLn $ case pkgDesc of+        Nothing -> "No cabal file loaded"+        Just x -> Cabal.showGenericPackageDescription x++cabalWrite, cabalRead :: [String] -> CmdM ()+cabalWrite [f] = do+    pkgDesc <- liftS get+    liftIO $ case pkgDesc of+        Nothing -> putStrLn "cabalWrite: no cabal file was loaded"+        Just x -> Cabal.writeGenericPackageDescription f x+cabalWrite [] = do+    conf <- askConf+    case cabalFile conf of+        Nothing -> liftIO $ putStrLn "Usage: cabalWrite <file.cabal>"+        Just f -> cabalWrite [f] -- goto previous case+cabalWrite _ = liftIO $ putStrLn "Usage: cabalWrite <file.cabal>"++cabalRead [f] = throwIO . Callback "cabalRead" $ \next -> do+    conf <- askConf+    pd <- liftIO $ Cabal.readPackageDescription (toEnumBounded (verbosityCabal conf)) f++    liftCT $ do+        ds <- getDirs+        let ds' = Cabal.getSrcDirs pd+        unless (null $ ds' \\ ds) $ dir ds'++        verse (unModuleName `map` Cabal.getModules pd)++    mapInputT (local (\x -> x{ cabalFile = Just f })) next++cabalRead _ = liftIO $ putStrLn "Usage: cabalRead <file.cabal>"+ unModuleName :: ModuleName -> String unModuleName (ModuleName x) = x  verse :: MonadClean m => [String] -> m () verse [] =     do modules <- getNames-       liftIO $ hPutStrLn stderr ("Usage: verse <pathormodule1> <pathormodule2> ...\n" +++       liftIO $ putStrLn ("Usage: verse <pathormodule1> <pathormodule2> ...\n" ++                                   "Add the module or all the modules below a directory to the moduVerse\n" ++                                   "Currently:\n  " ++ showVerse modules) verse args =     do new <- mapM (liftIO . find) args        List.mapM_ (List.mapM_ putModule) new        modules <- getNames-       liftIO (hPutStrLn stderr $ "moduVerse updated:\n  " ++ showVerse modules)+       liftIO (putStrLn $ "moduVerse updated:\n  " ++ showVerse modules)     where       find s =           do ms <- liftIO (findHsModules [s])@@ -70,18 +304,23 @@ dir xs =     do modifyDirs (++ xs)        xs' <- getDirs-       liftIO (hPutStrLn stderr $ "sourceDirs updated:\n  [ " ++ intercalate "\n  , " xs' ++ " ]")+       liftIO (putStrLn $ "sourceDirs updated:\n  [ " ++ intercalate "\n  , " xs' ++ " ]")  clean :: MonadClean m => [FilePath] -> m ()-clean [] = liftIO $ hPutStrLn stderr "Usage: clean <modulepath1> <modulepath2> ..."+clean [] = liftIO $ putStrLn "Usage: clean <modulepath1> <modulepath2> ..." clean args = cleanImports args >> return () -split :: MonadClean m => [FilePath] -> m ()-split [arg] = splitModuleDecls arg >> return ()-split _ = liftIO $ hPutStrLn stderr "Usage: split <modulepath>"+split :: [FilePath] -> CmdM ()+split [arg] = do+    r <- liftCT (splitModuleDecls arg)+    lift (modify (Cabal.update r))+    return ()+split _ = liftIO $ putStrLn "Usage: split <modulepath>" -merge :: MonadClean m => [String] -> m ()+merge :: [String] -> CmdM () merge args =     case splitAt (length args - 1) args of-      (inputs, [output]) -> mergeModules (map ModuleName inputs) (ModuleName output) >> return ()-      _ -> liftIO $ hPutStrLn stderr "Usage: merge <inputmodulename1> <inputmodulename2> ... <outputmodulename>"+      (inputs, [output]) -> do+            r <- liftCT $ mergeModules (map ModuleName inputs) (ModuleName output)+            liftS (modify (Cabal.update r))+      _ -> liftIO $ putStrLn "Usage: merge <inputmodulename1> <inputmodulename2> ... <outputmodulename>"
testdata.tar.gz view

binary file changed (548457 → 534129 bytes)