{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module Language.Haskell.Stylish.Module
(
Module
, Comments (..)
, Lines
, moduleImportGroups
, queryModule
, groupByLine
, canMergeImport
, mergeModuleImport
, importModuleName
, moduleLanguagePragmas
) where
import Data.Char (toLower)
import Data.Function (on)
import Data.Generics (Typeable, everything, mkQ)
import qualified Data.List as L
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe, mapMaybe)
import GHC.Hs (ImportDecl (..),
ImportDeclQualifiedStyle (..))
import qualified GHC.Hs as GHC
import GHC.Hs.Extension (GhcPs)
import GHC.Types.SrcLoc (GenLocated (..),
RealSrcSpan (..), unLoc)
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Unit.Module.Name as GHC
import Language.Haskell.Stylish.GHC
type Lines = [String]
type Module = GHC.Located GHC.HsModule
importModuleName :: ImportDecl GhcPs -> String
importModuleName :: ImportDecl GhcPs -> String
importModuleName = ModuleName -> String
GHC.moduleNameString (ModuleName -> String)
-> (ImportDecl GhcPs -> ModuleName) -> ImportDecl GhcPs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
GHC.unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> (ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName)
-> ImportDecl GhcPs
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
GHC.ideclName
canMergeImport :: ImportDecl GhcPs -> ImportDecl GhcPs -> Bool
canMergeImport :: ImportDecl GhcPs -> ImportDecl GhcPs -> Bool
canMergeImport ImportDecl GhcPs
i0 ImportDecl GhcPs
i1 = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ ((ImportDecl GhcPs -> ImportDecl GhcPs -> Bool) -> Bool)
-> [ImportDecl GhcPs -> ImportDecl GhcPs -> Bool] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ImportDecl GhcPs -> ImportDecl GhcPs -> Bool
f -> ImportDecl GhcPs -> ImportDecl GhcPs -> Bool
f ImportDecl GhcPs
i0 ImportDecl GhcPs
i1)
[ ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ModuleName -> ModuleName -> Bool)
-> (ImportDecl GhcPs -> ModuleName)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> (ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName)
-> ImportDecl GhcPs
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName
, Maybe StringLiteral -> Maybe StringLiteral -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe StringLiteral -> Maybe StringLiteral -> Bool)
-> (ImportDecl GhcPs -> Maybe StringLiteral)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ImportDecl GhcPs -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual
, IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
(==) (IsBootInterface -> IsBootInterface -> Bool)
-> (ImportDecl GhcPs -> IsBootInterface)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ImportDecl GhcPs -> IsBootInterface
forall pass. ImportDecl pass -> IsBootInterface
ideclSource
, ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool
hasMergableQualified (ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool)
-> (ImportDecl GhcPs -> ImportDeclQualifiedStyle)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ImportDecl GhcPs -> ImportDeclQualifiedStyle
forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified
, Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Bool -> Bool -> Bool)
-> (ImportDecl GhcPs -> Bool)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ImportDecl GhcPs -> Bool
forall pass. ImportDecl pass -> Bool
ideclImplicit
, Maybe ModuleName -> Maybe ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe ModuleName -> Maybe ModuleName -> Bool)
-> (ImportDecl GhcPs -> Maybe ModuleName)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> Maybe (GenLocated SrcSpanAnnA ModuleName) -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (Maybe (GenLocated SrcSpanAnnA ModuleName) -> Maybe ModuleName)
-> (ImportDecl GhcPs -> Maybe (GenLocated SrcSpanAnnA ModuleName))
-> ImportDecl GhcPs
-> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> Maybe (GenLocated SrcSpanAnnA ModuleName)
forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName)
ideclAs
, Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe Bool -> Maybe Bool -> Bool)
-> (ImportDecl GhcPs -> Maybe Bool)
-> ImportDecl GhcPs
-> ImportDecl GhcPs
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Bool, GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Bool)
-> Maybe
(Bool, GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Bool
forall a b. (a, b) -> a
fst (Maybe
(Bool, GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe Bool)
-> (ImportDecl GhcPs
-> Maybe
(Bool, GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]))
-> ImportDecl GhcPs
-> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs
-> Maybe
(Bool, GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
forall pass. ImportDecl pass -> Maybe (Bool, XRec pass [LIE pass])
ideclHiding
]
where
hasMergableQualified :: ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool
hasMergableQualified ImportDeclQualifiedStyle
QualifiedPre ImportDeclQualifiedStyle
QualifiedPost = Bool
True
hasMergableQualified ImportDeclQualifiedStyle
QualifiedPost ImportDeclQualifiedStyle
QualifiedPre = Bool
True
hasMergableQualified ImportDeclQualifiedStyle
q0 ImportDeclQualifiedStyle
q1 = ImportDeclQualifiedStyle
q0 ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool
forall a. Eq a => a -> a -> Bool
== ImportDeclQualifiedStyle
q1
newtype = [GHC.RealLocated GHC.EpaComment]
moduleImportGroups :: Module -> [NonEmpty (GHC.LImportDecl GHC.GhcPs)]
moduleImportGroups :: Module -> [NonEmpty (LImportDecl GhcPs)]
moduleImportGroups =
(GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> RealSrcSpan)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [NonEmpty (GenLocated SrcSpanAnnA (ImportDecl GhcPs))]
forall a. (a -> RealSrcSpan) -> [a] -> [NonEmpty a]
groupByLine (RealSrcSpan -> Maybe RealSrcSpan -> RealSrcSpan
forall a. a -> Maybe a -> a
fromMaybe RealSrcSpan
forall a. a
err (Maybe RealSrcSpan -> RealSrcSpan)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Maybe RealSrcSpan)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> SrcSpan)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA) ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [NonEmpty (GenLocated SrcSpanAnnA (ImportDecl GhcPs))])
-> (Module -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> Module
-> [NonEmpty (GenLocated SrcSpanAnnA (ImportDecl GhcPs))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
HsModule -> [LImportDecl GhcPs]
HsModule -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
GHC.hsmodImports (HsModule -> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
-> (Module -> HsModule)
-> Module
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> HsModule
forall l e. GenLocated l e -> e
GHC.unLoc
where
err :: a
err = String -> a
forall a. HasCallStack => String -> a
error String
"moduleImportGroups: import without soure span"
groupByLine :: (a -> RealSrcSpan) -> [a] -> [NonEmpty a]
groupByLine :: (a -> RealSrcSpan) -> [a] -> [NonEmpty a]
groupByLine a -> RealSrcSpan
f = [a] -> Maybe Int -> [a] -> [NonEmpty a]
go [] Maybe Int
forall a. Maybe a
Nothing
where
go :: [a] -> Maybe Int -> [a] -> [NonEmpty a]
go [a]
acc Maybe Int
_ [] = [a] -> [NonEmpty a]
forall a. [a] -> [NonEmpty a]
ne [a]
acc
go [a]
acc Maybe Int
mbCurrentLine (a
x:[a]
xs) =
let
lStart :: Int
lStart = RealSrcSpan -> Int
GHC.srcSpanStartLine (a -> RealSrcSpan
f a
x)
lEnd :: Int
lEnd = RealSrcSpan -> Int
GHC.srcSpanEndLine (a -> RealSrcSpan
f a
x) in
case Maybe Int
mbCurrentLine of
Just Int
lPrevEnd | Int
lPrevEnd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lStart
-> [a] -> [NonEmpty a]
forall a. [a] -> [NonEmpty a]
ne [a]
acc [NonEmpty a] -> [NonEmpty a] -> [NonEmpty a]
forall a. [a] -> [a] -> [a]
++ [a] -> Maybe Int -> [a] -> [NonEmpty a]
go [a
x] (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
lEnd) [a]
xs
Maybe Int
_ -> [a] -> Maybe Int -> [a] -> [NonEmpty a]
go ([a]
acc [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
lEnd) [a]
xs
ne :: [a] -> [NonEmpty a]
ne [] = []
ne (a
x : [a]
xs) = [a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs]
mergeModuleImport
:: GHC.LImportDecl GHC.GhcPs -> GHC.LImportDecl GHC.GhcPs
-> GHC.LImportDecl GHC.GhcPs
mergeModuleImport :: LImportDecl GhcPs -> LImportDecl GhcPs -> LImportDecl GhcPs
mergeModuleImport (L p0 i0) (L _p1 i1) =
SrcSpanAnnA
-> ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
p0 (ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs
i0 { ideclHiding :: Maybe (Bool, XRec GhcPs [LIE GhcPs])
ideclHiding = Maybe (Bool, XRec GhcPs [LIE GhcPs])
Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
newImportNames }
where
newImportNames :: Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
newImportNames =
case (ImportDecl GhcPs -> Maybe (Bool, XRec GhcPs [LIE GhcPs])
forall pass. ImportDecl pass -> Maybe (Bool, XRec pass [LIE pass])
ideclHiding ImportDecl GhcPs
i0, ImportDecl GhcPs -> Maybe (Bool, XRec GhcPs [LIE GhcPs])
forall pass. ImportDecl pass -> Maybe (Bool, XRec pass [LIE pass])
ideclHiding ImportDecl GhcPs
i1) of
(Just (Bool
b, L SrcSpanAnnL
p [LIE GhcPs]
imps0), Just (Bool
_, L SrcSpanAnnL
_ [LIE GhcPs]
imps1)) -> (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
-> Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
forall a. a -> Maybe a
Just (Bool
b, SrcSpanAnnL -> [LIE GhcPs] -> GenLocated SrcSpanAnnL [LIE GhcPs]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
p ([LIE GhcPs]
imps0 [LIE GhcPs] -> [LIE GhcPs] -> [LIE GhcPs]
forall a. Outputable a => [a] -> [a] -> [a]
`merge` [LIE GhcPs]
imps1))
(Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
Nothing, Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
Nothing) -> Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
forall a. Maybe a
Nothing
(Just (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
x, Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
Nothing) -> (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
-> Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
forall a. a -> Maybe a
Just (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
x
(Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
Nothing, Just (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
x) -> (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
-> Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
forall a. a -> Maybe a
Just (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
x
merge :: [a] -> [a] -> [a]
merge [a]
xs [a]
ys
= (a -> a -> Bool) -> [a] -> [a]
forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> String -> Bool) -> (a -> String) -> a -> a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> String
forall a. Outputable a => a -> String
showOutputable) ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys)
queryModule :: Typeable a => (a -> [b]) -> Module -> [b]
queryModule :: (a -> [b]) -> Module -> [b]
queryModule a -> [b]
f = ([b] -> [b] -> [b]) -> GenericQ [b] -> GenericQ [b]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
(++) ([b] -> (a -> [b]) -> a -> [b]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [] a -> [b]
f)
moduleLanguagePragmas :: Module -> [(RealSrcSpan, NonEmpty String)]
moduleLanguagePragmas :: Module -> [(RealSrcSpan, NonEmpty String)]
moduleLanguagePragmas =
(LEpaComment -> Maybe (RealSrcSpan, NonEmpty String))
-> [LEpaComment] -> [(RealSrcSpan, NonEmpty String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LEpaComment -> Maybe (RealSrcSpan, NonEmpty String)
prag ([LEpaComment] -> [(RealSrcSpan, NonEmpty String)])
-> (Module -> [LEpaComment])
-> Module
-> [(RealSrcSpan, NonEmpty String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpAnn AnnsModule -> [LEpaComment]
forall a. EpAnn a -> [LEpaComment]
epAnnComments (EpAnn AnnsModule -> [LEpaComment])
-> (Module -> EpAnn AnnsModule) -> Module -> [LEpaComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule -> EpAnn AnnsModule
GHC.hsmodAnn (HsModule -> EpAnn AnnsModule)
-> (Module -> HsModule) -> Module -> EpAnn AnnsModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> HsModule
forall l e. GenLocated l e -> e
GHC.unLoc
where
prag :: GHC.LEpaComment -> Maybe (GHC.RealSrcSpan, NonEmpty String)
prag :: LEpaComment -> Maybe (RealSrcSpan, NonEmpty String)
prag LEpaComment
comment = case EpaComment -> EpaCommentTok
GHC.ac_tok (LEpaComment -> EpaComment
forall l e. GenLocated l e -> e
GHC.unLoc LEpaComment
comment) of
GHC.EpaBlockComment String
str
| String
lang : String
p1 : [String]
ps <- String -> [String]
tokenize String
str, (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
lang String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"language" ->
(RealSrcSpan, NonEmpty String)
-> Maybe (RealSrcSpan, NonEmpty String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anchor -> RealSrcSpan
GHC.anchor (LEpaComment -> Anchor
forall l e. GenLocated l e -> l
GHC.getLoc LEpaComment
comment), String
p1 String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String]
ps)
EpaCommentTok
_ -> Maybe (RealSrcSpan, NonEmpty String)
forall a. Maybe a
Nothing
tokenize :: String -> [String]
tokenize = String -> [String]
words (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' then Char
' ' else Char
c) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#')