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

import GHC.Parser.Annotation
import GHC.Types.SrcLoc

import Control.Applicative
import Data.List.Extra

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 :: Located AnnotationComment -> String
comment :: Located AnnotationComment -> String
comment (L SrcSpan
_ (AnnBlockComment String
s)) = String
s
comment (L SrcSpan
_ (AnnLineComment String
s)) = String
s
comment (L SrcSpan
_ (AnnDocOptions String
s)) = String
s
comment (L SrcSpan
_ (AnnDocCommentNamed String
s)) = String
s
comment (L SrcSpan
_ (AnnDocCommentPrev String
s)) = String
s
comment (L SrcSpan
_ (AnnDocCommentNext String
s)) = String
s
comment (L SrcSpan
_ (AnnDocSection Int
_ String
s)) = String
s

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

isCommentMultiline :: Located AnnotationComment -> Bool
isCommentMultiline :: Located AnnotationComment -> Bool
isCommentMultiline (L SrcSpan
_ (AnnBlockComment String
_)) = Bool
True
isCommentMultiline Located AnnotationComment
_ = Bool
False

-- GHC parse trees don't contain pragmas. We work around this with
-- (nasty) parsing of comments.

-- Pragmas. Comments not associated with a span in the annotations
-- that have the form @{-# ...#-}@.
pragmas :: ApiAnns -> [(Located AnnotationComment, String)]
pragmas :: ApiAnns -> [(Located AnnotationComment, String)]
pragmas ApiAnns
anns =
  -- 'ApiAnns' 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).
  [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, String)]
forall a. [a] -> [a]
reverse
    [ (RealLocated AnnotationComment -> Located AnnotationComment
forall a. RealLocated a -> Located a
realToLoc RealLocated AnnotationComment
c, String
s) |
        c :: RealLocated AnnotationComment
c@(L RealSrcSpan
_ (AnnBlockComment String
comm)) <- ApiAnns -> [RealLocated AnnotationComment]
apiAnnRogueComments ApiAnns
anns
      , 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
    ]
   where
     realToLoc :: RealLocated a -> Located a
     realToLoc :: RealLocated a -> Located a
realToLoc (L RealSrcSpan
r a
x) = SrcSpan -> a -> Located a
forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
r Maybe BufSpan
forall a. Maybe a
Nothing) a
x

-- 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 (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 (located) annotation
-- comment that sets the flags enumerated in the second element of the
-- pair.
flags :: [(Located AnnotationComment, String)]
      -> [(Located AnnotationComment, [String])]
flags :: [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
flags [(Located AnnotationComment, String)]
ps =
  -- Old versions of GHC accepted 'OPTIONS' rather than 'OPTIONS_GHC' (but
  -- this is deprecated).
  [(Located AnnotationComment
c, [String]
opts) | (Located AnnotationComment
c, String
s) <- [(Located AnnotationComment, String)]
ps
             , Just String
rest <- [String -> String -> Maybe String
stripPrefixCI String
"OPTIONS_GHC " String
s
                             Maybe String -> Maybe String -> Maybe String
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 he second element of the pair.
languagePragmas :: [(Located AnnotationComment, String)]
         -> [(Located AnnotationComment, [String])]
languagePragmas :: [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
languagePragmas [(Located AnnotationComment, String)]
ps =
  [(Located AnnotationComment
c, [String]
exts) | (Located AnnotationComment
c, String
s) <- [(Located AnnotationComment, 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 :: SrcSpan -> [String] -> Located AnnotationComment
mkFlags :: SrcSpan -> [String] -> Located AnnotationComment
mkFlags SrcSpan
loc [String]
flags =
  SrcSpan -> AnnotationComment -> Located AnnotationComment
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (AnnotationComment -> Located AnnotationComment)
-> AnnotationComment -> Located AnnotationComment
forall a b. (a -> b) -> a -> b
$ String -> AnnotationComment
AnnBlockComment (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
" #-}")

mkLanguagePragmas :: SrcSpan -> [String] -> Located AnnotationComment
mkLanguagePragmas :: SrcSpan -> [String] -> Located AnnotationComment
mkLanguagePragmas SrcSpan
loc [String]
exts =
  SrcSpan -> AnnotationComment -> Located AnnotationComment
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (AnnotationComment -> Located AnnotationComment)
-> AnnotationComment -> Located AnnotationComment
forall a b. (a -> b) -> a -> b
$ String -> AnnotationComment
AnnBlockComment (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
" #-}")