module CabalGild.Unstable.Action.EvaluatePragmas where

import qualified CabalGild.Unstable.Class.MonadWalk as MonadWalk
import qualified CabalGild.Unstable.Extra.FieldLine as FieldLine
import qualified CabalGild.Unstable.Extra.ModuleName as ModuleName
import qualified CabalGild.Unstable.Extra.Name as Name
import qualified CabalGild.Unstable.Extra.String as String
import qualified CabalGild.Unstable.Type.Comment as Comment
import qualified CabalGild.Unstable.Type.Pragma as Pragma
import qualified Control.Monad as Monad
import qualified Control.Monad.Trans.Class as Trans
import qualified Control.Monad.Trans.Maybe as MaybeT
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Distribution.Compat.Lens as Lens
import qualified Distribution.Fields as Fields
import qualified Distribution.ModuleName as ModuleName
import qualified Distribution.Parsec as Parsec
import qualified Distribution.Utils.Generic as Utils
import qualified System.FilePath as FilePath

-- | High level wrapper around 'field' that makes this action easier to compose
-- with other actions.
run ::
  (MonadWalk.MonadWalk m) =>
  FilePath ->
  ([Fields.Field (p, [Comment.Comment q])], cs) ->
  m ([Fields.Field (p, [Comment.Comment q])], cs)
run :: forall (m :: * -> *) p q cs.
MonadWalk m =>
String
-> ([Field (p, [Comment q])], cs)
-> m ([Field (p, [Comment q])], cs)
run String
p ([Field (p, [Comment q])]
fs, cs
cs) = (,) ([Field (p, [Comment q])] -> cs -> ([Field (p, [Comment q])], cs))
-> m [Field (p, [Comment q])]
-> m (cs -> ([Field (p, [Comment q])], cs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Field (p, [Comment q]) -> m (Field (p, [Comment q])))
-> [Field (p, [Comment q])] -> m [Field (p, [Comment q])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (String -> Field (p, [Comment q]) -> m (Field (p, [Comment q]))
forall (m :: * -> *) p q.
MonadWalk m =>
String -> Field (p, [Comment q]) -> m (Field (p, [Comment q]))
field String
p) [Field (p, [Comment q])]
fs m (cs -> ([Field (p, [Comment q])], cs))
-> m cs -> m ([Field (p, [Comment q])], cs)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> cs -> m cs
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure cs
cs

-- | Evaluates pragmas within the given field. Or, if the field is a section,
-- evaluates pragmas recursively within the fields of the section.
--
-- If modules are discovered for a field, that fields lines are completely
-- replaced. If anything goes wrong while discovering modules, the original
-- field is returned.
field ::
  (MonadWalk.MonadWalk m) =>
  FilePath ->
  Fields.Field (p, [Comment.Comment q]) ->
  m (Fields.Field (p, [Comment.Comment q]))
field :: forall (m :: * -> *) p q.
MonadWalk m =>
String -> Field (p, [Comment q]) -> m (Field (p, [Comment q]))
field String
p Field (p, [Comment q])
f = case Field (p, [Comment q])
f of
  Fields.Field Name (p, [Comment q])
n [FieldLine (p, [Comment q])]
fls -> (Maybe (Field (p, [Comment q])) -> Field (p, [Comment q]))
-> m (Maybe (Field (p, [Comment q]))) -> m (Field (p, [Comment q]))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Field (p, [Comment q])
-> Maybe (Field (p, [Comment q])) -> Field (p, [Comment q])
forall a. a -> Maybe a -> a
Maybe.fromMaybe Field (p, [Comment q])
f) (m (Maybe (Field (p, [Comment q]))) -> m (Field (p, [Comment q])))
-> (MaybeT m (Field (p, [Comment q]))
    -> m (Maybe (Field (p, [Comment q]))))
-> MaybeT m (Field (p, [Comment q]))
-> m (Field (p, [Comment q]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m (Field (p, [Comment q]))
-> m (Maybe (Field (p, [Comment q])))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
MaybeT.runMaybeT (MaybeT m (Field (p, [Comment q])) -> m (Field (p, [Comment q])))
-> MaybeT m (Field (p, [Comment q])) -> m (Field (p, [Comment q]))
forall a b. (a -> b) -> a -> b
$ do
    Bool -> MaybeT m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
Monad.guard (Bool -> MaybeT m ()) -> Bool -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ FieldName -> Set FieldName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Name (p, [Comment q]) -> FieldName
forall a. Name a -> FieldName
Name.value Name (p, [Comment q])
n) Set FieldName
relevantFieldNames
    Comment q
comment <- Maybe (Comment q) -> MaybeT m (Comment q)
forall (f :: * -> *) a. Applicative f => Maybe a -> MaybeT f a
hoistMaybe (Maybe (Comment q) -> MaybeT m (Comment q))
-> ((p, [Comment q]) -> Maybe (Comment q))
-> (p, [Comment q])
-> MaybeT m (Comment q)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Comment q] -> Maybe (Comment q)
forall a. [a] -> Maybe a
Utils.safeLast ([Comment q] -> Maybe (Comment q))
-> ((p, [Comment q]) -> [Comment q])
-> (p, [Comment q])
-> Maybe (Comment q)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p, [Comment q]) -> [Comment q]
forall a b. (a, b) -> b
snd ((p, [Comment q]) -> MaybeT m (Comment q))
-> (p, [Comment q]) -> MaybeT m (Comment q)
forall a b. (a -> b) -> a -> b
$ Name (p, [Comment q]) -> (p, [Comment q])
forall a. Name a -> a
Name.annotation Name (p, [Comment q])
n
    Pragma
pragma <- Maybe Pragma -> MaybeT m Pragma
forall (f :: * -> *) a. Applicative f => Maybe a -> MaybeT f a
hoistMaybe (Maybe Pragma -> MaybeT m Pragma)
-> (FieldName -> Maybe Pragma) -> FieldName -> MaybeT m Pragma
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Maybe Pragma
forall a. Parsec a => FieldName -> Maybe a
Parsec.simpleParsecBS (FieldName -> MaybeT m Pragma) -> FieldName -> MaybeT m Pragma
forall a b. (a -> b) -> a -> b
$ Comment q -> FieldName
forall a. Comment a -> FieldName
Comment.value Comment q
comment
    case Pragma
pragma of
      Pragma.Discover NonEmpty String
ds -> do
        let root :: String
root = String -> String
FilePath.takeDirectory String
p
            directories :: [String]
directories =
              String -> String
FilePath.dropTrailingPathSeparator
                (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FilePath.normalise
                (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
FilePath.combine String
root
                (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty String
ds
        [String]
files <- m [String] -> MaybeT m [String]
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m [String] -> MaybeT m [String])
-> (m [[String]] -> m [String])
-> m [[String]]
-> MaybeT m [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[String]] -> [String]) -> m [[String]] -> m [String]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall a. Monoid a => [a] -> a
mconcat (m [[String]] -> MaybeT m [String])
-> m [[String]] -> MaybeT m [String]
forall a b. (a -> b) -> a -> b
$ (String -> m [String]) -> [String] -> m [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> m [String]
forall (m :: * -> *). MonadWalk m => String -> m [String]
MonadWalk.walk [String]
directories
        let comments :: [Comment q]
comments = (FieldLine (p, [Comment q]) -> [Comment q])
-> [FieldLine (p, [Comment q])] -> [Comment q]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((p, [Comment q]) -> [Comment q]
forall a b. (a, b) -> b
snd ((p, [Comment q]) -> [Comment q])
-> (FieldLine (p, [Comment q]) -> (p, [Comment q]))
-> FieldLine (p, [Comment q])
-> [Comment q]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLine (p, [Comment q]) -> (p, [Comment q])
forall a. FieldLine a -> a
FieldLine.annotation) [FieldLine (p, [Comment q])]
fls
            position :: p
position =
              p
-> (FieldLine (p, [Comment q]) -> p)
-> Maybe (FieldLine (p, [Comment q]))
-> p
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((p, [Comment q]) -> p
forall a b. (a, b) -> a
fst ((p, [Comment q]) -> p) -> (p, [Comment q]) -> p
forall a b. (a -> b) -> a -> b
$ Name (p, [Comment q]) -> (p, [Comment q])
forall a. Name a -> a
Name.annotation Name (p, [Comment q])
n) ((p, [Comment q]) -> p
forall a b. (a, b) -> a
fst ((p, [Comment q]) -> p)
-> (FieldLine (p, [Comment q]) -> (p, [Comment q]))
-> FieldLine (p, [Comment q])
-> p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLine (p, [Comment q]) -> (p, [Comment q])
forall a. FieldLine a -> a
FieldLine.annotation) (Maybe (FieldLine (p, [Comment q])) -> p)
-> Maybe (FieldLine (p, [Comment q])) -> p
forall a b. (a -> b) -> a -> b
$
                [FieldLine (p, [Comment q])] -> Maybe (FieldLine (p, [Comment q]))
forall a. [a] -> Maybe a
Maybe.listToMaybe [FieldLine (p, [Comment q])]
fls
            fieldLines :: [FieldLine (p, [Comment q])]
fieldLines =
              ((p, [Comment q]) -> ModuleName -> FieldLine (p, [Comment q]))
-> [(p, [Comment q])]
-> [ModuleName]
-> [FieldLine (p, [Comment q])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (p, [Comment q]) -> ModuleName -> FieldLine (p, [Comment q])
forall a. a -> ModuleName -> FieldLine a
ModuleName.toFieldLine ((,) p
position ([Comment q] -> (p, [Comment q]))
-> [[Comment q]] -> [(p, [Comment q])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Comment q]
comments [Comment q] -> [[Comment q]] -> [[Comment q]]
forall a. a -> [a] -> [a]
: [Comment q] -> [[Comment q]]
forall a. a -> [a]
repeat [])
                ([ModuleName] -> [FieldLine (p, [Comment q])])
-> ([String] -> [ModuleName])
-> [String]
-> [FieldLine (p, [Comment q])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe ModuleName) -> [String] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe ([String] -> String -> Maybe ModuleName
toModuleName [String]
directories)
                ([String] -> [FieldLine (p, [Comment q])])
-> [String] -> [FieldLine (p, [Comment q])]
forall a b. (a -> b) -> a -> b
$ (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (Set String -> String -> Maybe String
stripAnyExtension Set String
extensions) [String]
files
            -- This isn't great, but the comments have to go /somewhere/.
            name :: Name (p, [Comment q])
name =
              if [FieldLine (p, [Comment q])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLine (p, [Comment q])]
fieldLines
                then ASetter
  (Name (p, [Comment q]))
  (Name (p, [Comment q]))
  [Comment q]
  [Comment q]
-> ([Comment q] -> [Comment q])
-> Name (p, [Comment q])
-> Name (p, [Comment q])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
Lens.over (LensLike
  Identity
  (Name (p, [Comment q]))
  (Name (p, [Comment q]))
  (p, [Comment q])
  (p, [Comment q])
forall a (f :: * -> *).
Functor f =>
LensLike f (Name a) (Name a) a a
Name.annotationLens LensLike
  Identity
  (Name (p, [Comment q]))
  (Name (p, [Comment q]))
  (p, [Comment q])
  (p, [Comment q])
-> (([Comment q] -> Identity [Comment q])
    -> (p, [Comment q]) -> Identity (p, [Comment q]))
-> ASetter
     (Name (p, [Comment q]))
     (Name (p, [Comment q]))
     [Comment q]
     [Comment q]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Comment q] -> Identity [Comment q])
-> (p, [Comment q]) -> Identity (p, [Comment q])
forall c a b (f :: * -> *).
Functor f =>
LensLike f (c, a) (c, b) a b
Lens._2) ([Comment q]
comments [Comment q] -> [Comment q] -> [Comment q]
forall a. Semigroup a => a -> a -> a
<>) Name (p, [Comment q])
n
                else Name (p, [Comment q])
n
        Field (p, [Comment q]) -> MaybeT m (Field (p, [Comment q]))
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field (p, [Comment q]) -> MaybeT m (Field (p, [Comment q])))
-> Field (p, [Comment q]) -> MaybeT m (Field (p, [Comment q]))
forall a b. (a -> b) -> a -> b
$ Name (p, [Comment q])
-> [FieldLine (p, [Comment q])] -> Field (p, [Comment q])
forall ann. Name ann -> [FieldLine ann] -> Field ann
Fields.Field Name (p, [Comment q])
name [FieldLine (p, [Comment q])]
fieldLines
  Fields.Section Name (p, [Comment q])
n [SectionArg (p, [Comment q])]
sas [Field (p, [Comment q])]
fs -> Name (p, [Comment q])
-> [SectionArg (p, [Comment q])]
-> [Field (p, [Comment q])]
-> Field (p, [Comment q])
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
Fields.Section Name (p, [Comment q])
n [SectionArg (p, [Comment q])]
sas ([Field (p, [Comment q])] -> Field (p, [Comment q]))
-> m [Field (p, [Comment q])] -> m (Field (p, [Comment q]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Field (p, [Comment q]) -> m (Field (p, [Comment q])))
-> [Field (p, [Comment q])] -> m [Field (p, [Comment q])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (String -> Field (p, [Comment q]) -> m (Field (p, [Comment q]))
forall (m :: * -> *) p q.
MonadWalk m =>
String -> Field (p, [Comment q]) -> m (Field (p, [Comment q]))
field String
p) [Field (p, [Comment q])]
fs

-- | These are the names of the fields that can have this action applied to
-- them.
relevantFieldNames :: Set.Set Fields.FieldName
relevantFieldNames :: Set FieldName
relevantFieldNames =
  [FieldName] -> Set FieldName
forall a. Ord a => [a] -> Set a
Set.fromList ([FieldName] -> Set FieldName) -> [FieldName] -> Set FieldName
forall a b. (a -> b) -> a -> b
$
    (String -> FieldName) -> [String] -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      String -> FieldName
String.toUtf8
      [ String
"exposed-modules",
        String
"other-modules",
        String
"signatures"
      ]

-- | Attempts to strip any of the given extensions from the file path. If any
-- of them succeed, the result is returned. Otherwise 'Nothing' is returned.
stripAnyExtension :: Set.Set String -> FilePath -> Maybe String
stripAnyExtension :: Set String -> String -> Maybe String
stripAnyExtension Set String
es String
p =
  [String] -> Maybe String
forall a. [a] -> Maybe a
Maybe.listToMaybe
    ([String] -> Maybe String)
-> ([String] -> [String]) -> [String] -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (String -> String -> Maybe String
`FilePath.stripExtension` String
p)
    ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
es

-- | The set of extensions that should be discovered by this pragma. Any file
-- with one of these extensions will be discovered.
--
-- <https://cabal.readthedocs.io/en/3.10/cabal-package.html#modules-and-preprocessors>
extensions :: Set.Set String
extensions :: Set String
extensions =
  [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
    [ String
"chs",
      String
"cpphs",
      String
"gc",
      String
"hs",
      String
"hsc",
      String
"hsig",
      String
"lhs",
      String
"lhsig",
      String
"ly",
      String
"x",
      String
"y"
    ]

-- | Attempts to convert a file path (without an extension) into a module name
-- by making it relative to one of the given directories.
toModuleName :: [FilePath] -> FilePath -> Maybe ModuleName.ModuleName
toModuleName :: [String] -> String -> Maybe ModuleName
toModuleName [String]
ds String
f =
  [ModuleName] -> Maybe ModuleName
forall a. [a] -> Maybe a
Maybe.listToMaybe ([ModuleName] -> Maybe ModuleName)
-> [ModuleName] -> Maybe ModuleName
forall a b. (a -> b) -> a -> b
$
    (String -> Maybe ModuleName) -> [String] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (String -> Maybe ModuleName
ModuleName.fromFilePath (String -> Maybe ModuleName)
-> (String -> String) -> String -> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String) -> String -> String -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> String
FilePath.makeRelative String
f) [String]
ds

-- | This was added in @transformers-0.6.0.0@. See
-- <https://hub.darcs.net/ross/transformers/issue/49>.
hoistMaybe :: (Applicative f) => Maybe a -> MaybeT.MaybeT f a
hoistMaybe :: forall (f :: * -> *) a. Applicative f => Maybe a -> MaybeT f a
hoistMaybe = f (Maybe a) -> MaybeT f a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT.MaybeT (f (Maybe a) -> MaybeT f a)
-> (Maybe a -> f (Maybe a)) -> Maybe a -> MaybeT f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> f (Maybe a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure