{-# 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
_                       -> [Char] -> RealSrcSpan
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 (RealSrcSpan -> Int)
-> (Located a -> RealSrcSpan) -> Located a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located a -> RealSrcSpan
forall a. Located a -> RealSrcSpan
unsafeGetRealSrcSpan

getEndLineUnsafe :: Located a -> Int
getEndLineUnsafe :: forall a. Located a -> Int
getEndLineUnsafe = RealSrcSpan -> Int
srcSpanEndLine (RealSrcSpan -> Int)
-> (Located a -> RealSrcSpan) -> Located a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located a -> RealSrcSpan
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
_) ->
    (RealLocated b -> Bool) -> [RealLocated b] -> [RealLocated b]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(L RealSrcSpan
x b
_) -> RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
rloc Int -> Int -> Bool
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
_) ->
    (RealLocated b -> Bool) -> [RealLocated b] -> [RealLocated b]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(L RealSrcSpan
x b
_) -> RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rloc Int -> Int -> Bool
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 = Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
forall a b. Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
dropBeforeLocated (Located a -> Maybe (Located a)
forall a. a -> Maybe a
Just Located a
loc) ([RealLocated b] -> [RealLocated b])
-> ([RealLocated b] -> [RealLocated b])
-> [RealLocated b]
-> [RealLocated b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
forall a b. Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
dropAfterLocated (Located a -> Maybe (Located a)
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 HsDataDefn GhcPs -> DataDefnCons (LConDecl GhcPs)
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 = DynFlags -> a -> [Char]
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
EpAnnComments
Anchor
entry :: Anchor
anns :: a
comments :: EpAnnComments
entry :: forall ann. EpAnn ann -> Anchor
anns :: forall ann. EpAnn ann -> ann
comments :: forall ann. EpAnn ann -> EpAnnComments
..}   = EpAnnComments -> [LEpaComment]
priorAndFollowing EpAnnComments
comments

deepAnnComments :: (Data a, Typeable a) => a -> [GHC.LEpaComment]
deepAnnComments :: forall a. (Data a, Typeable a) => a -> [LEpaComment]
deepAnnComments = ([LEpaComment] -> [LEpaComment] -> [LEpaComment])
-> GenericQ [LEpaComment] -> GenericQ [LEpaComment]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. [a] -> [a] -> [a]
(++) ([LEpaComment]
-> (EpAnnComments -> [LEpaComment]) -> a -> [LEpaComment]
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 = (LEpaComment -> RealSrcSpan) -> [LEpaComment] -> [LEpaComment]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Anchor -> RealSrcSpan
GHC.anchor (Anchor -> RealSrcSpan)
-> (LEpaComment -> Anchor) -> LEpaComment -> RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEpaComment -> Anchor
forall l e. GenLocated l e -> l
GHC.getLoc) ([LEpaComment] -> [LEpaComment])
-> (EpAnnComments -> [LEpaComment])
-> EpAnnComments
-> [LEpaComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    GHC.EpaComments         {[LEpaComment]
priorComments :: [LEpaComment]
priorComments :: EpAnnComments -> [LEpaComment]
..} -> [LEpaComment]
priorComments
    GHC.EpaCommentsBalanced {[LEpaComment]
priorComments :: EpAnnComments -> [LEpaComment]
priorComments :: [LEpaComment]
followingComments :: [LEpaComment]
followingComments :: EpAnnComments -> [LEpaComment]
..} -> [LEpaComment]
priorComments [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. [a] -> [a] -> [a]
++ [LEpaComment]
followingComments