{-# LANGUAGE CPP        #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-unused-imports -Wno-orphans #-}

-- |GHC API utilities
module Ide.Plugin.Eval.GHC (
    addExtension,
    addImport,
    hasPackage,
    addPackages,
    modifyFlags,
    showDynFlags,
    setSessionAndInteractiveDynFlags,
) where

import           Data.List                       (isPrefixOf)
import           Data.Maybe                      (mapMaybe)
import           Data.String                     (fromString)
import qualified Data.Text                       as T
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Compat.Util
import qualified Development.IDE.GHC.Compat.Util as EnumSet
import           Development.IDE.GHC.Util        (printOutputable)

import           GHC.LanguageExtensions.Type     (Extension (..))
import           Ide.Plugin.Eval.Util            (gStrictTry)

#if MIN_VERSION_ghc(9,3,0)
import           GHC                             (setTopSessionDynFlags,
                                                  setUnitDynFlags)
import           GHC.Driver.Env
import           GHC.Driver.Session              (getDynFlags)
#endif

{- $setup
>>> import GHC
>>> import GHC.Paths
>>> run act = runGhc (Just libdir) (getInteractiveDynFlags >>= act)
>>> libdir
"/Users/titto/.ghcup/ghc/8.8.4/lib/ghc-8.8.4"
-}

{- | True if specified package is present in DynFlags

-- >>> hasPackageTst pkg = run $ \df -> return (hasPackage df pkg)
>>> hasPackageTst pkg = run $ \_ -> addPackages [pkg] >>= return . either Left (\df -> Right (hasPackage df pkg))

>>> hasPackageTst "base"
Right True

>>> hasPackageTst "ghc"
Right True

>>> hasPackageTst "extra"
Left "<command line>: cannot satisfy -package extra\n    (use -v for more information)"

>>> hasPackageTst "QuickCheck"
Left "<command line>: cannot satisfy -package QuickCheck\n    (use -v for more information)"
-}
hasPackage :: DynFlags -> String -> Bool
hasPackage :: DynFlags -> String -> Bool
hasPackage DynFlags
df = [PackageFlag] -> String -> Bool
hasPackage_ (DynFlags -> [PackageFlag]
packageFlags DynFlags
df)

hasPackage_ :: [PackageFlag] -> [Char] -> Bool
hasPackage_ :: [PackageFlag] -> String -> Bool
hasPackage_ [PackageFlag]
pkgFlags String
name = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
name `isPrefixOf`) ([PackageFlag] -> [String]
pkgNames_ [PackageFlag]
pkgFlags)

{- |
>>> run (return . pkgNames)
[]
-}
pkgNames :: DynFlags -> [String]
pkgNames :: DynFlags -> [String]
pkgNames = [PackageFlag] -> [String]
pkgNames_ ([PackageFlag] -> [String])
-> (DynFlags -> [PackageFlag]) -> DynFlags -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> [PackageFlag]
packageFlags

pkgNames_ :: [PackageFlag] -> [String]
pkgNames_ :: [PackageFlag] -> [String]
pkgNames_ =
    (PackageFlag -> Maybe String) -> [PackageFlag] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        ( \case
            ExposePackage String
_ (PackageArg String
n) ModRenaming
_  -> String -> Maybe String
forall a. a -> Maybe a
Just String
n
            ExposePackage String
_ (UnitIdArg Unit
uid) ModRenaming
_ -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Unit -> Text
forall a. Outputable a => a -> Text
printOutputable Unit
uid
            PackageFlag
_                                 -> Maybe String
forall a. Maybe a
Nothing
        )

{- | Expose a list of packages.
>>> addPackagesTest pkgs = run (\_ -> (packageFlags <$>) <$> addPackages pkgs)

>>> addPackagesTest []
Right []

>>> addPackagesTest ["base","base","array"]
Right [-package base{package base True ([])},-package array{package array True ([])}]

>>> addPackagesTest ["Cabal"]
Right [-package Cabal{package Cabal True ([])}]

>>> addPackagesTest ["QuickCheck"]
Left "<command line>: cannot satisfy -package QuickCheck\n    (use -v for more information)"

>>> addPackagesTest ["base","notThere"]
Left "<command line>: cannot satisfy -package notThere\n    (use -v for more information)"

prop> \(x::Int) -> x + x == 2 * x
+++ OK, passed 100 tests.
-}
addPackages :: [String] -> Ghc (Either String DynFlags)
addPackages :: [String] -> Ghc (Either String DynFlags)
addPackages [String]
pkgNames = Ghc DynFlags -> Ghc (Either String DynFlags)
forall (m :: * -> *) b.
(MonadIO m, MonadCatch m) =>
m b -> m (Either String b)
gStrictTry (Ghc DynFlags -> Ghc (Either String DynFlags))
-> Ghc DynFlags -> Ghc (Either String DynFlags)
forall a b. (a -> b) -> a -> b
$
    (DynFlags -> DynFlags) -> Ghc DynFlags
forall (m :: * -> *).
GhcMonad m =>
(DynFlags -> DynFlags) -> m DynFlags
modifyFlags ((DynFlags -> DynFlags) -> Ghc DynFlags)
-> (DynFlags -> DynFlags) -> Ghc DynFlags
forall a b. (a -> b) -> a -> b
$ \DynFlags
df ->
        DynFlags
df{packageFlags = foldr (\String
pkgName [PackageFlag]
pf -> if [PackageFlag] -> String -> Bool
hasPackage_ [PackageFlag]
pf String
pkgName then [PackageFlag]
pf else String -> PackageFlag
expose String
pkgName PackageFlag -> [PackageFlag] -> [PackageFlag]
forall a. a -> [a] -> [a]
: [PackageFlag]
pf) (packageFlags df) pkgNames}
  where
    expose :: String -> PackageFlag
expose String
name = String -> PackageArg -> ModRenaming -> PackageFlag
ExposePackage (String
"-package " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) (String -> PackageArg
PackageArg String
name) (Bool -> [(ModuleName, ModuleName)] -> ModRenaming
ModRenaming Bool
True [])

modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m DynFlags
modifyFlags :: forall (m :: * -> *).
GhcMonad m =>
(DynFlags -> DynFlags) -> m DynFlags
modifyFlags DynFlags -> DynFlags
f = do
    DynFlags
df <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    ()
_ <- DynFlags -> m ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags (DynFlags -> DynFlags
f DynFlags
df)
    m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags

-- modifyFlags f = do
--         modifyDynFlags f
--         getSessionDynFlags

{- | Add import to evaluation context

>>> run $ \_ -> addImport "import Data.Maybe"
Could not find module ‘Data.Maybe’
Use -v (or `:set -v` in ghci) to see a list of the files searched for.

>>> run $ \df -> addPackages ["base"] >> addImport "import Data.Maybe"
[import Data.Maybe]

>>> run $ \df -> addPackages ["base"] >> addImport "import qualified Data.Maybe as M"
[import qualified Data.Maybe as M]
-}
addImport :: GhcMonad m => String -> m [InteractiveImport]
addImport :: forall (m :: * -> *). GhcMonad m => String -> m [InteractiveImport]
addImport String
i = do
    [InteractiveImport]
ctx <- m [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
    -- dbgO "CONTEXT" ctx
    ImportDecl GhcPs
idecl <- String -> m (ImportDecl GhcPs)
forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl String
i
    [InteractiveImport] -> m ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext ([InteractiveImport] -> m ()) -> [InteractiveImport] -> m ()
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
idecl InteractiveImport -> [InteractiveImport] -> [InteractiveImport]
forall a. a -> [a] -> [a]
: [InteractiveImport]
ctx
    -- ctx' <- getContext
    -- dbg "CONTEXT'" ctx'
    m [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext

{- | Add extension to interactive evaluation session
>>> import GHC.LanguageExtensions.Type(Extension(..))
>>> run $ \_ -> addExtension DeriveGeneric
()
-}
addExtension :: GhcMonad m => Extension -> m ()
addExtension :: forall (m :: * -> *). GhcMonad m => Extension -> m ()
addExtension Extension
ext =
    (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc -> HscEnv
hsc{hsc_IC = setExtension (hsc_IC hsc) ext}

setExtension :: InteractiveContext -> Extension -> InteractiveContext
setExtension :: InteractiveContext -> Extension -> InteractiveContext
setExtension InteractiveContext
ic Extension
ext = InteractiveContext
ic{ic_dflags = xopt_set (ic_dflags ic) ext}

deriving instance Read Extension

-- Partial display of DynFlags contents, for testing purposes
showDynFlags :: DynFlags -> String
showDynFlags :: DynFlags -> String
showDynFlags DynFlags
df =
    Text -> String
T.unpack (Text -> String)
-> ([(String, SDoc)] -> Text) -> [(String, SDoc)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> Text
forall a. Outputable a => a -> Text
printOutputable (SDoc -> Text)
-> ([(String, SDoc)] -> SDoc) -> [(String, SDoc)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc)
-> ([(String, SDoc)] -> [SDoc]) -> [(String, SDoc)] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, SDoc) -> SDoc) -> [(String, SDoc)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
n, SDoc
d) -> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": ") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
d) ([(String, SDoc)] -> String) -> [(String, SDoc)] -> String
forall a b. (a -> b) -> a -> b
$
        [ (String
"extensions", [OnOff Extension] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([OnOff Extension] -> SDoc)
-> (DynFlags -> [OnOff Extension]) -> DynFlags -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> [OnOff Extension]
extensions (DynFlags -> SDoc) -> DynFlags -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags
df)
        , (String
"extensionFlags", [Extension] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Extension] -> SDoc)
-> (DynFlags -> [Extension]) -> DynFlags -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumSet Extension -> [Extension]
forall a. Enum a => EnumSet a -> [a]
EnumSet.toList (EnumSet Extension -> [Extension])
-> (DynFlags -> EnumSet Extension) -> DynFlags -> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> EnumSet Extension
extensionFlags (DynFlags -> SDoc) -> DynFlags -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags
df)
        , (String
"importPaths", [String] -> SDoc
vList ([String] -> SDoc) -> [String] -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags -> [String]
importPaths DynFlags
df)
        , (String
"generalFlags", FastString -> SDoc
pprHsString (FastString -> SDoc)
-> (DynFlags -> FastString) -> DynFlags -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
forall a. IsString a => String -> a
fromString (String -> FastString)
-> (DynFlags -> String) -> DynFlags -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GeneralFlag] -> String
forall a. Show a => a -> String
show ([GeneralFlag] -> String)
-> (DynFlags -> [GeneralFlag]) -> DynFlags -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumSet GeneralFlag -> [GeneralFlag]
forall a. Enum a => EnumSet a -> [a]
EnumSet.toList (EnumSet GeneralFlag -> [GeneralFlag])
-> (DynFlags -> EnumSet GeneralFlag) -> DynFlags -> [GeneralFlag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> EnumSet GeneralFlag
generalFlags (DynFlags -> SDoc) -> DynFlags -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags
df)
        , -- , ("includePaths", text . show $ includePaths df)
          -- ("packageEnv", ppr $ packageEnv df)
          (String
"pkgNames", [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> ([String] -> [SDoc]) -> [String] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
forall doc. IsLine doc => String -> doc
text ([String] -> SDoc) -> [String] -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags -> [String]
pkgNames DynFlags
df)
        , (String
"packageFlags", [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc)
-> ([PackageFlag] -> [SDoc]) -> [PackageFlag] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageFlag -> SDoc) -> [PackageFlag] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([PackageFlag] -> SDoc) -> [PackageFlag] -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags -> [PackageFlag]
packageFlags DynFlags
df)
        -- ,("pkgDatabase",(map) (ppr . installedPackageId) . pkgDatabase $ df)
        -- ("pkgDatabase", text . show <$> pkgDatabase $ df)
        ]

vList :: [String] -> SDoc
vList :: [String] -> SDoc
vList = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> ([String] -> [SDoc]) -> [String] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
forall doc. IsLine doc => String -> doc
text

setSessionAndInteractiveDynFlags :: DynFlags -> Ghc ()
setSessionAndInteractiveDynFlags :: DynFlags -> Ghc ()
setSessionAndInteractiveDynFlags DynFlags
df = do
#if MIN_VERSION_ghc(9,3,0)
    ()
_ <- UnitId -> DynFlags -> Ghc ()
forall (m :: * -> *). GhcMonad m => UnitId -> DynFlags -> m ()
setUnitDynFlags (DynFlags -> UnitId
homeUnitId_ DynFlags
df) DynFlags
df
    (HscEnv -> HscEnv) -> Ghc ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (HscEnv -> HscEnv
hscUpdateLoggerFlags (HscEnv -> HscEnv) -> (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (DynFlags -> UnitId
homeUnitId_ DynFlags
df))
    DynFlags
df' <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    DynFlags -> Ghc ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setTopSessionDynFlags DynFlags
df'
#else
    _ <- setSessionDynFlags df
#endif
    DynFlags
sessDyns <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    DynFlags -> Ghc ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags DynFlags
sessDyns