1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DerivingVia #-} 3{-# LANGUAGE GADTs #-} 4{-# LANGUAGE RankNTypes #-} 5{-# LANGUAGE TypeFamilies #-} 6 7module Development.IDE.GHC.ExactPrint 8 ( Graft(..), 9 graftDecls, 10 graftDeclsWithM, 11 annotate, 12 annotateDecl, 13 hoistGraft, 14 graftWithM, 15 graftExprWithM, 16 genericGraftWithSmallestM, 17 genericGraftWithLargestM, 18 graftSmallestDeclsWithM, 19 transform, 20 transformM, 21 useAnnotatedSource, 22 annotateParsedSource, 23 getAnnotatedParsedSourceRule, 24 GetAnnotatedParsedSource(..), 25 ASTElement (..), 26 ExceptStringT (..), 27 Annotated(..), 28 TransformT, 29 Anns, 30 Annotate, 31 setPrecedingLinesT, 32 ) 33where 34 35import BasicTypes (appPrec) 36import Control.Applicative (Alternative) 37import Control.Arrow 38import Control.Monad 39import qualified Control.Monad.Fail as Fail 40import Control.Monad.IO.Class (MonadIO) 41import Control.Monad.Trans.Class 42import Control.Monad.Trans.Except 43import Control.Monad.Zip 44import Data.Bool (bool) 45import qualified Data.DList as DL 46import Data.Either.Extra (mapLeft) 47import Data.Foldable (Foldable (fold)) 48import Data.Functor.Classes 49import Data.Functor.Contravariant 50import Data.Monoid (All (All), getAll) 51import qualified Data.Text as T 52import Data.Traversable (for) 53import Development.IDE.Core.RuleTypes 54import Development.IDE.Core.Service (runAction) 55import Development.IDE.Core.Shake 56import Development.IDE.GHC.Compat hiding (parseExpr) 57import Development.IDE.Graph (RuleResult, Rules) 58import Development.IDE.Graph.Classes 59import Development.IDE.Types.Location 60import qualified GHC.Generics as GHC 61import Generics.SYB 62import Generics.SYB.GHC 63import Ide.PluginUtils 64import Language.Haskell.GHC.ExactPrint 65import Language.Haskell.GHC.ExactPrint.Parsers 66import Language.LSP.Types 67import Language.LSP.Types.Capabilities (ClientCapabilities) 68import Outputable (Outputable, ppr, 69 showSDoc) 70import Parser (parseIdentifier) 71import Retrie.ExactPrint hiding (parseDecl, 72 parseExpr, 73 parsePattern, 74 parseType) 75 76 77------------------------------------------------------------------------------ 78 79data GetAnnotatedParsedSource = GetAnnotatedParsedSource 80 deriving (Eq, Show, Typeable, GHC.Generic) 81 82instance Hashable GetAnnotatedParsedSource 83instance NFData GetAnnotatedParsedSource 84instance Binary GetAnnotatedParsedSource 85type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource 86 87-- | Get the latest version of the annotated parse source with comments. 88getAnnotatedParsedSourceRule :: Rules () 89getAnnotatedParsedSourceRule = define $ \GetAnnotatedParsedSource nfp -> do 90 pm <- use GetParsedModuleWithComments nfp 91 return ([], fmap annotateParsedSource pm) 92 93annotateParsedSource :: ParsedModule -> Annotated ParsedSource 94annotateParsedSource = fixAnns 95 96useAnnotatedSource :: 97 String -> 98 IdeState -> 99 NormalizedFilePath -> 100 IO (Maybe (Annotated ParsedSource)) 101useAnnotatedSource herald state nfp = 102 runAction herald state (use GetAnnotatedParsedSource nfp) 103------------------------------------------------------------------------------ 104 105{- | A transformation for grafting source trees together. Use the semigroup 106 instance to combine 'Graft's, and run them via 'transform'. 107-} 108newtype Graft m a = Graft 109 { runGraft :: DynFlags -> a -> TransformT m a 110 } 111 112hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a 113hoistGraft h (Graft f) = Graft (fmap (hoistTransform h) . f) 114 115newtype ExceptStringT m a = ExceptStringT {runExceptString :: ExceptT String m a} 116 deriving newtype 117 ( MonadTrans 118 , Monad 119 , Functor 120 , Applicative 121 , Alternative 122 , Foldable 123 , Contravariant 124 , MonadIO 125 , Eq1 126 , Ord1 127 , Show1 128 , Read1 129 , MonadZip 130 , MonadPlus 131 , Eq 132 , Ord 133 , Show 134 , Read 135 ) 136 137instance Monad m => Fail.MonadFail (ExceptStringT m) where 138 fail = ExceptStringT . ExceptT . pure . Left 139 140instance Monad m => Semigroup (Graft m a) where 141 Graft a <> Graft b = Graft $ \dflags -> a dflags >=> b dflags 142 143instance Monad m => Monoid (Graft m a) where 144 mempty = Graft $ const pure 145 146------------------------------------------------------------------------------ 147 148-- | Convert a 'Graft' into a 'WorkspaceEdit'. 149transform :: 150 DynFlags -> 151 ClientCapabilities -> 152 Uri -> 153 Graft (Either String) ParsedSource -> 154 Annotated ParsedSource -> 155 Either String WorkspaceEdit 156transform dflags ccs uri f a = do 157 let src = printA a 158 a' <- transformA a $ runGraft f dflags 159 let res = printA a' 160 pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions 161 162------------------------------------------------------------------------------ 163 164-- | Convert a 'Graft' into a 'WorkspaceEdit'. 165transformM :: 166 Monad m => 167 DynFlags -> 168 ClientCapabilities -> 169 Uri -> 170 Graft (ExceptStringT m) ParsedSource -> 171 Annotated ParsedSource -> 172 m (Either String WorkspaceEdit) 173transformM dflags ccs uri f a = runExceptT $ 174 runExceptString $ do 175 let src = printA a 176 a' <- transformA a $ runGraft f dflags 177 let res = printA a' 178 pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions 179 180 181-- | Returns whether or not this node requires its immediate children to have 182-- be parenthesized and have a leading space. 183-- 184-- A more natural type for this function would be to return @(Bool, Bool)@, but 185-- we use 'All' instead for its monoid instance. 186needsParensSpace :: 187 HsExpr GhcPs -> 188 -- | (Needs parens, needs space) 189 (All, All) 190needsParensSpace HsLam{} = (All False, All False) 191needsParensSpace HsLamCase{} = (All False, All True) 192needsParensSpace HsApp{} = mempty 193needsParensSpace HsAppType{} = mempty 194needsParensSpace OpApp{} = mempty 195needsParensSpace HsPar{} = (All False, All False) 196needsParensSpace SectionL{} = (All False, All False) 197needsParensSpace SectionR{} = (All False, All False) 198needsParensSpace ExplicitTuple{} = (All False, All False) 199needsParensSpace ExplicitSum{} = (All False, All False) 200needsParensSpace HsCase{} = (All False, All True) 201needsParensSpace HsIf{} = (All False, All False) 202needsParensSpace HsMultiIf{} = (All False, All False) 203needsParensSpace HsLet{} = (All False, All True) 204needsParensSpace HsDo{} = (All False, All False) 205needsParensSpace ExplicitList{} = (All False, All False) 206needsParensSpace RecordCon{} = (All False, All True) 207needsParensSpace RecordUpd{} = mempty 208needsParensSpace _ = mempty 209 210 211------------------------------------------------------------------------------ 212 213{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the 214 given @Located ast@. The node at that position must already be a @Located 215 ast@, or this is a no-op. 216-} 217graft' :: 218 forall ast a. 219 (Data a, ASTElement ast) => 220 -- | Do we need to insert a space before this grafting? In do blocks, the 221 -- answer is no, or we will break layout. But in function applications, 222 -- the answer is yes, or the function call won't get its argument. Yikes! 223 -- 224 -- More often the answer is yes, so when in doubt, use that. 225 Bool -> 226 SrcSpan -> 227 Located ast -> 228 Graft (Either String) a 229graft' needs_space dst val = Graft $ \dflags a -> do 230 (anns, val') <- annotate dflags needs_space val 231 modifyAnnsT $ mappend anns 232 pure $ 233 everywhere' 234 ( mkT $ 235 \case 236 (L src _ :: Located ast) | src == dst -> val' 237 l -> l 238 ) 239 a 240 241-- | Like 'graft', but specialized to 'LHsExpr', and intelligently inserts 242-- parentheses if they're necessary. 243graftExpr :: 244 forall a. 245 (Data a) => 246 SrcSpan -> 247 LHsExpr GhcPs -> 248 Graft (Either String) a 249graftExpr dst val = Graft $ \dflags a -> do 250 let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a 251 252 runGraft 253 (graft' needs_space dst $ mk_parens val) 254 dflags 255 a 256 257 258getNeedsSpaceAndParenthesize :: 259 (ASTElement ast, Data a) => 260 SrcSpan -> 261 a -> 262 (Bool, Located ast -> Located ast) 263getNeedsSpaceAndParenthesize dst a = 264 -- Traverse the tree, looking for our replacement node. But keep track of 265 -- the context (parent HsExpr constructor) we're in while we do it. This 266 -- lets us determine wehther or not we need parentheses. 267 let (needs_parens, needs_space) = 268 everythingWithContext (Nothing, Nothing) (<>) 269 ( mkQ (mempty, ) $ \x s -> case x of 270 (L src _ :: LHsExpr GhcPs) | src == dst -> 271 (s, s) 272 L _ x' -> (mempty, Just *** Just $ needsParensSpace x') 273 ) a 274 in ( maybe True getAll needs_space 275 , bool id maybeParensAST $ maybe False getAll needs_parens 276 ) 277 278 279------------------------------------------------------------------------------ 280 281graftExprWithM :: 282 forall m a. 283 (Fail.MonadFail m, Data a) => 284 SrcSpan -> 285 (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) -> 286 Graft m a 287graftExprWithM dst trans = Graft $ \dflags a -> do 288 let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a 289 290 everywhereM' 291 ( mkM $ 292 \case 293 val@(L src _ :: LHsExpr GhcPs) 294 | src == dst -> do 295 mval <- trans val 296 case mval of 297 Just val' -> do 298 (anns, val'') <- 299 hoistTransform (either Fail.fail pure) 300 (annotate @(HsExpr GhcPs) dflags needs_space (mk_parens val')) 301 modifyAnnsT $ mappend anns 302 pure val'' 303 Nothing -> pure val 304 l -> pure l 305 ) 306 a 307 308graftWithM :: 309 forall ast m a. 310 (Fail.MonadFail m, Data a, ASTElement ast) => 311 SrcSpan -> 312 (Located ast -> TransformT m (Maybe (Located ast))) -> 313 Graft m a 314graftWithM dst trans = Graft $ \dflags a -> do 315 everywhereM' 316 ( mkM $ 317 \case 318 val@(L src _ :: Located ast) 319 | src == dst -> do 320 mval <- trans val 321 case mval of 322 Just val' -> do 323 (anns, val'') <- 324 hoistTransform (either Fail.fail pure) $ 325 annotate dflags True $ maybeParensAST val' 326 modifyAnnsT $ mappend anns 327 pure val'' 328 Nothing -> pure val 329 l -> pure l 330 ) 331 a 332 333-- | Run the given transformation only on the smallest node in the tree that 334-- contains the 'SrcSpan'. 335genericGraftWithSmallestM :: 336 forall m a ast. 337 (Monad m, Data a, Typeable ast) => 338 -- | The type of nodes we'd like to consider when finding the smallest. 339 Proxy (Located ast) -> 340 SrcSpan -> 341 (DynFlags -> ast -> GenericM (TransformT m)) -> 342 Graft m a 343genericGraftWithSmallestM proxy dst trans = Graft $ \dflags -> 344 smallestM (genericIsSubspan proxy dst) (trans dflags) 345 346-- | Run the given transformation only on the largest node in the tree that 347-- contains the 'SrcSpan'. 348genericGraftWithLargestM :: 349 forall m a ast. 350 (Monad m, Data a, Typeable ast) => 351 -- | The type of nodes we'd like to consider when finding the largest. 352 Proxy (Located ast) -> 353 SrcSpan -> 354 (DynFlags -> ast -> GenericM (TransformT m)) -> 355 Graft m a 356genericGraftWithLargestM proxy dst trans = Graft $ \dflags -> 357 largestM (genericIsSubspan proxy dst) (trans dflags) 358 359 360graftDecls :: 361 forall a. 362 (HasDecls a) => 363 SrcSpan -> 364 [LHsDecl GhcPs] -> 365 Graft (Either String) a 366graftDecls dst decs0 = Graft $ \dflags a -> do 367 decs <- forM decs0 $ \decl -> do 368 annotateDecl dflags decl 369 let go [] = DL.empty 370 go (L src e : rest) 371 | src == dst = DL.fromList decs <> DL.fromList rest 372 | otherwise = DL.singleton (L src e) <> go rest 373 modifyDeclsT (pure . DL.toList . go) a 374 375graftSmallestDeclsWithM :: 376 forall a. 377 (HasDecls a) => 378 SrcSpan -> 379 (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) -> 380 Graft (Either String) a 381graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do 382 let go [] = pure DL.empty 383 go (e@(L src _) : rest) 384 | dst `isSubspanOf` src = toDecls e >>= \case 385 Just decs0 -> do 386 decs <- forM decs0 $ \decl -> 387 annotateDecl dflags decl 388 pure $ DL.fromList decs <> DL.fromList rest 389 Nothing -> (DL.singleton e <>) <$> go rest 390 | otherwise = (DL.singleton e <>) <$> go rest 391 modifyDeclsT (fmap DL.toList . go) a 392 393graftDeclsWithM :: 394 forall a m. 395 (HasDecls a, Fail.MonadFail m) => 396 SrcSpan -> 397 (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) -> 398 Graft m a 399graftDeclsWithM dst toDecls = Graft $ \dflags a -> do 400 let go [] = pure DL.empty 401 go (e@(L src _) : rest) 402 | src == dst = toDecls e >>= \case 403 Just decs0 -> do 404 decs <- forM decs0 $ \decl -> 405 hoistTransform (either Fail.fail pure) $ 406 annotateDecl dflags decl 407 pure $ DL.fromList decs <> DL.fromList rest 408 Nothing -> (DL.singleton e <>) <$> go rest 409 | otherwise = (DL.singleton e <>) <$> go rest 410 modifyDeclsT (fmap DL.toList . go) a 411 412 413class (Data ast, Outputable ast) => ASTElement ast where 414 parseAST :: Parser (Located ast) 415 maybeParensAST :: Located ast -> Located ast 416 {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with 417 the given @Located ast@. The node at that position must already be 418 a @Located ast@, or this is a no-op. 419 -} 420 graft :: 421 forall a. 422 (Data a) => 423 SrcSpan -> 424 Located ast -> 425 Graft (Either String) a 426 graft dst = graft' True dst . maybeParensAST 427 428instance p ~ GhcPs => ASTElement (HsExpr p) where 429 parseAST = parseExpr 430 maybeParensAST = parenthesize 431 graft = graftExpr 432 433instance p ~ GhcPs => ASTElement (Pat p) where 434#if __GLASGOW_HASKELL__ == 808 435 parseAST = fmap (fmap $ right $ second dL) . parsePattern 436 maybeParensAST = dL . parenthesizePat appPrec . unLoc 437#else 438 parseAST = parsePattern 439 maybeParensAST = parenthesizePat appPrec 440#endif 441 442instance p ~ GhcPs => ASTElement (HsType p) where 443 parseAST = parseType 444 maybeParensAST = parenthesizeHsType appPrec 445 446instance p ~ GhcPs => ASTElement (HsDecl p) where 447 parseAST = parseDecl 448 maybeParensAST = id 449 450instance p ~ GhcPs => ASTElement (ImportDecl p) where 451 parseAST = parseImport 452 maybeParensAST = id 453 454instance ASTElement RdrName where 455 parseAST df fp = parseWith df fp parseIdentifier 456 maybeParensAST = id 457 458------------------------------------------------------------------------------ 459 460-- | Dark magic I stole from retrie. No idea what it does. 461fixAnns :: ParsedModule -> Annotated ParsedSource 462fixAnns ParsedModule {..} = 463 let ranns = relativiseApiAnns pm_parsed_source pm_annotations 464 in unsafeMkA pm_parsed_source ranns 0 465 466------------------------------------------------------------------------------ 467 468-- | Given an 'LHSExpr', compute its exactprint annotations. 469-- Note that this function will throw away any existing annotations (and format) 470annotate :: ASTElement ast => DynFlags -> Bool -> Located ast -> TransformT (Either String) (Anns, Located ast) 471annotate dflags needs_space ast = do 472 uniq <- show <$> uniqueSrcSpanT 473 let rendered = render dflags ast 474 (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered 475 let anns' = setPrecedingLines expr' 0 (bool 0 1 needs_space) anns 476 pure (anns', expr') 477 478-- | Given an 'LHsDecl', compute its exactprint annotations. 479annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs) 480-- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain 481-- multiple matches. To work around this, we split the single 482-- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match', 483-- and then merge them all back together. 484annotateDecl dflags 485 (L src ( 486 ValD ext fb@FunBind 487 { fun_matches = mg@MG { mg_alts = L alt_src alts@(_:_)} 488 })) = do 489 let set_matches matches = 490 ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }} 491 492 (anns', alts') <- fmap unzip $ for alts $ \alt -> do 493 uniq <- show <$> uniqueSrcSpanT 494 let rendered = render dflags $ set_matches [alt] 495 lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case 496 (ann, L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}})) 497 -> pure (setPrecedingLines alt' 1 0 ann, alt') 498 _ -> lift $ Left "annotateDecl: didn't parse a single FunBind match" 499 500 modifyAnnsT $ mappend $ fold anns' 501 pure $ L src $ set_matches alts' 502annotateDecl dflags ast = do 503 uniq <- show <$> uniqueSrcSpanT 504 let rendered = render dflags ast 505 (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered 506 let anns' = setPrecedingLines expr' 1 0 anns 507 modifyAnnsT $ mappend anns' 508 pure expr' 509 510------------------------------------------------------------------------------ 511 512-- | Print out something 'Outputable'. 513render :: Outputable a => DynFlags -> a -> String 514render dflags = showSDoc dflags . ppr 515 516------------------------------------------------------------------------------ 517 518-- | Put parentheses around an expression if required. 519parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs 520parenthesize = parenthesizeHsExpr appPrec 521 522