Skip to content
Browse files

removing Scion.Server.Protocol.Vim it is obsolete. vim uses JSON inte…

…rface as well
  • Loading branch information...
1 parent c4b8a09 commit 4752fabe4b9ed8940fc33d2a12cbd3828d335585 @MarcWeber MarcWeber committed Jul 23, 2009
Showing with 0 additions and 417 deletions.
  1. +0 −1 server/Main.hs
  2. +0 −416 server/Scion/Server/Protocol/Vim.hs
View
1 server/Main.hs
@@ -26,7 +26,6 @@ module Main where
import MonadUtils ( liftIO )
import Scion.Server.Generic as Gen
--import qualified Scion.Server.ProtocolEmacs as Emacs
-import qualified Scion.Server.Protocol.Vim as Vim
import qualified Scion.Server.ConnectionIO as CIO
import Scion (runScion)
View
416 server/Scion/Server/Protocol/Vim.hs
@@ -1,416 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables, CPP #-}
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances,
- FlexibleInstances, OverlappingInstances #-}
-{-# OPTIONS -Wnot #-}
--- |
--- Module : Scion.Server.ProtocolVim
--- License : BSD-style
---
--- Maintainer : marco-oweber@gmx.de
--- Stability : experimental
--- Portability : portable
---
--- talk to vim
--- each request or response is a vimtype (:h string and :h eval). Messages are
--- separated by a newline character "\n"
-
-module Scion.Server.Protocol.Vim where
-import Scion.Server.Protocol (scionVersion)
-import qualified Scion.Server.ConnectionIO as CIO
-import Scion.Server.Commands (supportedPragmas, allExposedModules)
-import Scion.Server.ConnectionIO (ConnectionIO(..))
-import Scion.Types (ScionM, Component(..), gets, bgTcCache, BgTcCache(..), CompilationResult(..))
-import Scion.Inspect ( prettyResult )
-import Scion.Inspect.Find ( overlaps, findHsThing, pathToDeepest)
-import Scion.Inspect.TypeOf ( typeOf )
-import Scion.Configure (configureCabalProject)
-import Scion.Utils ( unqualifiedForModule, camelCaseMatch )
-import Scion.Session (preprocessPackage, currentCabalPackage, loadComponent,
- backgroundTypecheckFile, unload, setGHCVerbosity, addCmdLineFlags)
-import FastString (fsLit, unpackFS)
-
-import Control.Monad (forever, liftM)
-import Control.Exception.Base (Exception)
---import Control.Monad.Trans (lift)
-import qualified Control.Exception as E
-import Prelude hiding (log)
-import qualified System.Log.Logger as HL
-
-import qualified Data.ByteString.Lazy.Char8 as S
-import qualified Data.Map as M
-import Data.Maybe (isJust, Maybe(..))
-import Data.List (intercalate, nub, isPrefixOf)
-import Data.Time.Clock ( NominalDiffTime )
-
-import DynFlags ( supportedLanguages, allFlags )
-import InteractiveEval ( getNamesInScope, getRdrNamesInScope )
-import qualified Outputable as O
-import GHC
-import Exception (ghandle)
-import PprTyThing (pprTypeForUser)
-import ErrUtils (WarningMessages, ErrorMessages, ErrMsg(..) )
-import Bag (bagToList, Bag)
-
-import GHC.Read (readPrec)
-import MonadUtils
-import SrcLoc (SrcSpan(..))
-import Text.ParserCombinators.ReadPrec (readPrec_to_S, minPrec)
-import Distribution.Text ( display )
-import qualified Distribution.PackageDescription as PD
-
-import GHC.SYB.Utils (showData)
-
--- think about using another parser so that this dependency can be removed?
-import Text.ParserCombinators.Parsec.Error (ParseError)
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Char
-
-import Text.ParserCombinators.ReadP (skipSpaces)
-import qualified Data.Set as Set
-
-log = HL.logM "protocol.vim"
-logInfo = log HL.INFO
-logError = log HL.ERROR
-logDebug = log HL.DEBUG
-
-data VimCommand = VimCommand String (M.Map VimType VimType -> ScionM VimType)
-
--- to be synchronized with allCommands
-vimCommands :: [VimCommand]
-vimCommands =
- [ cmdConnectionInfo
- , cmdOpenCabalProject
- , cmdLoadComponent
- , cmdListSupportedLanguages
- , cmdListSupportedPragmas
- , cmdListSupportedFlags
- , cmdListRdrNamesInScope
- , cmdListExposedModules
- , cmdSetGHCVerbosity
- , cmdBackgroundTypecheckFile
- , cmdForceUnload
- , cmdAddCmdLineFlag
- , cmdThingAtPoint
- , cmdModuleCompletion
- -- for testing. I'd like to get the module which is exporting the thing one day..
- -- basically its the same as cmdThingAtPoint
- , cmdThingAtPointMoreInfo
- -- , cmdDumpSources
- , cmdListCabalTargets
- ]
-
-------------------------------------------------------------------------------
-
--- | get request, parse it and send reply
-handle :: (ConnectionIO con) => con -> String -> ScionM ()
-handle con "0" = do
- -- handshake ok, accept this client version
- liftIO $ CIO.putLine con $ S.pack "ok"
-
- -- handle requests:
- forever $ do
- -- read request line
- l <- liftM S.unpack $ liftIO $ CIO.getLine con
- liftIO $ logDebug $ "got request str" ++ l
-
- -- handle it
- vimTypeReply <- handleFailure $ case parseVim l of
- Right (VDict map') -> case M.lookup (VString "request") map' of
- Nothing -> fail "key request missing "
- Just r -> do
- rs <- fromString r
- case lookup rs (map (\(VimCommand r a) -> (r, a)) vimCommands) of
- Just a -> a map'
- Nothing -> fail $ "unkown request: " ++ rs
-
- let reply = show vimTypeReply
- liftIO $ do
- logDebug $ "replying " ++ reply
- putLine con $ S.pack $ reply
-handle con unkownVersion = do
- -- handshake failure, don't accept this client version
- liftIO $ CIO.putLine con $
- S.pack $ "failure: don't know how to talk to vim client version "
- ++ (show unkownVersion)
-
-requireArg map key = do
- case M.lookup (VString key) map of
- Nothing -> fail $ "key " ++ key ++ "required"
- Just v -> fromString v
-defaultArg map key default' = do
- case M.lookup (VString key) map of
- Nothing -> default'
- Just v -> fromString v
-lookupAndRead dict key = do
- s <- fromString =<< M.lookup (VString key) dict
- case readEither s of
- Right x -> return x
- Left e -> Nothing
-lookupAndReadFail :: (Read r) => M.Map VimType VimType -> String -> ScionM r
-lookupAndReadFail dict key =
- maybe (fail $ "failed reading key " ++ key) return $ lookupAndRead dict key
-
--- TODO catch failures and send them as error to the client
---handleScionException (TODO)
-handleFailure :: ScionM VimType -> ScionM VimType
--- TODO narrow Exception type, check implementation
-handleFailure f = do
- rep <- f
- -- success, put everything into the key "result"
- return $ toVim [("result" , rep)]
--- handleFailure = ghandle (\(Exception e) -> return $ toVim [("error", show e)] )
-
-------------------------------------------------------------------------------
--- implementation vim commands, also see Scion.Server.Commands
-
-cmdConnectionInfo = VimCommand "cmdConnectionInfo" $ \map' -> do
- return $ toVim [ ("version", scionVersion),
- ("pid", 0)]
-
-cmdOpenCabalProject = VimCommand "cmdOpenCabalProject" $ \map' -> do
- root_dir <- requireArg map' "root_dir"
- dist_dir <- requireArg map' "dist_dir"
- case M.lookup (VString "extra_args") map' of
- Just (VList list) -> do
- extra_args' <- mapM fromString list
- configureCabalProject root_dir dist_dir extra_args'
- preprocessPackage dist_dir
- liftM ( toVim . display . PD.package) currentCabalPackage
- Just x -> fail $ "key extra_args: list expected, got " ++ (show x)
- Nothing -> fail $ "no arguments given!"
-
-cmdLoadComponent = VimCommand "cmdLoadComponent" $ \map' -> do
- -- component is either "library" or "executable:name"
- component <- requireArg map' "component"
- comp <- if component == "library"
- then return Library
- else case break (== ':') component of
- (_,_:b) -> return $ Executable b
- _ -> fail $ "couldn't parse component argument:\n"
- ++ "either library or executable:executable_name expected"
- liftM toVim $ loadComponent comp
-
-cmdListSupportedLanguages = VimCommand "cmdListSupportedLanguages" $ \map' -> do
- return $ toVim $ supportedLanguages
-
-cmdListSupportedPragmas = VimCommand "cmdListSupportedPragmas" $ \map' -> do
- return $ toVim $ supportedPragmas
-
-cmdListSupportedFlags = VimCommand "cmdListSupportedFlags" $ \map' -> do
- return $ toVim $ nub $ allFlags
-
-cmdListRdrNamesInScope = VimCommand "cmdListRdrNamesInScope" $ \map' -> do
- rdr_names <- getNamesInScope
- return $ toVim $ map (O.showSDoc . O.ppr) rdr_names
-
-cmdListExposedModules = VimCommand "cmdListExposedModules" $ \map' -> do
- mod_names <- allExposedModules
- return $ toVim $ map (O.showSDoc . O.ppr) mod_names
-
-cmdSetGHCVerbosity = VimCommand "cmdSetGHCVerbosity" $ \map' -> do
- lvl <- lookupAndReadFail map' "lvl"
- liftM toVim $ setGHCVerbosity lvl
-
-cmdBackgroundTypecheckFile = VimCommand "cmdBackgroundTypecheckFile" $ \map' -> do
- file <- requireArg map' "file"
- liftM (toVim . (\(a, b) -> [("inProject", toVim a),("compilationResult", toVim b)])) $
- backgroundTypecheckFile file
-
-cmdForceUnload = VimCommand "cmdForceUnload" $ \map' -> do
- liftM toVim $ unload
-
-cmdAddCmdLineFlag = VimCommand "cmdAddCmdLineFlag" $ \map' -> do
- add <- requireArg map' "add"
- addCmdLineFlags [add]
- return $ toVim ()
-
-cmdThingAtPoint = VimCommand "cmdThingAtPoint" $ \map' -> do
- file <- requireArg map' "file"
- line <- lookupAndReadFail map' "line"
- col <- lookupAndReadFail map' "col"
- liftM toVim $ cmd file line col
- where
- -- TODO remove this code duplication !
- cmd fname line col = do
- let loc = srcLocSpan $ mkSrcLoc (fsLit fname) line col
- tc_res <- gets bgTcCache
- 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 (O.showSDoc (O.ppr $ S.toList r)))
- unqual <- unqualifiedForModule tcm
- case pathToDeepest r of
- Nothing -> return (Just "no info")
- Just (x,xs) ->
- --return $ Just (O.showSDoc (O.ppr x O.$$ O.ppr xs))
- case typeOf (x,xs) of
- Just t ->
- return $ Just $ O.showSDocForUser unqual
- (prettyResult x O.<+> O.dcolon O.<+>
- pprTypeForUser True t)
- _ -> return (Just (O.showSDocDebug (O.ppr x O.$$ O.ppr xs )))
- _ -> return Nothing
-
--- module completion
-cmdModuleCompletion = VimCommand "cmdModuleCompletion" $ \map' -> do
- short <- requireArg map' "short"
- camelCase <- lookupAndReadFail map' "camelCase"
- mod_names <- allExposedModules
- let modules = map (O.showSDoc . O.ppr) mod_names
- let filterFunc = if camelCase
- then \c s -> isPrefixOf c s || camelCaseMatch c s
- else isPrefixOf
- return $ toVim $ filter (filterFunc short) modules
-
-cmdThingAtPointMoreInfo = VimCommand "cmdThingAtPointMoreInfo" $ \map' -> do
- file <- requireArg map' "file"
- line <- lookupAndReadFail map' "line"
- col <- lookupAndReadFail map' "col"
- liftM toVim $ cmd file line col
- where
- -- TODO remove this code duplication !
- cmd fname line col = do
- let loc = srcLocSpan $ mkSrcLoc (fsLit fname) line col
- tc_res <- gets bgTcCache
- 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 (O.showSDoc (O.ppr $ Set.toList r)))
- -- unqual <- unqualifiedForModule tcm
- -- case pathToDeepest r of
- -- Nothing -> return (Just "no info")
- -- Just (x,xs) ->
- -- --return $ Just (O.showSDoc (O.ppr x O.$$ O.ppr xs))
- -- case typeOf (x,xs) of
- -- Just t ->
- -- return $ Just $ O.showSDocForUser unqual
- -- (prettyResult x O.<+> O.dcolon O.<+>
- -- pprTypeForUser True t)
- -- _ -> return (Just (O.showSDocDebug (O.ppr x O.$$ O.ppr xs )))
- _ -> return Nothing
-
--- cmdDumpSources = VimCommand "cmdDumpSources" $ \map -> do
--- liftM toVim $ do
--- tc_res <- gets bgTcCache
--- case tc_res of
--- Just (Typechecked tcm) -> do
--- let Just (rn, _, _, _, _) = renamedSource tcm
--- let tc = typecheckedSource tcm
--- liftIO $ putStrLn $ O.showSDocDump $ O.ppr rn
--- liftIO $ putStrLn $ showData TypeChecker 2 tc
--- return ()
--- _ -> return ()
-
--- only used to pass a completion list over to vim
-cmdListCabalTargets = VimCommand "cmdListCabalTargets" $ \_ -> do
- cp <- currentCabalPackage
- return $ toVim $
- (if isJust (PD.library cp) then ["library"] else [] )
- ++ map ( ("executable:" ++) . PD.exeName) (PD.executables cp)
-
--- ========== passing data is done using serialized vim types : ======
---
-
-data VimType = VList [VimType]
- | VDict (M.Map VimType VimType)
- | VInt Int
- | VString String
- deriving (Eq, Ord)
-
-
-class ToVimType a where
- toVim :: a -> VimType
-
-instance Show VimType where
- show (VList l) = '[':intercalate "," (map show l) ++ "]"
- show (VDict d) = '{':intercalate "," [ (show k) ++ ":" ++ (show v) |(k,v) <- M.toList d ] ++ "}"
- show (VInt i) = show i
- show (VString s) = show s
-
-instance ToVimType VimType where toVim = id -- only for convinience
-instance ToVimType Int where toVim = VInt
-instance ToVimType String where toVim = VString
-listToVim :: (ToVimType a) => [a] -> VimType
-listToVim = VList . map toVim
-instance (ToVimType b) => ToVimType [b] where
- toVim = listToVim
-instance (ToVimType a, ToVimType b) => ToVimType [(a,b)] where
- toVim = VDict . M.fromList . map (\(a,b) -> (toVim a, toVim b) )
-instance ToVimType () where
- toVim _ = toVim [("void", toVim True)]
-instance ToVimType Bool where
- toVim b = toVim $ if b then (1::Int) else 0
-
-instance ToVimType CompilationResult where
- toVim cr = toVim [
- ("compilationSucceeded", toVim (compilationSucceeded cr)),
- ("compilationWarnings", toVim $ concatMap errMsgToVimList ([] :: [ErrMsg])),
- ("compilationErrors", toVim $ concatMap errMsgToVimList ([] :: [ErrMsg])),
- ("compilationTime", toVim ( "TODO" {- (compilationTime cr-} ))
- ]
--- return list which can be passed to setqflist
-errMsgToVimList :: ErrMsg -> [VimType]
-errMsgToVimList em =
- let (fst:moreLocations) = errMsgSpans em
- loc :: SrcSpan -> [(VimType, VimType)]
- loc em =
- [ (toVim "filename", (toVim . unpackFS) ( (srcLocFile . srcSpanStart) em))
- , (toVim "lnum", toVim ( srcLocLine . srcSpanStart $ em))
- , (toVim "col", toVim ( srcLocCol . srcSpanStart $ em))
- ]
-
- -- ghc does print multiline messages. So add a text qf item for all
- -- trailing lines to keep them readable
- addText :: VimType -> [String] -> [VimType]
- addText (VDict map') [msg] = [VDict $ M.insert (toVim "text") (toVim msg) map']
- addText (VDict map') (msg:msgs) = addText (VDict map') [msg] ++ map (\m -> toVim [(toVim "text", toVim m)]) msgs
- -- addText _ _ = error "never executed"
- in
- -- first location and message
- (addText (toVim $ loc fst) $ lines $ (O.showSDoc (errMsgShortDoc em)) ++ ("\n" ++ O.showSDoc (errMsgExtraInfo em)))
- -- more error locations - when do they occur?
- ++ map (toVim . loc) moreLocations
-
-instance ToVimType O.SDoc where
- toVim = toVim . O.showSDoc
-
-instance (ToVimType a) => ToVimType (Maybe a) where
- toVim (Just x) = toVim [("Just", toVim x)]
- toVim Nothing = toVim "Nothing"
-
-vdictFromList = VDict . M.fromList
-
-parseVim :: String -> Either ParseError VimType
-parseVim s =
- let spaces = many (oneOf " \t")
- enclosedBy st sp p = char st >> spaces >> p >>= \r -> spaces >> char sp >> return r
- parseVim' = choice [ parseInt, parseString, parseList, parseDict ]
- parseInt = liftM (VInt . read) $ many1 (oneOf $ '-':['0'..'9'])
- parseString = liftM (VString) $ choice [parseTick, parseQuot]
- where parseQuot = char '"' >> many qchar >>= \s -> char '"' >> return s
- qchar = choice [ char '\\' >> anyChar, noneOf "\\\"" ]
- parseTick = char '\'' >> many (noneOf "\'" ) >>= \s -> char '\'' >> return s
- parseList = enclosedBy '[' ']' $ liftM VList $ sepBy parseVim' ( spaces >> char ',' >> spaces )
- keyValue = parseVim' >>= \k -> spaces >> char ':' >> spaces >> parseVim' >>= \v -> return (k,v)
- parseDict = enclosedBy '{' '}' $ liftM (VDict . M.fromList) $ sepBy keyValue ( spaces >> char ',' >> spaces )
- parseDict :: CharParser () VimType
- in parse parseVim' "connection input" s
-
-fromString (VString s) = return s
-fromString r = fail $ "string expceted, but got " ++ (show r)
-
--- move this to Utils? The ghc library does no longer export readEither
-readEither :: Read a => String -> Either String a
-readEither s =
- case [ x | (x,"") <- readPrec_to_S readPrec minPrec s ] of
- [x] -> Right x
- [] -> Left "Prelude.read: no parse"
- _ -> Left "Prelude.read: ambiguous parse"

0 comments on commit 4752fab

Please sign in to comment.
Something went wrong with that request. Please try again.