1
1
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:
Patrick Thomson 2018-10-31 09:09:37 -04:00 committed by GitHub
commit 27a9ae546a
6 changed files with 76 additions and 51 deletions

View File

@ -49,6 +49,7 @@ library
, Control.Abstract.Value
-- Effects
, Control.Effect.Interpose
, Control.Effect.REPL
-- Matching and rewriting DSLs
, Control.Matching
, Control.Rewriting

View 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"

View File

@ -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.
--

View File

@ -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) ]
_ -> []

View File

@ -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"

View File

@ -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)