{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Ormolu.Printer.Meat.Pragma
( p_pragmas,
)
where
import Data.Char (isUpper)
import Data.Maybe (listToMaybe)
import qualified Data.Set as S
import qualified Data.Text as T
import Ormolu.Parser.Pragma (Pragma (..))
import Ormolu.Printer.Combinators
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)
data LanguagePragmaClass
=
Normal
|
Disabling
|
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)
p_pragmas :: [Pragma] -> R ()
p_pragmas :: [Pragma] -> R ()
p_pragmas ps :: [Pragma]
ps =
let prepare :: [Pragma] -> [(PragmaTy, String)]
prepare = (Pragma -> [(PragmaTy, String)])
-> [Pragma] -> [(PragmaTy, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Pragma -> [(PragmaTy, String)])
-> [Pragma] -> [(PragmaTy, String)])
-> (Pragma -> [(PragmaTy, String)])
-> [Pragma]
-> [(PragmaTy, String)]
forall a b. (a -> b) -> a -> b
$ \case
PragmaLanguage xs :: [String]
xs ->
let f :: String -> (PragmaTy, String)
f x :: String
x = (LanguagePragmaClass -> PragmaTy
Language (String -> LanguagePragmaClass
classifyLanguagePragma String
x), String
x)
in String -> (PragmaTy, String)
f (String -> (PragmaTy, String)) -> [String] -> [(PragmaTy, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs
PragmaOptionsGHC x :: String
x -> [(PragmaTy
OptionsGHC, String
x)]
PragmaOptionsHaddock x :: String
x -> [(PragmaTy
OptionsHaddock, String
x)]
in ((PragmaTy, String) -> R ()) -> [(PragmaTy, String)] -> R ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((PragmaTy -> String -> R ()) -> (PragmaTy, String) -> R ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PragmaTy -> String -> R ()
p_pragma) (Set (PragmaTy, String) -> [(PragmaTy, String)]
forall a. Set a -> [a]
S.toAscList (Set (PragmaTy, String) -> [(PragmaTy, String)])
-> ([Pragma] -> Set (PragmaTy, String))
-> [Pragma]
-> [(PragmaTy, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PragmaTy, String)] -> Set (PragmaTy, String)
forall a. Ord a => [a] -> Set a
S.fromList ([(PragmaTy, String)] -> Set (PragmaTy, String))
-> ([Pragma] -> [(PragmaTy, String)])
-> [Pragma]
-> Set (PragmaTy, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pragma] -> [(PragmaTy, String)]
prepare ([Pragma] -> [(PragmaTy, String)])
-> [Pragma] -> [(PragmaTy, String)]
forall a b. (a -> b) -> a -> b
$ [Pragma]
ps)
p_pragma :: PragmaTy -> String -> R ()
p_pragma :: PragmaTy -> String -> R ()
p_pragma ty :: PragmaTy
ty c :: String
c = do
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
c)
Text -> R ()
txt " #-}"
R ()
newline
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