module Language.Haskell.Stylish.Step.LanguagePragmas
( Style (..)
, step
, addLanguagePragma
) where
import qualified Data.Set as S
import qualified Language.Haskell.Exts as H
import Language.Haskell.Stylish.Block
import Language.Haskell.Stylish.Editor
import Language.Haskell.Stylish.Step
import Language.Haskell.Stylish.Util
data Style
= Vertical
| Compact
| CompactLine
deriving (Eq, Show)
pragmas :: H.Module l -> [(l, [String])]
pragmas (H.Module _ _ ps _ _) =
[(l, map nameToString names) | H.LanguagePragma l names <- ps]
pragmas _ = []
firstLocation :: [(Block a, [String])] -> Int
firstLocation = minimum . map (blockStart . fst)
verticalPragmas :: String -> Int -> Bool -> [String] -> Lines
verticalPragmas lg longest align pragmas' =
[ "{-# " ++ lg ++ " " ++ pad pragma ++ " #-}"
| pragma <- pragmas'
]
where
pad
| align = padRight longest
| otherwise = id
compactPragmas :: String -> Maybe Int -> [String] -> Lines
compactPragmas lg columns pragmas' = wrapMaybe columns ("{-# " ++ lg) 13 $
map (++ ",") (init pragmas') ++ [last pragmas' ++ " #-}"]
compactLinePragmas :: String -> Maybe Int -> Bool -> [String] -> Lines
compactLinePragmas _ _ _ [] = []
compactLinePragmas lg columns align pragmas' = map (wrapLanguage . pad) prags
where
wrapLanguage ps = "{-# " ++ lg ++ ps ++ " #-}"
maxWidth = fmap (\c -> c - 16) columns
longest = maximum $ map length prags
pad
| align = padRight longest
| otherwise = id
prags = map truncateComma $ wrapMaybe maxWidth "" 1 $
map (++ ",") (init pragmas') ++ [last pragmas']
truncateComma :: String -> String
truncateComma "" = ""
truncateComma xs
| last xs == ',' = init xs
| otherwise = xs
prettyPragmas :: String -> Maybe Int -> Int -> Bool -> Style -> [String] -> Lines
prettyPragmas lp _ longest align Vertical = verticalPragmas lp longest align
prettyPragmas lp cols _ _ Compact = compactPragmas lp cols
prettyPragmas lp cols _ align CompactLine = compactLinePragmas lp cols align
filterRedundant :: (String -> Bool)
-> [(l, [String])]
-> [(l, [String])]
filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, [])
where
filterRedundant' (l, xs) (known, zs)
| S.null xs' = (known', zs)
| otherwise = (known', (l, S.toAscList xs') : zs)
where
fxs = filter (not . isRedundant') xs
xs' = S.fromList fxs `S.difference` known
known' = xs' `S.union` known
step :: Maybe Int -> Style -> Bool -> Bool -> String -> Step
step = ((((makeStep "LanguagePragmas" .) .) .) .) . step'
step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines
step' columns style align removeRedundant lngPrefix ls (module', _)
| null pragmas' = ls
| otherwise = applyChanges changes ls
where
isRedundant'
| removeRedundant = isRedundant module'
| otherwise = const False
pragmas' = pragmas $ fmap linesFromSrcSpan module'
longest = maximum $ map length $ snd =<< pragmas'
groups = [(b, concat pgs) | (b, pgs) <- groupAdjacent pragmas']
changes =
[ change b (const $ prettyPragmas lngPrefix columns longest align style pg)
| (b, pg) <- filterRedundant isRedundant' groups
]
addLanguagePragma :: String -> String -> H.Module H.SrcSpanInfo -> [Change String]
addLanguagePragma lg prag modu
| prag `elem` present = []
| otherwise = [insert line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"]]
where
pragmas' = pragmas (fmap linesFromSrcSpan modu)
present = concatMap snd pragmas'
line = if null pragmas' then 1 else firstLocation pragmas'
isRedundant :: H.Module H.SrcSpanInfo -> String -> Bool
isRedundant m "ViewPatterns" = isRedundantViewPatterns m
isRedundant m "BangPatterns" = isRedundantBangPatterns m
isRedundant _ _ = False
isRedundantViewPatterns :: H.Module H.SrcSpanInfo -> Bool
isRedundantViewPatterns m = null
[() | H.PViewPat {} <- everything m :: [H.Pat H.SrcSpanInfo]]
isRedundantBangPatterns :: H.Module H.SrcSpanInfo -> Bool
isRedundantBangPatterns m = null
[() | H.PBangPat _ _ <- everything m :: [H.Pat H.SrcSpanInfo]]