ExpandExposedModules.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-deprecations #-}

-- |
-- License: GPL-3.0-or-later
-- Copyright: Oleg Grenrus
module CabalGild.Refactoring.ExpandExposedModules
  ( refactoringExpandExposedModules,
  )
where

import CabalGild.Monad
import CabalGild.Pragma
import CabalGild.Prelude
import CabalGild.Refactoring.Type
import qualified Distribution.Fields as C
import qualified Distribution.ModuleName as C

refactoringExpandExposedModules :: FieldRefactoring
refactoringExpandExposedModules C.Section {} = pure Nothing
refactoringExpandExposedModules (C.Field name@(C.Name (_, _, pragmas) _n) fls) = do
  dirs <- parse pragmas
  files <- traverseOf (traverse . _1) getFiles dirs

  let newModules :: [C.FieldLine CommentsPragmas]
      newModules =
        catMaybes
          [ return $ C.FieldLine emptyCommentsPragmas $ toUTF8BS $ intercalate "." parts
            | (files', mns) <- files,
              file <- files',
              let parts = splitDirectories $ dropExtension file,
              all C.validModuleComponent parts,
              let mn = C.fromComponents parts, -- TODO: don't use fromComponents
              mn `notElem` mns
          ]

  pure $ case newModules of
    [] -> Nothing
    _ -> Just (C.Field name (newModules ++ fls))
  where
    parse :: (MonadCabalGild r m) => [FieldPragma] -> m [(FilePath, [C.ModuleName])]
    parse = fmap mconcat . traverse go
      where
        go :: (MonadCabalGild r m) => FieldPragma -> m [(FilePath, [C.ModuleName])]
        go (PragmaExpandModules fp mns) = return [(fp, mns)]
        go p = do
          displayWarning $ "Skipped pragma " ++ show p
          return []