{-# 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           Development.IDE.GHC.Compat
import qualified EnumSet
import           GHC.LanguageExtensions.Type (Extension (..))
import           GhcMonad                    (modifySession)
import           GhcPlugins                  (DefUnitId (..),
                                              InstalledUnitId (..), fsLit,
                                              hsc_IC, pprHsString)
import           HscTypes                    (InteractiveContext (ic_dflags))
import           Ide.Plugin.Eval.Util        (asS, gStrictTry)
import qualified Lexer
import           Module                      (UnitId (DefiniteUnitId))
import           Outputable                  (Outputable (ppr), SDoc,
                                              showSDocUnsafe, text, vcat, (<+>))
import qualified Parser
import           SrcLoc                      (mkRealSrcLoc)
import           StringBuffer                (stringToStringBuffer)

{- $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 String -> String -> Bool
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_ ([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 (DefiniteUnitId DefUnitId
n)) ModRenaming
_ -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ DefUnitId -> String
forall a. Outputable a => a -> String
asS DefUnitId
n
            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.
ExceptionMonad 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 :: [PackageFlag]
packageFlags = (String -> [PackageFlag] -> [PackageFlag])
-> [PackageFlag] -> [String] -> [PackageFlag]
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 PackageFlag -> [PackageFlag] -> [PackageFlag]
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 " 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 :: (DynFlags -> DynFlags) -> m DynFlags
modifyFlags DynFlags -> DynFlags
f = do
    DynFlags
df <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
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 :: 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 :: 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 :: 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 =
    SDoc -> String
showSDocUnsafe (SDoc -> String)
-> ([(String, SDoc)] -> SDoc) -> [(String, SDoc)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
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
text (String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": ") SDoc -> SDoc -> SDoc
<+> 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
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
text ([String] -> SDoc) -> [String] -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags -> [String]
pkgNames DynFlags
df)
        , (String
"packageFlags", [SDoc] -> SDoc
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
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
text