stylish-haskell-0.14.3.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.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 Text.Regex.TDFA (Regex)
import qualified Text.Regex.TDFA as 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
forM_ (GHC.ideclPkgQual decl) $ \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.ideclHiding 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.ideclHiding 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.RdrName -> 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
Nothing -> 0
Just 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 = maybe False fst . GHC.ideclHiding
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