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

    -- | 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.Maybe (listToMaybe)
    import qualified Data.Text as T
    import Ormolu.Parser.CommentStream
    import Ormolu.Parser.Pragma (Pragma (..))
    import Ormolu.Printer.Combinators
    import Ormolu.Printer.Comments
    import SrcLoc

    -- | 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
    /= :: PragmaTy -> PragmaTy -> Bool
    $c/= :: PragmaTy -> PragmaTy -> Bool
    == :: PragmaTy -> PragmaTy -> Bool
    $c== :: 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
    min :: PragmaTy -> PragmaTy -> PragmaTy
    $cmin :: PragmaTy -> PragmaTy -> PragmaTy
    max :: PragmaTy -> PragmaTy -> PragmaTy
    $cmax :: PragmaTy -> PragmaTy -> PragmaTy
    >= :: PragmaTy -> PragmaTy -> Bool
    $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
    compare :: PragmaTy -> PragmaTy -> Ordering
    $ccompare :: PragmaTy -> PragmaTy -> Ordering
    $cp1Ord :: Eq 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
      = -- | 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
    /= :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
    $c/= :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
    == :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
    $c== :: 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
    min :: LanguagePragmaClass -> LanguagePragmaClass -> LanguagePragmaClass
    $cmin :: LanguagePragmaClass -> LanguagePragmaClass -> LanguagePragmaClass
    max :: LanguagePragmaClass -> LanguagePragmaClass -> LanguagePragmaClass
    $cmax :: LanguagePragmaClass -> LanguagePragmaClass -> LanguagePragmaClass
    >= :: LanguagePragmaClass -> LanguagePragmaClass -> Bool
    $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
    compare :: LanguagePragmaClass -> LanguagePragmaClass -> Ordering
    $ccompare :: LanguagePragmaClass -> LanguagePragmaClass -> Ordering
    $cp1Ord :: Eq 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 ps :: [([RealLocated Comment], Pragma)]
    ps = do
      let prepare :: [([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], (PragmaTy, String))]
    prepare = (([RealLocated Comment], (PragmaTy, String)) -> (PragmaTy, String))
    -> [([RealLocated Comment], (PragmaTy, String))]
    -> [([RealLocated Comment], (PragmaTy, String))]
    forall b a. Ord b => (a -> b) -> [a] -> [a]
    L.sortOn ([RealLocated Comment], (PragmaTy, String)) -> (PragmaTy, String)
    forall a b. (a, b) -> b
    snd ([([RealLocated Comment], (PragmaTy, String))]
     -> [([RealLocated Comment], (PragmaTy, String))])
    -> ([([RealLocated Comment], Pragma)]
        -> [([RealLocated Comment], (PragmaTy, String))])
    -> [([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], (PragmaTy, String))]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [([RealLocated Comment], (PragmaTy, String))]
    -> [([RealLocated Comment], (PragmaTy, String))]
    forall a. Eq a => [a] -> [a]
    L.nub ([([RealLocated Comment], (PragmaTy, String))]
     -> [([RealLocated Comment], (PragmaTy, String))])
    -> ([([RealLocated Comment], Pragma)]
        -> [([RealLocated Comment], (PragmaTy, String))])
    -> [([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], (PragmaTy, String))]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (([RealLocated Comment], Pragma)
     -> [([RealLocated Comment], (PragmaTy, String))])
    -> [([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], (PragmaTy, String))]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ([RealLocated Comment], Pragma)
    -> [([RealLocated Comment], (PragmaTy, String))]
    forall a. (a, Pragma) -> [(a, (PragmaTy, String))]
    analyze
          analyze :: (a, Pragma) -> [(a, (PragmaTy, String))]
    analyze = \case
            (cs :: a
    cs, PragmaLanguage xs :: [String]
    xs) ->
              let f :: String -> (a, (PragmaTy, String))
    f x :: String
    x = (a
    cs, (LanguagePragmaClass -> PragmaTy
    Language (String -> LanguagePragmaClass
    classifyLanguagePragma String
    x), String
    x))
               in String -> (a, (PragmaTy, String))
    f (String -> (a, (PragmaTy, String)))
    -> [String] -> [(a, (PragmaTy, String))]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [String]
    xs
            (cs :: a
    cs, PragmaOptionsGHC x :: String
    x) -> [(a
    cs, (PragmaTy
    OptionsGHC, String
    x))]
            (cs :: a
    cs, PragmaOptionsHaddock x :: String
    x) -> [(a
    cs, (PragmaTy
    OptionsHaddock, String
    x))]
      [([RealLocated Comment], (PragmaTy, String))]
    -> (([RealLocated Comment], (PragmaTy, String)) -> R ()) -> R ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ ([([RealLocated Comment], Pragma)]
    -> [([RealLocated Comment], (PragmaTy, String))]
    prepare [([RealLocated Comment], Pragma)]
    ps) ((([RealLocated Comment], (PragmaTy, String)) -> R ()) -> R ())
    -> (([RealLocated Comment], (PragmaTy, String)) -> R ()) -> R ()
    forall a b. (a -> b) -> a -> b
    $ \(cs :: [RealLocated Comment]
    cs, (pragmaTy :: PragmaTy
    pragmaTy, x :: String
    x)) ->
        [RealLocated Comment] -> PragmaTy -> String -> R ()
    p_pragma [RealLocated Comment]
    cs PragmaTy
    pragmaTy String
    x

    p_pragma :: [RealLocated Comment] -> PragmaTy -> String -> R ()
    p_pragma :: [RealLocated Comment] -> PragmaTy -> String -> R ()
    p_pragma comments :: [RealLocated Comment]
    comments ty :: PragmaTy
    ty x :: String
    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 l :: RealSrcSpan
    l comment :: Comment
    comment) -> do
        RealSrcSpan -> Comment -> R ()
    spitCommentNow RealSrcSpan
    l Comment
    comment
        R ()
    newline
      Text -> R ()
    txt "{-# "
      Text -> R ()
    txt (Text -> R ()) -> Text -> R ()
    forall a b. (a -> b) -> a -> b
    $ case PragmaTy
    ty of
        Language _ -> "LANGUAGE"
        OptionsGHC -> "OPTIONS_GHC"
        OptionsHaddock -> "OPTIONS_HADDOCK"
      R ()
    space
      Text -> R ()
    txt (String -> Text
    T.pack String
    x)
      Text -> R ()
    txt " #-}"
      R ()
    newline

    -- | Classify a 'LanguagePragma'.
    classifyLanguagePragma :: String -> LanguagePragmaClass
    classifyLanguagePragma :: String -> LanguagePragmaClass
    classifyLanguagePragma = \case
      "ImplicitPrelude" -> LanguagePragmaClass
    Final
      "CUSKs" -> LanguagePragmaClass
    Final
      str :: String
    str ->
        case Int -> String -> (String, String)
    forall a. Int -> [a] -> ([a], [a])
    splitAt 2 String
    str of
          ("No", rest :: String
    rest) ->
            case String -> Maybe Char
    forall a. [a] -> Maybe a
    listToMaybe String
    rest of
              Nothing -> LanguagePragmaClass
    Normal
              Just x :: Char
    x ->
                if Char -> Bool
    isUpper Char
    x
                  then LanguagePragmaClass
    Disabling
                  else LanguagePragmaClass
    Normal
          _ -> LanguagePragmaClass
    Normal