module GHC.Util.ApiAnnotation (
    comment, commentText, isCommentMultiline
  , pragmas, flags, langExts
  , mkFlags, mkLangExts
) where

import ApiAnnotation
import SrcLoc

import Control.Applicative
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.List.Extra

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

trimCommentEnd :: String -> String
trimCommentEnd :: String -> String
trimCommentEnd s :: String
s
    | Just s :: String
s <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix "-}" 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 _ (AnnBlockComment s :: String
s)) = String
s
comment (L _ (AnnLineComment s :: String
s)) = String
s
comment (L _ (AnnDocOptions s :: String
s)) = String
s
comment (L _ (AnnDocCommentNamed s :: String
s)) = String
s
comment (L _ (AnnDocCommentPrev s :: String
s)) = String
s
comment (L _ (AnnDocCommentNext s :: String
s)) = String
s
comment (L _ (AnnDocSection _ s :: 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 _ (AnnBlockComment _)) = Bool
True
isCommentMultiline _ = 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 anns :: 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
    [ (Located AnnotationComment
c, String
s) |
        c :: Located AnnotationComment
c@(L _ (AnnBlockComment comm :: String
comm)) <- [Located AnnotationComment]
-> Maybe [Located AnnotationComment] -> [Located AnnotationComment]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Located AnnotationComment] -> [Located AnnotationComment])
-> Maybe [Located AnnotationComment] -> [Located AnnotationComment]
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> Map SrcSpan [Located AnnotationComment]
-> Maybe [Located AnnotationComment]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SrcSpan
noSrcSpan (ApiAnns -> Map SrcSpan [Located AnnotationComment]
forall a b. (a, b) -> b
snd ApiAnns
anns)
      , let body :: String
body = String -> String
trimCommentDelims String
comm
      , Just rest :: String
rest <- [String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix "#" (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
body]
      , let s :: String
s = String -> String
trim String
rest
    ]

-- Utility for a case insensitive prefix strip.
stripPrefixCI :: String -> String -> Maybe String
stripPrefixCI :: String -> String -> Maybe String
stripPrefixCI pref :: String
pref str :: String
str =
  let pref' :: String
pref' = String -> String
lower String
pref
      (str_pref :: String
str_pref, rest :: 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 ps :: [(Located AnnotationComment, String)]
ps =
  -- Old versions of GHC accepted 'OPTIONS' rather than 'OPTIONS_GHC' (but
  -- this is deprecated).
  [(Located AnnotationComment
c, [String]
opts) | (c :: Located AnnotationComment
c, s :: String
s) <- [(Located AnnotationComment, String)]
ps
             , Just rest :: String
rest <- [String -> String -> Maybe String
stripPrefixCI "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 "OPTIONS " String
s]
             , let opts :: [String]
opts = String -> [String]
words String
rest]

-- Language extensions. The first element of the pair is the (located)
-- annotation comment that enables the extensions enumerated by he
-- second element of the pair.
langExts :: [(Located AnnotationComment, String)]
         -> [(Located AnnotationComment, [String])]
langExts :: [(Located AnnotationComment, String)]
-> [(Located AnnotationComment, [String])]
langExts ps :: [(Located AnnotationComment, String)]
ps =
  [(Located AnnotationComment
c, [String]
exts) | (c :: Located AnnotationComment
c, s :: String
s) <- [(Located AnnotationComment, String)]
ps
             , Just rest :: String
rest <- [String -> String -> Maybe String
stripPrefixCI "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
rest)]

-- Given a list of flags, make a GHC options pragma.
mkFlags :: SrcSpan -> [String] -> Located AnnotationComment
mkFlags :: SrcSpan -> [String] -> Located AnnotationComment
mkFlags loc :: SrcSpan
loc flags :: [String]
flags =
  SrcSpan
-> SrcSpanLess (Located AnnotationComment)
-> Located AnnotationComment
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
LL SrcSpan
loc (SrcSpanLess (Located AnnotationComment)
 -> Located AnnotationComment)
-> SrcSpanLess (Located AnnotationComment)
-> Located AnnotationComment
forall a b. (a -> b) -> a -> b
$ String -> AnnotationComment
AnnBlockComment ("{-# " String -> String -> String
forall a. [a] -> [a] -> [a]
++ "OPTIONS_GHC " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
flags String -> String -> String
forall a. [a] -> [a] -> [a]
++ " #-}")

mkLangExts :: SrcSpan -> [String] -> Located AnnotationComment
mkLangExts :: SrcSpan -> [String] -> Located AnnotationComment
mkLangExts loc :: SrcSpan
loc exts :: [String]
exts =
  SrcSpan
-> SrcSpanLess (Located AnnotationComment)
-> Located AnnotationComment
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
LL SrcSpan
loc (SrcSpanLess (Located AnnotationComment)
 -> Located AnnotationComment)
-> SrcSpanLess (Located AnnotationComment)
-> Located AnnotationComment
forall a b. (a -> b) -> a -> b
$ String -> AnnotationComment
AnnBlockComment ("{-# " String -> String -> String
forall a. [a] -> [a] -> [a]
++ "LANGUAGE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ", " [String]
exts String -> String -> String
forall a. [a] -> [a] -> [a]
++ " #-}")