module CabalGild.Unstable.Action.EvaluatePragmas where

import qualified CabalGild.Unstable.Class.MonadWalk as MonadWalk
import qualified CabalGild.Unstable.Exception.InvalidOption as InvalidOption
import qualified CabalGild.Unstable.Exception.UnknownOption as UnknownOption
import qualified CabalGild.Unstable.Extra.FieldLine as FieldLine
import qualified CabalGild.Unstable.Extra.FilePath as FilePath
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.DiscoverTarget as DiscoverTarget
import qualified CabalGild.Unstable.Type.Pragma as Pragma
import qualified Control.Applicative as Applicative
import qualified Control.Monad.Catch as Exception
import qualified Control.Monad.Trans.Class as Trans
import qualified Control.Monad.Trans.Maybe as MaybeT
import qualified Data.Containers.ListUtils as List
import qualified Data.Either as Either
import qualified Data.Map as Map
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.Console.GetOpt as GetOpt
import qualified System.FilePath as FilePath

-- | High level wrapper around 'field' that makes this action easier to compose
-- with other actions.
run ::
  (Exception.MonadThrow m, 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.
(MonadThrow m, 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.
(MonadThrow m, 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.
field ::
  (Exception.MonadThrow m, MonadWalk.MonadWalk m) =>
  FilePath ->
  Fields.Field (p, [Comment.Comment q]) ->
  m (Fields.Field (p, [Comment.Comment q]))
field :: forall (m :: * -> *) p q.
(MonadThrow m, 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
    dt <-
      MaybeT m DiscoverTarget
-> (DiscoverTarget -> MaybeT m DiscoverTarget)
-> Maybe DiscoverTarget
-> MaybeT m DiscoverTarget
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MaybeT m DiscoverTarget
forall a. MaybeT m a
forall (f :: * -> *) a. Alternative f => f a
Applicative.empty DiscoverTarget -> MaybeT m DiscoverTarget
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DiscoverTarget -> MaybeT m DiscoverTarget)
-> Maybe DiscoverTarget -> MaybeT m DiscoverTarget
forall a b. (a -> b) -> a -> b
$
        FieldName -> Map FieldName DiscoverTarget -> Maybe DiscoverTarget
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Name (p, [Comment q]) -> FieldName
forall a. Name a -> FieldName
Name.value Name (p, [Comment q])
n) Map FieldName DiscoverTarget
relevantFieldNames
    comment <- hoistMaybe . Utils.safeLast . snd $ Name.annotation n
    pragma <- hoistMaybe . Parsec.simpleParsecBS $ Comment.value comment
    case pragma of
      Pragma.Discover [String]
ds -> String
-> Name (p, [Comment q])
-> [FieldLine (p, [Comment q])]
-> DiscoverTarget
-> [String]
-> MaybeT m (Field (p, [Comment q]))
forall (m :: * -> *) p c.
(MonadThrow m, MonadWalk m) =>
String
-> Name (p, [c])
-> [FieldLine (p, [c])]
-> DiscoverTarget
-> [String]
-> MaybeT m (Field (p, [c]))
discover String
p Name (p, [Comment q])
n [FieldLine (p, [Comment q])]
fls DiscoverTarget
dt [String]
ds
  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.
(MonadThrow m, MonadWalk m) =>
String -> Field (p, [Comment q]) -> m (Field (p, [Comment q]))
field String
p) [Field (p, [Comment q])]
fs

-- | If modules are discovered for a field, that fields lines are completely
-- replaced.
discover ::
  (Exception.MonadThrow m, MonadWalk.MonadWalk m) =>
  FilePath ->
  Fields.Name (p, [c]) ->
  [Fields.FieldLine (p, [c])] ->
  DiscoverTarget.DiscoverTarget ->
  [String] ->
  MaybeT.MaybeT m (Fields.Field (p, [c]))
discover :: forall (m :: * -> *) p c.
(MonadThrow m, MonadWalk m) =>
String
-> Name (p, [c])
-> [FieldLine (p, [c])]
-> DiscoverTarget
-> [String]
-> MaybeT m (Field (p, [c]))
discover String
p Name (p, [c])
n [FieldLine (p, [c])]
fls DiscoverTarget
dt [String]
ds = do
  let ([Either String String]
flgs, [String]
args, [String]
opts, [String]
errs) =
        ArgOrder (Either String String)
-> [OptDescr (Either String String)]
-> [String]
-> ([Either String String], [String], [String], [String])
forall a.
ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
GetOpt.getOpt'
          ArgOrder (Either String String)
forall a. ArgOrder a
GetOpt.Permute
          [ String
-> [String]
-> ArgDescr (Either String String)
-> String
-> OptDescr (Either String String)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"include"] ((String -> Either String String)
-> String -> ArgDescr (Either String String)
forall a. (String -> a) -> String -> ArgDescr a
GetOpt.ReqArg String -> Either String String
forall a b. b -> Either a b
Right String
"PATTERN") String
"",
            String
-> [String]
-> ArgDescr (Either String String)
-> String
-> OptDescr (Either String String)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
GetOpt.Option [] [String
"exclude"] ((String -> Either String String)
-> String -> ArgDescr (Either String String)
forall a. (String -> a) -> String -> ArgDescr a
GetOpt.ReqArg String -> Either String String
forall a b. a -> Either a b
Left String
"PATTERN") String
""
          ]
          [String]
ds
  let ([String]
excs, [String]
incs) = [Either String String] -> ([String], [String])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either String String]
flgs
  (String -> MaybeT m (ZonkAny 0)) -> [String] -> MaybeT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UnknownOption -> MaybeT m (ZonkAny 0)
forall e a. (HasCallStack, Exception e) => e -> MaybeT m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
Exception.throwM (UnknownOption -> MaybeT m (ZonkAny 0))
-> (String -> UnknownOption) -> String -> MaybeT m (ZonkAny 0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnknownOption
UnknownOption.fromString) [String]
opts
  (String -> MaybeT m (ZonkAny 1)) -> [String] -> MaybeT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (InvalidOption -> MaybeT m (ZonkAny 1)
forall e a. (HasCallStack, Exception e) => e -> MaybeT m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
Exception.throwM (InvalidOption -> MaybeT m (ZonkAny 1))
-> (String -> InvalidOption) -> String -> MaybeT m (ZonkAny 1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InvalidOption
InvalidOption.fromString) [String]
errs
  let root :: String
root = String -> String
FilePath.dropTrailingPathSeparator (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
clean (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
FilePath.takeDirectory String
p
      directories :: [String]
directories =
        [String] -> [String]
forall a. Ord a => [a] -> [a]
List.nubOrd
          ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
clean
          ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args then [String
"."] else [String]
args
      exclusions :: [String]
exclusions = [String] -> [String]
forall a. Ord a => [a] -> [a]
List.nubOrd ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
clean [String]
excs
      inclusions :: [String]
inclusions =
        [String] -> [String]
forall a. Ord a => [a] -> [a]
List.nubOrd
          ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
clean
          ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
incs then (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
`FilePath.combine` String
"**") [String]
directories else [String]
incs
  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] -> MaybeT m [String]
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String] -> m [String]
forall (m :: * -> *).
MonadWalk m =>
String -> [String] -> [String] -> m [String]
MonadWalk.walk String
root [String]
inclusions [String]
exclusions
  let comments = (FieldLine (p, [c]) -> [c]) -> [FieldLine (p, [c])] -> [c]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((p, [c]) -> [c]
forall a b. (a, b) -> b
snd ((p, [c]) -> [c])
-> (FieldLine (p, [c]) -> (p, [c])) -> FieldLine (p, [c]) -> [c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLine (p, [c]) -> (p, [c])
forall a. FieldLine a -> a
FieldLine.annotation) [FieldLine (p, [c])]
fls
      position =
        p -> (FieldLine (p, [c]) -> p) -> Maybe (FieldLine (p, [c])) -> p
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((p, [c]) -> p
forall a b. (a, b) -> a
fst ((p, [c]) -> p) -> (p, [c]) -> p
forall a b. (a -> b) -> a -> b
$ Name (p, [c]) -> (p, [c])
forall a. Name a -> a
Name.annotation Name (p, [c])
n) ((p, [c]) -> p
forall a b. (a, b) -> a
fst ((p, [c]) -> p)
-> (FieldLine (p, [c]) -> (p, [c])) -> FieldLine (p, [c]) -> p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLine (p, [c]) -> (p, [c])
forall a. FieldLine a -> a
FieldLine.annotation) (Maybe (FieldLine (p, [c])) -> p)
-> Maybe (FieldLine (p, [c])) -> p
forall a b. (a -> b) -> a -> b
$
          [FieldLine (p, [c])] -> Maybe (FieldLine (p, [c]))
forall a. [a] -> Maybe a
Maybe.listToMaybe [FieldLine (p, [c])]
fls
      fieldLines = case DiscoverTarget
dt of
        DiscoverTarget
DiscoverTarget.Modules ->
          ((p, [c]) -> ModuleName -> FieldLine (p, [c]))
-> [(p, [c])] -> [ModuleName] -> [FieldLine (p, [c])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (p, [c]) -> ModuleName -> FieldLine (p, [c])
forall a. a -> ModuleName -> FieldLine a
ModuleName.toFieldLine ((,) p
position ([c] -> (p, [c])) -> [[c]] -> [(p, [c])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [c]
comments [c] -> [[c]] -> [[c]]
forall a. a -> [a] -> [a]
: [c] -> [[c]]
forall a. a -> [a]
repeat [])
            ([ModuleName] -> [FieldLine (p, [c])])
-> ([String] -> [ModuleName]) -> [String] -> [FieldLine (p, [c])]
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, [c])])
-> [String] -> [FieldLine (p, [c])]
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 -> Maybe String)
-> (String -> String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
clean) [String]
files
        DiscoverTarget
DiscoverTarget.Files ->
          ((p, [c]) -> String -> FieldLine (p, [c]))
-> [(p, [c])] -> [String] -> [FieldLine (p, [c])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
            (\(p, [c])
a -> (p, [c]) -> FieldName -> FieldLine (p, [c])
forall ann. ann -> FieldName -> FieldLine ann
Fields.FieldLine (p, [c])
a (FieldName -> FieldLine (p, [c]))
-> (String -> FieldName) -> String -> FieldLine (p, [c])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FieldName
String.toUtf8)
            ((,) p
position ([c] -> (p, [c])) -> [[c]] -> [(p, [c])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [c]
comments [c] -> [[c]] -> [[c]]
forall a. a -> [a] -> [a]
: [c] -> [[c]]
forall a. a -> [a]
repeat [])
            [String]
files
      -- This isn't great, but the comments have to go /somewhere/.
      name =
        if [FieldLine (p, [c])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLine (p, [c])]
fieldLines
          then ASetter (Name (p, [c])) (Name (p, [c])) [c] [c]
-> ([c] -> [c]) -> Name (p, [c]) -> Name (p, [c])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
Lens.over (LensLike Identity (Name (p, [c])) (Name (p, [c])) (p, [c]) (p, [c])
forall a (f :: * -> *).
Functor f =>
LensLike f (Name a) (Name a) a a
Name.annotationLens LensLike Identity (Name (p, [c])) (Name (p, [c])) (p, [c]) (p, [c])
-> (([c] -> Identity [c]) -> (p, [c]) -> Identity (p, [c]))
-> ASetter (Name (p, [c])) (Name (p, [c])) [c] [c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([c] -> Identity [c]) -> (p, [c]) -> Identity (p, [c])
forall c a b (f :: * -> *).
Functor f =>
LensLike f (c, a) (c, b) a b
Lens._2) ([c]
comments [c] -> [c] -> [c]
forall a. Semigroup a => a -> a -> a
<>) Name (p, [c])
n
          else Name (p, [c])
n
  pure $ Fields.Field name fieldLines

-- | Converts separators into POSIX format and then normalizes the result.
clean :: FilePath -> FilePath
clean :: String -> String
clean = String -> String
FilePath.normalise (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FilePath.toPosixSeparators

-- | These are the names of the fields that can have this action applied to
-- them.
relevantFieldNames :: Map.Map Fields.FieldName DiscoverTarget.DiscoverTarget
relevantFieldNames :: Map FieldName DiscoverTarget
relevantFieldNames =
  (String -> FieldName)
-> Map String DiscoverTarget -> Map FieldName DiscoverTarget
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys String -> FieldName
String.toUtf8 (Map String DiscoverTarget -> Map FieldName DiscoverTarget)
-> ([(String, DiscoverTarget)] -> Map String DiscoverTarget)
-> [(String, DiscoverTarget)]
-> Map FieldName DiscoverTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, DiscoverTarget)] -> Map String DiscoverTarget
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, DiscoverTarget)] -> Map FieldName DiscoverTarget)
-> [(String, DiscoverTarget)] -> Map FieldName DiscoverTarget
forall a b. (a -> b) -> a -> b
$
    [ (String
"asm-sources", DiscoverTarget
DiscoverTarget.Files),
      (String
"c-sources", DiscoverTarget
DiscoverTarget.Files),
      (String
"cxx-sources", DiscoverTarget
DiscoverTarget.Files),
      (String
"data-files", DiscoverTarget
DiscoverTarget.Files),
      (String
"exposed-modules", DiscoverTarget
DiscoverTarget.Modules),
      (String
"extra-doc-files", DiscoverTarget
DiscoverTarget.Files),
      (String
"extra-source-files", DiscoverTarget
DiscoverTarget.Files),
      (String
"includes", DiscoverTarget
DiscoverTarget.Files),
      (String
"install-includes", DiscoverTarget
DiscoverTarget.Files),
      (String
"js-sources", DiscoverTarget
DiscoverTarget.Files),
      (String
"license-files", DiscoverTarget
DiscoverTarget.Files),
      (String
"other-modules", DiscoverTarget
DiscoverTarget.Modules),
      (String
"signatures", DiscoverTarget
DiscoverTarget.Modules)
    ]

-- | 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