{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
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 Data.Set (Set)
import qualified Data.Set as Set
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
data PragmaTy
= Language LanguagePragmaClass
| OptionsGHC
| OptionsHaddock
deriving (PragmaTy -> PragmaTy -> Bool
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
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
Ord)
data LanguagePragmaClass
=
ExtensionPack
|
Normal
|
Disabling
|
Final
deriving (LanguagePragmaClass -> LanguagePragmaClass -> Bool
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
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
Ord)
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, String))]
prepare = forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
L.nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. (a, Pragma) -> [(a, (PragmaTy, String))]
analyze
analyze :: (a, Pragma) -> [(a, (PragmaTy, String))]
analyze = \case
(a
cs, PragmaLanguage [String]
xs) ->
let f :: String -> (a, (PragmaTy, String))
f String
x = (a
cs, (LanguagePragmaClass -> PragmaTy
Language (String -> LanguagePragmaClass
classifyLanguagePragma String
x), String
x))
in String -> (a, (PragmaTy, String))
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs
(a
cs, PragmaOptionsGHC String
x) -> [(a
cs, (PragmaTy
OptionsGHC, String
x))]
(a
cs, PragmaOptionsHaddock String
x) -> [(a
cs, (PragmaTy
OptionsHaddock, String
x))]
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) forall a b. (a -> b) -> a -> b
$ \([RealLocated Comment]
cs, (PragmaTy
pragmaTy, 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 [RealLocated Comment]
comments PragmaTy
ty String
x = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RealLocated Comment]
comments 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 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 (String -> Text
T.pack String
x)
Text -> R ()
txt Text
" #-}"
R ()
newline
classifyLanguagePragma :: String -> LanguagePragmaClass
classifyLanguagePragma :: String -> LanguagePragmaClass
classifyLanguagePragma = \case
String
str | String
str forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
extensionPacks -> LanguagePragmaClass
ExtensionPack
String
"ImplicitPrelude" -> LanguagePragmaClass
Final
String
"CUSKs" -> LanguagePragmaClass
Final
String
str ->
case forall a. Int -> [a] -> ([a], [a])
splitAt Int
2 String
str of
(String
"No", String
rest) ->
case forall a. [a] -> Maybe a
listToMaybe String
rest of
Maybe Char
Nothing -> LanguagePragmaClass
Normal
Just Char
x ->
if Char -> Bool
isUpper Char
x
then LanguagePragmaClass
Disabling
else LanguagePragmaClass
Normal
(String, String)
_ -> LanguagePragmaClass
Normal
extensionPacks :: Set String
extensionPacks :: Set String
extensionPacks =
forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [forall a. Bounded a => a
minBound :: Language .. forall a. Bounded a => a
maxBound]