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

-- |GHC API utilities
module Ide.Plugin.Eval.GHC (
    addExtension,
    addImport,
    hasPackage,
    addPackages,
    modifyFlags,
    showDynFlags,
) 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)

{- $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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
name forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([PackageFlag] -> [String]
pkgNames_ [PackageFlag]
pkgFlags)

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

pkgNames_ :: [PackageFlag] -> [String]
pkgNames_ :: [PackageFlag] -> [String]
pkgNames_ =
    forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        ( \case
            ExposePackage String
_ (PackageArg String
n) ModRenaming
_  -> forall a. a -> Maybe a
Just String
n
            ExposePackage String
_ (UnitIdArg Unit
uid) ModRenaming
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> Text
printOutputable Unit
uid
            PackageFlag
_                                 -> 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 = forall (m :: * -> *) b.
(MonadIO m, MonadCatch m) =>
m b -> m (Either String b)
gStrictTry forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
GhcMonad m =>
(DynFlags -> DynFlags) -> m DynFlags
modifyFlags forall a b. (a -> b) -> a -> b
$ \DynFlags
df ->
        DynFlags
df{packageFlags :: [PackageFlag]
packageFlags = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
pkgName [PackageFlag]
pf -> if [PackageFlag] -> String -> Bool
hasPackage_ [PackageFlag]
pf String
pkgName then [PackageFlag]
pf else String -> PackageFlag
expose String
pkgName forall a. a -> [a] -> [a]
: [PackageFlag]
pf) (DynFlags -> [PackageFlag]
packageFlags DynFlags
df) [String]
pkgNames}
  where
    expose :: String -> PackageFlag
expose String
name = String -> PackageArg -> ModRenaming -> PackageFlag
ExposePackage (String
"-package " 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 <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    ()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags (DynFlags -> DynFlags
f DynFlags
df)
    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 <- forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
    -- dbgO "CONTEXT" ctx
    ImportDecl GhcPs
idecl <- forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl String
i
    forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> InteractiveImport
IIDecl ImportDecl GhcPs
idecl forall a. a -> [a] -> [a]
: [InteractiveImport]
ctx
    -- ctx' <- getContext
    -- dbg "CONTEXT'" ctx'
    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 =
    forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc -> HscEnv
hsc{hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext -> Extension -> InteractiveContext
setExtension (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc) Extension
ext}

setExtension :: InteractiveContext -> Extension -> InteractiveContext
setExtension :: InteractiveContext -> Extension -> InteractiveContext
setExtension InteractiveContext
ic Extension
ext = InteractiveContext
ic{ic_dflags :: DynFlags
ic_dflags = DynFlags -> Extension -> DynFlags
xopt_set (InteractiveContext -> DynFlags
ic_dflags InteractiveContext
ic) Extension
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> Text
printOutputable forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(String
n, SDoc
d) -> String -> SDoc
text (String
n forall a. [a] -> [a] -> [a]
++ String
": ") SDoc -> SDoc -> SDoc
<+> SDoc
d) forall a b. (a -> b) -> a -> b
$
        [ (String
"extensions", forall a. Outputable a => a -> SDoc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> [OnOff Extension]
extensions forall a b. (a -> b) -> a -> b
$ DynFlags
df)
        , (String
"extensionFlags", forall a. Outputable a => a -> SDoc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => EnumSet a -> [a]
EnumSet.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> EnumSet Extension
extensionFlags forall a b. (a -> b) -> a -> b
$ DynFlags
df)
        , (String
"importPaths", [String] -> SDoc
vList forall a b. (a -> b) -> a -> b
$ DynFlags -> [String]
importPaths DynFlags
df)
        , (String
"generalFlags", FastString -> SDoc
pprHsString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => EnumSet a -> [a]
EnumSet.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> EnumSet GeneralFlag
generalFlags forall a b. (a -> b) -> a -> b
$ DynFlags
df)
        , -- , ("includePaths", text . show $ includePaths df)
          -- ("packageEnv", ppr $ packageEnv df)
          (String
"pkgNames", [SDoc] -> SDoc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text forall a b. (a -> b) -> a -> b
$ DynFlags -> [String]
pkgNames DynFlags
df)
        , (String
"packageFlags", [SDoc] -> SDoc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr 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
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text