Merge pull request #3 from phadej/refact

Add cabal-fmt: expand <dir> functionality

Makefile

@@ -1,11 +1,11 @@
-self-test :
-	cabal new-run --enable-tests cabal-fmt -- cabal-fmt.cabal
+build :
+	cabal v2-build
 
-self-test-Cabal :
-	cabal new-run --enable-tests cabal-fmt -- Cabal/Cabal.cabal
+self-test :
+	cabal v2-run cabal-fmt -- cabal-fmt.cabal
 
 golden :
-	cabal new-run --enable-tests golden
+	cabal v2-run golden
 
 golden-accept : 
-	cabal new-run --enable-tests golden -- --accept
+	cabal v2-run golden -- --accept

cabal-fmt.cabal

@@ -24,6 +24,8 @@ source-repository head
 library cabal-fmt-internal
   default-language: Haskell2010
   hs-source-dirs:   src
+
+  -- GHC boot libraries
   build-depends:
     , base        ^>=4.11.1.0 || ^>=4.12.0.0
     , bytestring  ^>=0.10.8.2
@@ -34,6 +36,12 @@ library cabal-fmt-internal
     , parsec      ^>=3.1.13.0
     , pretty      ^>=1.1.3.6
 
+  -- cabal-fmt: expand src
+  --
+  -- Note: the module list is expanded only when cabal-fmt is run from a
+  -- command line, with a single file. This is to get right relative
+  -- working directory.
+  --
   exposed-modules:
     CabalFmt
     CabalFmt.Comments
@@ -46,11 +54,14 @@ library cabal-fmt-internal
     CabalFmt.Monad
     CabalFmt.Options
     CabalFmt.Parser
+    CabalFmt.Refactoring
 
   other-extensions:
     DeriveFunctor
+    DerivingStrategies
     ExistentialQuantification
     FlexibleContexts
+    GeneralizedNewtypeDeriving
     OverloadedStrings
     RankNTypes
 
@@ -59,14 +70,17 @@ executable cabal-fmt
   hs-source-dirs:   cli
   main-is:          Main.hs
 
-  -- dependencims in library
+  -- dependencies in library
   build-depends:
     , base
     , bytestring
     , cabal-fmt-internal
+    , filepath
 
   -- extra dependencies
-  build-depends:    optparse-applicative >=0.14.3.0 && <0.16
+  build-depends:
+    , directory             ^>=1.3.1.5
+    , optparse-applicative  >=0.14.3.0 && <0.16
 
 test-suite golden
   type:             exitcode-stdio-1.0

cabal.project

@@ -1,4 +1,5 @@
 packages: .
+tests: true
 
 package cabal-fmt
   ghc-options: -Wall

cli/Main.hs

@@ -2,19 +2,29 @@ module Main (main) where
 
 import Control.Applicative (many, (<**>))
 import Data.Foldable       (for_)
+import System.Directory    (doesDirectoryExist, getDirectoryContents)
 import System.Exit         (exitFailure)
+import System.FilePath     (takeDirectory, (</>))
+import System.IO.Unsafe    (unsafeInterleaveIO)
 
 import qualified Data.ByteString     as BS
 import qualified Options.Applicative as O
 
 import CabalFmt         (cabalFmt)
+import CabalFmt.Error   (renderError)
 import CabalFmt.Monad   (runCabalFmt)
 import CabalFmt.Options
-import CabalFmt.Error (renderError)
 
 main :: IO ()
 main = do
-    (inplace, opts, filepaths) <- O.execParser optsP'
+    (inplace, opts', filepaths) <- O.execParser optsP'
+
+    -- glob all files, only when a single filepath is given.
+    files <- case filepaths of
+        [fp] -> getFiles (takeDirectory fp)
+        _    -> return []
+    let opts = opts' { optFileList = files }
+
     case filepaths of
         []    -> BS.getContents       >>= main' False opts "<stdin>"
         (_:_) -> for_ filepaths $ \filepath ->
@@ -49,3 +59,50 @@ optsP = (,,)
     optsP' = Options
         <$> O.option O.auto (O.long "indent" <> O.value (optIndent defaultOptions) <> O.help "Indentation" <> O.showDefault)
         <*> pure (optSpecVersion defaultOptions)
+        <*> pure []
+
+-------------------------------------------------------------------------------
+-- Files
+-------------------------------------------------------------------------------
+
+getFiles :: FilePath -> IO [FilePath]
+getFiles = getDirectoryContentsRecursive' check where
+    check "dist-newstyle" = False
+    check ('.' : _)       = False
+    check _               = True
+
+-- | List all the files in a directory and all subdirectories.
+--
+-- The order places files in sub-directories after all the files in their
+-- parent directories. The list is generated lazily so is not well defined if
+-- the source directory structure changes before the list is used.
+--
+-- /Note:/ From @Cabal@'s "Distribution.Simple.Utils"
+getDirectoryContentsRecursive'
+    :: (FilePath -> Bool) -- ^ Check, whether to recurse
+    -> FilePath           -- ^ top dir
+    -> IO [FilePath]
+getDirectoryContentsRecursive' ignore' topdir = recurseDirectories [""]
+  where
+    recurseDirectories :: [FilePath] -> IO [FilePath]
+    recurseDirectories []         = return []
+    recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
+      (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
+      files' <- recurseDirectories (dirs' ++ dirs)
+      return (files ++ files')
+
+      where
+        collect files dirs' []              = return (reverse files
+                                                     ,reverse dirs')
+        collect files dirs' (entry:entries) | ignore entry
+                                            = collect files dirs' entries
+        collect files dirs' (entry:entries) = do
+          let dirEntry = dir </> entry
+          isDirectory <- doesDirectoryExist (topdir </> dirEntry)
+          if isDirectory
+            then collect files (dirEntry:dirs') entries
+            else collect (dirEntry:files) dirs' entries
+
+        ignore ['.']      = True
+        ignore ['.', '.'] = True
+        ignore x          = not (ignore' x)

src/CabalFmt.hs

@@ -32,6 +32,7 @@ import CabalFmt.Fields.BuildDepends
 import CabalFmt.Fields.Extensions
 import CabalFmt.Fields.Modules
 import CabalFmt.Fields.TestedWith
+import CabalFmt.Refactoring
 import CabalFmt.Monad
 import CabalFmt.Options
 import CabalFmt.Parser
@@ -42,17 +43,18 @@ import CabalFmt.Parser
 
 cabalFmt :: FilePath -> BS.ByteString -> CabalFmt String
 cabalFmt filepath contents = do
-    indentWith  <- asks optIndent
-    gpd         <- parseGpd filepath contents
+    opts         <- asks id
+    indentWith   <- asks optIndent
+    gpd          <- parseGpd filepath contents
     inputFields' <- parseFields contents
-    let inputFields = attachComments contents inputFields'
+    let inputFields = foldr (\r f -> r opts f) (attachComments contents inputFields') refactorings 
 
     let v = C.cabalSpecFromVersionDigits
           $ C.versionNumbers
           $ C.specVersion
           $ C.packageDescription gpd
 
-    local (\opts -> opts { optSpecVersion = v }) $ do
+    local (\o -> o { optSpecVersion = v }) $ do
 
         outputPrettyFields <- C.genericFromParsecFields
             prettyFieldLines
@@ -64,6 +66,15 @@ cabalFmt filepath contents = do
 fromComments :: Comments -> [String]
 fromComments (Comments bss) = map C.fromUTF8BS bss
 
+-------------------------------------------------------------------------------
+-- Refactorings
+-------------------------------------------------------------------------------
+
+refactorings :: [Refactoring]
+refactorings =
+    [ refactoringExpandExposedModules
+    ]
+
 -------------------------------------------------------------------------------
 -- Field prettyfying
 -------------------------------------------------------------------------------

src/CabalFmt/Comments.hs

@@ -1,6 +1,8 @@
-{-# LANGUAGE BangPatterns        #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 module CabalFmt.Comments where
 
 import Data.Foldable (toList)
@@ -18,13 +20,8 @@ import qualified Distribution.Parsec       as C
 -------------------------------------------------------------------------------
 
 newtype Comments = Comments [BS.ByteString]
-
-instance Semigroup Comments where
-    Comments a <> Comments b = Comments (a <> b)
-
-instance Monoid Comments where
-    mempty = Comments []
-    mappend = (<>)
+  deriving stock Show
+  deriving newtype (Semigroup, Monoid)
 
 -------------------------------------------------------------------------------
 -- Attach comments

src/CabalFmt/Fields/Modules.hs

@@ -4,8 +4,8 @@ module CabalFmt.Fields.Modules (
     exposedModulesF,
     ) where
 
-import Data.List                   (sortBy)
-import Data.Function (on)
+import Data.Function               (on)
+import Data.List                   (nub, sortBy)
 import Distribution.Compat.Newtype
 
 import qualified Distribution.ModuleName      as C
@@ -26,7 +26,7 @@ parse :: C.CabalParsing m => m [C.ModuleName]
 parse = unpack' (C.alaList' C.VCat C.MQuoted) <$> C.parsec
 
 pretty :: [C.ModuleName] -> PP.Doc
-pretty = PP.vcat . map C.pretty . sortBy (cmp `on` C.prettyShow)
+pretty = PP.vcat . map C.pretty . nub . sortBy (cmp `on` C.prettyShow)
   where
     cmp a b = case dropCommonPrefix a b of
         ([], [])  -> EQ

src/CabalFmt/Options.hs

@@ -8,11 +8,13 @@ import qualified Distribution.CabalSpecVersion as C
 data Options = Options
     { optIndent      :: !Int
     , optSpecVersion :: !C.CabalSpecVersion
+    , optFileList    :: ![FilePath]
     }
   deriving Show
 
 defaultOptions :: Options
 defaultOptions = Options
     { optIndent      = 2
     , optSpecVersion = C.cabalSpecLatest
+    , optFileList    = []
     }

src/CabalFmt/Refactoring.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE OverloadedStrings #-}
+module CabalFmt.Refactoring (
+    Refactoring,
+    refactoringExpandExposedModules,
+    ) where
+
+import Data.List       (intercalate, stripPrefix)
+import Data.Maybe      (catMaybes)
+import System.FilePath (dropExtension, splitDirectories)
+
+import qualified Distribution.Compat.CharParsing     as C
+import qualified Distribution.Fields                 as C
+import qualified Distribution.Parsec                 as C
+import qualified Distribution.Parsec.FieldLineStream as C
+import qualified Distribution.Simple.Utils           as C
+
+import CabalFmt.Comments
+import CabalFmt.Options
+
+-------------------------------------------------------------------------------
+-- Refactoring type
+-------------------------------------------------------------------------------
+
+type Refactoring = Options -> [C.Field Comments] -> [C.Field Comments]
+
+-------------------------------------------------------------------------------
+-- Expand exposed-modules
+-------------------------------------------------------------------------------
+
+refactoringExpandExposedModules :: Refactoring
+refactoringExpandExposedModules opts = overField refact where
+    refact name@(C.Name c n) fls
+        | n == "exposed-modules" || n == "other-modules"
+        , definitions <- parse c =
+            let newModules :: [C.FieldLine Comments]
+                newModules = catMaybes
+                    [ do rest <- stripPrefix prefix fp
+                         return $ C.FieldLine mempty $ C.toUTF8BS $ intercalate "." rest
+                    | prefix <- definitions
+                    , fp <- fileList
+                    ]
+            in (name, newModules ++ fls)
+        | otherwise = (name, fls)
+
+    fileList :: [[FilePath]]
+    fileList = map (splitDirectories . dropExtension) (optFileList opts)
+
+    parse :: Comments -> [[FilePath]]
+    parse (Comments bss) = catMaybes
+        [ either (const Nothing) Just
+        $ C.runParsecParser parser "<input>" $ C.fieldLineStreamFromBS bs
+        | bs <- bss
+        ]
+
+    parser :: C.ParsecParser [FilePath]
+    parser = do
+        _ <- C.string "--"
+        C.spaces
+        _ <- C.string "cabal-fmt:"
+        C.spaces
+        _ <- C.string "expand"
+        C.spaces
+        dir <- C.parsecToken
+        return (splitDirectories dir)
+
+-------------------------------------------------------------------------------
+-- Tools
+-------------------------------------------------------------------------------
+
+overField :: (C.Name Comments -> [C.FieldLine Comments] -> (C.Name Comments, [C.FieldLine Comments]))
+          -> [C.Field Comments] -> [C.Field Comments]
+overField f = goMany where
+    goMany = map go
+
+    go (C.Field name fls)       = let ~(name', fls') = f name fls in C.Field name' fls'
+    go (C.Section name args fs) = C.Section name args (goMany fs)