stylish-haskell-0.14.5.0: lib/Language/Haskell/Stylish/Step/Imports.hs
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Language.Haskell.Stylish.Step.Imports
( Options (..)
, defaultOptions
, ImportAlign (..)
, ListAlign (..)
, LongListAlign (..)
, EmptyListAlign (..)
, ListPadding (..)
, GroupRule (..)
, step
, printImport
, parsePattern
, unsafeParsePattern
) where
--------------------------------------------------------------------------------
import Control.Monad (forM_, void, when)
import qualified Data.Aeson as A
import Data.Foldable (toList)
import Data.Function (on, (&))
import Data.Functor (($>))
import Data.List (groupBy, intercalate,
partition, sortBy, sortOn)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.Sequence (Seq ((:|>)))
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified GHC.Data.FastString as GHC
import qualified GHC.Hs as GHC
import qualified GHC.Types.Name.Reader as GHC
import qualified GHC.Types.PkgQual as GHC
import qualified GHC.Types.SourceText as GHC
import qualified GHC.Types.SrcLoc as GHC
--import qualified GHC.Unit.Module.Name as GHC
--import qualified GHC.Unit.Types as GHC
import qualified Text.Regex.TDFA as Regex
import Text.Regex.TDFA (Regex)
import Text.Regex.TDFA.ReadRegex (parseRegex)
--------------------------------------------------------------------------------
import Language.Haskell.Stylish.Block
import qualified Language.Haskell.Stylish.Editor as Editor
import Language.Haskell.Stylish.Module
import Language.Haskell.Stylish.Ordering
import Language.Haskell.Stylish.Printer
import Language.Haskell.Stylish.Step
import Language.Haskell.Stylish.Util
--------------------------------------------------------------------------------
data Options = Options
{ importAlign :: ImportAlign
, listAlign :: ListAlign
, padModuleNames :: Bool
, longListAlign :: LongListAlign
, emptyListAlign :: EmptyListAlign
, listPadding :: ListPadding
, separateLists :: Bool
, spaceSurround :: Bool
, postQualified :: Bool
, groupImports :: Bool
, groupRules :: [GroupRule]
} deriving (Eq, Show)
defaultOptions :: Options
defaultOptions = Options
{ importAlign = Global
, listAlign = AfterAlias
, padModuleNames = True
, longListAlign = Inline
, emptyListAlign = Inherit
, listPadding = LPConstant 4
, separateLists = True
, spaceSurround = False
, postQualified = False
, groupImports = False
, groupRules = [defaultGroupRule]
}
where defaultGroupRule = GroupRule
{ match = unsafeParsePattern ".*"
, subGroup = Just $ unsafeParsePattern "^[^.]+"
}
data ListPadding
= LPConstant Int
| LPModuleName
deriving (Eq, Show)
data ImportAlign
= Global
| File
| Group
| None
deriving (Eq, Show)
data ListAlign
= NewLine
| WithModuleName
| WithAlias
| AfterAlias
| Repeat
deriving (Eq, Show)
data EmptyListAlign
= Inherit
| RightAfter
deriving (Eq, Show)
data LongListAlign
= Inline -- inline
| InlineWithBreak -- new_line
| InlineToMultiline -- new_line_multiline
| Multiline -- multiline
deriving (Eq, Show)
-- | A rule for grouping imports that specifies which module names
-- belong in a group and (optionally) how to break them up into
-- sub-groups.
--
-- See the documentation for the group_rules setting in
-- data/stylish-haskell.yaml for more details.
data GroupRule = GroupRule
{ match :: Pattern
-- ^ The pattern that determines whether a rule applies to a
-- module name.
, subGroup :: Maybe Pattern
-- ^ An optional pattern for breaking the group up into smaller
-- sub-groups.
} deriving (Show, Eq)
instance A.FromJSON GroupRule where
parseJSON = A.withObject "group_rule" parse
where parse o = GroupRule
<$> (o A..: "match")
<*> (o A..:? "sub_group")
-- | A compiled regular expression. Provides instances that 'Regex'
-- does not have (eg 'Show', 'Eq' and 'FromJSON').
--
-- Construct with 'parsePattern' to maintain the invariant that
-- 'string' is the exact regex string used to compile 'regex'.
data Pattern = Pattern
{ regex :: Regex
-- ^ The compiled regular expression.
, string :: String
-- ^ The valid regex string that 'regex' was compiled from.
}
instance Show Pattern where show = show . string
instance Eq Pattern where (==) = (==) `on` string
instance A.FromJSON Pattern where
parseJSON = A.withText "regex" parse
where parse text = case parsePattern $ T.unpack text of
Left err -> fail $ "Invalid regex:\n" <> err
Right pat -> pure pat
-- | Parse a string into a compiled regular expression ('Pattern').
--
-- Returns a human-readable parse error message if the string is not
-- valid regex syntax.
--
-- >>> parsePattern "^([^.]+)"
-- Right "^([^.]+)"
--
-- >>> parsePattern "("
-- Left "\"(\" (line 1, column 2):\nunexpected end of input\nexpecting empty () or anchor ^ or $ or an atom"
parsePattern :: String -> Either String Pattern
parsePattern string = case parseRegex string of
Right _ -> Right $ Pattern { string, regex = Regex.makeRegex string }
Left err -> Left (show err)
-- | Parse a string into a regular expression, raising a runtime
-- exception if the string is not valid regex syntax.
--
-- >>> unsafeParsePattern "^([^.]+)"
-- "^([^.]+)"
--
-- >>> unsafeParsePattern "("
-- "*** Exception: "(" (line 1, column 2):
-- unexpected end of input
-- expecting empty () or anchor ^ or $ or an atom
unsafeParsePattern :: String -> Pattern
unsafeParsePattern = either error id . parsePattern
--------------------------------------------------------------------------------
step :: Maybe Int -> Options -> Step
step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns
--------------------------------------------------------------------------------
printImports :: Maybe Int -> Options -> Lines -> Module -> Lines
printImports maxCols options ls m = Editor.apply changes ls
where
groups = moduleImportGroups m
moduleStats = foldMap importStats . fmap GHC.unLoc $ concatMap toList groups
changes
| groupImports options =
groupAndFormat maxCols options moduleStats groups
| otherwise =
foldMap (formatGroup maxCols options moduleStats) groups
formatGroup
:: Maybe Int -> Options -> ImportStats
-> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Editor.Edits
formatGroup maxCols options moduleStats imports =
let newLines = formatImports maxCols options moduleStats imports in
Editor.changeLines (importBlock imports) (const newLines)
importBlock :: NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Block String
importBlock group = Block
(GHC.srcSpanStartLine . src $ NonEmpty.head group)
(GHC.srcSpanEndLine . src $ NonEmpty.last group)
where
src = fromMaybe (error "importBlock: missing location") .
GHC.srcSpanToRealSrcSpan . GHC.getLocA
formatImports
:: Maybe Int -- ^ Max columns.
-> Options -- ^ Options.
-> ImportStats -- ^ Module stats.
-> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Lines
formatImports maxCols options moduleStats rawGroup =
runPrinter_ (PrinterConfig maxCols) do
let
group :: NonEmpty (GHC.LImportDecl GHC.GhcPs)
group
= NonEmpty.sortBy (compareImports `on` GHC.unLoc) rawGroup
& mergeImports
unLocatedGroup = fmap GHC.unLoc $ toList group
align' = importAlign options
padModuleNames' = padModuleNames options
padNames = align' /= None && padModuleNames'
stats = case align' of
Global -> moduleStats {isAnyQualified = True}
File -> moduleStats
Group -> foldMap importStats unLocatedGroup
None -> mempty
forM_ group \imp -> printQualified options padNames stats imp >> newline
--------------------------------------------------------------------------------
-- | Reorganize imports into groups based on 'groupPatterns', then
-- format each group as specified by the rest of 'Options'.
--
-- Note: this will discard blank lines and comments inside the imports
-- section.
groupAndFormat
:: Maybe Int
-> Options
-> ImportStats
-> [NonEmpty (GHC.LImportDecl GHC.GhcPs)]
-> Editor.Edits
groupAndFormat _ _ _ [] = mempty
groupAndFormat maxCols options moduleStats groups =
Editor.changeLines block (const regroupedLines)
where
regroupedLines :: Lines
regroupedLines = intercalate [""] $
map (formatImports maxCols options moduleStats) grouped
grouped :: [NonEmpty (GHC.LImportDecl GHC.GhcPs)]
grouped = groupByRules (groupRules options) imports
imports :: [GHC.LImportDecl GHC.GhcPs]
imports = concatMap toList groups
-- groups is non-empty by the pattern for this case
-- imports is non-empty as long as groups is non-empty
block = Block
(GHC.srcSpanStartLine . src $ head imports)
(GHC.srcSpanEndLine . src $ last imports)
src = fromMaybe (error "regroupImports: missing location") .
GHC.srcSpanToRealSrcSpan . GHC.getLocA
-- | Group imports based on a list of patterns.
--
-- See the documentation for @group_patterns@ in
-- @data/stylish-haskell.yaml@ for details about the patterns and
-- grouping logic.
groupByRules
:: [GroupRule]
-- ^ The patterns specifying the groups to build. Order matters:
-- earlier patterns take precedence over later ones.
-> [GHC.LImportDecl GHC.GhcPs]
-- ^ The imports to group. Order does not matter.
-> [NonEmpty (GHC.LImportDecl GHC.GhcPs)]
groupByRules rules allImports = toList $ go rules allImports Seq.empty
where
go :: [GroupRule]
-> [GHC.LImportDecl GHC.GhcPs]
-> Seq (NonEmpty (GHC.LImportDecl GHC.GhcPs))
-> Seq (NonEmpty (GHC.LImportDecl GHC.GhcPs))
go [] [] groups = groups
go [] imports groups = groups :|> NonEmpty.fromList imports
go (r : rs) imports groups =
let
(groups', rest) = extract r imports
in
go rs rest (groups <> groups')
extract :: GroupRule
-> [GHC.LImportDecl GHC.GhcPs]
-> ( Seq (NonEmpty (GHC.LImportDecl GHC.GhcPs))
, [GHC.LImportDecl GHC.GhcPs]
)
extract GroupRule { match, subGroup } imports =
let
(matched, rest) = partition (matches match) imports
subgroups = groupBy ((==) `on` firstMatch subGroup) $
sortOn (firstMatch subGroup) matched
in
-- groupBy never produces empty groups, so this mapMaybe will
-- not discard anything from subgroups
(Seq.fromList $ mapMaybe NonEmpty.nonEmpty subgroups, rest)
matches :: Pattern -> GHC.LImportDecl GHC.GhcPs -> Bool
matches Pattern { regex } import_ = Regex.match regex $ moduleName import_
firstMatch :: Maybe Pattern -> GHC.LImportDecl GHC.GhcPs -> String
firstMatch (Just Pattern { regex }) import_ =
Regex.match regex $ moduleName import_
firstMatch Nothing _ =
"" -- constant grouping key, so everything will be grouped together
moduleName = importModuleName . GHC.unLoc
--------------------------------------------------------------------------------
printQualified
:: Options -> Bool -> ImportStats -> GHC.LImportDecl GHC.GhcPs -> P ()
printQualified Options{..} padNames stats ldecl = do
putText "import" >> space
case (isSource decl, isAnySource stats) of
(True, _) -> putText "{-# SOURCE #-}" >> space
(_, True) -> putText " " >> space
_ -> pure ()
when (GHC.ideclSafe decl) (putText "safe" >> space)
let module_ = do
moduleNamePosition <- length <$> getCurrentLine
case GHC.ideclPkgQual decl of
GHC.NoRawPkgQual -> pure ()
GHC.RawPkgQual pkg -> putText (stringLiteral pkg) >> space
putText (importModuleName decl)
-- Only print spaces if something follows.
let somethingFollows =
isJust (GHC.ideclAs decl) || isHiding decl ||
not (null $ GHC.ideclImportList decl)
when (padNames && somethingFollows) $ putText $ replicate
(isLongestImport stats - importModuleNameLength decl)
' '
pure moduleNamePosition
moduleNamePosition <-
case (postQualified, isQualified decl, isAnyQualified stats) of
(False, True , _ ) -> putText "qualified" *> space *> module_
(False, _ , True) -> putText " " *> space *> module_
(True , True , _ ) -> module_ <* space <* putText "qualified"
_ -> module_
beforeAliasPosition <- length <$> getCurrentLine
forM_ (GHC.ideclAs decl) $ \lname -> do
space >> putText "as" >> space
putText . GHC.moduleNameString $ GHC.unLoc lname
afterAliasPosition <- length <$> getCurrentLine
when (isHiding decl) (space >> putText "hiding")
let putOffset = putText $ replicate offset ' '
offset = case listPadding of
LPConstant n -> n
LPModuleName -> moduleNamePosition
pure ()
case snd <$> GHC.ideclImportList decl of
Nothing -> pure ()
Just limports | null (GHC.unLoc limports) -> case emptyListAlign of
RightAfter -> modifyCurrentLine trimRight >> space >> putText "()"
Inherit -> case listAlign of
NewLine -> do
modifyCurrentLine trimRight
newline >> putOffset >> putText "()"
_ -> space >> putText "()"
Just limports -> do
let imports = GHC.unLoc limports
printedImports = flagEnds $ -- [P ()]
(printImport separateLists) . GHC.unLoc <$>
prepareImportList imports
-- Since we might need to output the import module name several times, we
-- need to save it to a variable:
wrapPrefix <- case listAlign of
AfterAlias -> pure $ replicate (afterAliasPosition + 1) ' '
WithAlias -> pure $ replicate (beforeAliasPosition + 1) ' '
Repeat -> fmap (++ " (") getCurrentLine
WithModuleName -> pure $ replicate (moduleNamePosition + offset) ' '
NewLine -> pure $ replicate offset ' '
-- Helper
let doSpaceSurround = when spaceSurround space
-- Try to put everything on one line.
let printAsSingleLine = forM_ printedImports $ \(imp, start, end) -> do
when start $ putText "(" >> doSpaceSurround
imp
if end then doSpaceSurround >> putText ")" else comma >> space
-- Try to put everything one by one, wrapping if that fails.
let printAsInlineWrapping wprefix = forM_ printedImports $
\(imp, start, end) ->
patchForRepeatHiding $ wrapping
(do
if start then putText "(" >> doSpaceSurround else space
imp
if end then doSpaceSurround >> putText ")" else comma)
(do
case listAlign of
-- In 'Repeat' mode, end lines with ')' rather than ','.
Repeat | not start -> modifyCurrentLine . withLast $
\c -> if c == ',' then ')' else c
_ | start && spaceSurround ->
-- Only necessary if spaceSurround is enabled.
modifyCurrentLine trimRight
_ -> pure ()
newline
void wprefix
case listAlign of
-- '(' already included in repeat
Repeat -> pure ()
-- Print the much needed '('
_ | start -> putText "(" >> doSpaceSurround
-- Don't bother aligning if we're not in inline mode.
_ | longListAlign /= Inline -> pure ()
-- 'Inline + AfterAlias' is really where we want to be careful
-- with spacing.
AfterAlias -> space >> doSpaceSurround
WithModuleName -> pure ()
WithAlias -> pure ()
NewLine -> pure ()
imp
if end then doSpaceSurround >> putText ")" else comma)
-- Put everything on a separate line. 'spaceSurround' can be
-- ignored.
let printAsMultiLine = forM_ printedImports $ \(imp, start, end) -> do
when start $ modifyCurrentLine trimRight -- We added some spaces.
newline
putOffset
if start then putText "( " else putText ", "
imp
when end $ newline >> putOffset >> putText ")"
case longListAlign of
Multiline -> wrapping
(space >> printAsSingleLine)
printAsMultiLine
Inline | NewLine <- listAlign -> do
modifyCurrentLine trimRight
newline >> putOffset >> printAsInlineWrapping (putText wrapPrefix)
Inline -> space >> printAsInlineWrapping (putText wrapPrefix)
InlineWithBreak -> wrapping
(space >> printAsSingleLine)
(do
modifyCurrentLine trimRight
newline >> putOffset >> printAsInlineWrapping putOffset)
InlineToMultiline -> wrapping
(space >> printAsSingleLine)
(wrapping
(do
modifyCurrentLine trimRight
newline >> putOffset >> printAsSingleLine)
printAsMultiLine)
where
decl = GHC.unLoc ldecl
-- We cannot wrap/repeat 'hiding' imports since then we would get multiple
-- imports hiding different things.
patchForRepeatHiding = case listAlign of
Repeat | isHiding decl -> withColumns Nothing
_ -> id
--------------------------------------------------------------------------------
printImport :: Bool -> GHC.IE GHC.GhcPs -> P ()
printImport _ (GHC.IEVar _ name) = do
printIeWrappedName name
printImport _ (GHC.IEThingAbs _ name) = do
printIeWrappedName name
printImport separateLists (GHC.IEThingAll _ name) = do
printIeWrappedName name
when separateLists space
putText "(..)"
printImport _ (GHC.IEModuleContents _ modu) = do
putText "module"
space
putText . GHC.moduleNameString $ GHC.unLoc modu
printImport separateLists (GHC.IEThingWith _ name wildcard imps) = do
printIeWrappedName name
when separateLists space
let ellipsis = case wildcard of
GHC.IEWildcard _position -> [putText ".."]
GHC.NoIEWildcard -> []
parenthesize $
sep (comma >> space) (ellipsis <> fmap printIeWrappedName imps)
printImport _ (GHC.IEGroup _ _ _ ) =
error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'"
printImport _ (GHC.IEDoc _ _) =
error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'"
printImport _ (GHC.IEDocNamed _ _) =
error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'"
--------------------------------------------------------------------------------
printIeWrappedName :: GHC.LIEWrappedName GHC.GhcPs -> P ()
printIeWrappedName lie = case GHC.unLoc lie of
GHC.IEName _ n -> putRdrName n
GHC.IEPattern _ n -> putText "pattern" >> space >> putRdrName n
GHC.IEType _ n -> putText "type" >> space >> putRdrName n
mergeImports
:: NonEmpty (GHC.LImportDecl GHC.GhcPs)
-> NonEmpty (GHC.LImportDecl GHC.GhcPs)
mergeImports (x :| []) = x :| []
mergeImports (h :| (t : ts))
| canMergeImport (GHC.unLoc h) (GHC.unLoc t) = mergeImports (mergeModuleImport h t :| ts)
| otherwise = h :| mergeImportsTail (t : ts)
where
mergeImportsTail (x : y : ys)
| canMergeImport (GHC.unLoc x) (GHC.unLoc y) = mergeImportsTail ((mergeModuleImport x y) : ys)
| otherwise = x : mergeImportsTail (y : ys)
mergeImportsTail xs = xs
--------------------------------------------------------------------------------
data ImportStats = ImportStats
{ isLongestImport :: !Int
, isAnySource :: !Bool
, isAnyQualified :: !Bool
, isAnySafe :: !Bool
}
instance Semigroup ImportStats where
l <> r = ImportStats
{ isLongestImport = isLongestImport l `max` isLongestImport r
, isAnySource = isAnySource l || isAnySource r
, isAnyQualified = isAnyQualified l || isAnyQualified r
, isAnySafe = isAnySafe l || isAnySafe r
}
instance Monoid ImportStats where
mappend = (<>)
mempty = ImportStats 0 False False False
importStats :: GHC.ImportDecl GHC.GhcPs -> ImportStats
importStats i =
ImportStats (importModuleNameLength i) (isSource i) (isQualified i) (GHC.ideclSafe i)
-- Computes length till module name, includes package name.
-- TODO: this should reuse code with the printer
importModuleNameLength :: GHC.ImportDecl GHC.GhcPs -> Int
importModuleNameLength imp =
(case GHC.ideclPkgQual imp of
GHC.NoRawPkgQual -> 0
GHC.RawPkgQual sl -> 1 + length (stringLiteral sl)) +
(length $ importModuleName imp)
--------------------------------------------------------------------------------
stringLiteral :: GHC.StringLiteral -> String
stringLiteral sl = case GHC.sl_st sl of
GHC.NoSourceText -> show . GHC.unpackFS $ GHC.sl_fs sl
GHC.SourceText s -> s
--------------------------------------------------------------------------------
isQualified :: GHC.ImportDecl GHC.GhcPs -> Bool
isQualified = (/=) GHC.NotQualified . GHC.ideclQualified
isHiding :: GHC.ImportDecl GHC.GhcPs -> Bool
isHiding d = case GHC.ideclImportList d of
Just (GHC.EverythingBut, _) -> True
_ -> False
isSource :: GHC.ImportDecl GHC.GhcPs -> Bool
isSource = (==) GHC.IsBoot . GHC.ideclSource
--------------------------------------------------------------------------------
-- | Cleans up an import item list.
--
-- * Sorts import items.
-- * Sort inner import lists, e.g. `import Control.Monad (Monad (return, join))`
-- * Removes duplicates from import lists.
prepareImportList :: [GHC.LIE GHC.GhcPs] -> [GHC.LIE GHC.GhcPs]
prepareImportList =
sortBy compareLIE . map (fmap prepareInner) .
concatMap (toList . snd) . Map.toAscList . mergeByName
where
mergeByName
:: [GHC.LIE GHC.GhcPs]
-> Map.Map GHC.RdrName (NonEmpty (GHC.LIE GHC.GhcPs))
mergeByName imports0 = Map.fromListWith
-- Note that ideally every NonEmpty will just have a single entry and we
-- will be able to merge everything into that entry. Exotic imports can
-- mess this up, though. So they end up in the tail of the list.
(\(x :| xs) (y :| ys) -> case ieMerge (GHC.unLoc x) (GHC.unLoc y) of
Just z -> (x $> z) :| (xs ++ ys) -- Keep source from `x`
Nothing -> x :| (xs ++ y : ys))
[(GHC.ieName $ GHC.unLoc imp, imp :| []) | imp <- imports0]
prepareInner :: GHC.IE GHC.GhcPs -> GHC.IE GHC.GhcPs
prepareInner = \case
-- Simplify `A ()` to `A`.
GHC.IEThingWith x n GHC.NoIEWildcard [] -> GHC.IEThingAbs x n
GHC.IEThingWith x n w ns ->
GHC.IEThingWith x n w (sortBy (compareWrappedName `on` GHC.unLoc) ns)
ie -> ie
-- Merge two import items, assuming they have the same name.
ieMerge :: GHC.IE GHC.GhcPs -> GHC.IE GHC.GhcPs -> Maybe (GHC.IE GHC.GhcPs)
ieMerge l@(GHC.IEVar _ _) _ = Just l
ieMerge _ r@(GHC.IEVar _ _) = Just r
ieMerge (GHC.IEThingAbs _ _) r = Just r
ieMerge l (GHC.IEThingAbs _ _) = Just l
ieMerge l@(GHC.IEThingAll _ _) _ = Just l
ieMerge _ r@(GHC.IEThingAll _ _) = Just r
ieMerge (GHC.IEThingWith x0 n0 w0 ns0) (GHC.IEThingWith _ _ w1 ns1)
| w0 /= w1 = Nothing
| otherwise = Just $
-- TODO: sort the `ns0 ++ ns1`?
GHC.IEThingWith x0 n0 w0 (nubOn GHC.lieWrappedName $ ns0 ++ ns1)
ieMerge _ _ = Nothing
--------------------------------------------------------------------------------
nubOn :: Ord k => (a -> k) -> [a] -> [a]
nubOn f = go Set.empty
where
go _ [] = []
go acc (x : xs)
| y `Set.member` acc = go acc xs
| otherwise = x : go (Set.insert y acc) xs
where
y = f x