    {-# LANGUAGE ImportQualifiedPost #-}

    module GHC.Util.ApiAnnotation (
        comment_
      , commentText
      , GHC.Util.ApiAnnotation.comments
      , isCommentMultiline
      , pragmas
      , flags
      , languagePragmas
      , mkFlags
      , mkLanguagePragmas
      , extensions
    ) where

    import GHC.LanguageExtensions.Type (Extension)
    import GHC.Parser.Annotation
    import GHC.Hs.DocString
    import GHC.Types.SrcLoc

    import Language.Haskell.GhclibParserEx.GHC.Driver.Session

    import Control.Applicative
    import Data.List.Extra
    import Data.Maybe
    import Data.Set qualified as Set

    trimCommentStart :: String -> String
    trimCommentStart :: String -> String
    trimCommentStart String
    s
        | Just String
    s <- String -> String -> Maybe String
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    stripPrefix String
    "{-" String
    s = String
    s
        | Just String
    s <- String -> String -> Maybe String
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    stripPrefix String
    "--" String
    s = String
    s
        | Bool
    otherwise = String
    s

    trimCommentEnd :: String -> String
    trimCommentEnd :: String -> String
    trimCommentEnd String
    s
        | Just String
    s <- String -> String -> Maybe String
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    stripSuffix String
    "-}" String
    s = String
    s
        | Bool
    otherwise = String
    s

    trimCommentDelims :: String -> String
    trimCommentDelims :: String -> String
    trimCommentDelims = String -> String
    trimCommentEnd (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    trimCommentStart

    -- | A comment as a string.
    comment_ :: LEpaComment -> String
    comment_ :: LEpaComment -> String
    comment_ (L NoCommentsLocation
    _ (EpaComment (EpaDocComment HsDocString
    ds ) RealSrcSpan
    _)) = HsDocString -> String
    renderHsDocString HsDocString
    ds
    comment_ (L NoCommentsLocation
    _ (EpaComment (EpaDocOptions String
    s) RealSrcSpan
    _)) = String
    s
    comment_ (L NoCommentsLocation
    _ (EpaComment (EpaLineComment String
    s) RealSrcSpan
    _)) = String
    s
    comment_ (L NoCommentsLocation
    _ (EpaComment (EpaBlockComment String
    s) RealSrcSpan
    _)) = String
    s

    -- | The comment string with delimiters removed.
    commentText :: LEpaComment -> String
    commentText :: LEpaComment -> String
    commentText = String -> String
    trimCommentDelims (String -> String)
    -> (LEpaComment -> String) -> LEpaComment -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LEpaComment -> String
    comment_

    -- | Total replacement for the partial `GHC.Parser.Annotation.comments` field of
    -- `EpAnn`
    comments :: EpAnn ann -> EpAnnComments
    comments :: forall ann. EpAnn ann -> EpAnnComments
    comments EpAnn{ comments :: forall ann. EpAnn ann -> EpAnnComments
    GHC.Parser.Annotation.comments = EpAnnComments
    result } = EpAnnComments
    result

    isCommentMultiline :: LEpaComment -> Bool
    isCommentMultiline :: LEpaComment -> Bool
    isCommentMultiline (L NoCommentsLocation
    _ (EpaComment (EpaBlockComment String
    _) RealSrcSpan
    _)) = Bool
    True
    isCommentMultiline LEpaComment
    _ = Bool
    False

    -- Pragmas have the form @{-# ...#-}@.
    pragmas :: EpAnnComments -> [(LEpaComment, String)]
    pragmas :: EpAnnComments -> [(LEpaComment, String)]
    pragmas EpAnnComments
    x =
      -- 'EpaAnnComments' stores pragmas in reverse order to how they were
      -- encountered in the source file with the last at the head of the
      -- list (makes sense when you think about it).
      [(LEpaComment, String)] -> [(LEpaComment, String)]
    forall a. [a] -> [a]
    reverse
        [ (LEpaComment
    c, String
    s) |
            c :: LEpaComment
    c@(L NoCommentsLocation
    _ (EpaComment (EpaBlockComment String
    comm) RealSrcSpan
    _)) <- EpAnnComments -> [LEpaComment]
    priorComments EpAnnComments
    x
          , let body :: String
    body = String -> String
    trimCommentDelims String
    comm
          , Just String
    rest <- [String -> String -> Maybe String
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    stripSuffix String
    "#" (String -> Maybe String) -> Maybe String -> Maybe String
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> String -> Maybe String
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    stripPrefix String
    "#" String
    body]
          , let s :: String
    s = String -> String
    trim String
    rest
        ]

    -- All the extensions defined to be used.
    extensions :: EpAnnComments -> Set.Set Extension
    extensions :: EpAnnComments -> Set Extension
    extensions = [Extension] -> Set Extension
    forall a. Ord a => [a] -> Set a
    Set.fromList ([Extension] -> Set Extension)
    -> (EpAnnComments -> [Extension]) -> EpAnnComments -> Set Extension
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((LEpaComment, [String]) -> [Extension])
    -> [(LEpaComment, [String])] -> [Extension]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ((String -> Maybe Extension) -> [String] -> [Extension]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe String -> Maybe Extension
    readExtension ([String] -> [Extension])
    -> ((LEpaComment, [String]) -> [String])
    -> (LEpaComment, [String])
    -> [Extension]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (LEpaComment, [String]) -> [String]
    forall a b. (a, b) -> b
    snd) ([(LEpaComment, [String])] -> [Extension])
    -> (EpAnnComments -> [(LEpaComment, [String])])
    -> EpAnnComments
    -> [Extension]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(LEpaComment, String)] -> [(LEpaComment, [String])]
    languagePragmas ([(LEpaComment, String)] -> [(LEpaComment, [String])])
    -> (EpAnnComments -> [(LEpaComment, String)])
    -> EpAnnComments
    -> [(LEpaComment, [String])]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . EpAnnComments -> [(LEpaComment, String)]
    pragmas

    -- Utility for a case insensitive prefix strip.
    stripPrefixCI :: String -> String -> Maybe String
    stripPrefixCI :: String -> String -> Maybe String
    stripPrefixCI String
    pref String
    str =
      let pref' :: String
    pref' = String -> String
    lower String
    pref
          (String
    str_pref, String
    rest) = Int -> String -> (String, String)
    forall a. Int -> [a] -> ([a], [a])
    splitAt (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    pref') String
    str
      in if String -> String
    lower String
    str_pref String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    pref' then String -> Maybe String
    forall a. a -> Maybe a
    Just String
    rest else Maybe String
    forall a. Maybe a
    Nothing

    -- Flags. The first element of the pair is the comment that
    -- sets the flags enumerated in the second element of the pair.
    flags :: [(LEpaComment, String)] -> [(LEpaComment, [String])]
    flags :: [(LEpaComment, String)] -> [(LEpaComment, [String])]
    flags [(LEpaComment, String)]
    ps =
      -- Old versions of GHC accepted 'OPTIONS' rather than 'OPTIONS_GHC' (but
      -- this is deprecated).
      [(LEpaComment
    c, [String]
    opts) | (LEpaComment
    c, String
    s) <- [(LEpaComment, String)]
    ps
                 , Just String
    rest <- [String -> String -> Maybe String
    stripPrefixCI String
    "OPTIONS_GHC " String
    s
                                 Maybe String -> Maybe String -> Maybe String
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> String -> String -> Maybe String
    stripPrefixCI String
    "OPTIONS " String
    s]
                 , let opts :: [String]
    opts = String -> [String]
    words String
    rest]

    -- Language pragmas. The first element of the
    -- pair is the (located) annotation comment that enables the
    -- pragmas enumerated by the second element of the pair.
    languagePragmas :: [(LEpaComment, String)] -> [(LEpaComment, [String])]
    languagePragmas :: [(LEpaComment, String)] -> [(LEpaComment, [String])]
    languagePragmas [(LEpaComment, String)]
    ps =
      [(LEpaComment
    c, [String]
    exts) | (LEpaComment
    c, String
    s) <- [(LEpaComment, String)]
    ps
                 , Just String
    rest <- [String -> String -> Maybe String
    stripPrefixCI String
    "LANGUAGE " String
    s]
                 , let exts :: [String]
    exts = (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> String
    trim (String -> String -> [String]
    forall a. (Partial, Eq a) => [a] -> [a] -> [[a]]
    splitOn String
    "," String
    rest)]

    -- Given a list of flags, make a GHC options pragma.
    mkFlags :: NoCommentsLocation -> [String] -> LEpaComment
    mkFlags :: NoCommentsLocation -> [String] -> LEpaComment
    mkFlags NoCommentsLocation
    anc [String]
    flags =
      NoCommentsLocation -> EpaComment -> LEpaComment
    forall l e. l -> e -> GenLocated l e
    L NoCommentsLocation
    anc (EpaComment -> LEpaComment) -> EpaComment -> LEpaComment
    forall a b. (a -> b) -> a -> b
    $ EpaCommentTok -> RealSrcSpan -> EpaComment
    EpaComment (String -> EpaCommentTok
    EpaBlockComment (String
    "{-# " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "OPTIONS_GHC " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [String] -> String
    unwords [String]
    flags String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " #-}")) (NoCommentsLocation -> RealSrcSpan
    forall a. EpaLocation' a -> RealSrcSpan
    epaLocationRealSrcSpan NoCommentsLocation
    anc)

    mkLanguagePragmas :: NoCommentsLocation -> [String] -> LEpaComment
    mkLanguagePragmas :: NoCommentsLocation -> [String] -> LEpaComment
    mkLanguagePragmas NoCommentsLocation
    anc [String]
    exts =
      NoCommentsLocation -> EpaComment -> LEpaComment
    forall l e. l -> e -> GenLocated l e
    L NoCommentsLocation
    anc (EpaComment -> LEpaComment) -> EpaComment -> LEpaComment
    forall a b. (a -> b) -> a -> b
    $ EpaCommentTok -> RealSrcSpan -> EpaComment
    EpaComment (String -> EpaCommentTok
    EpaBlockComment (String
    "{-# " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "LANGUAGE " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    ", " [String]
    exts String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " #-}")) (NoCommentsLocation -> RealSrcSpan
    forall a. EpaLocation' a -> RealSrcSpan
    epaLocationRealSrcSpan NoCommentsLocation
    anc)