-- | Pretty-printing pragmas
module HIndent.Pretty.Pragma
  ( prettyPragmas
  , pragmaExists
  , isPragma
  ) where

import Data.Bifunctor
import Data.Char
import Data.Generics.Schemes
import Data.List
import Data.List.Split
import Data.Maybe
import GHC.Hs
import HIndent.Pragma
import HIndent.Pretty.Combinators.Lineup
import HIndent.Pretty.Combinators.String
import HIndent.Printer
import Text.Regex.TDFA

-- | This function pretty-prints the module's pragmas
prettyPragmas :: HsModule -> Printer ()
prettyPragmas :: HsModule -> Printer ()
prettyPragmas = [Printer ()] -> Printer ()
lined ([Printer ()] -> Printer ())
-> (HsModule -> [Printer ()]) -> HsModule -> Printer ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Printer ()) -> [String] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HasCallStack => String -> Printer ()
String -> Printer ()
string ([String] -> [Printer ()])
-> (HsModule -> [String]) -> HsModule -> [Printer ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule -> [String]
collectPragmas

-- | 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
matchToComment (EpAnn AnnsModule -> [EpaCommentTok])
-> (HsModule -> EpAnn AnnsModule) -> HsModule -> [EpaCommentTok]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule -> EpAnn AnnsModule
hsmodAnn
  where
    matchToComment :: EpaCommentTok -> Bool
    matchToComment :: EpaCommentTok -> Bool
matchToComment EpaBlockComment {} = Bool
True
    matchToComment EpaCommentTok
_ = Bool
False
    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
" #-}"

-- | 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

-- | 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