diff --git a/lib/Scion/Backend.hs b/lib/Scion/Backend.hs new file mode 100644 index 0000000..80081bd --- /dev/null +++ b/lib/Scion/Backend.hs @@ -0,0 +1,73 @@ +-- | The backend abstraction (well, the beginnings of it.) +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +module Scion.Backend + ( supportedLanguages, supportedOptions, optionsPragma, + supportedPragmas, + ModuleName, mkModuleName, moduleNameText, + allExposedModuleNames, + ) +where + +import Scion.Types + +import qualified DynFlags as Ghc +import qualified GHC as Ghc +import qualified Packages as Ghc +import qualified UniqFM as Ghc +--import qualified Module as Ghc +import qualified Distribution.InstalledPackageInfo as PInfo + +import qualified Data.Text as T +import Data.List ( nub, sort ) + +-- | Sorted list of all supported @LANGUAGE@ pragmas. +supportedLanguages :: [T.Text] +supportedLanguages = sort $ map T.pack Ghc.supportedLanguages + +-- | Sorted list of all flags allowed in the @OPTIONS@ pragma. +supportedOptions :: [T.Text] +supportedOptions = sort $ map T.pack (nub Ghc.allFlags) + +-- | The compiler-specific @OPTIONS@ pragma. (e.g., @OPTIONS_GHC@) +optionsPragma :: T.Text +optionsPragma = "OPTIONS_GHC" + +-- | List of supported pragmas. +supportedPragmas :: [T.Text] +supportedPragmas = sort $ + [ "OPTIONS_GHC", "LANGUAGE", "INCLUDE", "WARNING", "DEPRECATED" + , "INLINE", "NOINLINE", "RULES", "SPECIALIZE", "UNPACK", "SOURCE" + , "SCC" + -- , "LINE" -- only used by code generators, still include? + ] + +-- ------------------------------------------------------------------- + +-- TODO: Move this to a better place? + +-- | A module name (as used in @import@ lists). E.g., @Control.Monad@. +newtype ModuleName = ModuleName { moduleNameText :: T.Text } + deriving (Eq, Ord) + +instance Show ModuleName where + show (ModuleName txt) = T.unpack txt + +mkModuleName :: T.Text -> ModuleName +mkModuleName = ModuleName + +-- | Return all exposed modules of the current session's package DBs. +-- Note that this does /not/ include packages from the current +-- session. +-- +-- The provides a crude yet simple basis for completing @import@ +-- directives. +allExposedModuleNames :: ScionM [ModuleName] +allExposedModuleNames = do + dflags <- Ghc.getSessionDynFlags + let pkg_db = Ghc.pkgIdMap (Ghc.pkgState dflags) + return $ nub + . map (ModuleName . T.pack . Ghc.moduleNameString) + . concatMap PInfo.exposedModules + -- . filter exposed + $ Ghc.eltsUFM pkg_db + diff --git a/scion.cabal b/scion.cabal index ba37063..79d8ee7 100644 --- a/scion.cabal +++ b/scion.cabal @@ -51,6 +51,7 @@ library list-tries >= 0.1 && < 0.3, binary == 0.5.*, array >= 0.2 && < 0.4, + text == 0.7.*, old-time == 1.0.* if impl(ghc == 6.12.*) @@ -79,6 +80,7 @@ library Scion.Inspect.PackageDB, Scion.Utils, Scion.Session, + Scion.Backend, Scion.Cabal, Scion.Ghc, Scion diff --git a/server/Scion/Server/Commands2.hs b/server/Scion/Server/Commands2.hs index a3c7e20..a657ab3 100644 --- a/server/Scion/Server/Commands2.hs +++ b/server/Scion/Server/Commands2.hs @@ -2,16 +2,16 @@ {-# LANGUAGE ScopedTypeVariables #-} module Scion.Server.Commands2 where -import GHC (GhcException(..)) -import Exception (gcatch, ghandle) -import Control.Exception ( throwIO, SomeException ) -import System.Exit (ExitCode) import Scion.Types +import Scion.Backend import Scion.Server.Message -import Data.String ( fromString ) -import DynFlags ( supportedLanguages, allFlags ) +import GHC (GhcException(..)) +import Exception (gcatch, ghandle) +import Control.Exception ( throwIO, SomeException ) +import Data.String ( fromString ) +import System.Exit (ExitCode) import qualified Data.Map as M import qualified Data.Text as T @@ -169,10 +169,18 @@ allCmds = M.fromList [ (cmdName c, c) | c <- allCommands ] allCommands :: [Cmd] allCommands = [ cmdPing - , cmdListSupportedPragmas , cmdConnectionInfo + , cmdListSupportedLanguages + , cmdListSupportedPragmas + , cmdListSupportedFlags + , cmdListExposedModules ] +instance Message ModuleName where + toMsg mn = MsgText (moduleNameText mn) + fromMsg (MsgText txt) = Just (mkModuleName txt) + fromMsg _ = Nothing + -- | Used to test whether the server is alive. cmdPing :: Cmd cmdPing = @@ -191,17 +199,17 @@ cmdConnectionInfo = Cmd "connection-info" $ noArgs worker ,("pid", pid)] cmdListSupportedLanguages :: Cmd -cmdListSupportedLanguages = Cmd "list-supported-languages" $ noArgs cmd - where cmd = return (map T.pack supportedLanguages) +cmdListSupportedLanguages = + Cmd "list-supported-languages" $ noArgs $ return supportedLanguages cmdListSupportedPragmas :: Cmd cmdListSupportedPragmas = Cmd "list-supported-pragmas" $ noArgs $ return supportedPragmas -supportedPragmas :: [T.Text] -supportedPragmas = - [ "OPTIONS_GHC", "LANGUAGE", "INCLUDE", "WARNING", "DEPRECATED" - , "INLINE", "NOINLINE", "RULES", "SPECIALIZE", "UNPACK", "SOURCE" - , "SCC" - , "LINE" -- XXX: only used by code generators, still include? - ] +cmdListSupportedFlags :: Cmd +cmdListSupportedFlags = + Cmd "list-supported-flags" $ noArgs $ return supportedOptions + +cmdListExposedModules :: Cmd +cmdListExposedModules = + Cmd "list-exposed-modules" $ noArgs $ allExposedModuleNames