/server/Scion/Server/Commands.hs

{-# LANGUAGE ScopedTypeVariables, CPP, PatternGuards, FlexibleContexts,
             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.Types.Outline
import qualified Scion.Types.JSONDictionary as Dic
import Scion.Utils
import Scion.Session
import Scion.Server.Protocol
import Scion.Inspect
import Scion.Inspect.DefinitionSite
import Scion.Inspect.PackageDB
import Scion.Inspect.Completions
import Scion.Cabal
import Scion.Ghc hiding ( (<+>) )

#if __GLASGOW_HASKELL__ < 700
import DynFlags ( supportedLanguages, allFlags )
#else
import DynFlags ( supportedLanguagesAndExtensions, allFlags )
#endif
import Exception
import FastString
import PprTyThing ( pprTypeForUser )
import qualified Outputable as O ( (<+>),alwaysQualify,neverQualify,text )

import Control.Applicative
import Control.Monad
import Data.List ( nub, isInfixOf )
import Data.Time.Clock  ( NominalDiffTime )
import System.Exit ( ExitCode(..) )
import Text.JSON.AttoJSON (JSON,JSValue(..),fromJSON,toJSON)
import qualified Data.ByteString.UTF8 as S
import qualified Data.Map as M
import qualified Data.MultiSet as MS

import GHC.SYB.Utils

#ifndef HAVE_PACKAGE_DB_MODULES
import UniqFM ( eltsUFM )
import Packages ( pkgIdMap )

import Distribution.InstalledPackageInfo
#endif

#if __GLASGOW_HASKELL__ >= 700
supportedLanguages :: [String]
supportedLanguages = supportedLanguagesAndExtensions
#endif

type KeepGoing = Bool

-- a scion request is JS object with 3 keys:
-- method: the method to be called
-- params: arguments to be passed
-- id    : this value will be passed back to the client
--         to identify a reply to a specific request
--         asynchronous requests will be implemented in the future
handleRequest :: JSValue -> ScionM (JSValue, KeepGoing)
handleRequest req@(JSObject _) =
  let request = do JSString method <- Dic.lookupKey req (Dic.method)
                   params <- Dic.lookupKey req (Dic.params)
                   seq_id <- Dic.lookupKey req (Dic.id)
                   return (method, params, seq_id)

      decode_params JSNull arg_parser seq_id = decode_params (Dic.makeObject []) arg_parser seq_id
      decode_params args@(JSObject _) 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 (Dic.makeObject
                      [(Dic.version, str "0.1")
                      ,(Dic.id, seq_id)
                      ,(Dic.result, toJSON a)], True)

      decode_params _ _ seq_id = return (paramParseError seq_id "Params not an object", True)

      -- The quit command's reply
      quitReply seq_id = Dic.makeObject [ (Dic.version
                                        , JSString Dic.version01)
                                        , (Dic.result, JSNull)
                                        , (Dic.id, seq_id)
                                        ]

      -- The default command dispatcher:
      dispatch method params seq_id = 
        if method /= Dic.quit
          then case M.lookup (S.toString method) allCmds of
                Nothing                 -> return (unknownCommand seq_id method, True)
                Just (Cmd _ arg_parser) -> decode_params params arg_parser seq_id
          else return (quitReply seq_id, False)

  in case request of
      Nothing                       -> return (malformedRequest, True)
      Just (method, params, seq_id) -> dispatch method params seq_id

handleRequest _ = return(malformedRequest, True)

malformedRequest :: JSValue
malformedRequest = Dic.makeObject
 [(Dic.version, JSString Dic.version01)
 ,(Dic.error, Dic.makeObject
    [(Dic.name, str "MalformedRequest")
    ,(Dic.message, str "Request was not a proper request object.")])]

unknownCommand :: JSValue -> S.ByteString -> JSValue
unknownCommand seq_id method= Dic.makeObject
 [(Dic.version, JSString Dic.version01)
 ,(Dic.id, seq_id)
 ,(Dic.error, Dic.makeObject
    [(Dic.name, str "UnknownCommand")
    ,(Dic.message, str $ "The requested method '"++ (S.toString method) ++"' is not supported.")])]

paramParseError :: JSValue -> String -> JSValue
paramParseError seq_id msg = Dic.makeObject
 [(Dic.version, JSString Dic.version01)
 ,(Dic.id, seq_id)
 ,(Dic.error, Dic.makeObject
    [(Dic.name, str "ParamParseError")
    ,(Dic.message, str msg)])]

commandExecError :: JSValue -> String -> JSValue
commandExecError seq_id msg = Dic.makeObject
 [(Dic.version, JSString Dic.version01)
 ,(Dic.id, seq_id)
 ,(Dic.error, Dic.makeObject
    [(Dic.name, str "CommandFailed")
    ,(Dic.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
    , cmdListsupportedLanguages
    , cmdListSupportedPragmas
    , cmdListSupportedFlags
    , cmdListCabalComponents
    , cmdListCabalConfigurations
    , cmdWriteSampleConfig
    , cmdListRdrNamesInScope
    , cmdListExposedModules
    , cmdCurrentComponent
    , cmdSetVerbosity
    , cmdGetVerbosity
    , cmdLoad
    , cmdDumpSources
    , cmdThingAtPoint
    , cmdSetGHCVerbosity
    , cmdBackgroundTypecheckFile
    , cmdBackgroundTypecheckArbitrary
    , cmdAddCmdLineFlag
    , cmdForceUnload
    , cmdDumpDefinedNames
    , cmdDefinedNames
    , cmdNameDefinitions
    , cmdIdentify
    , cmdDumpModuleGraph
    , cmdDumpNameDB
    , cmdToplevelNames
    , cmdOutline
    , cmdTokens
    , cmdTokenAtPoint
    , cmdTokenPreceding
    , cmdTokenTypes
--    , cmdParseCabal
--    , cmdParseCabalArbitrary
    , cmdCabalDependencies
    , cmdModuleGraph
    , cmdCompletionTypes
    , cmdCompletionVarIds
    , cmdCompletionClassTypeNames
    , cmdOccurrences
    , cmdSetUserFlags
    ]

------------------------------------------------------------------------------

data OkErr a = Error String | Ok 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 ("Scion:" ++ (show e))))
  `gcatch` \(e' :: GhcException) ->
               case e' of
                Panic _ -> throw e'
                InstallationError _ -> throw e'
#if __GLASGOW_HASKELL__ < 700
                Interrupted -> throw e'
#endif
                _ -> return (Error ("GHC:" ++ (show e'))))
  `gcatch` \(e :: ExitCode) ->
                -- client code may not exit the server!
                return (Error (show e)))
  `gcatch` \(e :: IOError) ->
                return (Error ("IO:" ++ (show e))))
--   `gcatch` \(e :: SomeException) ->
--                 liftIO (print e) >> liftIO (throwIO e)

------------------------------------------------------------------------------

-- | Parsed argument ("Pa") type
newtype Pa a = Pa {
   unPa :: 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 :: (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 Dic.lookupKey req (S.fromString name) of
      Nothing -> fail $ "required arg missing: " ++ name
      Just x ->
          case fromJSON x of
            Nothing -> fail $ "could not decode: '" ++ name  ++ "'"
            Just a -> return (f (trans a))

optArg' :: JSON a => String -> b -> (a -> b) -> (b -> r) -> Pa r
optArg' name dflt trans f = withReq $ \req ->
    case Dic.lookupKey req (S.fromString name) of
      Nothing -> return (f dflt)
      Just x ->
          case fromJSON x of
            Nothing -> fail $ "could not decode: " ++ name -- ++ " - " ++ n
            Just 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

-- =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
-- Commonly used arguments:
-- =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

-- | Command takes no arguments
noArgs :: r -> Pa r
noArgs = return

-- | Command takes a file name argument
fileNameArg :: (String -> r) -> Pa r
fileNameArg = reqArg' "file" S.toString

-- | Command takes a document argument
docContentsArg :: (String -> r) -> Pa r
docContentsArg = reqArg' "contents" S.toString

-- | Command takes an optional literate Haskell flag
literateFlagOpt :: (Bool -> r) -> Pa r
literateFlagOpt = optArg' "literate" False decodeBool

-- | Command takes required line and column arguments
lineColumnArgs :: (Int -> Int -> r) -> Pa r
lineColumnArgs = reqArg "line" <&> reqArg "column"

-- | Combine two arguments.
--
-- TODO: explain type

infixr 1 <&>

(<&>) :: (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 -- TODO for linux: System.Posix.Internals (c_getpid)
             return $ Dic.makeObject
               [(Dic.version, toJSON scionVersion)
               ,(Dic.pid,     toJSON pid)]

decodeBool :: JSValue -> Bool
decodeBool (JSBool b) = b
decodeBool _ = error "no bool"

{- Unused at the moment
decodeExtraArgs :: JSValue -> [String]
decodeExtraArgs JSNull         = []
decodeExtraArgs (JSString s)   = words (S.toString s) -- TODO: check shell-escaping
decodeExtraArgs (JSArray arr)  = [ S.toString s | JSString s <- arr ]
decodeExtraArgs (JSBool b)     = [ (show b) ]
decodeExtraArgs (JSNumber b)   = [ (show b) ]
decodeExtraArgs (JSObject _)   = undefined -}

instance JSON Component where
  fromJSON obj = do
    case fromJSON obj of
      Just (c :: CabalComponent) -> return $ Component c
      Nothing -> case fromJSON obj of
             Just (c :: FileComp) -> return $ Component c
             Nothing -> fail $ "Unknown component" ++ show obj

  toJSON (Component c) = toJSON c

instance JSON CompilationResult where
  toJSON (CompilationResult suc notes time) =
      Dic.makeObject [(Dic.succeeded, JSBool suc)
                 ,(Dic.notes, toJSON notes)
                 ,(Dic.duration, toJSON time)]
  fromJSON obj@(JSObject _) = do
      JSBool suc <- Dic.lookupKey obj Dic.succeeded
      notes <- fromJSON =<< Dic.lookupKey obj Dic.notes
      dur <- fromJSON =<< Dic.lookupKey obj Dic.duration
      return (CompilationResult suc notes dur)
  fromJSON _ = fail "compilation-result"

instance JSON (MS.MultiSet Note) where
  toJSON ms = toJSON (MS.toList ms)
  fromJSON o = MS.fromList <$> fromJSON o

instance JSON Note where
  toJSON (Note note_kind loc msg) =
    Dic.makeObject [(Dic.kind, toJSON note_kind)
               ,(Dic.location, toJSON loc)
               ,(Dic.message, JSString (S.fromString msg))]
  fromJSON obj@(JSObject _) = do
    note_kind <- fromJSON =<< Dic.lookupKey obj Dic.kind
    loc <- fromJSON =<< Dic.lookupKey obj Dic.location
    JSString s <- Dic.lookupKey obj Dic.message
    return (Note note_kind loc (S.toString s))
  fromJSON _ = fail "note"

instance (JSON a, JSON b)=> JSON (Either a b) where
        toJSON (Left a)=Dic.makeObject [(Dic.leftC,toJSON a)]
        toJSON (Right a)=Dic.makeObject [(Dic.rightC,toJSON a)]
        fromJSON _ = fail "Either"

--instance (JSON a)=>JSON (Maybe a) where
--        toJSON (Nothing)=Dic.makeObject [(Dic.nothingC,JSNull)]
--        toJSON (Just a)=Dic.makeObject [(Dic.justC,toJSON a)]
--        fromJSON _ = fail "Maybe"

str :: String -> JSValue
str = JSString . S.fromString

instance JSON NoteKind where
  toJSON ErrorNote   = JSString Dic.error
  toJSON WarningNote = JSString Dic.warning
  toJSON InfoNote    = JSString Dic.info
  toJSON OtherNote   = JSString Dic.other
  fromJSON (JSString s) =
      case lookup s
               [(Dic.error, ErrorNote), (Dic.warning, WarningNote)
               ,(Dic.info, InfoNote), (Dic.other, OtherNote)]
      of Just x -> return x
         Nothing -> fail "note-kind"
  fromJSON _ = fail "note-kind"

instance JSON Location where
  toJSON loc | not (isValidLoc loc) =
    Dic.makeObject [(Dic.noLocation, str (noLocText loc))]
  toJSON loc | (src, l0, c0, l1, c1) <- viewLoc loc =
    Dic.makeObject [case src of
                  FileSrc f -> (Dic.file, str (toFilePath f))
                  OtherSrc s -> (Dic.other, str s)
               ,(Dic.region, JSArray (map toJSON [l0,c0,l1,c1]))]
  fromJSON obj@(JSObject _) = do
    src <- (do JSString f <- Dic.lookupKey obj Dic.file
               return (FileSrc (mkAbsFilePath "/" (S.toString f))))
           <|>
           (do JSString s <- Dic.lookupKey obj Dic.other
               return (OtherSrc (S.toString s)))
    JSArray ls <- Dic.lookupKey obj Dic.region
    case mapM fromJSON ls of
      Just [l0,c0,l1,c1] -> return (mkLocation src l0 c0 l1 c1)
      _ -> fail "region"
  fromJSON _ = fail "location"

instance JSON NominalDiffTime where
  toJSON t = JSNumber (fromRational (toRational t))
  fromJSON (JSNumber  n) = return $ fromRational (toRational n)
  fromJSON _ = fail "diff-time"

instance JSON OutlineDef where
  toJSON t =
    Dic.makeObject $
      [(Dic.name, str $ case od_name t of
                        Left n -> showSDocUnqual n
                        Right s -> s)
      ,(Dic.location, toJSON $ od_loc t)
      ,(Dic.block, toJSON $ od_block t)
      ,(Dic.typ, str $ od_type t)]
      ++
      (case od_parentName t of
         Just (n,typ) ->
             [(Dic.parent, Dic.makeObject [(Dic.name, str $ showSDocUnqual $ n)
                                    ,(Dic.typ, str typ)])]
         Nothing -> [])
  fromJSON _ = fail "OutlineDef"


cmdListsupportedLanguages :: Cmd
cmdListsupportedLanguages = Cmd "list-supported-languages" $ noArgs cmd
  where cmd = return (map S.fromString 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" S.toString $ cmd
  where cmd cabal_file = cabalProjectComponents cabal_file

--cmdParseCabal :: Cmd
--cmdParseCabal = 
--    Cmd "parse-cabal" $ reqArg' "cabal-file" S.toString $ cmd
--  where cmd _cabal_file = return (JSObject M.empty) --liftM toJSON $ cabalParse cabal_file
--
--cmdParseCabalArbitrary :: Cmd
--cmdParseCabalArbitrary =
--    Cmd "parse-cabal-arbitrary" $ docContentsArg $ cmd
--  where cmd cabal_contents = cabalParseArbitrary cabal_contents

cmdCabalDependencies :: Cmd
cmdCabalDependencies = 
    Cmd "cabal-dependencies" $ reqArg' "cabal-file" S.toString $ cmd
  where cmd cabal_file = do
        dep<- cabalDependencies cabal_file
        case dep of
                Left err->return $ Left err
                Right depArr -> return $ Right $ 
                        (JSArray $ map (\(x,y)->Dic.makeObject [(S.fromString x,JSArray $ map toJSON y)]) depArr) 
  
-- return all cabal configurations.
-- currently this just globs for * /setup-config
-- in the future you may write a config file describing the most common configuration settings
cmdListCabalConfigurations :: Cmd
cmdListCabalConfigurations =
    Cmd "list-cabal-configurations" $
      reqArg' "cabal-file" S.toString <&>
      optArg' "type" "uniq" id <&>
      optArg' "scion-default" False decodeBool $ cmd
  where cmd _cabal_file _type' _scionDefault = return (JSArray []) -- liftM toJSON $ cabalConfigurations cabal_file type' scionDefault

cmdWriteSampleConfig :: Cmd
cmdWriteSampleConfig =
    Cmd "write-sample-config" $ fileNameArg cmd
  where cmd fp = liftIO $ writeSampleConfig fp

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" $ fileNameArg $ cmd
  where cmd fname = backgroundTypecheckFile fname

cmdBackgroundTypecheckArbitrary :: Cmd
cmdBackgroundTypecheckArbitrary = 
    Cmd "background-typecheck-arbitrary" $ 
        fileNameArg <&> 
        docContentsArg $ cmd
  where cmd fname contents = backgroundTypecheckArbitrary fname contents

cmdForceUnload :: Cmd
cmdForceUnload = Cmd "force-unload" $ noArgs $ unload

cmdAddCmdLineFlag :: Cmd
cmdAddCmdLineFlag =
    Cmd "add-command-line-flag" $
      optArg' "flag" "" S.toString <&>
      optArg' "flags" [] (map S.toString) $ cmd
  where cmd flag flags' = do
          addCmdLineFlags $ (if flag == "" then [] else [flag]) ++ flags'
          return JSNull

cmdThingAtPoint :: Cmd
cmdThingAtPoint =
    Cmd "thing-at-point" $
      fileNameArg <&> lineColumnArgs <&> optArg' "qualify" False decodeBool <&> optArg' "typed" True decodeBool $ cmd
  where
    cmd fname line col qual typed= do
      let loc = srcLocSpan $ mkSrcLoc (fsLit fname) line (scionColToGhcCol col)
      tc_res <- getSessionSelector bgTcCache
      case tc_res of
        Just (Typechecked tcm) -> do
             let f=(if typed then (doThingAtPointTyped $ typecheckedSource tcm) else (doThingAtPointUntyped $ renamedSource tcm))
             --tap<- doThingAtPoint loc qual typed tcm (if typed then (typecheckedSource tcm) else (renamedSource tcm))
             tap<-f loc qual tcm
                --(if typed then (doThingAtPointTyped $ typecheckedSource tcm)
               -- else doThingAtPointTyped (renamedSource tcm) loc qual tcm
             return $ Just tap
        _ -> return Nothing
    doThingAtPointTyped :: TypecheckedSource ->  SrcSpan -> Bool -> TypecheckedModule -> ScionM String
    doThingAtPointTyped src loc qual tcm=do
            let in_range = overlaps loc
            let r = searchBindBag in_range noSrcSpan src
            unqual <- if qual
                then return $ O.alwaysQualify
                else unqualifiedForModule tcm
            --liftIO $ putStrLn $ showData TypeChecker 2 src
            return $ case pathToDeepest r of
              Nothing -> "no info"
              Just (x,xs) ->
                case typeOf (x,xs) of
                  Just t ->
                      showSDocForUser unqual
                        (prettyResult x O.<+> dcolon O.<+>
                          pprTypeForUser True t)
                  _ -> showSDocForUser unqual (prettyResult x) --(Just (showSDocDebug (ppr x O.$$ ppr xs )))
    doThingAtPointUntyped :: (Search id a, OutputableBndr id) => a -> SrcSpan -> Bool -> TypecheckedModule  -> ScionM String
    doThingAtPointUntyped src loc qual tcm =do
            let in_range = overlaps loc
            let r = findHsThing in_range src
            unqual <- if qual
                then return $ O.neverQualify
                else unqualifiedForModule tcm
            return $ case pathToDeepest r of
              Nothing -> "no info"
              Just (x,_) ->
                if qual
                        then showSDocForUser unqual ((qualifiedResult x) O.<+> (O.text $ haddockType x))
                        else showSDocForUser unqual ((prettyResult x) O.<+> (O.text $ haddockType x))

cmdToplevelNames :: Cmd
cmdToplevelNames=
     Cmd "top-level-names" $ noArgs $ cmd
  where
    cmd =do
    tc_res <- getSessionSelector bgTcCache
    case tc_res of
      Just m -> do
          return $ map showSDocDump $ toplevelNames m
      _ -> return []

cmdOutline :: Cmd
cmdOutline =
    Cmd "outline" $  optArg' "trimFile" True decodeBool $ cmd
 where
  cmd trim = do
    root_dir <- projectRootDir
    tc_res <- getSessionSelector bgTcCache
    case tc_res of
      Just m -> do
        let f = if trim then trimLocationFile else id
        return $ f $ outline root_dir m
      _ -> return []

cmdTokens :: Cmd
cmdTokens =
     Cmd "tokens" $ docContentsArg cmd
  where cmd contents = do
          root_dir <- projectRootDir
          tokensArbitrary root_dir contents

cmdTokenAtPoint :: Cmd
cmdTokenAtPoint =
  Cmd "token-at-point" $ cmdArgs tokenAtPoint
  where cmdArgs = docContentsArg <&> lineColumnArgs <&> literateFlagOpt
        tokenAtPoint contents line column literate =
          projectRootDir
          >>= (\rootDir -> tokenArbitraryAtPoint rootDir contents line column literate)

cmdTokenPreceding :: Cmd
cmdTokenPreceding =
  Cmd "token-preceding" $ cmdArgs tokenPreceding
  where cmdArgs = docContentsArg <&> optArg "numTokens" (1 :: Int) <&> lineColumnArgs <&> literateFlagOpt 
        tokenPreceding contents numToks line column literate =
          projectRootDir
          >>= (\rootDir -> tokensArbitraryPreceding rootDir contents numToks line column literate)

cmdOccurrences :: Cmd
cmdOccurrences =
  Cmd "occurrences" $ cmdArgs tokenPreceding
  where cmdArgs = docContentsArg <&> reqArg "query" <&> literateFlagOpt 
        tokenPreceding contents query literate =
          projectRootDir
          >>= (\rootDir -> occurrences rootDir contents query literate)

cmdSetUserFlags :: Cmd
cmdSetUserFlags =
  Cmd "set-user-flags" $ reqArg "user-flags" <&> reqArg' "cabal-file" S.toString $ cmd
   where cmd user_flags cabal_file= do
         modifySessionState $ \sess -> 
           sess { userFlags = user_flags }
         cabalClean cabal_file
         

cmdTokenTypes :: Cmd
cmdTokenTypes =
     Cmd "token-types" $ docContentsArg <&> literateFlagOpt $ cmd
  where cmd contents literate= do
          root_dir <- projectRootDir
          tokenTypesArbitrary root_dir contents literate
          {--mb_modsum <- filePathToProjectModule fname
          case mb_modsum of
            Nothing -> do
              return $ Left "Could not find file in module graph."
            Just modsum -> do
                ts<-tokens root_dir $ ms_mod modsum
                return $ Right ts--}

cmdDumpSources :: Cmd
cmdDumpSources = Cmd "dump-sources" $ noArgs $ cmd
  where
    cmd = do
      tc_res <- getSessionSelector bgTcCache
      case tc_res of
        Just (Typechecked tcm)
         | Just rn <- renamedSourceGroup `fmap` renamedSource tcm ->
          do let tc = typecheckedSource tcm
             liftIO $ putStrLn $ showSDocDump $ ppr rn
             liftIO $ putStrLn $ showData TypeChecker 2 tc
             return ()
        _ -> return ()

cmdLoad :: Cmd
cmdLoad = Cmd "load" $ reqArg "component" <&> optArg "options" defaultLoadOptions $ cmd
  where
    cmd comp options = do
        loadComponent' comp options
            `gcatch` \(e' :: GhcException) ->
                       case e' of
                         CmdLineError s | isInfixOf  "cannot satisfy -package-id" s,
                                Component c <- comp -> do
                                componentClean c
                                loadComponent' comp options
                         _ -> throw e'

cmdSetVerbosity :: Cmd
cmdSetVerbosity =
    Cmd "set-verbosity" $ reqArg "level" $ cmd
  where cmd v = setVerbosity (intToVerbosity v)

cmdGetVerbosity :: Cmd
cmdGetVerbosity = Cmd "get-verbosity" $ noArgs $ verbosityToInt <$> getVerbosity

-- rename to GetCurrentComponent?
cmdCurrentComponent :: Cmd
cmdCurrentComponent = Cmd "current-component" $ noArgs $ getActiveComponent

cmdDumpDefinedNames :: Cmd
cmdDumpDefinedNames = Cmd "dump-defined-names" $ noArgs $ cmd
  where
    cmd = getSessionSelector defSiteDB
          >>= (\db -> liftIO $ putStrLn $ dumpDefSiteDB db)

cmdDefinedNames :: Cmd
cmdDefinedNames = Cmd "defined-names" $ noArgs $ definedNames <$> getSessionSelector defSiteDB

cmdNameDefinitions :: Cmd
cmdNameDefinitions =
    Cmd "name-definitions" $ reqArg' "name" S.toString $ cmd
  where cmd nm = do
--          mc<-getSessionSelector moduleCache
--          liftIO $ putStrLn $ ("moduleCache values:" ++ (show $ moduleCacheSize mc))
          db <- getSessionSelector defSiteDB
          let nms=comps nm
          --liftIO $ putStrLn $ last nms
          --liftIO $ putStrLn $ show $ map (\(_,b)->showSDocForUser alwaysQualify $ ppr $ getName b) $ lookupDefSite db (last nms)
          return $ map fst
                $ filter (\(_,b)->nm == showSDocForUser alwaysQualify (ppr $ getName b))
                $ lookupDefSite db (last nms)
        comps                   :: String -> [String]
        comps s                 =  case dropWhile ('.'==) s of
                                "" -> []
                                s' -> w : comps s''
                                      where (w, s'') =
                                             break ('.'==) s'



cmdIdentify :: Cmd
cmdIdentify =
    Cmd "client-identify" $ reqArg' "name" S.toString $ cmd
  where cmd c = modifySessionState $ \s -> s { client = c }

cmdDumpModuleGraph :: Cmd
cmdDumpModuleGraph =
   Cmd "dump-module-graph" $ noArgs $ cmd
  where
    cmd = do
      mg <- getModuleGraph
      liftIO $ printDump (ppr mg)
      return ()

cmdModuleGraph :: Cmd
cmdModuleGraph =
   Cmd "module-graph" $ noArgs $ cmd
  where
    cmd = do
      mg <- getModuleGraph
      return $ map (showSDoc . ppr . moduleName . ms_mod) mg

cmdDumpNameDB :: Cmd
cmdDumpNameDB =
  Cmd "dump-name-db" $ noArgs $ buildNameDB >>= dumpNameDB >> return ()

-- | Type name completions: generate the list of type names currently visible within the
-- current module. The IDE is responsible for prefix or name filtering.

-- FIXME: Use focused_mod here, when available, just like what bgTypeCheck does.
cmdCompletionTypes :: Cmd
cmdCompletionTypes = Cmd "completion-types" $ fileNameArg $ cmd
  where
    currentModTyCons (Just modSum) =
      getSessionSelector moduleCache
      >>= (\mCache -> case M.lookup (ms_mod modSum) mCache of
                        Just mcd  -> return $ tyCons mcd
                        Nothing   -> return [])
    currentModTyCons Nothing = return []
    allTyCons projMod = liftM2 (++) (getTypeCompletions projMod) (currentModTyCons projMod)
    
    cmd fname = filePathToProjectModule fname
                >>= allTyCons

-- | Variable id completions: generate the list of variable identifiers currently visible within
-- the current module. The IDE is responsible for prefix or name filtering.

-- FIXME: Use focused_mod here, when available, mimicing bgTypeCheck.
cmdCompletionVarIds :: Cmd
cmdCompletionVarIds = Cmd "completion-varIds" $ fileNameArg $ generateCompletions getVarIdCompletions

-- | Class type name completions: generate the list of class names currently visible within the
-- current module. The IDE is repsonsible for prefix or name filering.

-- FIXME: Use focused_mod here, when available, mimicking bgTypeCheck.
cmdCompletionClassTypeNames :: Cmd
cmdCompletionClassTypeNames = Cmd "completion-classTypeNames" $ fileNameArg $ generateCompletions getClassTypeNameCompletions

-- | Generate the completion tuple list using a completion function and file name
generateCompletions :: forall a.
                      (Maybe ModSummary -> ScionM a)  -- ^ The completion function (see Completions.hs)
                    -> FilePath                       -- ^ File name, if there is no currently focused module.
                    -> ScionM a
generateCompletions completionFunc fpath = withSessionState $ getCompletions fpath
  where
    getCompletions fname scion =
      case focusedModule scion of
        modsum@(Just ms) -> validFocusedModuleSource fname (ml_hs_file (ms_location ms)) modsum
        Nothing -> getCompletionsFromProjectModule fname
    
    validFocusedModuleSource fname (Just f) modsum
      | f == fname
      = completionFunc modsum
      | otherwise
      = getCompletionsFromProjectModule fname
    validFocusedModuleSource fname Nothing _ = getCompletionsFromProjectModule fname
    
    -- Default: If we can't use focusedModule, find the module summary in the module graph
    getCompletionsFromProjectModule fname = filePathToProjectModule fname >>= completionFunc