{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Pretty-printing of language pragmas.
module Ormolu.Printer.Meat.Pragma
  ( p_pragmas,
  )
where

import Control.Monad
import Data.Char (isUpper)
import Data.List qualified as L
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Driver.Flags (Language)
import GHC.Types.SrcLoc
import Ormolu.Parser.CommentStream
import Ormolu.Parser.Pragma (Pragma (..))
import Ormolu.Printer.Combinators hiding (Placement (..))
import Ormolu.Printer.Comments

-- | Pragma classification.
data PragmaTy
  = Language LanguagePragmaClass
  | OptionsGHC
  | OptionsHaddock
  deriving (PragmaTy -> PragmaTy -> Bool
(PragmaTy -> PragmaTy -> Bool)
-> (PragmaTy -> PragmaTy -> Bool) -> Eq PragmaTy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PragmaTy -> PragmaTy -> Bool
== :: PragmaTy -> PragmaTy -> Bool
$c/= :: PragmaTy -> PragmaTy -> Bool
/= :: PragmaTy -> PragmaTy -> Bool
Eq, Eq PragmaTy
Eq PragmaTy =>
(PragmaTy -> PragmaTy -> Ordering)
-> (PragmaTy -> PragmaTy -> Bool)
-> (PragmaTy -> PragmaTy -> Bool)
-> (PragmaTy -> PragmaTy -> Bool)
-> (PragmaTy -> PragmaTy -> Bool)
-> (PragmaTy -> PragmaTy -> PragmaTy)
-> (PragmaTy -> PragmaTy -> PragmaTy)
-> Ord PragmaTy
PragmaTy -> PragmaTy -> Bool
PragmaTy -> PragmaTy -> Ordering
PragmaTy -> PragmaTy -> PragmaTy
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PragmaTy -> PragmaTy -> Ordering
compare :: PragmaTy -> PragmaTy -> Ordering
$c< :: PragmaTy -> PragmaTy -> Bool
< :: PragmaTy -> PragmaTy -> Bool
$c<= :: PragmaTy -> PragmaTy -> Bool
<= :: PragmaTy -> PragmaTy -> Bool
$c> :: PragmaTy -> PragmaTy -> Bool
> :: PragmaTy -> PragmaTy -> Bool
$c>= :: PragmaTy -> PragmaTy -> Bool
>= :: PragmaTy -> PragmaTy -> Bool
$cmax :: PragmaTy -> PragmaTy -> PragmaTy
max :: PragmaTy -> PragmaTy -> PragmaTy
$cmin :: PragmaTy -> PragmaTy -> PragmaTy
min :: PragmaTy -> PragmaTy -> PragmaTy
Ord)

-- | Language pragma classification.
--
-- The order in which language pragmas are put in the input sometimes
-- matters. This is because some language extensions can enable other
-- extensions, yet the extensions coming later in the list have the ability
-- to change it. So here we classify all extensions by assigning one of the
-- four groups to them. Then we only sort inside of the groups.
--
-- 'Ord' instance of this data type is what affects the sorting.
--
-- See also: <https://github.com/tweag/ormolu/issues/404>
data LanguagePragmaClass
  = -- | A pack of extensions like @GHC2021@ or @Haskell2010@
    ExtensionPack
  | -- | All other extensions
    Normal
  | -- | Extensions starting with "No"
    Disabling
  | -- | Extensions that should go after everything else
    Final
  deriving (LanguagePragmaClass -> LanguagePragmaClass -> Bool
(LanguagePragmaClass -> LanguagePragmaClass -> Bool)
-> (LanguagePragmaClass -> LanguagePragmaClass -> Bool)
-> Eq LanguagePragmaClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
== :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
$c/= :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
/= :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
Eq, Eq LanguagePragmaClass
Eq LanguagePragmaClass =>
(LanguagePragmaClass -> LanguagePragmaClass -> Ordering)
-> (LanguagePragmaClass -> LanguagePragmaClass -> Bool)
-> (LanguagePragmaClass -> LanguagePragmaClass -> Bool)
-> (LanguagePragmaClass -> LanguagePragmaClass -> Bool)
-> (LanguagePragmaClass -> LanguagePragmaClass -> Bool)
-> (LanguagePragmaClass
    -> LanguagePragmaClass -> LanguagePragmaClass)
-> (LanguagePragmaClass
    -> LanguagePragmaClass -> LanguagePragmaClass)
-> Ord LanguagePragmaClass
LanguagePragmaClass -> LanguagePragmaClass -> Bool
LanguagePragmaClass -> LanguagePragmaClass -> Ordering
LanguagePragmaClass -> LanguagePragmaClass -> LanguagePragmaClass
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LanguagePragmaClass -> LanguagePragmaClass -> Ordering
compare :: LanguagePragmaClass -> LanguagePragmaClass -> Ordering
$c< :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
< :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
$c<= :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
<= :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
$c> :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
> :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
$c>= :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
>= :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
$cmax :: LanguagePragmaClass -> LanguagePragmaClass -> LanguagePragmaClass
max :: LanguagePragmaClass -> LanguagePragmaClass -> LanguagePragmaClass
$cmin :: LanguagePragmaClass -> LanguagePragmaClass -> LanguagePragmaClass
min :: LanguagePragmaClass -> LanguagePragmaClass -> LanguagePragmaClass
Ord)

-- | Print a collection of 'Pragma's with their associated comments.
p_pragmas :: [([LComment], Pragma)] -> R ()
p_pragmas :: [([LComment], Pragma)] -> R ()
p_pragmas [([LComment], Pragma)]
ps = do
  let prepare :: [([LComment], Pragma)] -> [([LComment], (PragmaTy, Text))]
prepare = (([LComment], (PragmaTy, Text)) -> (PragmaTy, Text))
-> [([LComment], (PragmaTy, Text))]
-> [([LComment], (PragmaTy, Text))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn ([LComment], (PragmaTy, Text)) -> (PragmaTy, Text)
forall a b. (a, b) -> b
snd ([([LComment], (PragmaTy, Text))]
 -> [([LComment], (PragmaTy, Text))])
-> ([([LComment], Pragma)] -> [([LComment], (PragmaTy, Text))])
-> [([LComment], Pragma)]
-> [([LComment], (PragmaTy, Text))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([LComment], (PragmaTy, Text))]
-> [([LComment], (PragmaTy, Text))]
forall a. Eq a => [a] -> [a]
L.nub ([([LComment], (PragmaTy, Text))]
 -> [([LComment], (PragmaTy, Text))])
-> ([([LComment], Pragma)] -> [([LComment], (PragmaTy, Text))])
-> [([LComment], Pragma)]
-> [([LComment], (PragmaTy, Text))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([LComment], Pragma) -> [([LComment], (PragmaTy, Text))])
-> [([LComment], Pragma)] -> [([LComment], (PragmaTy, Text))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([LComment], Pragma) -> [([LComment], (PragmaTy, Text))]
forall {a}. (a, Pragma) -> [(a, (PragmaTy, Text))]
analyze
      analyze :: (a, Pragma) -> [(a, (PragmaTy, Text))]
analyze = \case
        (a
cs, PragmaLanguage [Text]
xs) ->
          let f :: Text -> (a, (PragmaTy, Text))
f Text
x = (a
cs, (LanguagePragmaClass -> PragmaTy
Language (Text -> LanguagePragmaClass
classifyLanguagePragma Text
x), Text
x))
           in Text -> (a, (PragmaTy, Text))
f (Text -> (a, (PragmaTy, Text)))
-> [Text] -> [(a, (PragmaTy, Text))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
xs
        (a
cs, PragmaOptionsGHC Text
x) -> [(a
cs, (PragmaTy
OptionsGHC, Text
x))]
        (a
cs, PragmaOptionsHaddock Text
x) -> [(a
cs, (PragmaTy
OptionsHaddock, Text
x))]
  [([LComment], (PragmaTy, Text))]
-> (([LComment], (PragmaTy, Text)) -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([([LComment], Pragma)] -> [([LComment], (PragmaTy, Text))]
prepare [([LComment], Pragma)]
ps) ((([LComment], (PragmaTy, Text)) -> R ()) -> R ())
-> (([LComment], (PragmaTy, Text)) -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \([LComment]
cs, (PragmaTy
pragmaTy, Text
x)) ->
    [LComment] -> PragmaTy -> Text -> R ()
p_pragma [LComment]
cs PragmaTy
pragmaTy Text
x

p_pragma :: [LComment] -> PragmaTy -> Text -> R ()
p_pragma :: [LComment] -> PragmaTy -> Text -> R ()
p_pragma [LComment]
comments PragmaTy
ty Text
x = do
  [LComment] -> (LComment -> R ()) -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [LComment]
comments ((LComment -> R ()) -> R ()) -> (LComment -> R ()) -> R ()
forall a b. (a -> b) -> a -> b
$ \(L RealSrcSpan
l Comment
comment) -> do
    RealSrcSpan -> Comment -> R ()
spitCommentNow RealSrcSpan
l Comment
comment
    R ()
newline
  Text -> R ()
txt Text
"{-# "
  Text -> R ()
txt (Text -> R ()) -> Text -> R ()
forall a b. (a -> b) -> a -> b
$ case PragmaTy
ty of
    Language LanguagePragmaClass
_ -> Text
"LANGUAGE"
    PragmaTy
OptionsGHC -> Text
"OPTIONS_GHC"
    PragmaTy
OptionsHaddock -> Text
"OPTIONS_HADDOCK"
  R ()
space
  Text -> R ()
txt Text
x
  Text -> R ()
txt Text
" #-}"
  R ()
newline

-- | Classify a 'LanguagePragma'.
classifyLanguagePragma :: Text -> LanguagePragmaClass
classifyLanguagePragma :: Text -> LanguagePragmaClass
classifyLanguagePragma = \case
  Text
str | Text
str Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
extensionPacks -> LanguagePragmaClass
ExtensionPack
  Text
"ImplicitPrelude" -> LanguagePragmaClass
Final
  Text
"CUSKs" -> LanguagePragmaClass
Final
  Text
str ->
    case Int -> Text -> (Text, Text)
T.splitAt Int
2 Text
str of
      (Text
"No", Text
rest) ->
        case Text -> Maybe (Char, Text)
T.uncons Text
rest of
          Maybe (Char, Text)
Nothing -> LanguagePragmaClass
Normal
          Just (Char
x, Text
_) ->
            if Char -> Bool
isUpper Char
x
              then LanguagePragmaClass
Disabling
              else LanguagePragmaClass
Normal
      (Text, Text)
_ -> LanguagePragmaClass
Normal

-- | Extension packs, like @GHC2021@ and @Haskell2010@.
extensionPacks :: Set Text
extensionPacks :: Set Text
extensionPacks =
  [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> (Language -> String) -> Language -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> String
forall a. Show a => a -> String
show (Language -> Text) -> [Language] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Language
forall a. Bounded a => a
minBound :: Language .. Language
forall a. Bounded a => a
maxBound]