{-# LANGUAGE CPP #-}

-- | Pragma-related functions.
module HIndent.Pragma
  ( extractPragmasFromCode
  , extractPragmaNameAndElement
  , pragmaExists
  , isPragma
  ) where

import Data.Bifunctor
import Data.Char
import Data.Generics
import Data.List
import Data.List.Split
import Data.Maybe
import GHC.Hs
import GHC.Parser.Lexer
import HIndent.GhcLibParserWrapper.GHC.Hs
import HIndent.Parse
import Text.Regex.TDFA hiding (empty)

-- | Extracts all pragmas from the given source code.
--
-- FIXME: The function is slow because it lexicographically analyzes the
-- given source code. An alternative way is to use regular expressions.
-- However, this method cannot determine if what appears to be a pragma is
-- really a pragma, or requires complex regular expressions. For example,
-- @{-\n\n{-# LANGUAGE CPP #-}\n\n-}@ is not a pragma, but is likely to be
-- recognized as such.
extractPragmasFromCode :: String -> [(String, String)] -- ^ [(Pragma's name (e.g., @"LANGUAGE"@), Pragma's element (e.g., @"CPP, DerivingVia"@))]
extractPragmasFromCode :: String -> [(String, String)]
extractPragmasFromCode =
  (String -> Maybe (String, String))
-> [String] -> [(String, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (String, String)
extractPragmaNameAndElement ([String] -> [(String, String)])
-> (String -> [String]) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Maybe String) -> [Token] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Token -> Maybe String
extractBlockComment ([Token] -> [String]) -> (String -> [Token]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> [Token]
String -> [Token]
lexCode
  where
    extractBlockComment :: Token -> Maybe String
extractBlockComment (ITblockComment String
c PsSpan
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
c
    extractBlockComment Token
_ = Maybe String
forall a. Maybe a
Nothing

-- | Extracts the pragma's name and its element from the given pragma.
--
-- This function returns a 'Nothing' if it fails to extract them.
extractPragmaNameAndElement :: String -> Maybe (String, String) -- ^ [(Pragma's name (e.g., @"LANGUAGE"@), Pragma's element (e.g., @"CPP, DerivingVia"@))]
extractPragmaNameAndElement :: String -> Maybe (String, String)
extractPragmaNameAndElement String
l
  | (String
_, String
_, String
_, [String
name, String
element]) <-
      Regex -> String -> (String, String, String, [String])
forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
pragmaRegex String
l :: (String, String, String, [String]) =
    (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
name, String
element)
extractPragmaNameAndElement String
_ = Maybe (String, String)
forall a. Maybe a
Nothing

-- | This function returns a 'True' if the passed 'EpaCommentTok' is
-- a pragma. Otherwise, it returns a 'False'.
isPragma :: EpaCommentTok -> Bool
isPragma :: EpaCommentTok -> Bool
isPragma (EpaBlockComment String
c) = Regex -> String -> Bool
forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
pragmaRegex String
c
isPragma EpaCommentTok
_ = Bool
False

-- | A regex to match against a pragma.
pragmaRegex :: Regex
pragmaRegex :: Regex
pragmaRegex =
  CompOption -> ExecOption -> String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts
    CompOption
compOption
    ExecOption
execOption
    String
"^{-#[[:space:]]*([^[:space:]]+)[[:space:]]+([^#]+)#-}"

-- | The option for matching against a pragma.
execOption :: ExecOption
execOption :: ExecOption
execOption = ExecOption {captureGroups :: Bool
captureGroups = Bool
True}

-- | The option for matching against a pragma.
--
-- 'multiline' is set to 'False' to match against multiline pragmas, e.g.,
-- @{-# LANGUAGE CPP\nOverloadedStrings #-}@.
compOption :: CompOption
compOption :: CompOption
compOption =
  CompOption
    { caseSensitive :: Bool
caseSensitive = Bool
True
    , multiline :: Bool
multiline = Bool
False
    , rightAssoc :: Bool
rightAssoc = Bool
True
    , newSyntax :: Bool
newSyntax = Bool
True
    , lastStarGreedy :: Bool
lastStarGreedy = Bool
True
    }

-- | This function returns a 'True' if the module has pragmas.
-- Otherwise, it returns a 'False'.
pragmaExists :: HsModule' -> Bool
pragmaExists :: HsModule' -> Bool
pragmaExists = Bool -> Bool
not (Bool -> Bool) -> (HsModule' -> Bool) -> HsModule' -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> (HsModule' -> [String]) -> HsModule' -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule' -> [String]
collectPragmas

-- | This function collects pragma comments from the
-- given module and modifies them into 'String's.
--
-- A pragma's name is converted to the @SHOUT_CASE@ (e.g., @lAnGuAgE@ ->
-- @LANGUAGE@).
collectPragmas :: HsModule' -> [String]
collectPragmas :: HsModule' -> [String]
collectPragmas =
  ((String, [String]) -> 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) -> (String, [String]) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> [String] -> String
constructPragma)
    ([(String, [String])] -> [String])
-> (HsModule' -> [(String, [String])]) -> HsModule' -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EpaCommentTok -> Maybe (String, [String]))
-> [EpaCommentTok] -> [(String, [String])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe EpaCommentTok -> Maybe (String, [String])
extractPragma
    ([EpaCommentTok] -> [(String, [String])])
-> (HsModule' -> [EpaCommentTok])
-> HsModule'
-> [(String, [String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EpaCommentTok -> Bool) -> GenericQ [EpaCommentTok]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify EpaCommentTok -> Bool
isBlockComment
    (EpAnn AnnsModule -> [EpaCommentTok])
-> (HsModule' -> EpAnn AnnsModule) -> HsModule' -> [EpaCommentTok]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule' -> EpAnn AnnsModule
getModuleAnn

-- | This function returns a 'Just' value with the pragma
-- extracted from the passed 'EpaCommentTok' if it has one. Otherwise, it
-- returns a 'Nothing'.
extractPragma :: EpaCommentTok -> Maybe (String, [String])
extractPragma :: EpaCommentTok -> Maybe (String, [String])
extractPragma (EpaBlockComment String
c) =
  (String -> [String]) -> (String, String) -> (String, [String])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((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
strip ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
",") ((String, String) -> (String, [String]))
-> Maybe (String, String) -> Maybe (String, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe (String, String)
extractPragmaNameAndElement String
c
  where
    strip :: String -> String
strip = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
extractPragma EpaCommentTok
_ = Maybe (String, [String])
forall a. Maybe a
Nothing

-- | Construct a pragma.
constructPragma :: String -> [String] -> String
constructPragma :: String -> [String] -> String
constructPragma String
optionOrPragma [String]
xs =
  String
"{-# " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toUpper String
optionOrPragma String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" #-}"

-- | Checks if the given comment is a block one.
isBlockComment :: EpaCommentTok -> Bool
isBlockComment :: EpaCommentTok -> Bool
isBlockComment EpaBlockComment {} = Bool
True
isBlockComment EpaCommentTok
_ = Bool
False