/src/RequestEval.hs

  1{-# LANGUAGE
  2  UnicodeSyntax,
  3  CPP,
  4  ViewPatterns,
  5  RecordWildCards,
  6  PatternGuards,
  7  ScopedTypeVariables,
  8  FlexibleInstances,
  9  TupleSections #-}
 10
 11module RequestEval (evaluator) where
 12
 13import qualified Data.Set as Set
 14import qualified EvalCxx
 15import qualified Editing.Parse
 16import qualified Editing.Diff
 17import qualified Editing.Execute
 18import qualified Editing.Basics
 19import qualified Editing.Commands
 20import qualified Editing.EditsPreparation
 21import qualified Parsers as P
 22import qualified Cxx.Parse
 23import qualified Cxx.Operations
 24import qualified Cxx.Show
 25import qualified Data.List as List
 26import qualified Data.List.NonEmpty as NeList
 27import qualified Gcc
 28
 29import Control.Monad (join, when)
 30import Control.Arrow (first, second)
 31import Cxx.Basics (Code, AbbreviatedMain(..), Findable(DeclarationOf), DeclaratorId(..), IdExpression(..), UnqualifiedId(..), Identifier(..), White(..))
 32import Cxx.Show (Highlighter)
 33import EvalCxx (WithEvaluation, noEvaluation, EvaluationResult(..), Line, Column, CxxStandard(..), stdDigits)
 34import Data.Char (isPrint, isSpace, showLitChar)
 35import Data.Either (partitionEithers)
 36import Data.Foldable (toList)
 37import Data.Pointed (Pointed(..))
 38import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty)
 39import Data.Set (Set)
 40import Editing.Basics (TextEdit(..), Range(..), Pos(..))
 41import Editing.Commands (FinalCommand(..))
 42import Parsers ((<|>), eof, option, spaces, getInput, kwd, kwds, Parser, run_parser, ParseResult(..), parseOrFail, commit, peek, parseSuccess)
 43import Util ((.), (‥), (<<), commas_and, capitalize, length_ge, replace, show_long_opt, strip, convert, maybeLast, orElse, E, NeList, propagateE, splitBy, mapHead)
 44import Request (Context(..), EvalOpt(..), Response(..), HistoryModification(..), EditableRequest(..), EditableRequestKind(..), EphemeralOpt(..), popContext)
 45import Data.SetOps
 46import Prelude hiding ((.))
 47import Prelude.Unicode hiding ((∈), (∉))
 48
 49show_EditableRequest :: Highlighter → EditableRequest → String
 50show_EditableRequest h (EditableRequest (Evaluate f) s) | Set.null f = Cxx.Parse.highlight h s
 51show_EditableRequest _ (EditableRequest k s) = show k ++ (if null s then "" else ' ' : s)
 52
 53instance Show EditableRequest where
 54  show = show_EditableRequest Cxx.Show.noHighlighting
 55
 56no_break_space :: Char
 57no_break_space = '\x00A0'
 58
 59throwError :: String -> Either String a
 60throwError = Left
 61
 62diff :: EditableRequest → EditableRequest → String
 63diff (EditableRequest MakeType y) (EditableRequest MakeType x) = pretty $ show . Editing.Diff.diff x y
 64diff (EditableRequest Precedence y) (EditableRequest Precedence x) = pretty $ show . Editing.Diff.diff x y
 65diff (EditableRequest (Evaluate flags) y) (EditableRequest (Evaluate flags') x) =
 66  pretty $ f "removed" flags' flags ++ f "added" flags flags' ++ show . Editing.Diff.diff x y
 67    where f n fl fl' = maybe [] (\l → [n ++ " " ++ concat (List.intersperse " and " $ map show_long_opt $ toList l)]) (nonEmpty $ Set.elems $ (Set.\\) fl fl')
 68diff _ _ = "Requests differ in kind."
 69
 70pretty :: [String] → String -- Todo: This is awkward.
 71pretty [] = "Requests are identical."
 72pretty l = capitalize (commas_and l) ++ "."
 73
 74ellipsis_options :: [(String, Bool)] → NeList [String]
 75ellipsis_options [] = return []
 76ellipsis_options ((y, _) : ys) = work ((y, False) : ys)
 77  where
 78    dummy = " → …"
 79    work [] = return []
 80    work [(x, _)] = return [x]
 81    work ((x, False) : xs) = fmap (x:) (work xs)
 82    work ((x, True) : xs) = work xs >>= \o → if dummy ∈ o
 83        then (return $ if head o == dummy then o else dummy : o)
 84        else (dummy : o) :| [x : o]
 85
 86nicer_namedPathTo :: [String] → String
 87nicer_namedPathTo l = drop 3 $ concat $ maybeLast (takeWhile ((≤ 140) . length . concat) $ toList n) `orElse` NeList.head n
 88  where n = ellipsis_options $ map (\s → (" → " ++ s, "expr" `List.isSuffixOf` s)) l
 89    -- Todo: Also don't abbreviate when there's enough space.
 90
 91-- The following aliases for 'return' and 'id' serve only to make subsequent monad-heavy code more readable.
 92
 93noErrors :: a → E a
 94noErrors = return
 95
 96inE :: E a → E a
 97inE = id
 98
 99continueParsing :: Parser t a → Parser t a
100continueParsing = id
101
102tagError :: E (WithEvaluation (String, Maybe (TextEdit Char)))
103            -> WithEvaluation (String, Maybe (TextEdit Char))
104tagError = either (point . noFixit . ("error: " ++)) id
105
106optParser :: Parser Char (E (Set EvalOpt, [EphemeralOpt]))
107optParser = first Set.fromList ‥ partitionEithers ‥ option (return []) P.optParser
108
109preamble :: Set EvalOpt → [String]
110preamble opts =
111  [ "#if !defined(GEORDI_PRELUDE) && !defined(__clang__)"
112  , "#define GEORDI_PRELUDE"
113  , "#include \"prelude-" ++ stdDigits (standardSpecifiedBy opts) ++ ".hpp\""
114  , "#endif" ] ++
115  ["using namespace std;" | NoUsingStd ∉ opts, PreprocessOnly ∉ opts]
116
117type LocationMap = (Int {- TU -}, (Line, Column)) → Int
118  -- To map locations in generated TUs back to positions in the request body.
119
120generated :: String → TString
121generated = map (, 0)
122
123tlines :: TString → [TString]
124tlines [] = []
125tlines (break ((== '\n') . fst) → (x, y)) =
126  x : case y of
127    [] -> []
128    _:z -> tlines z
129
130type TString = [(Char, Int)]
131
132translationUnits :: Set EvalOpt → Code → [[TString]]
133translationUnits opts requestChunks =
134    mapHead (++ maybe [] tlines main)
135     $ (map generated (preamble opts) ++) . splitBy null (tlines code)
136  where
137    (main, code) = Cxx.Operations.expand $ Cxx.Operations.line_breaks requestChunks
138
139fix_as_edit :: LocationMap → (EvalCxx.Fix → TextEdit Char)
140fix_as_edit f (EvalCxx.Fix file begin e repl) =
141    RangeReplaceEdit (Range (Pos begin') $ f (file, e) - begin') repl
142  where begin' = f (file, begin)
143
144locationMap :: [[TString]] → LocationMap
145locationMap us (u, (l, c))
146  | u < length us
147  , the_u <- us !! u
148  , l <= length the_u
149  , the_l@(_:_) <- the_u !! (l - 1) =
150      if c <= length the_l
151        then snd (the_l !! (c - 1))
152        else snd (last the_l) + 1 -- needed for fix-its that append at the end of lines
153  | otherwise = 0
154
155un_t :: TString → String
156un_t = map fst
157
158standardSpecifiedBy :: Set EvalOpt -> CxxStandard
159standardSpecifiedBy opts
160  | Std98 ∈ opts = Cxx 1998
161  | Std03 ∈ opts = Cxx 2003
162  | Std11 ∈ opts = Cxx 2011
163  | Std14 ∈ opts = Cxx 2014
164  | Std17 ∈ opts = Cxx 2017
165  | otherwise = CxxExperimental
166
167execEditableRequest :: Bool → EditableRequest → E (WithEvaluation (String, Maybe (TextEdit Char)))
168execEditableRequest clangByDefault (EditableRequest kind (dropWhile isSpace → body)) = case kind of
169  MakeType → noEvaluation . noFixit . Cxx.Show.show_simple . Cxx.Parse.makeType body
170  Precedence → noEvaluation . noFixit . Cxx.Parse.precedence body
171  Evaluate opts → do
172    chunks :: Code ← parseOrFail (Cxx.Parse.code << eof) (dropWhile isSpace body) "request"
173    let
174      tunits = translationUnits opts chunks
175      stageOfInterest
176        | CompileOnly ∈ opts = Gcc.Compile
177        | PreprocessOnly ∈ opts = Gcc.Preprocess
178        | otherwise = Gcc.Run
179      no_warn = NoWarn ∈ opts
180      clang
181        | clangByDefault = Gcc ∉ opts
182        | otherwise = Clang ∈ opts
183      units :: [String]
184      units = map (unlines . map un_t) tunits
185      standard = standardSpecifiedBy opts
186      tracing = Tracing ∈ opts
187    return $ second (fix_as_edit (locationMap tunits) .) . evaluate EvalCxx.Request{..}
188
189respond_and_remember :: Bool → EditableRequest → WithEvaluation Response
190respond_and_remember clangByDefault er = fmap f (tagError (execEditableRequest clangByDefault er))
191  where f (ou, edit) = Response (Just $ AddLast (er, edit)) ou
192
193noFixit :: String -> (String, Maybe (TextEdit Char))
194noFixit = flip (,) Nothing
195
196execFinalCommand :: Context → FinalCommand → E (WithEvaluation (String, Maybe (TextEdit Char)))
197execFinalCommand context@Context{..} fc = case fc of
198  Show Nothing → noEvaluation . noFixit . show_EditableRequest highlighter . fst . fst . popContext context
199  Show (Just substrs) → do
200    c ← evalRequestBody
201    l ← (\(Editing.EditsPreparation.Found _ x) → x) ‥ toList . Editing.EditsPreparation.findInStr c Nothing (flip (,) return . Cxx.Parse.parseRequest c) substrs
202    return $ noEvaluation $ noFixit $ commas_and (map (\x → '`' : strip (Editing.Basics.selectRange (convert $ Editing.Commands.replace_range x) c) ++ "`") l) ++ "."
203  Identify substrs → do
204    c ← evalRequestBody
205    tree ← Cxx.Parse.parseRequest c
206    l ← (\(Editing.EditsPreparation.Found _ x) → x) ‥ toList . Editing.EditsPreparation.findInStr c Nothing (Right (tree, return)) substrs
207    return $ noEvaluation $ noFixit $ concat $ List.intersperse ", " $ map (nicer_namedPathTo . Cxx.Operations.namedPathTo tree . convert . Editing.Commands.replace_range) l
208  Parse → evalRequestBody >>= Cxx.Parse.parseRequest >> return (noEvaluation $ noFixit "Looks fine to me.")
209  Diff → do ((x, _), context') ← popContext context; noEvaluation . noFixit . diff x . fst . fst . popContext context'
210  Run → fst . fst . popContext context >>= execEditableRequest clangByDefault
211 where
212  evalRequestBody :: E String
213  evalRequestBody = do
214    EditableRequest kind body ← fst . fst . popContext context
215    case kind of Evaluate _ → return body; _ → throwError "Last (editable) request was not an evaluation request."
216
217execEditCommand :: Context → ([Editing.Commands.Command], Maybe FinalCommand)
218  → E (EditableRequest, WithEvaluation (String, Maybe (TextEdit Char)))
219execEditCommand context@Context{..} (cs, mfcmd) = do
220  (r, maybeFixit) <- fst . popContext context
221  edited ← Editing.Execute.execute maybeFixit cs r
222  when (length_ge 1000 (editable_body edited)) $ throwError "Request would become too large."
223  (,) edited . case mfcmd of
224    Just fcmd → execFinalCommand context{previousRequests = (edited, Nothing) : previousRequests} fcmd
225    Nothing → execEditableRequest clangByDefault edited
226
227cout :: Context → Set EvalOpt → String → Parser Char (E (WithEvaluation Response))
228cout Context{..} opts s = parseSuccess $
229  Response Nothing ‥ fst ‥ execEditableRequest clangByDefault (EditableRequest (Evaluate opts) ("<< " ++ s))
230
231mainId :: DeclaratorId
232mainId = DeclaratorId_IdExpression Nothing $ IdExpression $ Right $ UnqualifiedId_Identifier $ Identifier "main" (White "")
233
234removeMain :: String -> String
235removeMain s =
236  case run_parser (Cxx.Parse.code << eof) s of
237    ParseFailure{} → s
238    ParseSuccess oldcode _ _ _ →
239      case Cxx.Operations.parseAbbrMain oldcode of
240        (Just _, x) -> show x
241        (Nothing, _) -> 
242          case Cxx.Parse.parseRequest s of
243            Left _ -> s
244            Right parsedReq -> case Cxx.Operations.find (DeclarationOf mainId) parsedReq of
245              [] -> s
246              ((r, _) : _) -> Editing.Basics.replaceRange r [] s
247
248p :: Context → Parser Char (E (WithEvaluation Response))
249p context@Context{..} = (spaces >>) $ do
250    (Response Nothing .) ‥ (>>= (fst ‥) . execFinalCommand context) . (Editing.Parse.finalCommandP << commit eof)
251  <|> do
252   kwds ["undo", "revert"]; commit $ propagateE (snd . popContext context) $ \context' → do
253    kwd "and"
254    (Response (Just DropLast) .) ‥ (>>= (fst ‥) . execFinalCommand context') . (Editing.Parse.finalCommandP << commit eof)
255     <|> (\(edited, we) -> (\(output, _) -> Response (Just $ ReplaceLast (edited, Nothing)) output) . we) ‥ (>>= execEditCommand context') . (Editing.Parse.commandsP << commit eof)
256  <|> do
257    kwds ["--precedence", "precedence"]
258    noErrors . respond_and_remember False . EditableRequest Precedence . getInput
259  <|> do
260    kwds ["--make-type", "make type"]
261    noErrors . respond_and_remember False . EditableRequest MakeType . getInput
262  <|> do kwds ["uname"]; cout context (∅) "geordi::uname()"
263  <|>
264    (\(edited, we) → (\(s, e) → Response (Just $ AddLast (edited, e)) s) . we) ‥ (>>= execEditCommand context) . (Editing.Parse.commandsP << commit eof)
265  <|> do
266   mopts ← optParser; spaces
267   propagateE mopts $ \(evalopts, eph_opts) → continueParsing $ do
268    s ← peek
269    case () of { ()
270      | Help ∈ eph_opts || s == "help" → cout context (∅) "help"
271      | Version ∈ eph_opts || s == "version" → cout context evalopts "geordi::compiler_description"
272      | Resume ∈ eph_opts → flip fmap (Cxx.Parse.code << eof) $ \code → case previousRequests of
273        [] → throwError "There is no previous resumable request."
274        (EditableRequest (Evaluate oldopts) (dropWhile isSpace → oldcodeblob), _) : _ →
275            noErrors $ respond_and_remember clangByDefault $
276              EditableRequest (Evaluate $ evalopts ∪ oldopts)
277                $ resume (removeMain oldcodeblob) (Cxx.Operations.parseAbbrMain code)
278        _ → throwError "Last (editable) request was not resumable."
279      | otherwise → parseSuccess . noErrors . respond_and_remember clangByDefault
280          =<< EditableRequest (Evaluate evalopts) . getInput }
281
282resume :: String -> Cxx.Operations.ShortCode → String
283resume old (Nothing, c) = old ++ show c
284resume old (Just x@(Block _), c) = show x ++ old ++ show c
285resume old (Just x, c) = show x ++ ";" ++ old ++ show c
286
287evaluate :: EvalCxx.Request → WithEvaluation (String, Maybe EvalCxx.Fix)
288evaluate = (g .) . EvalCxx.withEvaluation
289  where
290    g :: EvaluationResult -> (String, Maybe EvalCxx.Fix)
291    g er = (concatMap f $ show er, returnedFix er)
292    f :: Char -> String
293    f '\a' = "*BEEP*"
294    f '\n' = "\n"
295    f c | isPrint c = [c]
296    f c = '[' : showLitChar c "]"
297
298evaluator :: IO (String → Context → [(String, String)] → IO Response)
299evaluator = do
300  (ev, _) ← EvalCxx.evaluator
301  return $ \r context extra_env → either (return . Response Nothing . ("error: " ++)) (ev extra_env) $
302    join (parseOrFail (p context) (replace no_break_space ' ' r) "request")