/src/RequestEval.hs

http://github.com/Eelis/geordi · Haskell · 303 lines · 252 code · 39 blank · 12 comment · 28 complexity · 7b7385437f1d23961764e63cc2ecf7dd MD5 · raw file

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