content: 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 p (fs, cs) = (,) <$> traverse (field p) fs <*> pure 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 p f = case f of
    Fields.Field n fls -> fmap (Maybe.fromMaybe f) . MaybeT.runMaybeT $ do
      dt <-
        maybe Applicative.empty pure $
          Map.lookup (Name.value n) relevantFieldNames
      comment <- hoistMaybe . Utils.safeLast . snd $ Name.annotation n
      pragma <- hoistMaybe . Parsec.simpleParsecBS $ Comment.value comment
      case pragma of
        Pragma.Discover ds -> discover p n fls dt ds
    Fields.Section n sas fs -> Fields.Section n sas <$> traverse (field p) 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 p n fls dt ds = do
    let (flgs, args, opts, errs) =
          GetOpt.getOpt'
            GetOpt.Permute
            [ GetOpt.Option [] ["include"] (GetOpt.ReqArg Right "PATTERN") "",
              GetOpt.Option [] ["exclude"] (GetOpt.ReqArg Left "PATTERN") ""
            ]
            ds
    let (excs, incs) = Either.partitionEithers flgs
    mapM_ (Exception.throwM . UnknownOption.fromString) opts
    mapM_ (Exception.throwM . InvalidOption.fromString) errs
    let root = FilePath.dropTrailingPathSeparator . clean $ FilePath.takeDirectory p
        directories =
          List.nubOrd
            . fmap clean
            $ if null args then ["."] else args
        exclusions = List.nubOrd $ fmap clean excs
        inclusions =
          List.nubOrd
            . fmap clean
            $ if null incs then fmap (`FilePath.combine` "**") directories else incs
    files <- Trans.lift $ MonadWalk.walk root inclusions exclusions
    let comments = concatMap (snd . FieldLine.annotation) fls
        position =
          maybe (fst $ Name.annotation n) (fst . FieldLine.annotation) $
            Maybe.listToMaybe fls
        fieldLines = case dt of
          DiscoverTarget.Modules ->
            zipWith ModuleName.toFieldLine ((,) position <$> comments : repeat [])
              . Maybe.mapMaybe (toModuleName directories)
              $ Maybe.mapMaybe (stripAnyExtension extensions . clean) files
          DiscoverTarget.Files ->
            zipWith
              (\a -> Fields.FieldLine a . String.toUtf8)
              ((,) position <$> comments : repeat [])
              files
        -- This isn't great, but the comments have to go /somewhere/.
        name =
          if null fieldLines
            then Lens.over (Name.annotationLens . Lens._2) (comments <>) n
            else n
    pure $ Fields.Field name fieldLines
  
  -- | Converts separators into POSIX format and then normalizes the result.
  clean :: FilePath -> FilePath
  clean = FilePath.normalise . 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.mapKeys String.toUtf8 . Map.fromList $
      [ ("asm-sources", DiscoverTarget.Files),
        ("c-sources", DiscoverTarget.Files),
        ("cxx-sources", DiscoverTarget.Files),
        ("data-files", DiscoverTarget.Files),
        ("exposed-modules", DiscoverTarget.Modules),
        ("extra-doc-files", DiscoverTarget.Files),
        ("extra-source-files", DiscoverTarget.Files),
        ("includes", DiscoverTarget.Files),
        ("install-includes", DiscoverTarget.Files),
        ("js-sources", DiscoverTarget.Files),
        ("license-files", DiscoverTarget.Files),
        ("other-modules", DiscoverTarget.Modules),
        ("signatures", 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 es p =
    Maybe.listToMaybe
      . Maybe.mapMaybe (`FilePath.stripExtension` p)
      $ Set.toList 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.fromList
      [ "chs",
        "cpphs",
        "gc",
        "hs",
        "hsc",
        "hsig",
        "lhs",
        "lhsig",
        "ly",
        "x",
        "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 ds f =
    Maybe.listToMaybe $
      Maybe.mapMaybe (ModuleName.fromFilePath . flip FilePath.makeRelative f) 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 = MaybeT.MaybeT . pure
  