    {-# 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 qualified Data.List as L
    import Data.Set (Set)
    import qualified Data.Set as Set
    import Data.Text (Text)
    import qualified Data.Text 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 :: [([RealLocated Comment], Pragma)] -> R ()
    p_pragmas :: [([RealLocated Comment], Pragma)] -> R ()
    p_pragmas [([RealLocated Comment], Pragma)]
    ps = do
      let prepare :: [([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], (PragmaTy, Text))]
    prepare = (([RealLocated Comment], (PragmaTy, Text)) -> (PragmaTy, Text))
    -> [([RealLocated Comment], (PragmaTy, Text))]
    -> [([RealLocated Comment], (PragmaTy, Text))]
    forall b a. Ord b => (a -> b) -> [a] -> [a]
    L.sortOn ([RealLocated Comment], (PragmaTy, Text)) -> (PragmaTy, Text)
    forall a b. (a, b) -> b
    snd ([([RealLocated Comment], (PragmaTy, Text))]
     -> [([RealLocated Comment], (PragmaTy, Text))])
    -> ([([RealLocated Comment], Pragma)]
        -> [([RealLocated Comment], (PragmaTy, Text))])
    -> [([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], (PragmaTy, Text))]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [([RealLocated Comment], (PragmaTy, Text))]
    -> [([RealLocated Comment], (PragmaTy, Text))]
    forall a. Eq a => [a] -> [a]
    L.nub ([([RealLocated Comment], (PragmaTy, Text))]
     -> [([RealLocated Comment], (PragmaTy, Text))])
    -> ([([RealLocated Comment], Pragma)]
        -> [([RealLocated Comment], (PragmaTy, Text))])
    -> [([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], (PragmaTy, Text))]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (([RealLocated Comment], Pragma)
     -> [([RealLocated Comment], (PragmaTy, Text))])
    -> [([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], (PragmaTy, Text))]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ([RealLocated Comment], Pragma)
    -> [([RealLocated Comment], (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))]
      [([RealLocated Comment], (PragmaTy, Text))]
    -> (([RealLocated Comment], (PragmaTy, Text)) -> R ()) -> R ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ ([([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], (PragmaTy, Text))]
    prepare [([RealLocated Comment], Pragma)]
    ps) ((([RealLocated Comment], (PragmaTy, Text)) -> R ()) -> R ())
    -> (([RealLocated Comment], (PragmaTy, Text)) -> R ()) -> R ()
    forall a b. (a -> b) -> a -> b
    $ \([RealLocated Comment]
    cs, (PragmaTy
    pragmaTy, Text
    x)) ->
        [RealLocated Comment] -> PragmaTy -> Text -> R ()
    p_pragma [RealLocated Comment]
    cs PragmaTy
    pragmaTy Text
    x

    p_pragma :: [RealLocated Comment] -> PragmaTy -> Text -> R ()
    p_pragma :: [RealLocated Comment] -> PragmaTy -> Text -> R ()
    p_pragma [RealLocated Comment]
    comments PragmaTy
    ty Text
    x = do
      [RealLocated Comment] -> (RealLocated Comment -> R ()) -> R ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [RealLocated Comment]
    comments ((RealLocated Comment -> R ()) -> R ())
    -> (RealLocated Comment -> 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]