PageRenderTime 73ms CodeModel.GetById 17ms app.highlight 50ms RepoModel.GetById 1ms app.codeStats 0ms

/src/RequestEval.hs

http://github.com/Eelis/geordi
Haskell | 302 lines | 251 code | 39 blank | 12 comment | 13 complexity | 5bf61aee6f9e4b356625855ddc855357 MD5 | raw file
  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")