Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: d4b1e50d51
Fetching contributors…

Cannot retrieve contributors at this time

547 lines (474 sloc) 18.013 kb
{-# LANGUAGE ScopedTypeVariables, CPP, PatternGuards,
ExistentialQuantification #-} -- for 'Cmd'
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module : Scion.Server.Commands
-- Copyright : (c) Thomas Schilling 2008
-- License : BSD-style
--
-- Maintainer : nominolo@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- Commands provided by the server.
--
-- TODO: Need some way to document the wire protocol. Autogenerate?
--
module Scion.Server.Commands (
handleRequest, malformedRequest, -- allCommands, allCommands',
-- these are reused in the vim interface
supportedPragmas, allExposedModules,
) where
import Prelude as P
import Scion.Types
import Scion.Types.Notes
import Scion.Utils
import Scion.Session
import Scion.Server.Protocol
import Scion.Inspect
import Scion.Inspect.DefinitionSite
import Scion.Configure
import DynFlags ( supportedLanguages, allFlags )
import Exception
import FastString
import GHC
import PprTyThing ( pprTypeForUser )
import Outputable ( ppr, showSDoc, showSDocDump, dcolon, showSDocForUser,
showSDocDebug )
import qualified Outputable as O ( (<+>), ($$) )
import Control.Applicative
import Control.Monad
import Data.List ( nub )
import Data.Time.Clock ( NominalDiffTime )
import System.Exit ( ExitCode(..) )
import Text.JSON
import qualified Data.Map as M
import qualified Data.MultiSet as MS
import Distribution.Text ( display )
import qualified Distribution.PackageDescription as PD
import GHC.SYB.Utils
#ifndef HAVE_PACKAGE_DB_MODULES
import UniqFM ( eltsUFM )
import Packages ( pkgIdMap )
import Distribution.InstalledPackageInfo
#endif
------------------------------------------------------------------------
lookupKey :: JSON a => JSObject JSValue -> String -> Result a
lookupKey = flip valFromObj
makeObject :: [(String, JSValue)] -> JSValue
makeObject = makeObj
------------------------------------------------------------------------------
type KeepGoing = Bool
handleRequest :: JSValue -> ScionM (JSValue, KeepGoing)
handleRequest (JSObject req) =
let request = do JSString method <- lookupKey req "method"
params <- lookupKey req "params"
seq_id <- lookupKey req "id"
return (fromJSString method, params, seq_id)
in
case request of
Error _ -> return (malformedRequest, True)
Ok (method, params, seq_id)
| method == "quit" -> return (makeObject
[("version", str "0.1")
,("result", JSNull)
,("id", seq_id)], False)
| otherwise ->
case M.lookup method allCmds of
Nothing -> return (unknownCommand seq_id, True)
Just (Cmd _ arg_parser) ->
decode_params params arg_parser seq_id
where
decode_params JSNull arg_parser seq_id =
decode_params (makeObject []) arg_parser seq_id
decode_params (JSObject args) arg_parser seq_id =
case unPa arg_parser args of
Left err -> return (paramParseError seq_id err, True)
Right act -> do
r <- handleScionException act
case r of
Error msg -> return (commandExecError seq_id msg, True)
Ok a ->
return (makeObject
[("version", str "0.1")
,("id", seq_id)
,("result", showJSON a)], True)
decode_params _ _ seq_id =
return (paramParseError seq_id "Params not an object", True)
handleRequest _ = do
return (malformedRequest, True)
malformedRequest :: JSValue
malformedRequest = makeObject
[("version", str "0.1")
,("error", makeObject
[("name", str "MalformedRequest")
,("message", str "Request was not a proper request object.")])]
unknownCommand :: JSValue -> JSValue
unknownCommand seq_id = makeObject
[("version", str "0.1")
,("id", seq_id)
,("error", makeObject
[("name", str "UnknownCommand")
,("message", str "The requested method is not supported.")])]
paramParseError :: JSValue -> String -> JSValue
paramParseError seq_id msg = makeObject
[("version", str "0.1")
,("id", seq_id)
,("error", makeObject
[("name", str "ParamParseError")
,("message", str msg)])]
commandExecError :: JSValue -> String -> JSValue
commandExecError seq_id msg = makeObject
[("version", str "0.1")
,("id", seq_id)
,("error", makeObject
[("name", str "CommandFailed")
,("message", str msg)])]
allCmds :: M.Map String Cmd
allCmds = M.fromList [ (cmdName c, c) | c <- allCommands ]
------------------------------------------------------------------------
-- | All Commands supported by this Server.
allCommands :: [Cmd]
allCommands =
[ cmdConnectionInfo
, cmdOpenCabalProject
, cmdConfigureCabalProject
, cmdLoadComponent
, cmdListSupportedLanguages
, cmdListSupportedPragmas
, cmdListSupportedFlags
, cmdListCabalComponents
, cmdListRdrNamesInScope
, cmdListExposedModules
, cmdCurrentComponent
, cmdCurrentCabalFile
, cmdSetVerbosity
, cmdGetVerbosity
, cmdLoad
, cmdDumpSources
, cmdThingAtPoint
, cmdSetGHCVerbosity
, cmdBackgroundTypecheckFile
, cmdAddCmdLineFlag
, cmdForceUnload
, cmdDumpDefinedNames
, cmdDefinedNames
, cmdNameDefinitions
]
------------------------------------------------------------------------------
type OkErr a = Result a
-- encode expected errors as proper return values
handleScionException :: ScionM a -> ScionM (OkErr a)
handleScionException m = ((((do
r <- m
return (Ok r)
`gcatch` \(e :: SomeScionException) -> return (Error (show e)))
`gcatch` \(e' :: GhcException) ->
case e' of
Panic _ -> throw e'
InstallationError _ -> throw e'
Interrupted -> throw e'
_ -> return (Error (show e')))
`gcatch` \(e :: ExitCode) ->
-- client code may not exit the server!
return (Error (show e)))
`gcatch` \(e :: IOError) ->
return (Error (show e)))
-- `gcatch` \(e :: SomeException) ->
-- liftIO (print e) >> liftIO (throwIO e)
------------------------------------------------------------------------------
newtype Pa a = Pa { unPa :: JSObject JSValue -> Either String a }
instance Monad Pa where
return x = Pa $ \_ -> Right x
m >>= k = Pa $ \req ->
case unPa m req of
Left err -> Left err
Right a -> unPa (k a) req
fail msg = Pa $ \_ -> Left msg
withReq :: (JSObject JSValue -> Pa a) -> Pa a
withReq f = Pa $ \req -> unPa (f req) req
reqArg' :: JSON a => String -> (a -> b) -> (b -> r) -> Pa r
reqArg' name trans f = withReq $ \req ->
case lookupKey req name of
Error _ -> fail $ "required arg missing: " ++ name
Ok x ->
case readJSON x of
Error m -> fail $ "could not decode: " ++ name ++ " - " ++ m
Ok a -> return (f (trans a))
optArg' :: JSON a => String -> b -> (a -> b) -> (b -> r) -> Pa r
optArg' name dflt trans f = withReq $ \req ->
case lookupKey req name of
Error _ -> return (f dflt)
Ok x ->
case readJSON x of
Error n -> fail $ "could not decode: " ++ name ++ " - " ++ n
Ok a -> return (f (trans a))
reqArg :: JSON a => String -> (a -> r) -> Pa r
reqArg name f = reqArg' name id f
optArg :: JSON a => String -> a -> (a -> r) -> Pa r
optArg name dflt f = optArg' name dflt id f
noArgs :: r -> Pa r
noArgs = return
infixr 1 <&>
-- | Combine two arguments.
--
-- TODO: explain type
(<&>) :: (a -> Pa b)
-> (b -> Pa c)
-> a -> Pa c
a1 <&> a2 = \f -> do f' <- a1 f; a2 f'
data Cmd = forall a. JSON a => Cmd String (Pa (ScionM a))
cmdName :: Cmd -> String
cmdName (Cmd n _) = n
------------------------------------------------------------------------
-- | Used by the client to initialise the connection.
cmdConnectionInfo :: Cmd
cmdConnectionInfo = Cmd "connection-info" $ noArgs worker
where
worker = let pid = 0 :: Int in
return $ makeObject
[("version", showJSON scionVersion)
,("pid", showJSON pid)]
cmdOpenCabalProject :: Cmd
cmdOpenCabalProject =
Cmd "open-cabal-project" $
reqArg' "root-dir" fromJSString <&>
optArg' "dist-dir" ".dist-scion" fromJSString <&>
optArg' "extra-args" "" fromJSString $ worker
where
worker root_dir dist_dir extra_args = do
openOrConfigureCabalProject root_dir dist_dir (words extra_args)
preprocessPackage dist_dir
(toJSString . display . PD.package) `fmap` currentCabalPackage
cmdConfigureCabalProject :: Cmd
cmdConfigureCabalProject =
Cmd "configure-cabal-project" $
reqArg' "root-dir" fromJSString <&>
optArg' "dist-dir" ".dist-scion" fromJSString <&>
optArg' "extra-args" "" fromJSString $ cmd
where
cmd path rel_dist extra_args = do
configureCabalProject path rel_dist (words extra_args)
preprocessPackage rel_dist
(toJSString . display . PD.package) `fmap` currentCabalPackage
instance JSON Component where
readJSON (JSObject obj)
| Ok JSNull <- lookupKey obj "library" = return Library
| Ok s <- lookupKey obj "executable" =
return $ Executable (fromJSString s)
| Ok s <- lookupKey obj "file" =
return $ File (fromJSString s)
readJSON _ = fail "component"
showJSON Library = makeObject [("library", JSNull)]
showJSON (Executable n) =
makeObject [("executable", JSString (toJSString n))]
showJSON (File n) =
makeObject [("file", JSString (toJSString n))]
instance JSON CompilationResult where
showJSON (CompilationResult suc notes time) =
makeObject [("succeeded", JSBool suc)
,("notes", showJSON notes)
,("duration", showJSON time)]
readJSON (JSObject obj) = do
JSBool suc <- lookupKey obj "succeeded"
notes <- readJSON =<< lookupKey obj "notes"
dur <- readJSON =<< lookupKey obj "duration"
return (CompilationResult suc notes dur)
readJSON _ = fail "compilation-result"
instance (Ord a, JSON a) => JSON (MS.MultiSet a) where
showJSON ms = showJSON (MS.toList ms)
readJSON o = MS.fromList <$> readJSON o
instance JSON Note where
showJSON (Note note_kind loc msg) =
makeObject [("kind", showJSON note_kind)
,("location", showJSON loc)
,("message", JSString (toJSString msg))]
readJSON (JSObject obj) = do
note_kind <- readJSON =<< lookupKey obj "kind"
loc <- readJSON =<< lookupKey obj "location"
JSString s <- lookupKey obj "message"
return (Note note_kind loc (fromJSString s))
readJSON _ = fail "note"
str :: String -> JSValue
str = JSString . toJSString
instance JSON NoteKind where
showJSON ErrorNote = JSString (toJSString "error")
showJSON WarningNote = JSString (toJSString "warning")
showJSON InfoNote = JSString (toJSString "info")
showJSON OtherNote = JSString (toJSString "other")
readJSON (JSString s) =
case lookup (fromJSString s)
[("error", ErrorNote), ("warning", WarningNote)
,("info", InfoNote), ("other", OtherNote)]
of Just x -> return x
Nothing -> fail "note-kind"
readJSON _ = fail "note-kind"
instance JSON Location where
showJSON loc | (src, l0, c0, l1, c1) <- viewLoc loc =
makeObject [case src of
FileSrc f -> ("file", str (show f))
OtherSrc s -> ("other", str s)
,("region", JSArray (map showJSON [l0,c0,l1,c1]))]
readJSON (JSObject obj) = do
src <- (do JSString f <- lookupKey obj "file"
return (FileSrc (mkAbsFilePath "/" (fromJSString f))))
<|>
(do JSString s <- lookupKey obj "other"
return (OtherSrc (fromJSString s)))
JSArray ls <- lookupKey obj "region"
case mapM readJSON ls of
Ok [l0,c0,l1,c1] -> return (mkLocation src l0 c0 l1 c1)
_ -> fail "region"
readJSON _ = fail "location"
instance JSON NominalDiffTime where
showJSON t = JSRational True (fromRational (toRational t))
readJSON (JSRational _ n) = return $ fromRational (toRational n)
readJSON _ = fail "diff-time"
cmdLoadComponent :: Cmd
cmdLoadComponent =
Cmd "load-component" $
reqArg "component" $ cmd
where
cmd comp = do
loadComponent comp
instance Sexp CompilationResult where
toSexp (CompilationResult success notes time) = toSexp $
ExactSexp $ parens $
showString "compilation-result" <+>
toSexp success <+>
toSexp notes <+>
toSexp (ExactSexp (showString (show
(fromRational (toRational time) :: Float))))
cmdListSupportedLanguages :: Cmd
cmdListSupportedLanguages = Cmd "list-supported-languages" $ noArgs cmd
where cmd = return (map toJSString supportedLanguages)
cmdListSupportedPragmas :: Cmd
cmdListSupportedPragmas =
Cmd "list-supported-pragmas" $ noArgs $ return supportedPragmas
supportedPragmas :: [String]
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 (nub allFlags)
cmdListRdrNamesInScope :: Cmd
cmdListRdrNamesInScope =
Cmd "list-rdr-names-in-scope" $ noArgs $ cmd
where cmd = do
rdr_names <- getNamesInScope
return (map (showSDoc . ppr) rdr_names)
cmdListCabalComponents :: Cmd
cmdListCabalComponents =
Cmd "list-cabal-components" $ reqArg' "cabal-file" fromJSString $ cmd
where cmd cabal_file = cabalProjectComponents cabal_file
allExposedModules :: ScionM [ModuleName]
#ifdef HAVE_PACKAGE_DB_MODULES
allExposedModules = map moduleName `fmap` packageDbModules True
#else
-- This implementation requires our Cabal to be the same as GHC's.
allExposedModules = do
dflags <- getSessionDynFlags
let pkg_db = pkgIdMap (pkgState dflags)
return $ P.concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
#endif
cmdListExposedModules :: Cmd
cmdListExposedModules = Cmd "list-exposed-modules" $ noArgs $ cmd
where cmd = do
mod_names <- allExposedModules
return $ map (showSDoc . ppr) mod_names
cmdSetGHCVerbosity :: Cmd
cmdSetGHCVerbosity =
Cmd "set-ghc-verbosity" $ reqArg "level" $ setGHCVerbosity
cmdBackgroundTypecheckFile :: Cmd
cmdBackgroundTypecheckFile =
Cmd "background-typecheck-file" $ reqArg' "file" fromJSString $ cmd
where cmd fname = backgroundTypecheckFile fname
cmdForceUnload :: Cmd
cmdForceUnload = Cmd "force-unload" $ noArgs $ unload
cmdAddCmdLineFlag :: Cmd
cmdAddCmdLineFlag =
Cmd "add-command-line-flag" $ reqArg' "flag" fromJSString $ cmd
where cmd flag = addCmdLineFlags [flag] >> return JSNull
cmdThingAtPoint :: Cmd
cmdThingAtPoint =
Cmd "thing-at-point" $
reqArg "file" <&> reqArg "line" <&> reqArg "column" $ cmd
where
cmd fname line col = do
let loc = srcLocSpan $ mkSrcLoc (fsLit fname) line col
tc_res <- gets bgTcCache
-- TODO: don't return something of type @Maybe X@. The default
-- serialisation sucks.
case tc_res of
Just (Typechecked tcm) -> do
--let Just (src, _, _, _, _) = renamedSource tcm
let src = typecheckedSource tcm
--let in_range = const True
let in_range = overlaps loc
let r = findHsThing in_range src
--return (Just (showSDoc (ppr $ S.toList r)))
unqual <- unqualifiedForModule tcm
case pathToDeepest r of
Nothing -> return (Just "no info")
Just (x,xs) ->
--return $ Just (showSDoc (ppr x O.$$ ppr xs))
case typeOf (x,xs) of
Just t ->
return $ Just $ showSDocForUser unqual
(prettyResult x O.<+> dcolon O.<+>
pprTypeForUser True t)
_ -> return (Just (showSDocDebug (ppr x O.$$ ppr xs )))
_ -> return Nothing
cmdDumpSources :: Cmd
cmdDumpSources = Cmd "dump-sources" $ noArgs $ cmd
where
cmd = do
tc_res <- gets bgTcCache
case tc_res of
Just (Typechecked tcm) -> do
let Just (rn, _, _, _, _) = renamedSource tcm
let tc = typecheckedSource tcm
liftIO $ putStrLn $ showSDocDump $ ppr rn
liftIO $ putStrLn $ showData TypeChecker 2 tc
return ()
_ -> return ()
cmdLoad :: Cmd
cmdLoad = Cmd "load" $ reqArg "component" $ cmd
where
cmd comp = do
liftIO (putStrLn $ "Loading " ++ show comp)
loadComponent comp
cmdSetVerbosity :: Cmd
cmdSetVerbosity =
Cmd "set-verbosity" $ reqArg "level" $ cmd
where cmd v = setVerbosity (intToVerbosity v)
cmdGetVerbosity :: Cmd
cmdGetVerbosity = Cmd "get-verbosity" $ noArgs $ verbosityToInt <$> getVerbosity
cmdCurrentComponent :: Cmd
cmdCurrentComponent = Cmd "current-component" $ noArgs $ getActiveComponent
cmdCurrentCabalFile :: Cmd
cmdCurrentCabalFile = Cmd "current-cabal-file" $ noArgs $ cmd
where cmd = do
r <- gtry currentCabalFile
case r of
Right f -> return (showJSON f)
Left (_::SomeScionException) -> return JSNull
cmdDumpDefinedNames :: Cmd
cmdDumpDefinedNames = Cmd "dump-defined-names" $ noArgs $ cmd
where
cmd = do db <- gets defSiteDB
liftIO $ putStrLn $ dumpDefSiteDB db
cmdDefinedNames :: Cmd
cmdDefinedNames = Cmd "defined-names" $ noArgs $ cmd
where cmd = definedNames <$> gets defSiteDB
cmdNameDefinitions :: Cmd
cmdNameDefinitions =
Cmd "name-definitions" $ reqArg' "name" fromJSString $ cmd
where cmd nm = do
db <- gets defSiteDB
let locs = map fst $ lookupDefSite db nm
return locs
Jump to Line
Something went wrong with that request. Please try again.