cabal-fmt 0.1 → 0.1.1

raw patch · 17 files changed

+540/−183 lines, 17 filesdep ~basedep ~directoryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, directory

API changes (from Hackage documentation)

Files

• Changelog.md +10/−0
• cabal-fmt.cabal +15/−13
• cli/Main.hs +58/−65
• fixtures/simple-example.format +10/−1
• src/CabalFmt.hs +54/−21
• src/CabalFmt/Comments.hs +27/−4
• src/CabalFmt/Error.hs +13/−4
• src/CabalFmt/Fields.hs +3/−0
• src/CabalFmt/Fields/BuildDepends.hs +16/−9
• src/CabalFmt/Fields/Extensions.hs +3/−0
• src/CabalFmt/Fields/Modules.hs +3/−0
• src/CabalFmt/Fields/TestedWith.hs +44/−11
• src/CabalFmt/Monad.hs +128/−3
• src/CabalFmt/Options.hs +27/−5
• src/CabalFmt/Parser.hs +6/−3
• src/CabalFmt/Pragma.hs +67/−0
• src/CabalFmt/Refactoring.hs +56/−44

@@ -0,0 +1,10 @@+# 0.1.1++- Change metavar of file arguments to be `FILE...`,+  to imply that multiple files at once are supported+- Add `expand src -ModuleName1 -ModuleName2` support+- Add `--tabular` and `--no-tabular` configuraiton options+- Add `-Werror` option (there are some warnings)+- Preserve end file comments+- More pretty `tested-with` formatting+- Add `--version` flag

@@ -1,19 +1,20 @@ cabal-version:      2.2 name:               cabal-fmt-version:            0.1+version:            0.1.1 synopsis:           Format .cabal files category:           Development description:-  Format @.cabal@ files preserving the original ordering and comments.+  Format @.cabal@ files preserving the original field ordering, and comments.   .   Tuned for Oleg's preference, but has some knobs still. -license:            GPL-3.0-or-later+license:            GPL-3.0-or-later AND BSD-3-Clause license-file:       LICENSE author:             Oleg Grenrus <oleg.grenrus@iki.fi> maintainer:         Oleg Grenrus <oleg.grenrus@iki.fi>-tested-with:        GHC ==8.4.4 || ==8.6.5+tested-with:        GHC ==8.4.4 || ==8.6.5 || ==8.8.1 extra-source-files:+  Changelog.md   fixtures/*.cabal   fixtures/*.format @@ -27,21 +28,17 @@    -- GHC boot libraries   build-depends:-    , base        ^>=4.11.1.0 || ^>=4.12.0.0+    , base        ^>=4.11.1.0 || ^>=4.12.0.0 || ^>=4.13.0.0     , bytestring  ^>=0.10.8.2     , Cabal       ^>=3.0.0.0     , containers  ^>=0.5.11.0 || ^>=0.6.0.1+    , directory   ^>=1.3.1.5     , filepath    ^>=1.4.2     , mtl         ^>=2.2.2     , 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@@ -54,6 +51,7 @@     CabalFmt.Monad     CabalFmt.Options     CabalFmt.Parser+    CabalFmt.Pragma     CabalFmt.Refactoring    other-extensions:@@ -64,23 +62,25 @@     GeneralizedNewtypeDeriving     OverloadedStrings     RankNTypes+    ScopedTypeVariables  executable cabal-fmt   default-language: Haskell2010   hs-source-dirs:   cli   main-is:          Main.hs+  other-modules:    Paths_cabal_fmt+  autogen-modules:  Paths_cabal_fmt    -- dependencies in library   build-depends:     , base     , bytestring     , cabal-fmt-internal+    , directory     , filepath    -- extra dependencies-  build-depends:-    , directory             ^>=1.3.1.5-    , optparse-applicative  >=0.14.3.0 && <0.16+  build-depends:    optparse-applicative >=0.14.3.0 && <0.16  test-suite golden   type:             exitcode-stdio-1.0@@ -101,3 +101,5 @@     , process     , tasty     , tasty-golden++-- end file comment

@@ -1,44 +1,64 @@+-- |+-- License: BSD-3-Clause+-- Copyright: Oleg Grenrus module Main (main) where  import Control.Applicative (many, (<**>))-import Data.Foldable       (for_)-import System.Directory    (doesDirectoryExist, getDirectoryContents)+import Data.Foldable       (asum, for_)+import Data.Version        (showVersion) import System.Exit         (exitFailure)-import System.FilePath     (takeDirectory, (</>))-import System.IO.Unsafe    (unsafeInterleaveIO)+import System.FilePath     (takeDirectory)  import qualified Data.ByteString     as BS import qualified Options.Applicative as O+import qualified System.Directory    as D  import CabalFmt         (cabalFmt) import CabalFmt.Error   (renderError)-import CabalFmt.Monad   (runCabalFmt)+import CabalFmt.Monad   (runCabalFmtIO) import CabalFmt.Options +import Paths_cabal_fmt (version)+ main :: IO () main = do     (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 }+    let opts = runOptionsMorphism opts' defaultOptions      case filepaths of-        []    -> BS.getContents       >>= main' False opts "<stdin>"-        (_:_) -> for_ filepaths $ \filepath ->-            BS.readFile filepath >>= main' inplace opts filepath+        []    -> BS.getContents >>= main' False opts Nothing+        (_:_) -> for_ filepaths $ \filepath -> do+            contents <- BS.readFile filepath+            main' inplace opts (Just filepath) contents   where-    optsP' = O.info (optsP <**> O.helper) $ mconcat+    optsP' = O.info (optsP <**> O.helper <**> versionP) $ mconcat         [ O.fullDesc         , O.progDesc "Reformat .cabal files"         , O.header "cabal-fmt - .cabal file reformatter"         ] -main' :: Bool -> Options -> FilePath -> BS.ByteString -> IO ()-main' inplace opts filepath input =-    case runCabalFmt opts (cabalFmt filepath input) of+    versionP = O.infoOption (showVersion version)+        $ O.long "version" <> O.help "Show version"++main' :: Bool -> Options -> Maybe FilePath -> BS.ByteString -> IO ()+main' inplace opts mfilepath input = do+    cwd <- D.getCurrentDirectory++    -- change to the directory where 'filepath' is.+    -- so expanding works+    filepath <- case mfilepath of+        Nothing       -> return "<stdin>"+        Just filepath -> do+            D.setCurrentDirectory (takeDirectory filepath)+            return filepath++    -- process+    res <- runCabalFmtIO opts (cabalFmt filepath input)++    -- change the cwd back+    D.setCurrentDirectory cwd++    case res of         Right output             | inplace   -> writeFile filepath output             | otherwise -> putStr output@@ -50,59 +70,32 @@ -- Options parser ------------------------------------------------------------------------------- -optsP :: O.Parser (Bool, Options, [FilePath])+optsP :: O.Parser (Bool, OptionsMorphism, [FilePath]) optsP = (,,)     <$> O.flag False True (O.short 'i' <> O.long "inplace" <> O.help "process files in-place")     <*> optsP'-    <*> many (O.strArgument (O.metavar "FILE" <> O.help "input files"))+    <*> many (O.strArgument (O.metavar "FILE..." <> O.help "input files"))   where-    optsP' = Options-        <$> O.option O.auto (O.long "indent" <> O.value (optIndent defaultOptions) <> O.help "Indentation" <> O.showDefault)-        <*> pure (optSpecVersion defaultOptions)-        <*> pure []+    optsP' = fmap mconcat $ many $ asum+        [ werrorP+        , noWerrorP+        , indentP+        , tabularP+        , noTabularP+        ] ----------------------------------------------------------------------------------- Files--------------------------------------------------------------------------------+    werrorP = O.flag' (mkOptionsMorphism $ \opts -> opts { optError = True })+        $ O.long "Werror" <> O.help "Treat warnings as errors" -getFiles :: FilePath -> IO [FilePath]-getFiles = getDirectoryContentsRecursive' check where-    check "dist-newstyle" = False-    check ('.' : _)       = False-    check _               = True+    noWerrorP = O.flag' (mkOptionsMorphism $ \opts -> opts { optError = False })+        $ O.long "Wno-error" --- | 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')+    indentP = O.option (fmap (\n -> mkOptionsMorphism $ \opts -> opts { optIndent = n}) O.auto)+        $ O.long "indent" <> O.help "Indentation" <> O.metavar "N" -      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+    tabularP = O.flag' (mkOptionsMorphism $ \opts -> opts { optTabular = True })+        $ O.long "tabular" <> O.help "Tabular formatting" -        ignore ['.']      = True-        ignore ['.', '.'] = True-        ignore x          = not (ignore' x)+    noTabularP = O.flag' (mkOptionsMorphism $ \opts -> opts { optTabular = False })+        $ O.long "no-tabular"+

@@ -15,7 +15,16 @@ build-type:    Custom cabal-version: 1.12 tested-with:-  GHC ==8.6.3 || ==8.4.4 || ==8.2.2 || ==8.0.2 || ==7.10.3 || ==7.8.4 || ==7.6.3 || ==7.4.2 || ==7.2.2 || ==7.0.4+  GHC ==7.0.4+   || ==7.2.2+   || ==7.4.2+   || ==7.6.3+   || ==7.8.4+   || ==7.10.3+   || ==8.0.2+   || ==8.2.2+   || ==8.4.4+   || ==8.6.3  custom-setup   setup-depends:

@@ -1,13 +1,19 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}--- | This is a demo application of how you can make Cabal-like+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus+--+-- This is a demo application of how you can make Cabal-like -- file formatter. -- module CabalFmt (cabalFmt) where -import Control.Monad        (join)+import Control.Monad        (foldM, join) import Control.Monad.Except (catchError)-import Control.Monad.Reader (asks, local)+import Control.Monad.Reader (ask, asks, local)+import Data.Foldable        (traverse_)+import Data.Function        ((&)) import Data.Maybe           (fromMaybe)  import qualified Data.ByteString                              as BS@@ -32,29 +38,44 @@ import CabalFmt.Fields.Extensions import CabalFmt.Fields.Modules import CabalFmt.Fields.TestedWith-import CabalFmt.Refactoring import CabalFmt.Monad import CabalFmt.Options import CabalFmt.Parser+import CabalFmt.Pragma+import CabalFmt.Refactoring  ------------------------------------------------------------------------------- -- Main ------------------------------------------------------------------------------- -cabalFmt :: FilePath -> BS.ByteString -> CabalFmt String+cabalFmt :: MonadCabalFmt m => FilePath -> BS.ByteString -> m String cabalFmt filepath contents = do-    opts         <- asks id-    indentWith   <- asks optIndent     gpd          <- parseGpd filepath contents     inputFields' <- parseFields contents-    let inputFields = foldr (\r f -> r opts f) (attachComments contents inputFields') refactorings +    let (inputFieldsC, endComments) = attachComments contents inputFields' +    -- parse pragmas+    let parse c = case parsePragmas c of (ws, ps) -> traverse_ displayWarning ws *> return (c, ps)+    inputFieldsP <- traverse (traverse parse) inputFieldsC+    endCommentsPragmas <- case parsePragmas endComments of+        (ws, ps) -> traverse_ displayWarning ws *> return ps++    -- apply refactorings+    inputFieldsR  <- foldM (&) inputFieldsP refactorings++    -- options morphisms+    let pragmas = foldMap (foldMap snd) inputFieldsR <> endCommentsPragmas+        optsEndo :: OptionsMorphism+        optsEndo = foldMap pragmaToOM pragmas+     let v = C.cabalSpecFromVersionDigits           $ C.versionNumbers           $ C.specVersion           $ C.packageDescription gpd -    local (\o -> o { optSpecVersion = v }) $ do+    local (\o -> runOptionsMorphism optsEndo $ o { optSpecVersion = v }) $ do+        indentWith <- asks optIndent+        let inputFields = fmap (fmap fst) inputFieldsR          outputPrettyFields <- C.genericFromParsecFields             prettyFieldLines@@ -62,6 +83,8 @@             inputFields          return $ C.showFields' fromComments indentWith outputPrettyFields+            & if nullComments endComments then id else+                (++ unlines ("" : [ C.fromUTF8BS c | c <- unComments endComments ]))  fromComments :: Comments -> [String] fromComments (Comments bss) = map C.fromUTF8BS bss@@ -70,7 +93,7 @@ -- Refactorings ------------------------------------------------------------------------------- -refactorings :: [Refactoring]+refactorings :: MonadCabalFmt m => [Refactoring' m] refactorings =     [ refactoringExpandExposedModules     ]@@ -79,27 +102,28 @@ -- Field prettyfying ------------------------------------------------------------------------------- -prettyFieldLines :: C.FieldName -> [C.FieldLine ann] -> CabalFmt PP.Doc+prettyFieldLines :: MonadCabalFmt m => C.FieldName -> [C.FieldLine ann] -> m PP.Doc prettyFieldLines fn fls =     fromMaybe (C.prettyFieldLines fn fls) <$> knownField fn fls -knownField :: C.FieldName -> [C.FieldLine ann] -> CabalFmt (Maybe PP.Doc)+knownField :: MonadCabalFmt m => C.FieldName -> [C.FieldLine ann] -> m (Maybe PP.Doc) knownField fn fls = do-    v <- asks optSpecVersion-    return $ join $ fieldDescrLookup (fieldDescrs v) fn $ \p pp ->+    opts <- ask+    let v = optSpecVersion opts+    return $ join $ fieldDescrLookup (fieldDescrs opts) fn $ \p pp ->         case C.runParsecParser' v p "<input>" (C.fieldLinesToStream fls) of             Right x -> Just (pp x)             Left _  -> Nothing -fieldDescrs :: C.CabalSpecVersion -> FieldDescrs () ()-fieldDescrs v-    =  buildDependsF v-    <> setupDependsF v+fieldDescrs :: Options -> FieldDescrs () ()+fieldDescrs opts+    =  buildDependsF opts+    <> setupDependsF opts     <> defaultExtensionsF     <> otherExtensionsF     <> exposedModulesF     <> otherModulesF-    <> testedWithF+    <> testedWithF opts     <> coerceFieldDescrs C.packageDescriptionFieldGrammar     <> coerceFieldDescrs C.buildInfoFieldGrammar @@ -107,12 +131,12 @@ -- Sections ------------------------------------------------------------------------------- -prettySectionArgs :: C.FieldName -> [C.SectionArg ann] -> CabalFmt [PP.Doc]+prettySectionArgs :: MonadCabalFmt m => C.FieldName -> [C.SectionArg ann] -> m [PP.Doc] prettySectionArgs x args =     prettySectionArgs' x args `catchError` \_ ->         return (C.prettySectionArgs x args) -prettySectionArgs' :: a -> [C.SectionArg ann] -> CabalFmt [PP.Doc]+prettySectionArgs' :: MonadCabalFmt m => a -> [C.SectionArg ann] -> m [PP.Doc] prettySectionArgs' _ args = do     c <- runParseResult "<args>" "" $ C.parseConditionConfVar (map (C.zeroPos <$) args)     return [ppCondition c]@@ -135,3 +159,12 @@ ppConfVar (C.Arch arch) = PP.text "arch" PP.<> PP.parens (C.pretty arch) ppConfVar (C.Flag name) = PP.text "flag" PP.<> PP.parens (C.pretty name) ppConfVar (C.Impl c v)  = PP.text "impl" PP.<> PP.parens (C.pretty c PP.<+> C.pretty v)++-------------------------------------------------------------------------------+-- Pragma to OM+-------------------------------------------------------------------------------++pragmaToOM :: Pragma -> OptionsMorphism+pragmaToOM (PragmaOptIndent n)    = mkOptionsMorphism $ \opts -> opts { optIndent = n }+pragmaToOM (PragmaOptTabular b)   = mkOptionsMorphism $ \opts -> opts { optTabular = b }+pragmaToOM PragmaExpandModules {} = mempty

@@ -1,3 +1,6 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus {-# LANGUAGE BangPatterns               #-} {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -6,7 +9,7 @@ module CabalFmt.Comments where  import Data.Foldable (toList)-import Data.Maybe    (fromMaybe)+import Data.Maybe    (fromMaybe, isNothing)  import qualified Data.ByteString           as BS import qualified Data.ByteString.Char8     as BS8@@ -23,27 +26,47 @@   deriving stock Show   deriving newtype (Semigroup, Monoid) +unComments :: Comments -> [BS.ByteString]+unComments (Comments cs) = cs++nullComments :: Comments -> Bool+nullComments (Comments cs) = null cs+ ------------------------------------------------------------------------------- -- Attach comments ------------------------------------------------------------------------------- +-- | Returns a 'C.Field' forest with comments attached.+--+-- * Comments are attached to the field after it.+-- * A glitch: comments "inside" the field are attached to the field after it.+-- * End-of-file comments are returned separately.+-- attachComments     :: BS.ByteString        -- ^ source with comments     -> [C.Field C.Position] -- ^ parsed source fields-    -> [C.Field Comments]-attachComments input inputFields = overAnn attach inputFields where+    -> ([C.Field Comments], Comments)+attachComments input inputFields =+    (overAnn attach inputFields, endComments)+  where     inputFieldsU :: [(FieldPath, C.Field C.Position)]     inputFieldsU = fieldUniverseN inputFields      comments :: [(Int, Comments)]     comments = extractComments input -    -- todo: warning when comments are omitted     comments' :: Map.Map FieldPath Comments     comments' = Map.fromListWith (flip (<>))         [ (path, cs)         | (l, cs) <- comments         , path <- toList (findPath C.fieldAnn l inputFieldsU)+        ]++    endComments :: Comments+    endComments = mconcat+        [ cs+        | (l, cs) <- comments+        , isNothing (findPath C.fieldAnn l inputFieldsU)         ]      attach :: FieldPath -> C.Position -> Comments

@@ -1,6 +1,11 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus module CabalFmt.Error (Error (..), renderError) where +import Control.Exception (Exception) import System.FilePath   (normalise)+import System.IO         (hPutStr, hPutStrLn, stderr) import Text.Parsec.Error (ParseError)  import qualified Data.ByteString            as BS@@ -13,13 +18,17 @@     = SomeError String     | CabalParseError FilePath BS.ByteString [C.PError] (Maybe C.Version) [C.PWarning]     | PanicCannotParseInput  ParseError+    | WarningError String   deriving (Show) +instance Exception Error+ renderError :: Error -> IO ()-renderError (SomeError err) = putStrLn $ "error: " ++ err-renderError (PanicCannotParseInput err) = putStrLn $ "panic! " ++ show err-renderError (CabalParseError filepath contents errors _ warnings) = -    putStr $ renderParseError filepath contents errors warnings+renderError (SomeError err) = hPutStrLn stderr $ "error: " ++ err+renderError (PanicCannotParseInput err) = hPutStrLn stderr $ "panic! " ++ show err+renderError (CabalParseError filepath contents errors _ warnings) =+    hPutStr stderr $ renderParseError filepath contents errors warnings+renderError (WarningError w) = hPutStrLn stderr $ "error (-Werror): " ++ w  ------------------------------------------------------------------------------- -- Rendering of Cabal parser error

@@ -1,3 +1,6 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus {-# LANGUAGE DeriveFunctor             #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes                #-}

@@ -1,3 +1,6 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus {-# LANGUAGE OverloadedStrings #-} module CabalFmt.Fields.BuildDepends (     buildDependsF,@@ -22,18 +25,19 @@ import qualified Text.PrettyPrint                   as PP  import CabalFmt.Fields+import CabalFmt.Options -setupDependsF :: C.CabalSpecVersion -> FieldDescrs () ()-setupDependsF v = singletonF "setup-depends" (pretty v) parse+setupDependsF :: Options -> FieldDescrs () ()+setupDependsF opts = singletonF "setup-depends" (pretty opts) parse -buildDependsF :: C.CabalSpecVersion -> FieldDescrs () ()-buildDependsF v = singletonF "build-depends" (pretty v) parse+buildDependsF :: Options -> FieldDescrs () ()+buildDependsF opts = singletonF "build-depends" (pretty opts) parse  parse :: C.CabalParsing m => m [C.Dependency] parse = unpack' (C.alaList C.CommaVCat) <$> C.parsec -pretty :: C.CabalSpecVersion -> [C.Dependency] -> PP.Doc-pretty v deps = case deps of+pretty :: Options -> [C.Dependency] -> PP.Doc+pretty Options { optSpecVersion = v, optTabular = tab } deps = case deps of     [] -> PP.empty     [dep] -> C.pretty (C.depPkgName dep) PP.<+> prettyVR vr'       where@@ -59,14 +63,14 @@                 Left [] -> comma PP.<+> PP.text name                 Left (vi : vis') ->                     comma PP.<+>-                    PP.text (leftpad width name) PP.<+>+                    PP.text (lp width name) PP.<+>                     PP.hsep                         ( prettyVi vi                         : map (\vi' -> PP.text "||" PP.<+> prettyVi' vi') vis'                         )                 Right vr ->                     comma PP.<+>-                    PP.text (leftpad width name) PP.<+>+                    PP.text (lp width name) PP.<+>                     C.pretty vr           where             comma | isFirst, v < C.CabalSpecV2_2 = PP.text " "@@ -78,7 +82,7 @@         prettyVi (C.LowerBound l C.InclusiveBound, C.UpperBound u C.InclusiveBound)             | l == u = PP.text "==" PP.<> C.pretty l         prettyVi (C.LowerBound l lb, C.UpperBound u ub) =-            prettyLowerBound lb PP.<> PP.text (leftpad width' l')+            prettyLowerBound lb PP.<> PP.text (lp width' l')             PP.<+> PP.text "&&" PP.<+>             prettyUpperBound ub PP.<> C.pretty u           where@@ -119,6 +123,9 @@     firstComponent :: [C.VersionInterval] -> Int     firstComponent [] = 0     firstComponent ((C.LowerBound l _, _) : _) = length (C.prettyShow l)++    lp | tab       = leftpad+       | otherwise = \_ x -> x  leftpad :: Int -> String -> String leftpad w s = s ++ replicate (w - length s) ' '

@@ -1,3 +1,6 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus {-# LANGUAGE OverloadedStrings #-} module CabalFmt.Fields.Extensions (     otherExtensionsF,

@@ -1,3 +1,6 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus {-# LANGUAGE OverloadedStrings #-} module CabalFmt.Fields.Modules (     otherModulesF,

@@ -1,34 +1,67 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus+{-# LANGUAGE BangPatterns      #-} {-# LANGUAGE OverloadedStrings #-} module CabalFmt.Fields.TestedWith (     testedWithF,     ) where +import Data.Set                    (Set) import Distribution.Compat.Newtype -import qualified Distribution.Parsec                as C-import qualified Distribution.Compiler                as C-import qualified Distribution.Parsec.Newtypes       as C-import qualified Distribution.Pretty                as C-import qualified Distribution.Types.VersionRange    as C-import qualified Text.PrettyPrint                   as PP-import qualified Data.Map.Strict as Map+import qualified Data.Map.Strict               as Map+import qualified Data.Set                      as Set+import qualified Distribution.CabalSpecVersion as C+import qualified Distribution.Compiler         as C+import qualified Distribution.Parsec           as C+import qualified Distribution.Parsec.Newtypes  as C+import qualified Distribution.Pretty           as C+import qualified Distribution.Version          as C+import qualified Text.PrettyPrint              as PP  import CabalFmt.Fields+import CabalFmt.Options -testedWithF :: FieldDescrs () ()-testedWithF = singletonF "tested-with" pretty parse where+testedWithF :: Options -> FieldDescrs () ()+testedWithF Options { optSpecVersion = ver } = singletonF "tested-with" pretty parse where     parse :: C.CabalParsing m => m [(C.CompilerFlavor, C.VersionRange)]     parse = unpack' (C.alaList' C.FSep C.TestedWith) <$> C.parsec      pretty :: [(C.CompilerFlavor, C.VersionRange)] -> PP.Doc-    pretty tw0 = PP.fsep $ PP.punctuate PP.comma-        [ prettyC c PP.<+> C.pretty vr+    pretty tw0 = leadingComma ver+        [ prettyC c PP.<+> prettyVr vr         | (c, vr) <- Map.toList tw1         ]       where         tw1 :: Map.Map C.CompilerFlavor C.VersionRange         tw1 = Map.fromListWith C.unionVersionRanges tw0 +        -- TODO: Cabal 3.0 formatting!+        prettyVr vr = case isVersionSet vr of+            Just vs -> PP.sep $ mapTail (\doc -> PP.nest (-3) $ PP.text "||" PP.<+> doc) [ C.pretty (C.thisVersion v) | v <- Set.toList vs ]+            Nothing -> C.pretty vr+         prettyC C.GHC   = PP.text "GHC"         prettyC C.GHCJS = PP.text "GHCJS"         prettyC c       = C.pretty c++leadingComma :: C.CabalSpecVersion -> [PP.Doc] -> PP.Doc+leadingComma _ []  = PP.empty+leadingComma _ [x] = x+leadingComma v xs = PP.vcat $ zipWith comma (True : repeat False) xs where+    comma :: Bool -> PP.Doc -> PP.Doc+    comma isFirst doc+        | isFirst, v < C.CabalSpecV3_0 = PP.char ' ' PP.<+> doc+        | otherwise                    = PP.char ',' PP.<+> doc++isVersionSet :: C.VersionRange -> Maybe (Set C.Version)+isVersionSet vr = go Set.empty (C.asVersionIntervals vr) where+    go !acc [] = Just acc+    go acc ((C.LowerBound v C.InclusiveBound, C.UpperBound u C.InclusiveBound) : vis)+        | v == u    = go (Set.insert v acc) vis+    go _ _ = Nothing++mapTail :: (a -> a) -> [a] -> [a]+mapTail _ []     = []+mapTail f (x:xs) = x : map f xs

@@ -1,17 +1,142 @@-{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-}+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-} module CabalFmt.Monad (+    -- * Monad class+    MonadCabalFmt (..),+    getFiles,+    -- * Pure implementation     CabalFmt,     runCabalFmt,+    -- * IO implementation+    CabalFmtIO,+    runCabalFmtIO,     ) where -import Control.Monad.Except (MonadError)-import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)+import Control.Exception      (catch, throwIO, try)+import Control.Monad          (when)+import Control.Monad.Except   (MonadError (..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader   (MonadReader, ReaderT (..), runReaderT, asks)+import System.FilePath        ((</>))+import System.IO              (hPutStrLn, stderr)+import System.Exit (exitFailure) +import qualified System.Directory as D+ import CabalFmt.Error import CabalFmt.Options +-------------------------------------------------------------------------------+-- Class+-------------------------------------------------------------------------------++-- | @cabal-fmt@ interface.+--+-- * reader of 'Options'+-- * errors of 'Error'+-- * can list directories+--+class (MonadReader Options m, MonadError Error m) => MonadCabalFmt m where+    listDirectory      :: FilePath -> m [FilePath]+    doesDirectoryExist :: FilePath -> m Bool+    displayWarning     :: String -> m ()++-------------------------------------------------------------------------------+-- Pure+-------------------------------------------------------------------------------++-- | Pure 'MonadCabalFmt'.+--+-- 'listDirectory' always return empty list.+-- newtype CabalFmt a = CabalFmt { unCabalFmt :: ReaderT Options (Either Error) a }   deriving newtype (Functor, Applicative, Monad, MonadReader Options, MonadError Error) +instance MonadCabalFmt CabalFmt where+    listDirectory _      = return []+    doesDirectoryExist _ = return False+    displayWarning w     = do+        werror <- asks optError+        when werror $ throwError $ WarningError w+ runCabalFmt :: Options -> CabalFmt a -> Either Error a runCabalFmt opts m = runReaderT (unCabalFmt m) opts++-------------------------------------------------------------------------------+-- IO+-------------------------------------------------------------------------------++newtype CabalFmtIO a = CabalFmtIO { unCabalFmtIO :: ReaderT Options IO a }+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader Options)++instance MonadError Error CabalFmtIO where+    throwError = liftIO . throwIO+    catchError m h = CabalFmtIO $ ReaderT $ \r ->+        catch (unCabalFmtIO' r m) (unCabalFmtIO' r . h)+      where+        unCabalFmtIO' r m' = runReaderT (unCabalFmtIO m') r++instance MonadCabalFmt CabalFmtIO where+    listDirectory      = liftIO . D.listDirectory+    doesDirectoryExist = liftIO . D.doesDirectoryExist+    displayWarning w   = do+        werror <- asks optError+        liftIO $ do+            hPutStrLn stderr $ (if werror then "ERROR: " else "WARNING: ") ++ w+            when werror exitFailure++runCabalFmtIO :: Options -> CabalFmtIO a -> IO (Either Error a)+runCabalFmtIO opts m = try $ runReaderT (unCabalFmtIO m) opts++-------------------------------------------------------------------------------+-- Files+-------------------------------------------------------------------------------++getFiles :: MonadCabalFmt m => FilePath -> m [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'+    :: forall m. MonadCabalFmt m+    => (FilePath -> Bool) -- ^ Check, whether to recurse+    -> FilePath           -- ^ top dir+    -> m [FilePath]+getDirectoryContentsRecursive' ignore' topdir = recurseDirectories [""]+  where+    recurseDirectories :: [FilePath] -> m [FilePath]+    recurseDirectories []         = return []+    recurseDirectories (dir:dirs) = do+      (files, dirs') <- collect [] [] =<< listDirectory (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)

@@ -1,20 +1,42 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus module CabalFmt.Options (     Options (..),     defaultOptions,+    OptionsMorphism, mkOptionsMorphism, runOptionsMorphism,     ) where -import qualified Distribution.CabalSpecVersion as C+import qualified Distribution.CabalSpecVersion       as C  data Options = Options-    { optIndent      :: !Int+    { optError       :: !Bool+    , optIndent      :: !Int+    , optTabular     :: !Bool     , optSpecVersion :: !C.CabalSpecVersion-    , optFileList    :: ![FilePath]     }   deriving Show  defaultOptions :: Options defaultOptions = Options-    { optIndent      = 2+    { optError       = False+    , optIndent      = 2+    , optTabular     = True     , optSpecVersion = C.cabalSpecLatest-    , optFileList    = []     }++newtype OptionsMorphism = OM (Options -> Options)++runOptionsMorphism :: OptionsMorphism -> Options -> Options+runOptionsMorphism (OM f) = f++mkOptionsMorphism :: (Options -> Options) -> OptionsMorphism+mkOptionsMorphism = OM++instance Semigroup OptionsMorphism where+    OM f <> OM g = OM (g . f)++instance Monoid OptionsMorphism where+    mempty  = OM id+    mappend = (<>)+

@@ -1,3 +1,6 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus module CabalFmt.Parser where  import Control.Monad.Except (throwError)@@ -11,17 +14,17 @@ import CabalFmt.Error import CabalFmt.Monad -runParseResult :: FilePath -> BS.ByteString -> C.ParseResult a -> CabalFmt a+runParseResult :: MonadCabalFmt m => FilePath -> BS.ByteString -> C.ParseResult a -> m a runParseResult filepath contents pr = case result of     Right gpd -> return gpd     Left (mspecVersion, errors) -> throwError $ CabalParseError filepath contents errors mspecVersion warnings   where     (warnings, result) = C.runParseResult pr -parseGpd :: FilePath -> BS.ByteString -> CabalFmt C.GenericPackageDescription+parseGpd :: MonadCabalFmt m => FilePath -> BS.ByteString -> m C.GenericPackageDescription parseGpd filepath contents = runParseResult filepath contents $ C.parseGenericPackageDescription contents -parseFields :: BS.ByteString -> CabalFmt [C.Field C.Position]+parseFields :: MonadCabalFmt m => BS.ByteString -> m [C.Field C.Position] parseFields contents = case C.readFields contents of     Left err -> throwError $ PanicCannotParseInput err     Right x  -> return x

@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+module CabalFmt.Pragma where++import Data.Bifunctor  (bimap)+import Data.ByteString (ByteString)+import Data.Either     (partitionEithers)+import Data.Maybe      (catMaybes)++import qualified Data.ByteString                     as BS+import qualified Distribution.Compat.CharParsing     as C+import qualified Distribution.ModuleName             as C+import qualified Distribution.Parsec                 as C+import qualified Distribution.Parsec.FieldLineStream as C++import CabalFmt.Comments++data Pragma+    = PragmaOptIndent Int+    | PragmaOptTabular Bool+    | PragmaExpandModules FilePath [C.ModuleName]+  deriving (Show)++-- | Parse pragma from 'ByteString'.+--+-- An error ('Left') is reported only if input 'ByteString' starts with @-- cabal-fmt:@.+--+parsePragma :: ByteString -> Either String (Maybe Pragma)+parsePragma bs = case dropPrefix bs of+    Nothing  -> Right Nothing+    Just bs' -> bimap show Just $ C.runParsecParser parser "<input>" $ C.fieldLineStreamFromBS bs'+  where+    dropPrefix bs0 = do+        bs1 <- BS.stripPrefix "--" bs0+        bs2 <- BS.stripPrefix "cabal-fmt:" (stripWhitespace bs1)+        return (stripWhitespace bs2)++    parser :: C.ParsecParser Pragma+    parser = do+        t <- C.parsecToken+        case t of+            "expand"     -> expandModules+            "indent"     -> indent+            "tabular"    -> return $ PragmaOptTabular True+            "no-tabular" -> return $ PragmaOptTabular False+            _            -> fail $ "Unknown pragma " ++ t++    expandModules :: C.ParsecParser Pragma+    expandModules = do+        C.spaces+        dir <- C.parsecToken+        mns <- C.many (C.space *> C.spaces *> C.char '-' *> C.parsec)+        return (PragmaExpandModules dir mns)++    indent :: C.ParsecParser Pragma+    indent = do+        C.spaces+        n <- C.integral+        return $ PragmaOptIndent n++stripWhitespace :: ByteString -> ByteString+stripWhitespace bs = case BS.uncons bs of+    Nothing                   -> bs+    Just (w, bs') | w == 32   -> stripWhitespace bs'+                  | otherwise -> bs++parsePragmas :: Comments -> ([String], [Pragma])+parsePragmas = fmap catMaybes . partitionEithers . map parsePragma . unComments

@@ -1,76 +1,88 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-} module CabalFmt.Refactoring (     Refactoring,+    Refactoring',     refactoringExpandExposedModules,     ) where -import Data.List       (intercalate, stripPrefix)+import Data.List       (intercalate) 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 qualified Distribution.Fields       as C+import qualified Distribution.ModuleName   as C+import qualified Distribution.Simple.Utils as C  import CabalFmt.Comments-import CabalFmt.Options+import CabalFmt.Monad+import CabalFmt.Pragma  ------------------------------------------------------------------------------- -- Refactoring type ------------------------------------------------------------------------------- -type Refactoring = Options -> [C.Field Comments] -> [C.Field Comments]+type C = (Comments, [Pragma])+type Refactoring           = forall m. MonadCabalFmt m => Refactoring' m+type Refactoring' m        = [C.Field C] -> m [C.Field C]+type RefactoringOfField    = forall m. MonadCabalFmt m => RefactoringOfField' m+type RefactoringOfField' m = C.Name C -> [C.FieldLine C] -> m (C.Name C, [C.FieldLine C])  ------------------------------------------------------------------------------- -- 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]+refactoringExpandExposedModules = traverseFields refact where+    refact :: RefactoringOfField+    refact name@(C.Name (_, pragmas) n) fls+        | n == "exposed-modules" || n == "other-modules" = do+            dirs <- parse pragmas+            files <- traverseOf (traverse . _1) getFiles dirs++            let newModules :: [C.FieldLine C]                 newModules = catMaybes-                    [ do rest <- stripPrefix prefix fp-                         return $ C.FieldLine mempty $ C.toUTF8BS $ intercalate "." rest-                    | prefix <- definitions-                    , fp <- fileList+                    [ return $ C.FieldLine mempty $ C.toUTF8BS $ intercalate "." parts+                    | (files', mns) <- files+                    , file <- files'+                    , let parts = splitDirectories $ dropExtension file+                    , all C.validModuleComponent parts+                    , let mn = C.fromComponents parts+                    , mn `notElem` mns                     ]-            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-        ]+            pure (name, newModules ++ fls)+        | otherwise = pure (name, fls) -    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)+    parse :: MonadCabalFmt m => [Pragma] -> m [(FilePath, [C.ModuleName])]+    parse = fmap mconcat . traverse go where+        go (PragmaExpandModules fp mns) = return [ (fp, mns) ]+        go p = do+            displayWarning $ "Skipped pragma " ++ show p+            return []  ------------------------------------------------------------------------------- -- 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+traverseOf+    :: Applicative f+    => ((a -> f b) -> s ->  f t)+    -> (a -> f b) -> s ->  f t+traverseOf = id -    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)+_1 :: Functor f => (a -> f b) -> (a, c) -> f (b, c)+_1 f (a, c) = (\b -> (b, c)) <$> f a++traverseFields+    :: Applicative f+    => RefactoringOfField' f+    -> [C.Field C] -> f [C.Field C]+traverseFields f = goMany where+    goMany = traverse go++    go (C.Field name fls)       = uncurry C.Field <$> f name fls+    go (C.Section name args fs) = C.Section name args <$> goMany fs