--------------------------------------------------------------------------------
{-# LANGUAGE BlockArguments    #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.Stylish.Step.LanguagePragmas
    ( Style (..)
    , step
      -- * Utilities
    , addLanguagePragma
    ) where


--------------------------------------------------------------------------------
import           Data.List.NonEmpty              (NonEmpty, fromList, toList)
import qualified Data.Set                        as S


--------------------------------------------------------------------------------
import qualified GHC.Hs                          as GHC
import qualified GHC.Types.SrcLoc                as GHC


--------------------------------------------------------------------------------
import           Language.Haskell.Stylish.Block
import qualified Language.Haskell.Stylish.Editor as Editor
import           Language.Haskell.Stylish.Module
import           Language.Haskell.Stylish.Step
import           Language.Haskell.Stylish.Util


--------------------------------------------------------------------------------
data Style
    = Vertical
    | Compact
    | CompactLine
    | VerticalCompact
    deriving (Style -> Style -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c== :: Style -> Style -> Bool
Eq, Int -> Style -> ShowS
[Style] -> ShowS
Style -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Style] -> ShowS
$cshowList :: [Style] -> ShowS
show :: Style -> String
$cshow :: Style -> String
showsPrec :: Int -> Style -> ShowS
$cshowsPrec :: Int -> Style -> ShowS
Show)


--------------------------------------------------------------------------------
verticalPragmas :: String -> Int -> Bool -> [String] -> Lines
verticalPragmas :: String -> Int -> Bool -> Lines -> Lines
verticalPragmas String
lg Int
longest Bool
align Lines
pragmas' =
    [ String
"{-# " forall a. [a] -> [a] -> [a]
++ String
lg forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ ShowS
pad String
pragma forall a. [a] -> [a] -> [a]
++ String
" #-}"
    | String
pragma <- Lines
pragmas'
    ]
  where
    pad :: ShowS
pad
      | Bool
align = Int -> ShowS
padRight Int
longest
      | Bool
otherwise = forall a. a -> a
id


--------------------------------------------------------------------------------
compactPragmas :: String -> Maybe Int -> [String] -> Lines
compactPragmas :: String -> Maybe Int -> Lines -> Lines
compactPragmas String
lg Maybe Int
columns Lines
pragmas' = Maybe Int -> String -> Int -> Lines -> Lines
wrapMaybe Maybe Int
columns (String
"{-# " forall a. [a] -> [a] -> [a]
++ String
lg) Int
13 forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a] -> [a]
++ String
",") (forall a. [a] -> [a]
init Lines
pragmas') forall a. [a] -> [a] -> [a]
++ [forall a. [a] -> a
last Lines
pragmas' forall a. [a] -> [a] -> [a]
++ String
" #-}"]


--------------------------------------------------------------------------------
compactLinePragmas :: String -> Maybe Int -> Bool -> [String] -> Lines
compactLinePragmas :: String -> Maybe Int -> Bool -> Lines -> Lines
compactLinePragmas String
_  Maybe Int
_ Bool
_ [] = []
compactLinePragmas String
lg Maybe Int
columns Bool
align Lines
pragmas' = forall a b. (a -> b) -> [a] -> [b]
map (ShowS
wrapLanguage forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
pad) Lines
prags
  where
    wrapLanguage :: ShowS
wrapLanguage String
ps = String
"{-# " forall a. [a] -> [a] -> [a]
++ String
lg forall a. [a] -> [a] -> [a]
++ String
ps forall a. [a] -> [a] -> [a]
++  String
" #-}"
    maxWidth :: Maybe Int
maxWidth = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
c -> Int
c forall a. Num a => a -> a -> a
- Int
16) Maybe Int
columns
    longest :: Int
longest  = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length Lines
prags
    pad :: ShowS
pad
      | Bool
align = Int -> ShowS
padRight Int
longest
      | Bool
otherwise = forall a. a -> a
id
    prags :: Lines
prags = forall a b. (a -> b) -> [a] -> [b]
map ShowS
truncateComma forall a b. (a -> b) -> a -> b
$ Maybe Int -> String -> Int -> Lines -> Lines
wrapMaybe Maybe Int
maxWidth String
"" Int
1 forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a] -> [a]
++ String
",") (forall a. [a] -> [a]
init Lines
pragmas') forall a. [a] -> [a] -> [a]
++ [forall a. [a] -> a
last Lines
pragmas']


--------------------------------------------------------------------------------
verticalCompactPragmas :: String -> [String] -> Lines
verticalCompactPragmas :: String -> Lines -> Lines
verticalCompactPragmas String
lg Lines
pragmas' =
  [ String
"{-# " forall a. Semigroup a => a -> a -> a
<> String
lg
  , String
"    " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> a
head Lines
pragmas'
  ]
  forall a. Semigroup a => a -> a -> a
<> [ String
"  , "  forall a. Semigroup a => a -> a -> a
<> String
pragma | String
pragma <- forall a. [a] -> [a]
tail Lines
pragmas']
  forall a. Semigroup a => a -> a -> a
<> [ String
"  #-}"]


--------------------------------------------------------------------------------
truncateComma :: String -> String
truncateComma :: ShowS
truncateComma String
""     = String
""
truncateComma String
xs
    | forall a. [a] -> a
last String
xs forall a. Eq a => a -> a -> Bool
== Char
',' = forall a. [a] -> [a]
init String
xs
    | Bool
otherwise      = String
xs


--------------------------------------------------------------------------------
prettyPragmas :: String -> Maybe Int -> Int -> Bool -> Style -> [String] -> Lines
prettyPragmas :: String -> Maybe Int -> Int -> Bool -> Style -> Lines -> Lines
prettyPragmas String
lp Maybe Int
_    Int
longest Bool
align Style
Vertical        = String -> Int -> Bool -> Lines -> Lines
verticalPragmas String
lp Int
longest Bool
align
prettyPragmas String
lp Maybe Int
cols Int
_       Bool
_     Style
Compact         = String -> Maybe Int -> Lines -> Lines
compactPragmas String
lp Maybe Int
cols
prettyPragmas String
lp Maybe Int
cols Int
_       Bool
align Style
CompactLine     = String -> Maybe Int -> Bool -> Lines -> Lines
compactLinePragmas String
lp Maybe Int
cols Bool
align
prettyPragmas String
lp Maybe Int
_    Int
_       Bool
_     Style
VerticalCompact = String -> Lines -> Lines
verticalCompactPragmas String
lp


--------------------------------------------------------------------------------
-- | Filter redundant (and duplicate) pragmas out of the groups. As a side
-- effect, we also sort the pragmas in their group...
filterRedundant :: (String -> Bool)
                -> [(l, NonEmpty String)]
                -> [(l, [String])]
filterRedundant :: forall l.
(String -> Bool) -> [(l, NonEmpty String)] -> [(l, Lines)]
filterRedundant String -> Bool
isRedundant' = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}.
(a, Lines)
-> (Set String, [(a, Lines)]) -> (Set String, [(a, Lines)])
filterRedundant' (forall a. Set a
S.empty, []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. NonEmpty a -> [a]
toList)
  where
    filterRedundant' :: (a, Lines)
-> (Set String, [(a, Lines)]) -> (Set String, [(a, Lines)])
filterRedundant' (a
l, Lines
xs) (Set String
known, [(a, Lines)]
zs)
        | forall a. Set a -> Bool
S.null Set String
xs' = (Set String
known', [(a, Lines)]
zs)
        | Bool
otherwise  = (Set String
known', (a
l, forall a. Set a -> [a]
S.toAscList Set String
xs') forall a. a -> [a] -> [a]
: [(a, Lines)]
zs)
      where
        fxs :: Lines
fxs    = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isRedundant') Lines
xs
        xs' :: Set String
xs'    = forall a. Ord a => [a] -> Set a
S.fromList Lines
fxs forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set String
known
        known' :: Set String
known' = Set String
xs' forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set String
known

--------------------------------------------------------------------------------
step :: Maybe Int -> Style -> Bool -> Bool -> String -> Step
step :: Maybe Int -> Style -> Bool -> Bool -> String -> Step
step = ((((String -> (Lines -> Module -> Lines) -> Step
makeStep String
"LanguagePragmas" forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int
-> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines
step'


--------------------------------------------------------------------------------
step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines
step' :: Maybe Int
-> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines
step' Maybe Int
columns Style
style Bool
align Bool
removeRedundant String
lngPrefix Lines
ls Module
m
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RealSrcSpan, NonEmpty String)]
languagePragmas = Lines
ls
  | Bool
otherwise = Edits -> Lines -> Lines
Editor.apply Edits
changes Lines
ls
  where
    isRedundant' :: String -> Bool
isRedundant'
        | Bool
removeRedundant = Module -> String -> Bool
isRedundant Module
m
        | Bool
otherwise       = forall a b. a -> b -> a
const Bool
False

    languagePragmas :: [(RealSrcSpan, NonEmpty String)]
languagePragmas = Module -> [(RealSrcSpan, NonEmpty String)]
moduleLanguagePragmas Module
m

    convertFstToBlock :: [(GHC.RealSrcSpan, a)] -> [(Block String, a)]
    convertFstToBlock :: forall a. [(RealSrcSpan, a)] -> [(Block String, a)]
convertFstToBlock = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \(RealSrcSpan
rspan, a
a) ->
      (forall a. Int -> Int -> Block a
Block (RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
rspan) (RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
rspan), a
a)

    groupAdjacent' :: [(Block a, NonEmpty a)] -> [(Block a, NonEmpty a)]
groupAdjacent' =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {t :: * -> *} {a} {a}.
Foldable t =>
(a, t [a]) -> (a, NonEmpty a)
turnSndBackToNel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(Block a, b)] -> [(Block a, [b])]
groupAdjacent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. NonEmpty a -> [a]
toList)
      where
        turnSndBackToNel :: (a, t [a]) -> (a, NonEmpty a)
turnSndBackToNel (a
a, t [a]
bss) = (a
a, forall a. [a] -> NonEmpty a
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ t [a]
bss)

    longest :: Int
    longest :: Int
longest  = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(RealSrcSpan, NonEmpty String)]
languagePragmas

    groups :: [(Block String, NonEmpty String)]
    groups :: [(Block String, NonEmpty String)]
groups = [(Block String
b, NonEmpty String
pgs) | (Block String
b, NonEmpty String
pgs) <- forall {a} {a}. [(Block a, NonEmpty a)] -> [(Block a, NonEmpty a)]
groupAdjacent' (forall a. [(RealSrcSpan, a)] -> [(Block String, a)]
convertFstToBlock [(RealSrcSpan, NonEmpty String)]
languagePragmas)]

    changes :: Edits
changes = forall a. Monoid a => [a] -> a
mconcat
      [ Block String -> (Lines -> Lines) -> Edits
Editor.changeLines Block String
b (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ String -> Maybe Int -> Int -> Bool -> Style -> Lines -> Lines
prettyPragmas String
lngPrefix Maybe Int
columns Int
longest Bool
align Style
style Lines
pg)
      | (Block String
b, Lines
pg) <- forall l.
(String -> Bool) -> [(l, NonEmpty String)] -> [(l, Lines)]
filterRedundant String -> Bool
isRedundant' [(Block String, NonEmpty String)]
groups
      ]


--------------------------------------------------------------------------------
-- | Add a LANGUAGE pragma to a module if it is not present already.
addLanguagePragma :: String -> String -> Module -> Editor.Edits
addLanguagePragma :: String -> String -> Module -> Edits
addLanguagePragma String
lg String
prag Module
modu
    | String
prag forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Lines
present = forall a. Monoid a => a
mempty
    | Bool
otherwise           = Int -> Lines -> Edits
Editor.insertLines Int
line [String
"{-# " forall a. [a] -> [a] -> [a]
++ String
lg forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
prag forall a. [a] -> [a] -> [a]
++ String
" #-}"]
  where
    pragmas' :: [(RealSrcSpan, NonEmpty String)]
pragmas'      = Module -> [(RealSrcSpan, NonEmpty String)]
moduleLanguagePragmas Module
modu
    present :: Lines
present       = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. NonEmpty a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(RealSrcSpan, NonEmpty String)]
pragmas'
    line :: Int
line          = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RealSrcSpan, NonEmpty String)]
pragmas' then Int
1 else [(RealSrcSpan, NonEmpty String)] -> Int
firstLocation [(RealSrcSpan, NonEmpty String)]
pragmas'
    firstLocation :: [(GHC.RealSrcSpan, NonEmpty String)] -> Int
    firstLocation :: [(RealSrcSpan, NonEmpty String)] -> Int
firstLocation = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealSrcLoc -> Int
GHC.srcLocLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> RealSrcLoc
GHC.realSrcSpanStart forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)


--------------------------------------------------------------------------------
-- | Check if a language pragma is redundant. We can't do this for all pragmas,
-- but we do a best effort.
isRedundant :: Module -> String -> Bool
isRedundant :: Module -> String -> Bool
isRedundant Module
m String
"ViewPatterns" = Module -> Bool
isRedundantViewPatterns Module
m
isRedundant Module
m String
"BangPatterns" = Module -> Bool
isRedundantBangPatterns Module
m
isRedundant Module
_ String
_              = Bool
False


--------------------------------------------------------------------------------
-- | Check if the ViewPatterns language pragma is redundant.
isRedundantViewPatterns :: Module -> Bool
isRedundantViewPatterns :: Module -> Bool
isRedundantViewPatterns = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Typeable a => (a -> [b]) -> Module -> [b]
queryModule Pat GhcPs -> [()]
getViewPat
  where
    getViewPat :: GHC.Pat GHC.GhcPs -> [()]
    getViewPat :: Pat GhcPs -> [()]
getViewPat = \case
      GHC.ViewPat{} -> [()]
      Pat GhcPs
_             -> []


--------------------------------------------------------------------------------
-- | Check if the BangPatterns language pragma is redundant.
isRedundantBangPatterns :: Module -> Bool
isRedundantBangPatterns :: Module -> Bool
isRedundantBangPatterns Module
modul =
    (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a b. Typeable a => (a -> [b]) -> Module -> [b]
queryModule Pat GhcPs -> [()]
getBangPat Module
modul) Bool -> Bool -> Bool
&&
    (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a b. Typeable a => (a -> [b]) -> Module -> [b]
queryModule Match GhcPs (LHsExpr GhcPs) -> [()]
getMatchStrict Module
modul)
  where
    getBangPat :: GHC.Pat GHC.GhcPs -> [()]
    getBangPat :: Pat GhcPs -> [()]
getBangPat = \case
      GHC.BangPat{} -> [()]
      Pat GhcPs
_             -> []

    getMatchStrict :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> [()]
    getMatchStrict :: Match GhcPs (LHsExpr GhcPs) -> [()]
getMatchStrict (GHC.Match XCMatch GhcPs (LHsExpr GhcPs)
_ HsMatchContext GhcPs
ctx [LPat GhcPs]
_ GRHSs GhcPs (LHsExpr GhcPs)
_) = case HsMatchContext GhcPs
ctx of
      GHC.FunRhs LIdP (NoGhcTc GhcPs)
_ LexicalFixity
_ SrcStrictness
GHC.SrcStrict -> [()]
      HsMatchContext GhcPs
_                            -> []