#ifdef HINT
#endif
module Yi.Eval (
execEditorAction,
getAllNamesInScope,
describeNamedAction,
Evaluator(..),
evaluator,
#ifdef HINT
ghciEvaluator,
#endif
publishedActionsEvaluator,
publishedActions,
publishAction,
jumpToErrorE,
jumpToE,
consoleKeymap
) where
import Prelude hiding (mapM_)
import Lens.Micro.Platform ( (^.), (.=), (%=) )
import Control.Monad (when, void, forever)
import Data.Array ( elems )
import Data.Binary ( Binary )
import Data.Default ( Default, def )
import Data.Foldable ( mapM_ )
import qualified Data.HashMap.Strict as M
( HashMap, insert, lookup, empty, keys )
import Data.Monoid ( (<>) )
import Data.Typeable ( Typeable )
#ifdef HINT
import Control.Concurrent
( takeMVar, putMVar, newEmptyMVar, MVar, forkIO )
import Control.Monad.Base ( MonadBase )
import Control.Monad.Catch ( try )
import Control.Monad.Trans ( lift )
import Data.Binary ( get, put )
import Data.List ( sort )
import qualified Language.Haskell.Interpreter as LHI
( typeOf,
setImportsQ,
searchPath,
set,
runInterpreter,
ModuleElem(Data, Class, Fun),
getModuleExports,
as,
loadModules,
languageExtensions,
OptionVal((:=)),
InterpreterError,
Extension(OverloadedStrings),
setTopLevelModules,
interpret )
import System.Directory ( doesFileExist )
import Yi.Boot.Internal ( reload )
import Yi.Core ( errorEditor )
import Yi.Editor
( getEditorDyn,
putEditorDyn,
MonadEditor)
import qualified Yi.Paths ( getEvaluatorContextFilename )
import Yi.String ( showT )
import Yi.Utils ( io )
#endif
import Text.Read ( readMaybe )
import Yi.Buffer
( gotoLn,
moveXorEol,
BufferM,
readLnB,
pointB,
botB,
insertN,
getBookmarkB,
markPointA )
import Yi.Config.Simple.Types ( customVariable, Field, ConfigM )
import Yi.Core ( runAction )
import Yi.Types ( YiVariable, YiConfigVariable )
import Yi.Editor
( printMsg,
askCfg,
withCurrentBuffer,
withCurrentBuffer )
import Yi.File ( openingNewFile )
import Yi.Hooks ( runHook )
import Yi.Keymap
( YiM, Action, YiAction, makeAction, Keymap, write )
import Yi.Keymap.Keys ( event, Event(..), Key(KEnter) )
import Yi.Regex ( Regex, makeRegex, matchOnceText )
import qualified Yi.Rope as R
( toString, YiString, splitAt, length )
import Yi.Utils ( makeLensesWithSuffix )
infixl 1 <&>
(<&>) :: Functor f => f a -> (a -> b) -> f b
a <&> f = f <$> a
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
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
#ifdef HINT
data HintRequest = HintEvaluate String (MVar (Either LHI.InterpreterError Action))
| HintGetNames (MVar (Either LHI.InterpreterError [LHI.ModuleElem]))
| HintDescribe String (MVar (Either LHI.InterpreterError String))
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 ]]
when haveUserContext $ do
LHI.loadModules [contextFile]
LHI.setTopLevelModules ["Env"]
LHI.setImportsQ [("Yi", Nothing), ("Yi.Keymap",Just "Yi.Keymap")]
forever $ lift (takeMVar request) >>= \case
HintEvaluate s response -> do
res <- try $ LHI.interpret ("Yi.makeAction (" ++ s ++ ")") (LHI.as :: Action)
lift $ putMVar response res
HintGetNames response -> do
res <- try $ LHI.getModuleExports "Yi"
lift $ putMVar response res
HintDescribe name response -> do
res <- try $ LHI.typeOf name
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 (HintEvaluate 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
request <- getHintThread
res <- io $ do
response <- newEmptyMVar
putMVar request (HintGetNames response)
takeMVar response
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
request <- getHintThread
res <- io $ do
response <- newEmptyMVar
putMVar request (HintDescribe name response)
takeMVar response
let newDescription = either show id res
putEditorDyn $ HelpCache $ M.insert name newDescription cache
return newDescription
Just description -> return description
return $ name ++ " :: " ++ description
#endif
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
instance Default Evaluator where
#ifdef HINT
def = ghciEvaluator
#else
def = publishedActionsEvaluator
#endif
instance YiConfigVariable Evaluator