{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TupleSections              #-}
module Language.Haskell.Stylish.Module
  ( -- * Data types
    Module
  , Comments (..)
  , Lines

    -- * Getters
  , moduleImportGroups
  , queryModule
  , groupByLine

    -- * Imports
  , canMergeImport
  , mergeModuleImport
  , importModuleName

    -- * Pragmas
  , 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 qualified GHC.Types.PkgQual            as GHC
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]

deriving instance Eq GHC.RawPkgQual

--------------------------------------------------------------------------------
-- | Concrete module type
type Module = GHC.Located GHC.HsModule

importModuleName :: ImportDecl GhcPs -> String
importModuleName :: ImportDecl GhcPs -> [Char]
importModuleName = ModuleName -> [Char]
GHC.moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
GHC.unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> XRec pass ModuleName
GHC.ideclName

-- | Returns true if the two import declarations can be merged
canMergeImport :: ImportDecl GhcPs -> ImportDecl GhcPs -> Bool
canMergeImport :: ImportDecl GhcPs -> ImportDecl GhcPs -> Bool
canMergeImport ImportDecl GhcPs
i0 ImportDecl GhcPs
i1 = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ 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)
  [ forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName
  , forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual
  , forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall pass. ImportDecl pass -> IsBootInterface
ideclSource
  , ImportDeclQualifiedStyle -> ImportDeclQualifiedStyle -> Bool
hasMergableQualified forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified
  , forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall pass. ImportDecl pass -> Bool
ideclImplicit
  , forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName)
ideclAs
  , forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> Maybe (Bool, XRec pass [LIE pass])
ideclHiding -- same 'hiding' flags
  ]
  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 forall a. Eq a => a -> a -> Bool
== ImportDeclQualifiedStyle
q1

-- | Comments associated with module
newtype Comments = Comments [GHC.RealLocated GHC.EpaComment]

-- | Get groups of imports from module
moduleImportGroups :: Module -> [NonEmpty (GHC.LImportDecl GHC.GhcPs)]
moduleImportGroups :: Module -> [NonEmpty (LImportDecl GhcPs)]
moduleImportGroups =
    forall a. (a -> RealSrcSpan) -> [a] -> [NonEmpty a]
groupByLine (forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
GHC.getLocA) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    HsModule -> [LImportDecl GhcPs]
GHC.hsmodImports forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
GHC.unLoc
  where
    err :: a
err = forall a. HasCallStack => [Char] -> a
error [Char]
"moduleImportGroups: import without soure span"

-- The same logic as 'Language.Haskell.Stylish.Module.moduleImportGroups'.
groupByLine :: (a -> RealSrcSpan) -> [a] -> [NonEmpty a]
groupByLine :: forall a. (a -> RealSrcSpan) -> [a] -> [NonEmpty a]
groupByLine a -> RealSrcSpan
f = [a] -> Maybe Int -> [a] -> [NonEmpty a]
go [] forall a. Maybe a
Nothing
  where
    go :: [a] -> Maybe Int -> [a] -> [NonEmpty a]
go [a]
acc Maybe Int
_ [] = 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 forall a. Num a => a -> a -> a
+ Int
1 forall a. Ord a => a -> a -> Bool
< Int
lStart
          -> forall {a}. [a] -> [NonEmpty a]
ne [a]
acc forall a. [a] -> [a] -> [a]
++ [a] -> Maybe Int -> [a] -> [NonEmpty a]
go [a
x] (forall a. a -> Maybe a
Just Int
lEnd) [a]
xs
        Maybe Int
_ -> [a] -> Maybe Int -> [a] -> [NonEmpty a]
go ([a]
acc forall a. [a] -> [a] -> [a]
++ [a
x]) (forall a. a -> Maybe a
Just Int
lEnd) [a]
xs

    ne :: [a] -> [NonEmpty a]
ne []       = []
    ne (a
x : [a]
xs) = [a
x forall a. a -> [a] -> NonEmpty a
:| [a]
xs]

-- | Merge two import declarations, keeping positions from the first
--
--   As alluded, this highlights an issue with merging imports. The GHC
--   annotation comments aren't attached to any particular AST node. This
--   means that right now, we're manually reconstructing the attachment. By
--   merging two import declarations, we lose that mapping.
--
--   It's not really a big deal if we consider that people don't usually
--   comment imports themselves. It _is_ however, systemic and it'd be better
--   if we processed comments beforehand and attached them to all AST nodes in
--   our own representation.
mergeModuleImport
    :: GHC.LImportDecl GHC.GhcPs -> GHC.LImportDecl GHC.GhcPs
    -> GHC.LImportDecl GHC.GhcPs
mergeModuleImport :: LImportDecl GhcPs -> LImportDecl GhcPs -> LImportDecl GhcPs
mergeModuleImport (L SrcSpanAnn' (EpAnn AnnListItem)
p0 ImportDecl GhcPs
i0) (L SrcSpanAnn' (EpAnn AnnListItem)
_p1 ImportDecl GhcPs
i1) =
  forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
p0 forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs
i0 { ideclHiding :: Maybe (Bool, XRec GhcPs [LIE GhcPs])
ideclHiding = Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
newImportNames }
  where
    newImportNames :: Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
newImportNames =
      case (forall pass. ImportDecl pass -> Maybe (Bool, XRec pass [LIE pass])
ideclHiding ImportDecl GhcPs
i0, 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)) -> forall a. a -> Maybe a
Just (Bool
b, forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
p ([LIE GhcPs]
imps0 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) -> forall a. Maybe a
Nothing
        (Just (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
x, Maybe (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
Nothing) -> 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) -> forall a. a -> Maybe a
Just (Bool, GenLocated SrcSpanAnnL [LIE GhcPs])
x
    merge :: [a] -> [a] -> [a]
merge [a]
xs [a]
ys
      = forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. Outputable a => a -> [Char]
showOutputable) ([a]
xs forall a. [a] -> [a] -> [a]
++ [a]
ys)

-- | Query the module AST using @f@
queryModule :: Typeable a => (a -> [b]) -> Module -> [b]
queryModule :: forall a b. Typeable a => (a -> [b]) -> Module -> [b]
queryModule a -> [b]
f = forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything forall a. [a] -> [a] -> [a]
(++) (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 [Char])]
moduleLanguagePragmas =
    forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LEpaComment -> Maybe (RealSrcSpan, NonEmpty [Char])
prag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EpAnn a -> [LEpaComment]
epAnnComments forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule -> EpAnn AnnsModule
GHC.hsmodAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
GHC.unLoc
  where
    prag :: GHC.LEpaComment -> Maybe (GHC.RealSrcSpan, NonEmpty String)
    prag :: LEpaComment -> Maybe (RealSrcSpan, NonEmpty [Char])
prag LEpaComment
comment = case EpaComment -> EpaCommentTok
GHC.ac_tok (forall l e. GenLocated l e -> e
GHC.unLoc LEpaComment
comment) of
        GHC.EpaBlockComment [Char]
str
            | [Char]
lang : [Char]
p1 : [[Char]]
ps <- [Char] -> [[Char]]
tokenize [Char]
str, forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
lang forall a. Eq a => a -> a -> Bool
== [Char]
"language" ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anchor -> RealSrcSpan
GHC.anchor (forall l e. GenLocated l e -> l
GHC.getLoc LEpaComment
comment), [Char]
p1 forall a. a -> [a] -> NonEmpty a
:| [[Char]]
ps)
        EpaCommentTok
_ -> forall a. Maybe a
Nothing

    tokenize :: [Char] -> [[Char]]
tokenize = [Char] -> [[Char]]
words forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c forall a. Eq a => a -> a -> Bool
== Char
',' then Char
' ' else Char
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'#') forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'#')