mirror of
https://github.com/github/semantic.git
synced 2024-12-29 18:06:14 +03:00
Merge branch 'master' into add-data-coerce-to-prologue
This commit is contained in:
commit
27a9ae546a
@ -49,6 +49,7 @@ library
|
||||
, Control.Abstract.Value
|
||||
-- Effects
|
||||
, Control.Effect.Interpose
|
||||
, Control.Effect.REPL
|
||||
-- Matching and rewriting DSLs
|
||||
, Control.Matching
|
||||
, Control.Rewriting
|
||||
|
53
src/Control/Effect/REPL.hs
Normal file
53
src/Control/Effect/REPL.hs
Normal file
@ -0,0 +1,53 @@
|
||||
{-# LANGUAGE KindSignatures, LambdaCase, TypeOperators, UndecidableInstances #-}
|
||||
|
||||
module Control.Effect.REPL
|
||||
( REPL (..)
|
||||
, REPLC (..)
|
||||
, prompt
|
||||
, output
|
||||
, runREPL
|
||||
) where
|
||||
|
||||
import Prologue
|
||||
|
||||
import Control.Effect
|
||||
import Control.Effect.Carrier
|
||||
import Control.Effect.Sum
|
||||
import Data.Coerce
|
||||
import System.Console.Haskeline
|
||||
import qualified Data.Text as T
|
||||
|
||||
data REPL (m :: * -> *) k
|
||||
= Prompt Text (Maybe Text -> k)
|
||||
| Output Text k
|
||||
deriving (Functor)
|
||||
|
||||
instance HFunctor REPL where
|
||||
hmap _ = coerce
|
||||
|
||||
instance Effect REPL where
|
||||
handle state handler (Prompt p k) = Prompt p (handler . (<$ state) . k)
|
||||
handle state handler (Output s k) = Output s (handler (k <$ state))
|
||||
|
||||
prompt :: (Member REPL sig, Carrier sig m) => Text -> m (Maybe Text)
|
||||
prompt p = send (Prompt p ret)
|
||||
|
||||
output :: (Member REPL sig, Carrier sig m) => Text -> m ()
|
||||
output s = send (Output s (ret ()))
|
||||
|
||||
runREPL :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> Eff (REPLC m) a -> m a
|
||||
runREPL prefs settings = flip runREPLC (prefs, settings) . interpret
|
||||
|
||||
newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a }
|
||||
|
||||
instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where
|
||||
ret = REPLC . const . ret
|
||||
eff op = REPLC (\ args -> handleSum (eff . handleReader args runREPLC) (\case
|
||||
Prompt p k -> liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= flip runREPLC args . k
|
||||
Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> runREPLC k args) op)
|
||||
|
||||
cyan :: String
|
||||
cyan = "\ESC[1;36m\STX"
|
||||
|
||||
plain :: String
|
||||
plain = "\ESC[0m\STX"
|
@ -6,6 +6,7 @@ module Semantic.CLI
|
||||
, Parse.runParse
|
||||
) where
|
||||
|
||||
import Control.Exception as Exc (displayException)
|
||||
import Data.File
|
||||
import Data.Language (ensureLanguage, languageForFilePath)
|
||||
import Data.List (intercalate, uncons)
|
||||
@ -24,12 +25,17 @@ import qualified Semantic.Task as Task
|
||||
import Semantic.Task.Files
|
||||
import qualified Semantic.Telemetry.Log as Log
|
||||
import Semantic.Version
|
||||
import System.Exit (die)
|
||||
import System.FilePath
|
||||
import Serializing.Format hiding (Options)
|
||||
import Text.Read
|
||||
|
||||
main :: IO ()
|
||||
main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
|
||||
main = do
|
||||
(options, task) <- customExecParser (prefs showHelpOnEmpty) arguments
|
||||
res <- Task.withOptions options $ \ config logger statter ->
|
||||
Task.runTaskWithConfig config { configSHA = Just buildSHA } logger statter task
|
||||
either (die . displayException) pure res
|
||||
|
||||
-- | A parser for the application's command-line arguments.
|
||||
--
|
||||
|
@ -23,7 +23,6 @@ import Semantic.Env
|
||||
import Semantic.Telemetry
|
||||
import qualified Semantic.Telemetry.Haystack as Haystack
|
||||
import qualified Semantic.Telemetry.Stat as Stat
|
||||
import Semantic.Version
|
||||
import System.Environment
|
||||
import System.IO (hIsTerminalDevice, stdout)
|
||||
import System.Posix.Process
|
||||
@ -43,6 +42,7 @@ data Config
|
||||
, configIsTerminal :: Bool -- ^ Whether a terminal is attached (set automaticaly at runtime).
|
||||
, configLogPrintSource :: Bool -- ^ Whether to print the source reference when logging errors (set automatically at runtime).
|
||||
, configLogFormatter :: LogFormatter -- ^ Log formatter to use (set automaticaly at runtime).
|
||||
, configSHA :: Maybe String -- ^ Optional SHA to include in log messages.
|
||||
|
||||
, configOptions :: Options -- ^ Options configurable via command line arguments.
|
||||
}
|
||||
@ -84,6 +84,7 @@ defaultConfig options@Options{..} = do
|
||||
, configIsTerminal = isTerminal
|
||||
, configLogPrintSource = isTerminal
|
||||
, configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter
|
||||
, configSHA = Nothing
|
||||
|
||||
, configOptions = options
|
||||
}
|
||||
@ -105,8 +106,9 @@ logOptionsFromConfig Config{..} = LogOptions
|
||||
False -> [ ("app", configAppName)
|
||||
, ("pid", show configProcessID)
|
||||
, ("hostname", configHostName)
|
||||
, ("sha", buildSHA)
|
||||
] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ]
|
||||
, ("sha", fromMaybe "development" configSHA)
|
||||
]
|
||||
<> [("request_id", x) | x <- toList (optionsRequestID configOptions) ]
|
||||
_ -> []
|
||||
|
||||
|
||||
|
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE GADTs, KindSignatures, LambdaCase, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE GADTs, LambdaCase, TypeOperators, UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
||||
module Semantic.REPL
|
||||
( rubyREPL
|
||||
@ -8,6 +8,7 @@ import Control.Abstract hiding (Continue, List, string)
|
||||
import Control.Effect.Carrier
|
||||
import Control.Effect.Resource
|
||||
import Control.Effect.Sum
|
||||
import Control.Effect.REPL
|
||||
import Data.Abstract.Address.Precise as Precise
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable hiding (string)
|
||||
@ -24,6 +25,7 @@ import Data.List (uncons)
|
||||
import Data.Project
|
||||
import Data.Quieterm
|
||||
import Data.Span
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
|
||||
import qualified Data.Time.LocalTime as LocalTime
|
||||
import Numeric (readDec)
|
||||
@ -44,43 +46,11 @@ import System.Console.Haskeline
|
||||
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
|
||||
import System.FilePath
|
||||
|
||||
data REPL (m :: * -> *) k
|
||||
= Prompt (Maybe String -> k)
|
||||
| Output String k
|
||||
deriving (Functor)
|
||||
|
||||
prompt :: (Member REPL sig, Carrier sig m) => m (Maybe String)
|
||||
prompt = send (Prompt ret)
|
||||
|
||||
output :: (Member REPL sig, Carrier sig m) => String -> m ()
|
||||
output s = send (Output s (ret ()))
|
||||
|
||||
|
||||
data Quit = Quit
|
||||
deriving Show
|
||||
|
||||
instance Exception Quit
|
||||
|
||||
|
||||
instance HFunctor REPL where
|
||||
hmap _ = coerce
|
||||
|
||||
instance Effect REPL where
|
||||
handle state handler (Prompt k) = Prompt (handler . (<$ state) . k)
|
||||
handle state handler (Output s k) = Output s (handler (k <$ state))
|
||||
|
||||
|
||||
runREPL :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> Eff (REPLC m) a -> m a
|
||||
runREPL prefs settings = flip runREPLC (prefs, settings) . interpret
|
||||
|
||||
newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a }
|
||||
|
||||
instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where
|
||||
ret = REPLC . const . ret
|
||||
eff op = REPLC (\ args -> handleSum (eff . handleReader args runREPLC) (\case
|
||||
Prompt k -> liftIO (uncurry runInputTWithPrefs args (getInputLine (cyan <> "repl: " <> plain))) >>= flip runREPLC args . k
|
||||
Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn s)) *> runREPLC k args) op)
|
||||
|
||||
rubyREPL = repl (Proxy @'Language.Ruby) rubyParser
|
||||
|
||||
repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runResource (runM . runDistribute) . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . Files.runFiles . runResolution . runTaskF $ do
|
||||
@ -161,7 +131,7 @@ step blobs recur0 recur term = do
|
||||
where list = do
|
||||
path <- asks modulePath
|
||||
span <- ask
|
||||
maybe (pure ()) (\ blob -> output (showExcerpt True span blob "")) (Prelude.lookup path blobs)
|
||||
maybe (pure ()) (\ blob -> output (T.pack (showExcerpt True span blob ""))) (Prelude.lookup path blobs)
|
||||
help = do
|
||||
output "Commands available from the prompt:"
|
||||
output ""
|
||||
@ -173,12 +143,12 @@ step blobs recur0 recur term = do
|
||||
output " :quit, :q, :abandon abandon the current evaluation and exit the repl"
|
||||
showBindings = do
|
||||
bindings <- Env.head <$> getEnv
|
||||
output $ unlines (uncurry showBinding <$> Env.pairs bindings)
|
||||
output . T.pack $ unlines (uncurry showBinding <$> Env.pairs bindings)
|
||||
showBinding name addr = show name <> " = " <> show addr
|
||||
runCommand run [":step"] = local (const Step) run
|
||||
runCommand run [":continue"] = local (const Continue) run
|
||||
runCommand run [":break", s]
|
||||
| [(i, "")] <- readDec s = modify (OnLine i :) >> runCommands run
|
||||
| [(i, "")] <- readDec (T.unpack s) = modify (OnLine i :) >> runCommands run
|
||||
-- TODO: :show breakpoints
|
||||
-- TODO: :delete breakpoints
|
||||
runCommand run [":list"] = list >> runCommands run
|
||||
@ -189,10 +159,10 @@ step blobs recur0 recur term = do
|
||||
runCommand run [":help"] = help >> runCommands run
|
||||
runCommand run [":?"] = help >> runCommands run
|
||||
runCommand run [] = runCommands run
|
||||
runCommand run other = output ("unknown command '" <> unwords other <> "'") >> output "use :? for help" >> runCommands run
|
||||
runCommand run other = output ("unknown command '" <> T.unwords other <> "'") >> output "use :? for help" >> runCommands run
|
||||
runCommands run = do
|
||||
str <- prompt
|
||||
maybe (runCommands run) (runCommand run . words) str
|
||||
str <- prompt "repl: "
|
||||
maybe (runCommands run) (runCommand run . T.words) str
|
||||
|
||||
|
||||
newtype Breakpoint
|
||||
@ -223,10 +193,3 @@ shouldBreak = do
|
||||
| n >= posLine spanStart
|
||||
, n <= posLine spanEnd = True
|
||||
| otherwise = False
|
||||
|
||||
|
||||
cyan :: String
|
||||
cyan = "\ESC[1;36m\STX"
|
||||
|
||||
plain :: String
|
||||
plain = "\ESC[0m\STX"
|
||||
|
@ -18,7 +18,7 @@ import Semantic.Config (defaultOptions)
|
||||
import Semantic.Graph
|
||||
import Semantic.IO
|
||||
|
||||
callGraphPythonProject paths = runTaskWithOptions defaultOptions $ do
|
||||
callGraphPythonProject paths = runTask $ do
|
||||
let proxy = Proxy @'Language.Python
|
||||
let lang = Language.Python
|
||||
blobs <- catMaybes <$> traverse readBlobFromFile (flip File lang <$> paths)
|
||||
|
Loading…
Reference in New Issue
Block a user