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