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