{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-missing-fields #-}
-- | Utility functions for working with the GHC AST
module Language.Haskell.Stylish.GHC
  ( dropAfterLocated
  , dropBeforeLocated
  , dropBeforeAndAfter
    -- * Unsafe getters
  , unsafeGetRealSrcSpan
  , getEndLineUnsafe
  , getStartLineUnsafe
    -- * Standard settings
  , baseDynFlags
    -- * Outputable operators
  , showOutputable

    -- * Deconstruction
  , getConDecls
  , epAnnComments
  , deepAnnComments
  ) where

--------------------------------------------------------------------------------
import           Data.Generics                                       (Data,
                                                                      Typeable,
                                                                      everything,
                                                                      mkQ)
import           Data.List                                           (sortOn)
import qualified GHC.Driver.Ppr                                      as GHC (showPpr)
import           GHC.Driver.Session                                  (defaultDynFlags)
import qualified GHC.Driver.Session                                  as GHC
import qualified GHC.Hs                                              as GHC
import           GHC.Types.SrcLoc                                    (GenLocated (..),
                                                                      Located,
                                                                      RealLocated,
                                                                      RealSrcSpan,
                                                                      SrcSpan (..),
                                                                      srcSpanEndLine,
                                                                      srcSpanStartLine)
import qualified GHC.Types.SrcLoc                                    as GHC
import qualified GHC.Utils.Outputable                                as GHC
import qualified Language.Haskell.GhclibParserEx.GHC.Settings.Config as GHCEx

unsafeGetRealSrcSpan :: Located a -> RealSrcSpan
unsafeGetRealSrcSpan :: forall a. Located a -> RealSrcSpan
unsafeGetRealSrcSpan = \case
  (L (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_) a
_) -> RealSrcSpan
s
  Located a
_                       -> forall a. HasCallStack => [Char] -> a
error [Char]
"could not get source code location"

getStartLineUnsafe :: Located a -> Int
getStartLineUnsafe :: forall a. Located a -> Int
getStartLineUnsafe = RealSrcSpan -> Int
srcSpanStartLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> RealSrcSpan
unsafeGetRealSrcSpan

getEndLineUnsafe :: Located a -> Int
getEndLineUnsafe :: forall a. Located a -> Int
getEndLineUnsafe = RealSrcSpan -> Int
srcSpanEndLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> RealSrcSpan
unsafeGetRealSrcSpan

dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
dropAfterLocated :: forall a b. Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
dropAfterLocated Maybe (Located a)
loc [RealLocated b]
xs = case Maybe (Located a)
loc of
  Just (L (RealSrcSpan RealSrcSpan
rloc Maybe BufSpan
_) a
_) ->
    forall a. (a -> Bool) -> [a] -> [a]
filter (\(L RealSrcSpan
x b
_) -> RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
rloc forall a. Ord a => a -> a -> Bool
>= RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
x) [RealLocated b]
xs
  Maybe (Located a)
_ -> [RealLocated b]
xs

dropBeforeLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
dropBeforeLocated :: forall a b. Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
dropBeforeLocated Maybe (Located a)
loc [RealLocated b]
xs = case Maybe (Located a)
loc of
  Just (L (RealSrcSpan RealSrcSpan
rloc Maybe BufSpan
_) a
_) ->
    forall a. (a -> Bool) -> [a] -> [a]
filter (\(L RealSrcSpan
x b
_) -> RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rloc forall a. Ord a => a -> a -> Bool
<= RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
x) [RealLocated b]
xs
  Maybe (Located a)
_ -> [RealLocated b]
xs

dropBeforeAndAfter :: Located a -> [RealLocated b] -> [RealLocated b]
dropBeforeAndAfter :: forall a b. Located a -> [RealLocated b] -> [RealLocated b]
dropBeforeAndAfter Located a
loc = forall a b. Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
dropBeforeLocated (forall a. a -> Maybe a
Just Located a
loc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
dropAfterLocated (forall a. a -> Maybe a
Just Located a
loc)

baseDynFlags :: GHC.DynFlags
baseDynFlags :: DynFlags
baseDynFlags = Settings -> DynFlags
defaultDynFlags Settings
GHCEx.fakeSettings 

getConDecls :: GHC.HsDataDefn GHC.GhcPs -> [GHC.LConDecl GHC.GhcPs]
getConDecls :: HsDataDefn GhcPs -> [LConDecl GhcPs]
getConDecls d :: HsDataDefn GhcPs
d@GHC.HsDataDefn {} = case forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
GHC.dd_cons HsDataDefn GhcPs
d of
  GHC.NewTypeCon LConDecl GhcPs
con -> [LConDecl GhcPs
con]
  GHC.DataTypeCons Bool
_ [LConDecl GhcPs]
cons -> [LConDecl GhcPs]
cons

showOutputable :: GHC.Outputable a => a -> String
showOutputable :: forall a. Outputable a => a -> [Char]
showOutputable = forall a. Outputable a => DynFlags -> a -> [Char]
GHC.showPpr DynFlags
baseDynFlags

epAnnComments :: GHC.EpAnn a -> [GHC.LEpaComment]
epAnnComments :: forall a. EpAnn a -> [LEpaComment]
epAnnComments EpAnn a
GHC.EpAnnNotUsed = []
epAnnComments GHC.EpAnn {a
Anchor
EpAnnComments
entry :: forall ann. EpAnn ann -> Anchor
anns :: forall ann. EpAnn ann -> ann
comments :: forall ann. EpAnn ann -> EpAnnComments
comments :: EpAnnComments
anns :: a
entry :: Anchor
..}   = EpAnnComments -> [LEpaComment]
priorAndFollowing EpAnnComments
comments

deepAnnComments :: (Data a, Typeable a) => a -> [GHC.LEpaComment]
deepAnnComments :: forall a. (Data a, Typeable a) => a -> [LEpaComment]
deepAnnComments = 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 [] EpAnnComments -> [LEpaComment]
priorAndFollowing)

priorAndFollowing :: GHC.EpAnnComments -> [GHC.LEpaComment]
priorAndFollowing :: EpAnnComments -> [LEpaComment]
priorAndFollowing = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Anchor -> RealSrcSpan
GHC.anchor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> l
GHC.getLoc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    GHC.EpaComments         {[LEpaComment]
priorComments :: EpAnnComments -> [LEpaComment]
priorComments :: [LEpaComment]
..} -> [LEpaComment]
priorComments
    GHC.EpaCommentsBalanced {[LEpaComment]
followingComments :: EpAnnComments -> [LEpaComment]
followingComments :: [LEpaComment]
priorComments :: [LEpaComment]
priorComments :: EpAnnComments -> [LEpaComment]
..} -> [LEpaComment]
priorComments forall a. [a] -> [a] -> [a]
++ [LEpaComment]
followingComments