module HIndent.Ast.FileHeaderPragma
  ( FileHeaderPragma
  , mkFileHeaderPragma
  ) where

import Data.Bifunctor
import Data.Char
import Data.List
import Data.List.Split
import qualified GHC.Hs as GHC
import HIndent.Ast.NodeComments
import HIndent.Pragma
import HIndent.Pretty
import HIndent.Pretty.Combinators
import HIndent.Pretty.NodeComments

newtype FileHeaderPragma =
  FileHeaderPragma String

instance CommentExtraction FileHeaderPragma where
  nodeComments :: FileHeaderPragma -> NodeComments
nodeComments FileHeaderPragma
_ = [LEpaComment] -> [LEpaComment] -> [LEpaComment] -> NodeComments
NodeComments [] [] []

instance Pretty FileHeaderPragma where
  pretty' :: FileHeaderPragma -> Printer ()
pretty' (FileHeaderPragma String
x) = HasCallStack => String -> Printer ()
String -> Printer ()
string String
x

mkFileHeaderPragma :: GHC.EpaCommentTok -> Maybe FileHeaderPragma
mkFileHeaderPragma :: EpaCommentTok -> Maybe FileHeaderPragma
mkFileHeaderPragma =
  ((String, [String]) -> FileHeaderPragma)
-> Maybe (String, [String]) -> Maybe FileHeaderPragma
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> FileHeaderPragma
FileHeaderPragma (String -> FileHeaderPragma)
-> ((String, [String]) -> String)
-> (String, [String])
-> FileHeaderPragma
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> String) -> (String, [String]) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> [String] -> String
constructPragma) (Maybe (String, [String]) -> Maybe FileHeaderPragma)
-> (EpaCommentTok -> Maybe (String, [String]))
-> EpaCommentTok
-> Maybe FileHeaderPragma
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpaCommentTok -> Maybe (String, [String])
extractPragma

-- | This function returns a 'Just' value with the pragma
-- extracted from the passed 'EpaCommentTok' if it has one. Otherwise, it
-- returns a 'Nothing'.
extractPragma :: GHC.EpaCommentTok -> Maybe (String, [String])
extractPragma :: EpaCommentTok -> Maybe (String, [String])
extractPragma (GHC.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
" #-}"