1{-# LANGUAGE DataKinds #-}
2
3module Language.Haskell.Brittany.Internal.ExactPrintUtils
4  ( parseModule
5  , parseModuleFromString
6  , commentAnnFixTransformGlob
7  , extractToplevelAnns
8  , foldedAnnKeys
9  , withTransformedAnns
10  )
11where
12
13
14
15#include "prelude.inc"
16
17import           Language.Haskell.Brittany.Internal.Types
18import           Language.Haskell.Brittany.Internal.Config.Types
19import           Language.Haskell.Brittany.Internal.Utils
20import           Data.Data
21import           Data.HList.HList
22
23import           DynFlags ( getDynFlags )
24import           GHC ( runGhc, GenLocated(L), moduleNameString )
25import qualified DynFlags      as GHC
26import qualified GHC           as GHC hiding (parseModule)
27import qualified Parser        as GHC
28import qualified SrcLoc        as GHC
29import qualified FastString    as GHC
30import qualified GHC           as GHC hiding (parseModule)
31import qualified Lexer         as GHC
32import qualified StringBuffer  as GHC
33import qualified Outputable    as GHC
34import qualified CmdLineParser as GHC
35
36#if MIN_VERSION_ghc(8,10,1)   /* ghc-8.10.1 */
37import           GHC.Hs
38import           Bag
39#else
40import           HsSyn
41#endif
42
43import           SrcLoc ( SrcSpan, Located )
44
45
46import qualified Language.Haskell.GHC.ExactPrint            as ExactPrint
47import qualified Language.Haskell.GHC.ExactPrint.Annotate   as ExactPrint
48import qualified Language.Haskell.GHC.ExactPrint.Types      as ExactPrint
49import qualified Language.Haskell.GHC.ExactPrint.Parsers    as ExactPrint
50import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint
51import qualified Language.Haskell.GHC.ExactPrint.Delta      as ExactPrint
52
53import qualified Data.Generics as SYB
54
55import           Control.Exception
56-- import           Data.Generics.Schemes
57
58
59
60parseModule
61  :: [String]
62  -> System.IO.FilePath
63  -> (GHC.DynFlags -> IO (Either String a))
64  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
65parseModule =
66  parseModuleWithCpp ExactPrint.defaultCppOptions ExactPrint.normalLayout
67
68-- | Parse a module with specific instructions for the C pre-processor.
69parseModuleWithCpp
70  :: ExactPrint.CppOptions
71  -> ExactPrint.DeltaOptions
72  -> [String]
73  -> System.IO.FilePath
74  -> (GHC.DynFlags -> IO (Either String a))
75  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
76parseModuleWithCpp cpp opts args fp dynCheck =
77  ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do
78    dflags0                       <- lift $ GHC.getSessionDynFlags
79    (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine
80      dflags0
81      (GHC.noLoc <$> ("-hide-all-packages" : args))
82      -- that we pass -hide-all-packages here is a duplication, because
83      -- ExactPrint.initDynFlags also does it, but necessary because of
84      -- stupid and careless GHC API design. We explicitly want to pass
85      -- our args before calling that, so this is what we do. Should be
86      -- harmless. See commit 1b7576dcd1823e1c685a44927b1fcaade1319063.
87    void $ lift $ GHC.setSessionDynFlags dflags1
88    dflags2 <- lift $ ExactPrint.initDynFlags fp
89    when (not $ null leftover)
90      $  ExceptT.throwE
91      $  "when parsing ghc flags: leftover flags: "
92      ++ show (leftover <&> \(L _ s) -> s)
93    when (not $ null warnings)
94      $  ExceptT.throwE
95      $  "when parsing ghc flags: encountered warnings: "
96      ++ show (warnings <&> warnExtractorCompat)
97    x   <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2
98    res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp
99#if MIN_VERSION_ghc(8,10,1)   /* ghc-8.10.1 */
100    either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err)))
101#else
102    either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err)
103#endif
104           (\(a, m) -> pure (a, m, x))
105      $ ExactPrint.postParseTransform res opts
106
107parseModuleFromString
108  :: [String]
109  -> System.IO.FilePath
110  -> (GHC.DynFlags -> IO (Either String a))
111  -> String
112  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
113parseModuleFromString args fp dynCheck str =
114  -- We mask here because otherwise using `throwTo` (i.e. for a timeout) will
115  -- produce nasty looking errors ("ghc panic"). The `mask_` makes it so we
116  -- cannot kill the parsing thread - not very nice. But i'll
117  -- optimistically assume that most of the time brittany uses noticable or
118  -- longer time, the majority of the time is not spend in parsing, but in
119  -- bridoc transformation stuff.
120  -- (reminder to update note on `parsePrintModule` if this changes.)
121  mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do
122    dflags0                       <- lift $ ExactPrint.initDynFlagsPure fp str
123    (dflags1, leftover, warnings) <- lift
124      $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args)
125    when (not $ null leftover)
126      $  ExceptT.throwE
127      $  "when parsing ghc flags: leftover flags: "
128      ++ show (leftover <&> \(L _ s) -> s)
129    when (not $ null warnings)
130      $  ExceptT.throwE
131      $  "when parsing ghc flags: encountered warnings: "
132      ++ show (warnings <&> warnExtractorCompat)
133    dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
134    let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
135    case res of
136#if MIN_VERSION_ghc(8,10,1)   /* ghc-8.10.1 */
137      Left  err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err))
138#else
139      Left  (span, err) -> ExceptT.throwE $ showOutputable span ++ ": " ++ err
140#endif
141      Right (a   , m  ) -> pure (a, m, dynCheckRes)
142
143
144commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
145commentAnnFixTransformGlob ast = do
146  let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
147      extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
148        const Seq.empty
149          `SYB.ext1Q`
150            (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l))
151  let nodes = SYB.everything (<>) extract ast
152  let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
153      annsMap = Map.fromListWith
154        (flip const)
155        [ (GHC.realSrcSpanEnd span, annKey)
156        | (GHC.RealSrcSpan span, annKey) <- Foldable.toList nodes
157        ]
158  nodes `forM_` (snd .> processComs annsMap)
159 where
160  processComs annsMap annKey1 = do
161    mAnn <- State.Class.gets fst <&> Map.lookup annKey1
162    mAnn `forM_` \ann1 -> do
163      let priors  = ExactPrint.annPriorComments ann1
164          follows = ExactPrint.annFollowingComments ann1
165          assocs  = ExactPrint.annsDP ann1
166      let
167        processCom
168          :: (ExactPrint.Comment, ExactPrint.DeltaPos)
169          -> ExactPrint.TransformT Identity Bool
170        processCom comPair@(com, _) =
171          case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of
172            GHC.UnhelpfulLoc{}    -> return True -- retain comment at current node.
173            GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of
174              Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
175                (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
176                  move $> False
177                (x, y) | x == y -> move $> False
178                _               -> return True
179               where
180                ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
181                ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
182                loc1                              = GHC.srcSpanStart annKeyLoc1
183                loc2                              = GHC.srcSpanStart annKeyLoc2
184                move = ExactPrint.modifyAnnsT $ \anns ->
185                  let
186                    ann2  = Data.Maybe.fromJust $ Map.lookup annKey2 anns
187                    ann2' = ann2
188                      { ExactPrint.annFollowingComments =
189                          ExactPrint.annFollowingComments ann2 ++ [comPair]
190                      }
191                  in
192                    Map.insert annKey2 ann2' anns
193              _ -> return True -- retain comment at current node.
194      priors'  <- flip filterM priors processCom
195      follows' <- flip filterM follows $ processCom
196      assocs'  <- flip filterM assocs $ \case
197        (ExactPrint.AnnComment com, dp) -> processCom (com, dp)
198        _                               -> return True
199      let ann1' = ann1 { ExactPrint.annPriorComments     = priors'
200                       , ExactPrint.annFollowingComments = follows'
201                       , ExactPrint.annsDP               = assocs'
202                       }
203      ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
204
205
206-- TODO: this is unused by now, but it contains one detail that
207--       commentAnnFixTransformGlob does not include: Moving of comments for
208--       "RecordUpd"s.
209-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
210-- commentAnnFixTransform modul = SYB.everything (>>) genF modul
211--  where
212--   genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
213--   genF = (\_ -> return ()) `SYB.extQ` exprF
214--   exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
215--   exprF lexpr@(L _ expr) = case expr of
216-- #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
217--     RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->
218-- #else
219--     RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) ->
220-- #endif
221--       moveTrailingComments lexpr (List.last fs)
222-- #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
223--     RecordUpd _ _e fs@(_:_) ->
224-- #else
225--     RecordUpd _e fs@(_:_) _cons _ _ _ ->
226-- #endif
227--       moveTrailingComments lexpr (List.last fs)
228--     _ -> return ()
229
230commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
231commentAnnFixTransform modul = SYB.everything (>>) genF modul
232 where
233  genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
234  genF = (\_ -> return ()) `SYB.extQ` exprF
235  exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
236  exprF lexpr@(L _ expr) = case expr of
237    RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->
238      moveTrailingComments lexpr (List.last fs)
239    RecordUpd _ _e fs@(_:_) ->
240      moveTrailingComments lexpr (List.last fs)
241    _ -> return ()
242
243moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)
244                     => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()
245moveTrailingComments astFrom astTo = do
246  let
247    k1 = ExactPrint.mkAnnKey astFrom
248    k2 = ExactPrint.mkAnnKey astTo
249    moveComments ans = ans'
250      where
251        an1 = Data.Maybe.fromJust $ Map.lookup k1 ans
252        an2 = Data.Maybe.fromJust $ Map.lookup k2 ans
253        cs1f = ExactPrint.annFollowingComments an1
254        cs2f = ExactPrint.annFollowingComments an2
255        (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1)
256             $ \case
257               (ExactPrint.AnnComment com, dp) -> Left (com, dp)
258               x -> Right x
259        an1' = an1
260          { ExactPrint.annsDP               = nonComments
261          , ExactPrint.annFollowingComments = []
262          }
263        an2' = an2
264          { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments
265          }
266        ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans
267
268  ExactPrint.modifyAnnsT moveComments
269
270-- | split a set of annotations in a module into a map from top-level module
271-- elements to the relevant annotations. Avoids quadratic behaviour a trivial
272-- implementation would have.
273extractToplevelAnns
274  :: Located (HsModule GhcPs)
275  -> ExactPrint.Anns
276  -> Map ExactPrint.AnnKey ExactPrint.Anns
277extractToplevelAnns lmod anns = output
278 where
279  (L _ (HsModule _ _ _ ldecls _ _)) = lmod
280  declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey
281  declMap1 = Map.unions $ ldecls <&> \ldecl ->
282    Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl)
283  declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey
284  declMap2 =
285    Map.fromList
286      $ [ (captured, declMap1 Map.! k)
287        | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns
288        ]
289  declMap = declMap1 `Map.union` declMap2
290  modKey  = ExactPrint.mkAnnKey lmod
291  output  = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns
292
293groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a)
294groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m)
295                               Map.empty
296 where
297  insert k a Nothing  = Just (Map.singleton k a)
298  insert k a (Just m) = Just (Map.insert k a m)
299
300foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
301foldedAnnKeys ast = SYB.everything
302  Set.union
303  ( \x -> maybe
304    Set.empty
305    Set.singleton
306    [ SYB.gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x
307    | locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
308    , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
309      -- for some reason, ghc-8.8 has forgotten how to infer the type of l,
310      -- even though it is passed to mkAnnKey above, which only accepts
311      -- SrcSpan.
312    ]
313  )
314  ast
315  where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
316
317
318withTransformedAnns
319  :: Data ast
320  => ast
321  -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a
322  -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a
323withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
324  readers@(conf :+: anns :+: HNil) -> do
325    -- TODO: implement `local` for MultiReader/MultiRWS
326    MultiRWSS.mPutRawR (conf :+: f anns :+: HNil)
327    x <- m
328    MultiRWSS.mPutRawR readers
329    pure x
330 where
331  f anns =
332    let ((), (annsBalanced, _), _) =
333          ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
334    in  annsBalanced
335
336
337warnExtractorCompat :: GHC.Warn -> String
338warnExtractorCompat (GHC.Warn _ (L _ s)) = s
339