module Yi.Eval (
execEditorAction,
getAllNamesInScope,
describeNamedAction,
Evaluator(..),
evaluator,
ghciEvaluator,
publishedActionsEvaluator,
publishedActions,
publishAction,
jumpToErrorE,
jumpToE,
consoleKeymap
) where
import Control.Applicative ((<$>), (<*>))
import Control.Concurrent
import Control.Monad.Catch (try)
import Control.Lens hiding (Action)
import Control.Monad hiding (mapM_)
import Control.Monad.Base
import Control.Monad.Trans (lift)
import Data.Array
import Data.Binary
import Data.Default
import Data.Foldable (mapM_)
import qualified Data.HashMap.Strict as M
import Data.List
import Data.Monoid
import Data.Typeable
import qualified Language.Haskell.Interpreter as LHI
import Prelude hiding (error, mapM_)
import System.Directory (doesFileExist)
import Text.Read (readMaybe)
import Yi.Boot.Internal (reload)
import Yi.Buffer
import Yi.Config.Simple.Types
import Yi.Core (errorEditor, runAction)
import Yi.Types (YiVariable,YiConfigVariable)
import Yi.Editor
import Yi.File
import Yi.Hooks
import Yi.Keymap
import Yi.Keymap.Keys
import qualified Yi.Paths (getEvaluatorContextFilename)
import Yi.Regex
import qualified Yi.Rope as R
import Yi.String
import Yi.Utils
execEditorAction :: String -> YiM ()
execEditorAction = runHook execEditorActionImpl
getAllNamesInScope :: YiM [String]
getAllNamesInScope = runHook getAllNamesInScopeImpl
describeNamedAction :: String -> YiM String
describeNamedAction = runHook describeNamedActionImpl
data Evaluator = Evaluator
{ execEditorActionImpl :: String -> YiM ()
, getAllNamesInScopeImpl :: YiM [String]
, describeNamedActionImpl :: String -> YiM String
} deriving (Typeable)
evaluator :: Field Evaluator
evaluator = customVariable
instance Default Evaluator where def = ghciEvaluator
instance YiConfigVariable Evaluator
newtype NamesCache = NamesCache [String] deriving (Typeable, Binary)
instance Default NamesCache where
def = NamesCache []
instance YiVariable NamesCache
newtype HelpCache = HelpCache (M.HashMap String String) deriving (Typeable, Binary)
instance Default HelpCache where
def = HelpCache M.empty
instance YiVariable HelpCache
type HintRequest = (String, MVar (Either LHI.InterpreterError Action))
newtype HintThreadVar = HintThreadVar (Maybe (MVar HintRequest))
deriving (Typeable, Default)
instance Binary HintThreadVar where
put _ = return ()
get = return def
instance YiVariable HintThreadVar
getHintThread :: (MonadEditor m, MonadBase IO m) => m (MVar HintRequest)
getHintThread = do
HintThreadVar x <- getEditorDyn
case x of
Just t -> return t
Nothing -> do
req <- io newEmptyMVar
contextFile <- Yi.Paths.getEvaluatorContextFilename
void . io . forkIO $ hintEvaluatorThread req contextFile
putEditorDyn . HintThreadVar $ Just req
return req
hintEvaluatorThread :: MVar HintRequest -> FilePath -> IO ()
hintEvaluatorThread request contextFile = do
haveUserContext <- doesFileExist contextFile
void $ LHI.runInterpreter $ do
LHI.set [LHI.searchPath LHI.:= []]
LHI.set [LHI.languageExtensions LHI.:= [ LHI.OverloadedStrings
, LHI.NoImplicitPrelude
]]
when haveUserContext $ do
LHI.loadModules [contextFile]
LHI.setTopLevelModules ["Env"]
LHI.setImportsQ [("Yi", Nothing), ("Yi.Keymap",Just "Yi.Keymap")]
forever $ do
(s,response) <- lift $ takeMVar request
res <- try $ LHI.interpret ("Yi.makeAction (" ++ s ++ ")") (LHI.as :: Action)
lift $ putMVar response res
ghciEvaluator :: Evaluator
ghciEvaluator = Evaluator { execEditorActionImpl = execAction
, getAllNamesInScopeImpl = getNames
, describeNamedActionImpl = describeName
}
where
execAction :: String -> YiM ()
execAction "reload" = reload
execAction s = do
request <- getHintThread
res <- io $ do
response <- newEmptyMVar
putMVar request (s,response)
takeMVar response
case res of
Left err -> errorEditor (showT err)
Right action -> runAction action
getNames :: YiM [String]
getNames = do
NamesCache cache <- getEditorDyn
result <- if null cache
then do
res <- io $ LHI.runInterpreter $ do
LHI.set [LHI.searchPath LHI.:= []]
LHI.getModuleExports "Yi"
return $ case res of
Left err ->[show err]
Right exports -> flattenExports exports
else return $ sort cache
putEditorDyn $ NamesCache result
return result
flattenExports :: [LHI.ModuleElem] -> [String]
flattenExports = concatMap flattenExport
flattenExport :: LHI.ModuleElem -> [String]
flattenExport (LHI.Fun x) = [x]
flattenExport (LHI.Class _ xs) = xs
flattenExport (LHI.Data _ xs) = xs
describeName :: String -> YiM String
describeName name = do
HelpCache cache <- getEditorDyn
description <- case name `M.lookup` cache of
Nothing -> do
result <- io $ LHI.runInterpreter $ do
LHI.set [LHI.searchPath LHI.:= []]
LHI.setImportsQ [("Yi", Nothing), ("Yi.Keymap",Just "Yi.Keymap")]
LHI.typeOf name
let newDescription = either show id result
putEditorDyn $ HelpCache $ M.insert name newDescription cache
return newDescription
Just description -> return description
return $ name ++ " :: " ++ description
newtype PublishedActions = PublishedActions {
_publishedActions :: M.HashMap String Action
} deriving(Typeable, Monoid)
instance Default PublishedActions where def = mempty
makeLensesWithSuffix "A" ''PublishedActions
instance YiConfigVariable PublishedActions
publishedActions :: Field (M.HashMap String Action)
publishedActions = customVariable . _publishedActionsA
publishAction :: (YiAction a x, Show x) => String -> a -> ConfigM ()
publishAction s a = publishedActions %= M.insert s (makeAction a)
publishedActionsEvaluator :: Evaluator
publishedActionsEvaluator = Evaluator
{ getAllNamesInScopeImpl = askCfg <&> M.keys . (^. publishedActions)
, execEditorActionImpl = \s ->
askCfg <&> M.lookup s . (^. publishedActions) >>= mapM_ runAction
, describeNamedActionImpl = return
}
jumpToE :: FilePath
-> Int
-> Int
-> YiM ()
jumpToE filename line column =
openingNewFile filename $ gotoLn line >> moveXorEol column
errorRegex :: Regex
errorRegex = makeRegex ("^(.+):([0-9]+):([0-9]+):.*$" :: String)
parseErrorMessage :: R.YiString -> Maybe (String, Int, Int)
parseErrorMessage ln = do
(_ ,result, _) <- matchOnceText errorRegex (R.toString ln)
case take 3 $ map fst $ elems result of
[_, fname, l, c] -> (,,) <$> return fname <*> readMaybe l <*> readMaybe c
_ -> Nothing
parseErrorMessageB :: BufferM (Maybe (String, Int, Int))
parseErrorMessageB = parseErrorMessage <$> readLnB
jumpToErrorE :: YiM ()
jumpToErrorE = withCurrentBuffer parseErrorMessageB >>= \case
Nothing -> printMsg "Couldn't parse out an error message."
Just (f, l, c) -> jumpToE f l c
prompt :: R.YiString
prompt = "Yi> "
takeCommand :: R.YiString -> R.YiString
takeCommand t = case R.splitAt (R.length prompt) t of
(f, s) -> if f == prompt then s else t
consoleKeymap :: Keymap
consoleKeymap = do
_ <- event (Event KEnter [])
write $ withCurrentBuffer readLnB >>= \x -> case parseErrorMessage x of
Just (f,l,c) -> jumpToE f l c
Nothing -> do
withCurrentBuffer $ do
p <- pointB
botB
p' <- pointB
when (p /= p') $ insertN ("\n" <> prompt <> takeCommand x)
insertN "\n"
pt <- pointB
insertN prompt
bm <- getBookmarkB "errorInsert"
markPointA bm .= pt
execEditorAction . R.toString $ takeCommand x