-- | Per-project 'Config' and functions to interpret it.
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-} -- sort keys only care about Ord
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
module Config where
import Control.Monad (foldM, unless)
import Data.Bifunctor (second)
import qualified Data.Char as Char
import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Text.IO as Text.IO
import qualified Data.Tuple as Tuple
import qualified Language.Haskell.Exts as Haskell
import qualified Language.Haskell.Exts.Extension as Extension
import qualified System.FilePath as FilePath
import qualified System.IO as IO
import qualified Text.PrettyPrint as PP
import Text.PrettyPrint ((<+>))
import qualified Text.Read as Read
import qualified Index
import qualified Types
import qualified Util
data Config = Config {
-- | Additional directories to search for local modules. Taken from the
-- -i flag and 'include' config line.
_includes :: [FilePath]
-- | These language extensions are enabled by default.
, _language :: [Extension.Extension]
-- | Import sort order. Used by 'formatGroups'.
, _order :: Order
-- | Heuristics to pick the right module. Used by 'pickModule'.
, _modulePriority :: Priorities
-- | Map unqualified names to the module to import for them.
, _unqualified :: Map.Map (Haskell.Name ()) Types.ModuleName
-- import-as: Data.Text.Lazy as DTL -> Map DTL Data.Text.Lazy
, _qualifyAs :: Map.Map Types.Qualification Types.Qualification
, _format :: Format
, _debug :: Bool
} deriving (Eq, Show)
data Order = Order {
_importOrder :: Priority ModulePattern
-- | Put unqualified import-all imports last.
, _sortUnqualifiedLast :: Bool
} deriving (Eq, Show)
data Priorities = Priorities {
-- | Place these packages either first or last in priority.
prioPackage :: Priority Index.Package
-- | Place these modules either first or last in priority.
, prioModule :: Priority Types.ModuleName
} deriving (Eq, Show)
instance Semigroup Priorities where
Priorities a1 b1 <> Priorities a2 b2 = Priorities (a1<>a2) (b1<>b2)
instance Monoid Priorities where
mempty = Priorities mempty mempty
data Priority a = Priority { high :: [a], low :: [a] }
deriving (Eq, Show)
instance Semigroup (Priority a) where
Priority a1 b1 <> Priority a2 b2 = Priority (a1<>a2) (b1<>b2)
instance Monoid (Priority a) where
mempty = Priority mempty mempty
data Format = Format {
-- | If true, group imports by their first component.
_groupImports :: Bool
-- | Insert space for unqualified imports to make the modules line up.
, _leaveSpaceForQualified :: Bool
-- | Number of columns to wrap to.
, _columns :: Int
} deriving (Eq, Show)
-- | A simple pattern: @M.@ matches M and M.*. Anything else matches exactly.
type ModulePattern = String
matchModule :: ModulePattern -> Types.ModuleName -> Bool
matchModule pattern (Types.ModuleName mod) = case Util.unsnoc pattern of
Nothing -> False
Just (parent, '.') -> parent == mod || pattern `List.isPrefixOf` mod
_ -> pattern == mod
empty :: Config
empty = Config
{ _includes = []
, _language = []
, _order = Order
{ _importOrder = Priority { high = [], low = [] }
, _sortUnqualifiedLast = False
}
, _modulePriority = mempty
, _unqualified = mempty
, _qualifyAs = mempty
, _format = defaultFormat
, _debug = False
}
defaultFormat :: Format
defaultFormat = Format
{ _groupImports = True
, _leaveSpaceForQualified = False
, _columns = 80
}
-- | Parse .fix-imports file.
parse :: Text -> (Config, [Text])
parse text = (config, errors)
where
commas = Text.intercalate ", "
errors = map (".fix-imports: "<>) $ concat
[ [ "duplicate fields: " <> commas duplicates | not (null duplicates) ]
, [ "unrecognized fields: " <> commas unknownFields
| not (null unknownFields)
]
, [ "unknown language extensions: " <> commas unknownLanguage
| not (null unknownLanguage)
]
, [ "unqualified: " <> commas unknownUnqualified
| not (null unknownUnqualified)
]
, [ "qualify-as: " <> commas unknownQualifyAs
| not (null unknownQualifyAs)
]
, maybe [] ((:[]) . ("format: "<>)) formatError
]
config = empty
{ _includes = getStrings "include"
, _language = language
, _order = Order
{ _importOrder = Priority
{ high = getStrings "import-order-first"
, low = getStrings "import-order-last"
}
, _sortUnqualifiedLast = getBool "sort-unqualified-last"
}
, _modulePriority = Priorities
{ prioPackage = Priority
{ high = getStrings "prio-package-high"
, low = getStrings "prio-package-low"
}
, prioModule = Priority
{ high = getModules "prio-module-high"
, low = getModules "prio-module-low"
}
}
, _unqualified = Map.fromList $ map Tuple.swap unqualified
, _format = format
, _qualifyAs = qualifyAs
}
(unknownUnqualified, unqualified) = Either.partitionEithers $
parseUnqualified (Text.unwords (get "unqualified"))
(unknownLanguage, language) = parseLanguage (get "language")
(unknownQualifyAs, qualifyAs) =
parseQualifyAs $ Text.unwords $ get "qualify-as"
(format, formatError) = case parseFormat (get "format") of
Right format -> (format, Nothing)
Left err -> (defaultFormat, Just err)
unknownFields = Map.keys fields List.\\ valid
valid =
[ "format"
, "import-order-first", "import-order-last"
, "include"
, "language"
, "prio-module-high", "prio-module-low"
, "prio-package-high", "prio-package-low"
, "qualify-as"
, "sort-unqualified-last"
, "unqualified"
]
fields = Map.fromList sections
sections = Index.parseSections text
duplicates = map head $ filter ((>1) . length) $ List.group $ List.sort $
map fst sections
getModules = map (Types.ModuleName . Text.unpack) . get
get k = Map.findWithDefault [] k fields
getStrings = map Text.unpack . get
getBool k = k `Map.member` fields
parseFormat :: [Text] -> Either Text Format
parseFormat = foldM set defaultFormat
where
set fmt "leave-space-for-qualified" = Right $
fmt { _leaveSpaceForQualified = True }
set fmt "no-group" = Right $ fmt { _groupImports = False }
set fmt w | Just cols <- Text.stripPrefix "columns=" w =
case Read.readMaybe (Text.unpack cols) of
Nothing -> Left $ "non-numeric: " <> w
Just cols -> Right $ fmt { _columns = cols }
set _ w = Left $ "unrecognized word: " <> showt w
-- |
-- "A.B(c); Q(r)" -> [Right ("A.B", "c"), Right ("Q", "r")]
parseUnqualified :: Text
-> [Either Text (Types.ModuleName, Haskell.Name ())]
parseUnqualified = concatMap (parse . Text.break (=='(')) . Text.splitOn ";"
where
parse (pre, post)
| Text.null pre && Text.null post = []
| Text.null pre = [Left $ "no module name before " <> showt post]
| Text.null post = [Left $ "no import after " <> showt pre]
| Just imports <- hasParens post =
map (parseUnqualifiedImport (Text.strip pre))
(map Text.strip (Text.splitOn "," imports))
| otherwise = [Left $ "expected parens: " <> showt post]
-- |
-- "A.B" "(c)" -> (Haskell.Ident () "c", "A.B")
-- "A.B" "((+))" -> (Haskell.Symbol () "+", "A.B")
parseUnqualifiedImport :: Text -> Text
-> Either Text (Types.ModuleName, Haskell.Name ())
parseUnqualifiedImport pre post = do
unless (Text.all isModuleChar pre) $
Left $ "this doesn't look like a module name: " <> showt pre
let module_ = Types.ModuleName (Text.unpack pre)
case hasParens post of
Just op
| Text.all Util.haskellOpChar op ->
Right (module_, Haskell.Symbol () (Text.unpack op))
| otherwise -> Left $ "non-symbols in operator: " <> showt post
Nothing
| Text.all (not . Util.haskellOpChar) post ->
Right (module_, Haskell.Ident () (Text.unpack post))
| otherwise ->
Left $ "symbol char in id, use parens: " <> showt post
where
isModuleChar c = Char.isLetter c || Char.isDigit c || c == '.'
-- |
-- "A.B as AB; C as E" -> [("AB", "A.B"), ("E", "C")]
parseQualifyAs :: Text
-> ([Text], Map.Map Types.Qualification Types.Qualification)
parseQualifyAs field
| Text.null field = ([], mempty)
| otherwise = second Map.fromList . Either.partitionEithers
. map (parse . Text.words) . Text.splitOn ";" $ field
where
parse [module_, "as", alias] = Right
( Types.Qualification (Text.unpack alias)
, Types.Qualification (Text.unpack module_)
)
parse ws = Left $ "stanza should look like 'ModuleName as X':"
<> Text.unwords ws
hasParens :: Text -> Maybe Text
hasParens s
| "(" `Text.isPrefixOf` s && ")" `Text.isSuffixOf` s =
Just $ Text.drop 1 $ Text.dropEnd 1 s
| otherwise = Nothing
parseLanguage :: [Text] -> ([Text], [Extension.Extension])
parseLanguage = Either.partitionEithers . map parse
where
parse w = case Extension.parseExtension (Text.unpack w) of
Extension.UnknownExtension _ -> Left w
ext -> Right ext
-- * pick candidates
pickModule :: Priorities -> FilePath
-> [(Maybe Index.Package, Types.ModuleName)]
-> Maybe (Maybe Index.Package, Types.ModuleName)
pickModule prios modulePath candidates =
Util.minimumOn (uncurry (prioritize prios modulePath)) $
-- Don't pick myself!
filter ((/= Types.pathToModule modulePath) . snd) candidates
-- | The order of priority is:
--
-- - high or low in 'prioModule'
-- - local modules that share prefix with the module path
-- - local modules to ones from packages
-- - package modules high or low in 'prioPackage'
-- - prefer with fewer dots, so System.IO over Data.Text.IO
-- - If all else is equal alphabetize so at least the order is predictable.
prioritize :: Priorities -> FilePath -> Maybe String -> Types.ModuleName -> _
prioritize prios modulePath mbPackage mod =
( modulePrio (prioModule prios) mod
, localPrio mbPackage
, packagePrio (prioPackage prios) mbPackage
, length $ filter (=='.') $ Types.moduleName mod
, Types.moduleName mod
)
where
localPrio Nothing = Before $ localOrder modulePath mod
localPrio (Just _) = After
packagePrio _ Nothing = Nothing
packagePrio (Priority {high, low}) (Just pkg) =
Just $ searchPrio high low pkg
modulePrio (Priority {high, low}) =
searchPrio (map Types.moduleName high) (map Types.moduleName low)
. Types.moduleName
-- | This is like Maybe, except that a present value will always sort before an
-- absent one.
data Before a = Before a | After deriving (Eq, Show)
instance Ord a => Ord (Before a) where
compare After After = EQ
compare (Before _) After = LT
compare After (Before _) = GT
compare (Before a) (Before b) = compare a b
-- | Lower numbers for modules that share more prefix with the module's path.
-- A/B/Z.hs vs A.B.C -> -2
-- A/Z.hs vs B -> 0
localOrder :: FilePath -> Types.ModuleName -> Int
localOrder modulePath mod = negate $ length $ takeWhile id $ zipWith (==)
(Util.split "/" (Types.moduleToPath mod))
(Util.split "/" (FilePath.takeDirectory modulePath))
searchPrio :: [String] -> [String] -> String -> Int
searchPrio high low mod = case List.findIndex (== mod) high of
Just n -> - length high + n
Nothing -> maybe 0 (+1) (List.findIndex (== mod) low)
-- * format imports
-- | Format import list. Imports are alphabetized and grouped into sections
-- based on the top level module name (before the first dot). Sections that
-- are too small are grouped with the section below them.
--
-- The local imports are sorted and grouped separately from the package
-- imports. Rather than being alphabetical, they are sorted in a per-project
-- order that should be general-to-specific.
--
-- An unqualified import will follow a qualified one. The Prelude, if
-- imported, always goes first.
formatGroups :: Format -> Order -> [Types.ImportLine] -> String
formatGroups format order imports =
unlines $ joinGroups
[ showGroups (group (Util.sortOn packagePrio package))
, showGroups (group (Util.sortOn localPrio local))
, showGroups [Util.sortOn name unqualified]
]
where
packagePrio import_ =
( name import_ /= prelude
, name import_
, qualifiedPrio import_
)
localPrio import_ =
( localPriority (_importOrder order) (Types.importModule import_)
, name import_
, qualifiedPrio import_
)
qualifiedPrio = not . qualifiedImport
name = Types.importModule
(unqualified, local, package) = Util.partition2
((_sortUnqualifiedLast order &&) . isUnqualified . Types.importDecl)
((==Types.Local) . Types.importSource)
imports
group
| _groupImports format = collapse . Util.groupOn topModule
| otherwise = (:[])
topModule = takeWhile (/='.') . Types.moduleName . Types.importModule
collapse [] = []
collapse (x:xs)
| length x <= 2 = case collapse xs of
[] -> [x]
y : ys -> (x ++ y) : ys
| otherwise = x : collapse xs
showGroups = List.intercalate [""] . map (map (showImport format))
joinGroups = List.intercalate [""] . filter (not . null)
prelude = Types.ModuleName "Prelude"
isUnqualified :: Haskell.ImportDecl a -> Bool
isUnqualified imp = not (Haskell.importQualified imp)
&& Maybe.isNothing (Haskell.importSpecs imp)
-- | Modules whose top level element is in 'importFirst' go first, ones in
-- 'importLast' go last, and the rest go in the middle.
--
-- Like 'searchPrio' but for order.
localPriority :: Priority ModulePattern -> Types.ModuleName
-> (Int, Maybe Int)
localPriority prio import_ =
case List.findIndex (`matchModule` import_) firsts of
Just k -> (-1, Just k)
Nothing -> case List.findIndex (`matchModule` import_) lasts of
Nothing -> (0, Nothing)
Just k -> (1, Just k)
where
firsts = high prio
lasts = low prio
qualifiedImport :: Types.ImportLine -> Bool
qualifiedImport = Haskell.importQualified . Types.importDecl
showImport :: Format -> Types.ImportLine -> String
showImport format (Types.ImportLine decl cmts _) =
above ++ showImportDecl format decl
++ (if null right then "" else ' ' : right)
where
above = concat [cmt ++ "\n" | Types.Comment Types.CmtAbove cmt <- cmts]
right = Util.join "\n" [cmt | Types.Comment Types.CmtRight cmt <- cmts]
showImportDecl :: Format -> Types.ImportDecl -> String
showImportDecl format = PP.renderStyle style . prettyImportDecl format
where
style = Haskell.style
{ Haskell.lineLength = _columns format
, Haskell.ribbonsPerLine = 1
}
-- showImportDecl format = case _ppConfig format of
-- Nothing -> Haskell.prettyPrintStyleMode style Haskell.defaultMode
-- Just config -> PP.renderStyle style . prettyImportDecl config
-- where
-- style = Haskell.style
-- { Haskell.lineLength = _columns format
-- , Haskell.ribbonsPerLine = 1
-- }
prettyImportDecl :: Format -> Haskell.ImportDecl a -> PP.Doc
prettyImportDecl format
(Haskell.ImportDecl _ m qual src safe mbPkg mbName mbSpecs) = do
mySep
[ "import"
, if qual || not (_leaveSpaceForQualified format) then mempty
else PP.text (replicate (length ("qualified" :: String)) ' ')
, if src then "{-# SOURCE #-}" else mempty
, if safe then "safe" else mempty
, if qual then "qualified" else mempty
, maybe mempty (\s -> PP.text (show s)) mbPkg
, nameOf m
, maybe mempty (\m -> "as" <+> nameOf m) mbName
, maybe mempty prettyImportSpecList mbSpecs
]
where
nameOf (Haskell.ModuleName _ s) = PP.text s
-- ** Language.Haskell.Exts.Pretty copy-paste
-- Language.Haskell.Exts.Pretty doesn't export the pretty method.
--
-- Ironically the haskell-src-exts complains about having to copy paste
-- PP.punctuate, which is no longer necessary, while forcing me to copy paste
-- much more, by committing the same mistake.
prettyImportSpecList :: Haskell.ImportSpecList a -> PP.Doc
prettyImportSpecList (Haskell.ImportSpecList _ b ispecs) =
(if b then "hiding" else mempty) <+> parenList (map prettyISpec ispecs)
prettyISpec :: Haskell.ImportSpec a -> PP.Doc
prettyISpec = \case
Haskell.IVar _ name -> prettyName name
Haskell.IAbs _ ns name -> prettyNamespace ns <+> prettyName name
Haskell.IThingAll _ name -> prettyName name <> PP.text "(..)"
Haskell.IThingWith _ name nameList ->
prettyName name <> (parenList . map prettyCName $ nameList)
prettyName :: Haskell.Name l -> PP.Doc
prettyName name = case name of
Haskell.Symbol _ ('#':_) -> PP.char '(' <+> ppName name <+> PP.char ')'
_ -> parensIf (isSymbolName name) (ppName name)
prettyCName :: Haskell.CName l -> PP.Doc
prettyCName = \case
Haskell.VarName _ n -> prettyName n
Haskell.ConName _ n -> prettyName n
prettyNamespace :: Haskell.Namespace l -> PP.Doc
prettyNamespace = \case
Haskell.NoNamespace {} -> mempty
Haskell.TypeNamespace {} -> "type"
Haskell.PatternNamespace {} -> "pattern"
parensIf :: Bool -> PP.Doc -> PP.Doc
parensIf True = PP.parens
parensIf False = id
isSymbolName :: Haskell.Name l -> Bool
isSymbolName (Haskell.Symbol {}) = True
isSymbolName _ = False
ppName :: Haskell.Name l -> PP.Doc
ppName (Haskell.Ident _ s) = PP.text s
ppName (Haskell.Symbol _ s) = PP.text s
parenList :: [PP.Doc] -> PP.Doc
parenList = PP.parens . PP.fsep . PP.punctuate PP.comma
pretty :: Haskell.Pretty a => a -> PP.Doc
pretty _ = "?"
mySep :: [PP.Doc] -> PP.Doc
mySep [] = error "mySep got empty"
mySep [x] = x
mySep (x:xs) = x <+> PP.fsep xs
-- * log
debug :: Config -> Text -> IO ()
debug config msg
| _debug config = Text.IO.hPutStrLn IO.stderr msg
| otherwise = return ()
showt :: Show a => a -> Text
showt = Text.pack . show