/src/RequestEval.hs
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")