diff --git a/brittany.cabal b/brittany.cabal index ad87944..35bf75d 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -39,9 +39,9 @@ flag pedantic common library build-depends: , aeson ^>= 2.0.1 - , base ^>= 4.15.0 + , base ^>= 4.16.0 , butcher ^>= 1.3.3 - , bytestring ^>= 0.10.12 + , bytestring ^>= 0.11 , cmdargs ^>= 0.10.21 , containers ^>= 0.6.4 , czipwith ^>= 1.0.1 @@ -50,10 +50,10 @@ common library , directory ^>= 1.3.6 , extra ^>= 1.7.10 , filepath ^>= 1.4.2 - , ghc ^>= 9.0.1 - , ghc-boot ^>= 9.0.1 - , ghc-boot-th ^>= 9.0.1 - , ghc-exactprint ^>= 0.6.4 + , ghc ^>= 9.2.1 + , ghc-boot ^>= 9.2.1 + , ghc-boot-th ^>= 9.2.1 + , ghc-exactprint ^>= 1.4 , monad-memo ^>= 0.5.3 , mtl ^>= 2.2.2 , multistate ^>= 0.8.0 diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index 06cbb63..04985d0 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -57,7 +57,7 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified UI.Butcher.Monadic as Butcher - +import Language.Haskell.Brittany.Internal.EPCompat as ExactPrint data InlineConfigTarget = InlineConfigTargetModule @@ -73,16 +73,17 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do let commentLiness = [ ( k - , [ x - | (ExactPrint.Comment x _ _, _) <- - (ExactPrint.annPriorComments ann - ++ ExactPrint.annFollowingComments ann - ) - ] - ++ [ x - | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- - ExactPrint.annsDP ann - ] + , [] + -- , [ x + -- | (ExactPrint.Comment x _ _, _) <- + -- (ExactPrint.annPriorComments ann + -- ++ ExactPrint.annFollowingComments ann + -- ) + -- ] + -- ++ [ x + -- | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- + -- ExactPrint.annsDP ann + -- ] ) | (k, ann) <- Map.toList anns ] @@ -218,11 +219,12 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap -getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = +getTopLevelDeclNameMap (L _ (HsModule _ _ _name _exports _ decls _ _)) = TopLevelDeclNameMap $ Map.fromList - [ (ExactPrint.mkAnnKey decl, name) - | decl <- decls - , (name : _) <- [getDeclBindingNames decl] + [ + -- (ExactPrint.mkAnnKey decl, name) + -- | decl <- decls + -- , (name : _) <- [getDeclBindingNames decl] ] @@ -245,7 +247,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do let config_pp = config & _conf_preprocessor let cppMode = config_pp & _ppconf_CPPMode & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack - (anns, parsedSource, hasCPP) <- do + ({-anns,-} parsedSource, hasCPP) <- do let hackF s = if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s @@ -270,7 +272,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do Right x -> pure x (inlineConf, perItemConf) <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure - $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + $ extractCommentConfigs {-anns-} undefined (getTopLevelDeclNameMap parsedSource) let moduleConfig = cZipWith fromOptionIdentity config inlineConf let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack if disableFormatting @@ -285,9 +287,9 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do & _econf_omit_output_valid_check & confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule moduleConfig perItemConf anns parsedSource + then return $ pPrintModule moduleConfig perItemConf {-anns-} undefined parsedSource else lift - $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource + $ pPrintModuleAndCheck moduleConfig perItemConf {-anns-} undefined parsedSource let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s @@ -341,7 +343,7 @@ pPrintModule conf inlineConf anns parsedModule = $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) $ do traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns + $ annsDoc {-anns-} undefined ppModule parsedModule tracer = if Seq.null debugStrings then id @@ -389,9 +391,9 @@ parsePrintModuleTests conf filename input = do inputStr case parseResult of Left err -> return $ Left err - Right (anns, parsedModule, _) -> runExceptT $ do + Right ({-anns,-} parsedModule, _) -> runExceptT $ do (inlineConf, perItemConf) <- - case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of + case extractCommentConfigs {-anns-} undefined (getTopLevelDeclNameMap parsedModule) of Left err -> throwE $ "error in inline config: " ++ show err Right x -> pure x let moduleConf = cZipWith fromOptionIdentity conf inlineConf @@ -402,9 +404,9 @@ parsePrintModuleTests conf filename input = do .> _econf_omit_output_valid_check .> confUnpack (errs, ltext) <- if omitCheck - then return $ pPrintModule moduleConf perItemConf anns parsedModule + then return $ pPrintModule moduleConf perItemConf {-anns-} undefined parsedModule else lift - $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule + $ pPrintModuleAndCheck moduleConf perItemConf {-anns-} undefined parsedModule if null errs then pure $ TextL.toStrict $ ltext else @@ -460,18 +462,18 @@ toLocal conf anns m = do pure x ppModule :: GenLocated SrcSpan HsModule -> PPM () -ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do +ppModule lmod@(L _loc _m@(HsModule _ _ _name _exports _ decls _ _)) = do defaultAnns <- do anns <- mAsk - let annKey = ExactPrint.mkAnnKey lmod + let annKey = undefined -- ExactPrint.mkAnnKey lmod let annMap = Map.findWithDefault Map.empty annKey anns - let isEof = (== ExactPrint.AnnEofPos) - let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a } - pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap + -- let isEof = (== ExactPrint.AnnEofPos) + -- let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a } + pure $ undefined {- fmap (overAnnsDP . filter $ isEof . fst) -} annMap post <- ppPreamble lmod decls `forM_` \decl -> do - let declAnnKey = ExactPrint.mkAnnKey decl + let declAnnKey = undefined --ExactPrint.mkAnnKey decl let declBindingNames = getDeclBindingNames decl inlineConf <- mAsk let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf @@ -484,7 +486,7 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations - $ annsDoc filteredAnns + $ annsDoc {-filteredAnns-} undefined config <- mAsk @@ -505,27 +507,27 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do else briDocMToPPM $ briDocByExactNoComment decl layoutBriDoc bd - let - finalComments = filter - (fst .> \case - ExactPrint.AnnComment{} -> True - _ -> False - ) - post + -- let + -- finalComments = filter + -- (fst .> \case + -- -- ExactPrint.AnnComment{} -> True + -- _ -> False + -- ) + -- post post `forM_` \case - (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do - ppmMoveToExactLoc l - mTell $ Text.Builder.fromString cmStr - (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let - folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> - ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + -- (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do + -- ppmMoveToExactLoc l + -- mTell $ Text.Builder.fromString cmStr + -- (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> + -- let + -- folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + -- ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> + -- ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + -- , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + -- ) + -- _ -> (acc + y, x) + -- (cmY, cmX) = foldl' folder (0, 0) finalComments + -- in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () getDeclBindingNames :: LHsDecl GhcPs -> [String] @@ -539,10 +541,10 @@ getDeclBindingNames (L _ decl) = case decl of -- This includes the imports ppPreamble :: GenLocated SrcSpan HsModule - -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] + -> PPM [{- (ExactPrint.KeywordId, ExactPrint.DeltaPos)-} ((), ())] ppPreamble lmod@(L loc m@HsModule{}) = do filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap + Map.findWithDefault Map.empty ({-ExactPrint.mkAnnKey-} undefined lmod) annMap -- Since ghc-exactprint adds annotations following (implicit) -- modules to both HsModule and the elements in the module -- this can cause duplication of comments. So strip @@ -555,14 +557,14 @@ ppPreamble lmod@(L loc m@HsModule{}) = do let (filteredAnns', post) = - case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of + case Map.lookup ({-ExactPrint.mkAnnKey-} undefined lmod) filteredAnns of Nothing -> (filteredAnns, []) Just mAnn -> let - modAnnsDp = ExactPrint.annsDP mAnn - isWhere (ExactPrint.G AnnWhere) = True + modAnnsDp = undefined -- ExactPrint.annsDP mAnn + -- isWhere (ExactPrint.G AnnWhere) = True isWhere _ = False - isEof (ExactPrint.AnnEofPos) = True + -- isEof (ExactPrint.AnnEofPos) = True isEof _ = False whereInd = List.findIndex (isWhere . fst) modAnnsDp eofInd = List.findIndex (isEof . fst) modAnnsDp @@ -571,9 +573,9 @@ ppPreamble lmod@(L loc m@HsModule{}) = do (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp - mAnn' = mAnn { ExactPrint.annsDP = pre } + mAnn' = mAnn -- { ExactPrint.annsDP = pre } filteredAnns'' = - Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns + Map.insert ({-ExactPrint.mkAnnKey-} undefined lmod) mAnn' filteredAnns in (filteredAnns'', post') traceIfDumpConf "bridoc annotations filtered/transformed" @@ -582,7 +584,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do if shouldReformatPreamble then toLocal config filteredAnns' $ withTransformedAnns lmod $ do - briDoc <- briDocMToPPM $ layoutModule lmod + briDoc <- briDocMToPPM $ layoutModule (reLocA lmod) layoutBriDoc briDoc else let emptyModule = L loc m { hsmodDecls = [] } @@ -667,16 +669,18 @@ layoutBriDoc briDoc = do state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' let + remainingComments :: [((), ())] remainingComments = - [ c - | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList - (_lstate_comments state') - -- With the new import layouter, we manually process comments - -- without relying on the backend to consume the comments out of - -- the state/map. So they will end up here, and we need to ignore - -- them. - , ExactPrint.unConName con /= "ImportDecl" - , c <- extractAllComments elemAnns + [ + -- c + -- | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList + -- (_lstate_comments state') + -- -- With the new import layouter, we manually process comments + -- -- without relying on the backend to consume the comments out of + -- -- the state/map. So they will end up here, and we need to ignore + -- -- them. + -- , ExactPrint.unConName con /= "ImportDecl" + -- , c <- extractAllComments elemAnns ] remainingComments `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs index 55a3c97..1a1e741 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Backend.hs @@ -66,7 +66,7 @@ data ColBuildState = ColBuildState type LayoutConstraints m = ( MonadMultiReader Config m - , MonadMultiReader ExactPrint.Types.Anns m + -- , MonadMultiReader ExactPrint.Types.Anns m , MonadMultiWriter Text.Builder.Builder m , MonadMultiWriter (Seq String) m , MonadMultiState LayoutState m @@ -138,12 +138,12 @@ layoutBriDocM = \case let tlines = Text.lines $ t <> Text.pack "\n" tlineCount = length tlines - anns :: ExactPrint.Anns <- mAsk + -- anns <- mAsk when shouldAddComment $ do layoutWriteAppend $ Text.pack $ "{-" - ++ show (annKey, Map.lookup annKey anns) + ++ show (annKey, Map.lookup annKey {-anns-} undefined :: Maybe String) ++ "-}" zip [1 ..] tlines `forM_` \(i, l) -> do layoutWriteAppend $ l @@ -152,7 +152,7 @@ layoutBriDocM = \case state <- mGet let filterF k _ = not $ k `Set.member` subKeys mSet $ state - { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state + { _lstate_comments = undefined -- Map.filterWithKey filterF $ _lstate_comments state } BDPlain t -> do layoutWriteAppend t @@ -162,12 +162,12 @@ layoutBriDocM = \case let moveToExactLocationAction = case _lstate_curYOrAddNewline state of Left{} -> pure () - Right{} -> moveToExactAnn annKey + Right{} -> undefined -- moveToExactAnn annKey mAnn <- do - let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m + let mAnn = {-ExactPrint.annPriorComments-} undefined <$> Map.lookup annKey m mSet $ state { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annPriorComments = [] }) + (\ann -> ann {- ExactPrint.annPriorComments = [] -}) annKey m } @@ -177,20 +177,20 @@ layoutBriDocM = \case Just [] -> moveToExactLocationAction Just priors -> do -- layoutResetSepSpace - priors - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - case comment of - ('#' : _) -> - layoutMoveToCommentPos y (-999) (length commentLines) - -- ^ evil hack for CPP - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + -- priors + -- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + -- when (comment /= "(" && comment /= ")") $ do + -- let commentLines = Text.lines $ Text.pack $ comment + -- case comment of + -- ('#' : _) -> + -- layoutMoveToCommentPos y (-999) (length commentLines) + -- -- ^ evil hack for CPP + -- _ -> layoutMoveToCommentPos y x (length commentLines) + -- -- fixedX <- fixMoveToLineByIsNewline x + -- -- replicateM_ fixedX layoutWriteNewline + -- -- layoutMoveToIndentCol y + -- layoutWriteAppendMultiline commentLines + -- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } moveToExactLocationAction layoutBriDocM bd BDAnnotationKW annKey keyword bd -> do @@ -198,22 +198,22 @@ layoutBriDocM = \case mComments <- do state <- mGet let m = _lstate_comments state - let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m + let mAnn = {-ExactPrint.annsDP-} undefined <$> Map.lookup annKey m let mToSpan = case mAnn of Just anns | Maybe.isNothing keyword -> Just anns - Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> - Just annR + -- Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> + -- Just annR _ -> Nothing case mToSpan of Just anns -> do let (comments, rest) = flip spanMaybe anns $ \case - (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) + -- (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) _ -> Nothing mSet $ state { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annsDP = rest }) + (\ann -> ann {- ExactPrint.annsDP = rest -}) annKey m } @@ -221,21 +221,22 @@ layoutBriDocM = \case _ -> return Nothing case mComments of Nothing -> pure () - Just comments -> do - comments - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - -- evil hack for CPP: - case comment of - ('#' : _) -> - layoutMoveToCommentPos y (-999) (length commentLines) - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + Just comments -> undefined + -- do + -- comments + -- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + -- when (comment /= "(" && comment /= ")") $ do + -- let commentLines = Text.lines $ Text.pack $ comment + -- -- evil hack for CPP: + -- case comment of + -- ('#' : _) -> + -- layoutMoveToCommentPos y (-999) (length commentLines) + -- _ -> layoutMoveToCommentPos y x (length commentLines) + -- -- fixedX <- fixMoveToLineByIsNewline x + -- -- replicateM_ fixedX layoutWriteNewline + -- -- layoutMoveToIndentCol y + -- layoutWriteAppendMultiline commentLines + -- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDAnnotationRest annKey bd -> do layoutBriDocM bd annMay <- do @@ -247,7 +248,7 @@ layoutBriDocM = \case semiCount = length [ () | Just ann <- [annMay] - , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann + -- , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann ] shouldAddSemicolonNewlines <- mAsk @@ -257,12 +258,12 @@ layoutBriDocM = \case mModify $ \state -> state { _lstate_comments = Map.adjust (\ann -> ann - { ExactPrint.annFollowingComments = [] - , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case - (ExactPrint.Types.AnnComment{}, _) -> False - _ -> True - } + -- { ExactPrint.annFollowingComments = [] + -- , ExactPrint.annPriorComments = [] + -- , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case + -- (ExactPrint.Types.AnnComment{}, _) -> False + -- _ -> True + -- } ) annKey (_lstate_comments state) @@ -271,41 +272,44 @@ layoutBriDocM = \case Nothing -> do when shouldAddSemicolonNewlines $ do [1 .. semiCount] `forM_` const layoutWriteNewline - Just comments -> do - comments - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack comment - case comment of - ('#' : _) -> layoutMoveToCommentPos y (-999) 1 - -- ^ evil hack for CPP - ")" -> pure () - -- ^ fixes the formatting of parens - -- on the lhs of type alias defs - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + Just comments -> undefined + -- do + -- comments + -- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + -- when (comment /= "(" && comment /= ")") $ do + -- let commentLines = Text.lines $ Text.pack comment + -- case comment of + -- ('#' : _) -> layoutMoveToCommentPos y (-999) 1 + -- -- ^ evil hack for CPP + -- ")" -> pure () + -- -- ^ fixes the formatting of parens + -- -- on the lhs of type alias defs + -- _ -> layoutMoveToCommentPos y x (length commentLines) + -- -- fixedX <- fixMoveToLineByIsNewline x + -- -- replicateM_ fixedX layoutWriteNewline + -- -- layoutMoveToIndentCol y + -- layoutWriteAppendMultiline commentLines + -- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do state <- mGet let m = _lstate_comments state - let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m + -- let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m let - relevant = - [ dp - | Just ann <- [mAnn] - , (ExactPrint.Types.G kw1, dp) <- ann - , keyword == kw1 - ] + relevant = undefined + -- [ dp + -- | Just ann <- [mAnn] + -- -- , (ExactPrint.Types.G kw1, dp) <- ann + + -- , keyword == kw1 + -- ] -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] case relevant of [] -> pure Nothing - (ExactPrint.Types.DP (y, x) : _) -> do - mSet state { _lstate_commentNewlines = 0 } - pure $ Just (y - _lstate_commentNewlines state, x) + _ -> pure undefined + -- (ExactPrint.Types.DP (y, x) : _) -> do + -- mSet state { _lstate_commentNewlines = 0 } + -- pure $ Just (y - _lstate_commentNewlines state, x) case mDP of Nothing -> pure () Just (y, x) -> diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs index 310ea56..920e3a5 100644 --- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -17,7 +17,7 @@ import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) +-- import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint @@ -338,23 +338,23 @@ layoutAddSepSpace = do -- TODO: when refactoring is complete, the other version of this method -- can probably be removed. -moveToExactAnn - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiReader (Map AnnKey Annotation) m - ) - => AnnKey - -> m () -moveToExactAnn annKey = do - traceLocal ("moveToExactAnn", annKey) - anns <- mAsk - case Map.lookup annKey anns of - Nothing -> return () - Just ann -> do - -- curY <- mGet <&> _lstate_curY - let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann - -- mModify $ \state -> state { _lstate_addNewline = Just x } - moveToY y +-- moveToExactAnn +-- :: ( MonadMultiWriter Text.Builder.Builder m +-- , MonadMultiState LayoutState m +-- -- , MonadMultiReader (Map AnnKey Annotation) m +-- ) +-- => AnnKey +-- -> m () +-- moveToExactAnn annKey = do +-- traceLocal ("moveToExactAnn", annKey) +-- anns <- mAsk +-- case Map.lookup annKey anns of +-- Nothing -> return () +-- Just ann -> do +-- -- curY <- mGet <&> _lstate_curY +-- let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann +-- -- mModify $ \state -> state { _lstate_addNewline = Just x } +-- moveToY y moveToY :: MonadMultiState LayoutState m => Int -> m () moveToY y = mModify $ \state -> @@ -379,77 +379,77 @@ moveToY y = mModify $ \state -> -- then x-1 -- else x -ppmMoveToExactLoc - :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () -ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do - replicateM_ x $ mTell $ Text.Builder.fromString "\n" - replicateM_ y $ mTell $ Text.Builder.fromString " " +-- ppmMoveToExactLoc +-- :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () +-- ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do +-- replicateM_ x $ mTell $ Text.Builder.fromString "\n" +-- replicateM_ y $ mTell $ Text.Builder.fromString " " -- TODO: update and use, or clean up. Currently dead code. -layoutWritePriorComments - :: ( Data.Data.Data ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Located ast - -> m () -layoutWritePriorComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.mkAnnKey ast - let anns = _lstate_comments state - let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annPriorComments = [] }) - key - anns - } - return mAnn - case mAnn of - Nothing -> return () - Just priors -> do - unless (null priors) $ layoutSetCommentCol - priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> - do - replicateM_ x layoutWriteNewline - layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.lines $ Text.pack comment +-- layoutWritePriorComments +-- :: ( Data.Data.Data ast +-- , MonadMultiWriter Text.Builder.Builder m +-- , MonadMultiState LayoutState m +-- ) +-- => Located ast +-- -> m () +-- layoutWritePriorComments ast = do +-- mAnn <- do +-- state <- mGet +-- let key = ExactPrint.mkAnnKey ast +-- let anns = _lstate_comments state +-- let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns +-- mSet $ state +-- { _lstate_comments = Map.adjust +-- (\ann -> ann { ExactPrint.annPriorComments = [] }) +-- key +-- anns +-- } +-- return mAnn +-- case mAnn of +-- Nothing -> return () +-- Just priors -> do +-- unless (null priors) $ layoutSetCommentCol +-- priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> +-- do +-- replicateM_ x layoutWriteNewline +-- layoutWriteAppendSpaces y +-- layoutWriteAppendMultiline $ Text.lines $ Text.pack comment -- TODO: update and use, or clean up. Currently dead code. -- this currently only extracs from the `annsDP` field of Annotations. -- per documentation, this seems sufficient, as the -- "..`annFollowingComments` are only added by AST transformations ..". -layoutWritePostComments - :: ( Data.Data.Data ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Located ast - -> m () -layoutWritePostComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.mkAnnKey ast - let anns = _lstate_comments state - let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annFollowingComments = [] }) - key - anns - } - return mAnn - case mAnn of - Nothing -> return () - Just posts -> do - unless (null posts) $ layoutSetCommentCol - posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> - do - replicateM_ x layoutWriteNewline - layoutWriteAppend $ Text.pack $ replicate y ' ' - mModify $ \s -> s { _lstate_addSepSpace = Nothing } - layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment +-- layoutWritePostComments +-- :: ( Data.Data.Data ast +-- , MonadMultiWriter Text.Builder.Builder m +-- , MonadMultiState LayoutState m +-- ) +-- => Located ast +-- -> m () +-- layoutWritePostComments ast = do +-- mAnn <- do +-- state <- mGet +-- let key = ExactPrint.mkAnnKey ast +-- let anns = _lstate_comments state +-- let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns +-- mSet $ state +-- { _lstate_comments = Map.adjust +-- (\ann -> ann { ExactPrint.annFollowingComments = [] }) +-- key +-- anns +-- } +-- return mAnn +-- case mAnn of +-- Nothing -> return () +-- Just posts -> do +-- unless (null posts) $ layoutSetCommentCol +-- posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> +-- do +-- replicateM_ x layoutWriteNewline +-- layoutWriteAppend $ Text.pack $ replicate y ' ' +-- mModify $ \s -> s { _lstate_addSepSpace = Nothing } +-- layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment layoutIndentRestorePostComment :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m) diff --git a/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs b/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs new file mode 100644 index 0000000..850fce1 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs @@ -0,0 +1,13 @@ +module Language.Haskell.Brittany.Internal.EPCompat where + +import Data.Map (Map) + +type DeltaPos = () +type Comment = () + +type Annotation = () + +type Anns = Map AnnKey () +type AnnKey = () + +type EPAnns = Map AnnKey () diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 63d6b53..1f89422 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -31,13 +31,13 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified System.IO - +import Language.Haskell.Brittany.Internal.EPCompat parseModule :: [String] -> System.IO.FilePath -> (GHC.DynFlags -> IO (Either String a)) - -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) + -> IO (Either String (GHC.ParsedSource, a)) parseModule args fp dynCheck = do str <- System.IO.readFile fp parseModuleFromString args fp dynCheck str @@ -47,74 +47,75 @@ parseModuleFromString -> System.IO.FilePath -> (GHC.DynFlags -> IO (Either String a)) -> String - -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) + -> IO (Either String (GHC.ParsedSource, a)) parseModuleFromString = ParseModule.parseModule commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () -commentAnnFixTransformGlob ast = do - let - extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) - extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ - const Seq.empty - `SYB.ext1Q` (\l@(L span _) -> - Seq.singleton (span, ExactPrint.mkAnnKey l) - ) - let nodes = SYB.everything (<>) extract ast - let - annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey - annsMap = Map.fromListWith - (const id) - [ (GHC.realSrcSpanEnd span, annKey) - | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes - ] - nodes `forM_` (snd .> processComs annsMap) - where - processComs annsMap annKey1 = do - mAnn <- State.Class.gets fst <&> Map.lookup annKey1 - mAnn `forM_` \ann1 -> do - let - priors = ExactPrint.annPriorComments ann1 - follows = ExactPrint.annFollowingComments ann1 - assocs = ExactPrint.annsDP ann1 - let - processCom - :: (ExactPrint.Comment, ExactPrint.DeltaPos) - -> ExactPrint.TransformT Identity Bool - processCom comPair@(com, _) = - case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of - comLoc -> case Map.lookupLE comLoc annsMap of - Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of - (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> - move $> False - (x, y) | x == y -> move $> False - _ -> return True - where - ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 - ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 - loc1 = GHC.realSrcSpanStart annKeyLoc1 - loc2 = GHC.realSrcSpanStart annKeyLoc2 - move = ExactPrint.modifyAnnsT $ \anns -> - let - ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns - ann2' = ann2 - { ExactPrint.annFollowingComments = - ExactPrint.annFollowingComments ann2 ++ [comPair] - } - in Map.insert annKey2 ann2' anns - _ -> return True -- retain comment at current node. - priors' <- filterM processCom priors - follows' <- filterM processCom follows - assocs' <- flip filterM assocs $ \case - (ExactPrint.AnnComment com, dp) -> processCom (com, dp) - _ -> return True - let - ann1' = ann1 - { ExactPrint.annPriorComments = priors' - , ExactPrint.annFollowingComments = follows' - , ExactPrint.annsDP = assocs' - } - ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns +commentAnnFixTransformGlob ast = undefined +-- do +-- let +-- extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) +-- extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ +-- const Seq.empty +-- `SYB.ext1Q` (\l@(L span _) -> +-- Seq.singleton (span, ExactPrint.mkAnnKey l) +-- ) +-- let nodes = SYB.everything (<>) extract ast +-- let +-- annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey +-- annsMap = Map.fromListWith +-- (const id) +-- [ (GHC.realSrcSpanEnd span, annKey) +-- | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes +-- ] +-- nodes `forM_` (snd .> processComs annsMap) +-- where +-- processComs annsMap annKey1 = do +-- mAnn <- State.Class.gets fst <&> Map.lookup annKey1 +-- mAnn `forM_` \ann1 -> do +-- let +-- priors = ExactPrint.annPriorComments ann1 +-- follows = ExactPrint.annFollowingComments ann1 +-- assocs = ExactPrint.annsDP ann1 +-- let +-- processCom +-- :: (ExactPrint.Comment, ExactPrint.DeltaPos) +-- -> ExactPrint.TransformT Identity Bool +-- processCom comPair@(com, _) = +-- case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of +-- comLoc -> case Map.lookupLE comLoc annsMap of +-- Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of +-- (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> +-- move $> False +-- (x, y) | x == y -> move $> False +-- _ -> return True +-- where +-- ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 +-- ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 +-- loc1 = GHC.realSrcSpanStart annKeyLoc1 +-- loc2 = GHC.realSrcSpanStart annKeyLoc2 +-- move = ExactPrint.modifyAnnsT $ \anns -> +-- let +-- ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns +-- ann2' = ann2 +-- { ExactPrint.annFollowingComments = +-- ExactPrint.annFollowingComments ann2 ++ [comPair] +-- } +-- in Map.insert annKey2 ann2' anns +-- _ -> return True -- retain comment at current node. +-- priors' <- filterM processCom priors +-- follows' <- filterM processCom follows +-- assocs' <- flip filterM assocs $ \case +-- (ExactPrint.AnnComment com, dp) -> processCom (com, dp) +-- _ -> return True +-- let +-- ann1' = ann1 +-- { ExactPrint.annPriorComments = priors' +-- , ExactPrint.annFollowingComments = follows' +-- , ExactPrint.annsDP = assocs' +-- } +-- ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns -- TODO: this is unused by now, but it contains one detail that @@ -181,27 +182,29 @@ commentAnnFixTransformGlob ast = do -- ExactPrint.modifyAnnsT moveComments + -- | split a set of annotations in a module into a map from top-level module -- elements to the relevant annotations. Avoids quadratic behaviour a trivial -- implementation would have. extractToplevelAnns :: Located HsModule - -> ExactPrint.Anns - -> Map ExactPrint.AnnKey ExactPrint.Anns + -> Anns + -> Map AnnKey Anns extractToplevelAnns lmod anns = output where - (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod - declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey + (L _ (HsModule _ _ _ _ _ ldecls _ _)) = lmod + declMap1 :: Map AnnKey AnnKey declMap1 = Map.unions $ ldecls <&> \ldecl -> - Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) - declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey + Map.fromSet (const ({-ExactPrint.mkAnnKey-} undefined ldecl)) (foldedAnnKeys ldecl) + declMap2 :: Map AnnKey AnnKey declMap2 = Map.fromList - $ [ (captured, declMap1 Map.! k) - | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns + $ [ + -- (captured, declMap1 Map.! k) + -- | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns ] declMap = declMap1 `Map.union` declMap2 - modKey = ExactPrint.mkAnnKey lmod + modKey = {-ExactPrint.mkAnnKey-} undefined lmod output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) @@ -212,13 +215,13 @@ groupMap f = Map.foldlWithKey' insert k a Nothing = Just (Map.singleton k a) insert k a (Just m) = Just (Map.insert k a m) -foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey +foldedAnnKeys :: Data.Data.Data ast => ast -> Set AnnKey foldedAnnKeys ast = SYB.everything Set.union (\x -> maybe Set.empty Set.singleton - [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x + [ SYB.gmapQi 1 ({-ExactPrint.mkAnnKey-} undefined . L l) x | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x ] @@ -233,8 +236,8 @@ foldedAnnKeys ast = SYB.everything withTransformedAnns :: Data ast => ast - -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a - -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config , Anns] w s a + -> MultiRWSS.MultiRWS '[Config , Anns] w s a withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case readers@(conf :+: anns :+: HNil) -> do -- TODO: implement `local` for MultiReader/MultiRWS @@ -245,9 +248,9 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case where f anns = let - ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced + ((), _, _) = + ExactPrint.runTransform (commentAnnFixTransformGlob ast) + in anns warnExtractorCompat :: GHC.Warn -> String diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 136468e..d2b2ff5 100644 --- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -17,7 +17,7 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as Text.Builder import DataTreePrint -import GHC (GenLocated(L), Located, moduleName, moduleNameString) +import GHC (GenLocated(L), Located, LocatedAn, moduleName, moduleNameString) import qualified GHC.OldList as List import GHC.Parser.Annotation (AnnKeywordId(..)) import GHC.Types.Name (getOccString) @@ -31,24 +31,26 @@ import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Utils import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate +-- import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) +-- import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils - +import Language.Haskell.Brittany.Internal.EPCompat processDefault - :: ( ExactPrint.Annotate.Annotate ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiReader ExactPrint.Types.Anns m + :: ( + -- ExactPrint.Annotate.Annotate ast + ExactPrint.ExactPrint ast + , MonadMultiWriter Text.Builder.Builder m + -- , MonadMultiReader ExactPrint.Types.Anns m ) => Located ast -> m () processDefault x = do - anns <- mAsk - let str = ExactPrint.exactPrint x anns + -- anns <- mAsk + let str = ExactPrint.exactPrint x {-anns-} -- this hack is here so our print-empty-module trick does not add -- a newline at the start if there actually is no module header / imports -- / anything. @@ -63,16 +65,18 @@ processDefault x = do -- not handled by brittany yet). Useful when starting implementing new -- syntactic constructs when children are not handled yet. briDocByExact - :: (ExactPrint.Annotate.Annotate ast) - => Located ast + :: + -- (ExactPrint.Annotate.Annotate ast) + (Data ast, Data an) + => LocatedAn an ast -> ToBriDocM BriDocNumbered briDocByExact ast = do - anns <- mAsk + -- anns <- mAsk traceIfDumpConf "ast" _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) - docExt ast anns True + (printTreeWithCustom 100 (customLayouterF {-anns-}) ast) + docExt ast {-anns-} True -- | Use ExactPrint's output for this node. -- Consider that for multi-line input, the indentation of the code produced @@ -80,38 +84,44 @@ briDocByExact ast = do -- of its surroundings as layouted by brittany. But there are safe uses of -- this, e.g. for any top-level declarations. briDocByExactNoComment - :: (ExactPrint.Annotate.Annotate ast) - => Located ast + :: + -- (ExactPrint.Annotate.Annotate ast) + (Data ast, Data an) + => LocatedAn an ast -> ToBriDocM BriDocNumbered briDocByExactNoComment ast = do - anns <- mAsk + -- anns <- mAsk traceIfDumpConf "ast" _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) - docExt ast anns False + (printTreeWithCustom 100 (customLayouterF {-anns-}) ast) + docExt ast {-anns-} False -- | Use ExactPrint's output for this node, presuming that this output does -- not contain any newlines. If this property is not met, the semantics -- depend on the @econf_AllowRiskyExactPrintUse@ config flag. briDocByExactInlineOnly - :: (ExactPrint.Annotate.Annotate ast) + :: + -- (ExactPrint.Annotate.Annotate ast) + (Data ast, ExactPrint.ExactPrint (LocatedAn an ast), Data an) => String - -> Located ast + -> LocatedAn an ast -> ToBriDocM BriDocNumbered briDocByExactInlineOnly infoStr ast = do - anns <- mAsk + -- anns <- mAsk traceIfDumpConf "ast" _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) - let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns + (printTreeWithCustom 100 (customLayouterF {-anns-}) ast) + let exactPrinted = Text.pack $ ExactPrint.exactPrint ast {-anns-} fallbackMode <- mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack let exactPrintNode t = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey ast) - (foldedAnnKeys ast) + -- ({-ExactPrint.Types.mkAnnKey-} undefined ast) + undefined + -- (foldedAnnKeys ast) + undefined False t let @@ -138,38 +148,48 @@ lrdrNameToText :: GenLocated l RdrName -> Text lrdrNameToText (L _ n) = rdrNameToText n lrdrNameToTextAnnGen - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) + :: (MonadMultiReader Config m + -- , MonadMultiReader (Map AnnKey Annotation) m + ) => (Text -> Text) - -> Located RdrName + -> LocatedAn an RdrName -> m Text lrdrNameToTextAnnGen f ast@(L _ n) = do - anns <- mAsk + -- anns <- mAsk let t = f $ rdrNameToText n let - hasUni x (ExactPrint.Types.G y, _) = x == y + -- hasUni x (ExactPrint.Types.G y, _) = x == y hasUni _ _ = False -- TODO: in general: we should _always_ process all annotaiton stuff here. -- whatever we don't probably should have had some effect on the -- output. in such cases, resorting to byExact is probably the safe -- choice. - return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of + return $ case {-Map.lookup ({-ExactPrint.Types.mkAnnKey-} undefined ast) anns-} undefined of Nothing -> t - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of + Just {-(ExactPrint.Types.Ann _ _ _ aks _ _)-} _ -> case n of Exact{} | t == Text.pack "()" -> t _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" _ | any (hasUni AnnCommaTuple) aks -> t _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" _ | otherwise -> t + where + aks :: [a] + aks = undefined + lrdrNameToTextAnn - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => Located RdrName + :: (MonadMultiReader Config m + -- , MonadMultiReader (Map AnnKey Annotation) m + ) + => LocatedAn an RdrName -> m Text lrdrNameToTextAnn = lrdrNameToTextAnnGen id lrdrNameToTextAnnTypeEqualityIsSpecial - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => Located RdrName + :: (MonadMultiReader Config m + -- , MonadMultiReader (Map AnnKey Annotation) m + ) + => LocatedAn an RdrName -> m Text lrdrNameToTextAnnTypeEqualityIsSpecial ast = do let @@ -186,10 +206,10 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick :: ( Data ast , MonadMultiReader Config m - , MonadMultiReader (Map AnnKey Annotation) m + -- , MonadMultiReader (Map AnnKey Annotation) m ) - => Located ast - -> Located RdrName + => LocatedAn an ast + -> LocatedAn an RdrName -> m Text lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote @@ -205,60 +225,62 @@ askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk extractAllComments - :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] + :: Annotation -> [(Comment, DeltaPos)] extractAllComments ann = - ExactPrint.annPriorComments ann ++ extractRestComments ann + undefined + -- ExactPrint.annPriorComments ann ++ extractRestComments ann extractRestComments - :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] + :: Annotation -> [(Comment, DeltaPos)] extractRestComments ann = - ExactPrint.annFollowingComments ann - ++ (ExactPrint.annsDP ann >>= \case - (ExactPrint.AnnComment com, dp) -> [(com, dp)] - _ -> [] - ) + undefined + -- ExactPrint.annFollowingComments ann + -- ++ (ExactPrint.annsDP ann >>= \case + -- (ExactPrint.AnnComment com, dp) -> [(com, dp)] + -- _ -> [] + -- ) -filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) +-- filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns +-- filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) -- | True if there are any comments that are -- a) connected to any node below (in AST sense) the given node AND -- b) after (in source code order) the node. -hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsBelow :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool hasAnyCommentsBelow ast@(L l _) = - List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l) + List.any (\(c, _) -> {-ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l-} undefined) <$> astConnectedComments ast hasCommentsBetween :: Data ast - => GHC.Located ast + => GHC.LocatedAn an ast -> AnnKeywordId -> AnnKeywordId -> ToBriDocM Bool hasCommentsBetween ast leftKey rightKey = do - mAnn <- astAnn ast + mAnn <- {-astAnn-} undefined ast let go1 [] = False - go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest + -- go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest go1 (_ : rest) = go1 rest go2 [] = False - go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True - go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False + -- go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True + -- go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False go2 (_ : rest) = go2 rest case mAnn of Nothing -> pure False - Just ann -> pure $ go1 $ ExactPrint.annsDP ann + Just ann -> pure $ go1 $ undefined ann -- | True if there are any comments that are connected to any node below (in AST -- sense) the given node -hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsConnected :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast -- | True if there are any regular comments connected to any node below (in AST -- sense) the given node -hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyRegularCommentsConnected :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool hasAnyRegularCommentsConnected ast = - any isRegularComment <$> astConnectedComments ast + any {-isRegularComment-} undefined <$> astConnectedComments ast -- | Regular comments are comments that are actually "source code comments", -- i.e. things that start with "--" or "{-". In contrast to comment-annotations @@ -269,51 +291,61 @@ hasAnyRegularCommentsConnected ast = -- I believe that most of the time we branch on the existence of comments, we -- only care about "regular" comments. We simply did not need the distinction -- because "irregular" comments are not that common outside of type/data decls. -isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool -isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst +-- isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool +-- isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst astConnectedComments :: Data ast - => GHC.Located ast - -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)] + => GHC.LocatedAn an ast + -> ToBriDocM [(Comment, DeltaPos)] astConnectedComments ast = do - anns <- filterAnns ast <$> mAsk - pure $ extractAllComments =<< Map.elems anns + undefined + -- anns <- filterAnns ast <$> mAsk + -- pure $ extractAllComments =<< Map.elems anns hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsPrior ast = astAnn ast <&> \case +hasAnyCommentsPrior ast = {-astAnn-} undefined ast <&> \case Nothing -> False - Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors + Just _ {-(ExactPrint.Types.Ann _ priors _ _ _ _)-} -> not $ null priors + where priors = [undefined] -hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyRegularCommentsRest ast = astAnn ast <&> \case +hasAnyRegularCommentsRest :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool +hasAnyRegularCommentsRest ast = {-astAnn-} undefined ast <&> \case Nothing -> False - Just ann -> any isRegularComment (extractRestComments ann) + Just ann -> undefined -- any isRegularComment (extractRestComments ann) hasAnnKeywordComment - :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool -hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case + :: Data ast => GHC.LocatedAn an ast -> AnnKeywordId -> ToBriDocM Bool +hasAnnKeywordComment ast annKeyword = {-astAnn-} undefined ast <&> \case Nothing -> False - Just ann -> any hasK (extractAllComments ann) - where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst + Just ann -> any hasK ({-extractAllComments-} thing ann) + where + hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst + thing ann = [undefined] hasAnnKeyword - :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) - => Located a + :: (Data a + -- , MonadMultiReader (Map AnnKey Annotation) m + , Functor m + ) + => LocatedAn an a -> AnnKeywordId -> m Bool -hasAnnKeyword ast annKeyword = astAnn ast <&> \case +hasAnnKeyword ast annKeyword = {-astAnn-} astAnn' ast <&> \case Nothing -> False - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks + Just {-(ExactPrint.Types.Ann _ _ _ aks _ _)-} undefined -> any hasK aks where - hasK (ExactPrint.Types.G x, _) = x == annKeyword + -- hasK (ExactPrint.Types.G x, _) = x == annKeyword hasK _ = False + aks = [undefined] + -- astAnn' :: Functor f => Located a -> f (Maybe b) + astAnn' = undefined -astAnn - :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) - => GHC.Located ast - -> m (Maybe Annotation) -astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk +-- astAnn +-- :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) +-- => GHC.Located ast +-- -> m (Maybe Annotation) +-- astAnn ast = {-Map.lookup ({-ExactPrint.Types.mkAnnKey-} undefined ast)-} undefined <$> mAsk -- new BriDoc stuff @@ -338,7 +370,7 @@ allocNodeIndex = do -- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m) -- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered -- docExt x anns shouldAddComment = allocateNode $ BDFExternal --- (ExactPrint.Types.mkAnnKey x) +-- ({-ExactPrint.Types.mkAnnKey-} undefined x) -- (foldedAnnKeys x) -- shouldAddComment -- (Text.pack $ ExactPrint.exactPrint x anns) @@ -393,7 +425,7 @@ allocNodeIndex = do -- -> m BriDocNumbered -- docPostComment ast bdm = do -- bd <- bdm --- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd +-- allocateNode $ BDFAnnotationPost ({-ExactPrint.Types.mkAnnKey-} undefined ast) bd -- -- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m) -- => Located ast @@ -405,9 +437,9 @@ allocNodeIndex = do -- i2 <- allocNodeIndex -- return -- $ (,) i1 --- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) +-- $ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast) -- $ (,) i2 --- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) +-- $ BDFAnnotationPost ({-ExactPrint.Types.mkAnnKey-} undefined ast) -- $ bd -- -- docPar :: MonadMultiState NodeAllocIndex m @@ -438,16 +470,19 @@ docLitS :: String -> ToBriDocM BriDocNumbered docLitS s = allocateNode $ BDFLit $ Text.pack s docExt - :: (ExactPrint.Annotate.Annotate ast) - => Located ast - -> ExactPrint.Types.Anns + :: + -- (ExactPrint.Annotate.Annotate ast) + LocatedAn an ast + -- -> ExactPrint.Types.Anns -> Bool -> ToBriDocM BriDocNumbered -docExt x anns shouldAddComment = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey x) - (foldedAnnKeys x) +docExt x shouldAddComment = allocateNode $ BDFExternal + -- ({-ExactPrint.Types.mkAnnKey-} undefined x) + undefined + -- (foldedAnnKeys x) + undefined shouldAddComment - (Text.pack $ ExactPrint.exactPrint x anns) + (Text.pack $ {-ExactPrint.exactPrint x anns-} undefined) docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docAlt l = allocateNode . BDFAlt =<< sequence l @@ -580,34 +615,34 @@ docTick = docLit $ Text.pack "'" docNodeAnnKW :: Data.Data.Data ast - => Located ast + => LocatedAn an ast -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docNodeAnnKW ast kw bdm = - docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm + docAnnotationKW ({-{-ExactPrint.Types.mkAnnKey-} undefined-} undefined ast) kw bdm docNodeMoveToKWDP :: Data.Data.Data ast - => Located ast + => LocatedAn an ast -> AnnKeywordId -> Bool -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = - docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm + docMoveToKWDP ({-{-ExactPrint.Types.mkAnnKey-} undefined-} undefined ast) kw shouldRestoreIndent bdm class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) - => Located ast + => LocatedAn an ast -> a -> a docWrapNodePrior :: ( Data.Data.Data ast) - => Located ast + => LocatedAn an ast -> a -> a docWrapNodeRest :: ( Data.Data.Data ast) - => Located ast + => LocatedAn an ast -> a -> a @@ -618,18 +653,18 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where i2 <- allocNodeIndex return $ (,) i1 - $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) + $ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast) $ (,) i2 - $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) + $ BDFAnnotationRest ({-ExactPrint.Types.mkAnnKey-} undefined ast) $ bd docWrapNodePrior ast bdm = do bd <- bdm i1 <- allocNodeIndex - return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd + return $ (,) i1 $ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast) $ bd docWrapNodeRest ast bdm = do bd <- bdm i2 <- allocNodeIndex - return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd + return $ (,) i2 $ BDFAnnotationRest ({-ExactPrint.Types.mkAnnKey-} undefined ast) $ bd instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where docWrapNode ast bdms = case bdms of @@ -746,7 +781,7 @@ docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd unknownNodeError :: Data.Data.Data ast => String - -> GenLocated GHC.SrcSpan ast + -> LocatedAn an ast -> ToBriDocM BriDocNumbered unknownNodeError infoStr ast = do mTell [ErrorUnknownNode infoStr ast] diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 37f648e..e946cd1 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -20,16 +20,17 @@ import Language.Haskell.Brittany.Internal.Types layoutDataDecl - :: Located (TyClDecl GhcPs) - -> Located RdrName + :: Data.Data.Data an1 + => LocatedAn an1 (TyClDecl GhcPs) + -> LocatedAn an2 RdrName -> LHsQTyVars GhcPs -> HsDataDefn GhcPs -> ToBriDocM BriDocNumbered layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- newtype MyType a b = MyType .. - HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> + HsDataDefn _ext NewType _ctxt _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) + (L _ (ConDeclH98 _ext consName False _qvars (Just (L _ [])) details _conDoc)) -> docWrapNode ltycl $ do nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName @@ -54,9 +55,9 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- data MyData a b -- (zero constructors) - HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> + HsDataDefn _ext DataType mLhsContext _ctype Nothing [] mDerivs -> docWrapNode ltycl $ do - lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + lhsContextDoc <- docSharedWrapper createContextDoc mLhsContext nameStr <- lrdrNameToTextAnn name tyVarLine <- return <$> createBndrDoc bndrs createDerivingPar mDerivs $ docSeq @@ -68,11 +69,11 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- data MyData = MyData .. -- data MyData = MyData { .. } - HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> + HsDataDefn _ext DataType mLhsContext _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) + (L _ (ConDeclH98 _ext consName _hasExt qvars mRhsContext details _conDoc)) -> docWrapNode ltycl $ do - lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + lhsContextDoc <- docSharedWrapper createContextDoc mLhsContext nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName tyVarLine <- return <$> createBndrDoc bndrs @@ -81,7 +82,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of Just x -> Just . pure <$> x rhsContextDocMay <- case mRhsContext of Nothing -> pure Nothing - Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt + Just lctxt -> Just . pure <$> createContextDoc (Just lctxt) rhsDoc <- return <$> createDetailsDoc consNameStr details consDoc <- fmap pure @@ -200,28 +201,29 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of _ -> briDocByExactNoComment ltycl -createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered -createContextDoc [] = docEmpty -createContextDoc [t] = - docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] -createContextDoc (t1 : tR) = do - t1Doc <- docSharedWrapper layoutType t1 - tRDocs <- tR `forM` docSharedWrapper layoutType - docAlt - [ docSeq - [ docLitS "(" - , docForceSingleline $ docSeq $ List.intersperse - docCommaSep - (t1Doc : tRDocs) - , docLitS ") =>" - , docSeparator +createContextDoc :: Maybe (LHsContext GhcPs) -> ToBriDocM BriDocNumbered +createContextDoc Nothing = docEmpty +createContextDoc (Just (L _ lhsContext)) = case lhsContext of + [] -> docEmpty + [t] -> docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] + (t1 : tR) -> do + t1Doc <- docSharedWrapper layoutType t1 + tRDocs <- tR `forM` docSharedWrapper layoutType + docAlt + [ docSeq + [ docLitS "(" + , docForceSingleline $ docSeq $ List.intersperse + docCommaSep + (t1Doc : tRDocs) + , docLitS ") =>" + , docSeparator + ] + , docLines $ join + [ [docSeq [docLitS "(", docSeparator, t1Doc]] + , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] + , [docLitS ") =>", docSeparator] + ] ] - , docLines $ join - [ [docSeq [docLitS "(", docSeparator, t1Doc]] - , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] - , [docLitS ") =>", docSeparator] - ] - ] createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> ToBriDocM BriDocNumbered createBndrDoc bs = do @@ -246,20 +248,20 @@ createBndrDoc bs = do createDerivingPar :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered createDerivingPar derivs mainDoc = do - case derivs of - (L _ []) -> mainDoc - (L _ types) -> - docPar mainDoc - $ docEnsureIndent BrIndentRegular - $ docLines - $ docWrapNode derivs - $ derivingClauseDoc - <$> types + docPar mainDoc + $ docEnsureIndent BrIndentRegular + $ docLines + $ docWrapNode (noLocA derivs) + $ derivingClauseDoc + <$> derivs derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of - (L _ []) -> docSeq [] - (L _ ts) -> + (L _ (DctSingle _ t)) -> derivingClauseDoc' [t] + (L _ (DctMulti _ ts)) -> derivingClauseDoc' ts + where + derivingClauseDoc' [] = docSeq [] + derivingClauseDoc' ts = let tsLength = length ts whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS "" @@ -275,29 +277,32 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of $ List.intersperse docCommaSep $ ts <&> \case - HsIB _ t -> layoutType t + _ -> undefined + -- HsIB _ t -> layoutType t , whenMoreThan1Type ")" , rhsStrategy ] - where + strategyLeftRight + :: Located (DerivStrategy GhcPs) + -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) strategyLeftRight = \case - (L _ StockStrategy) -> (docLitS " stock", docEmpty) - (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty) - (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty) + (L _ (StockStrategy _)) -> (docLitS " stock", docEmpty) + (L _ (AnyclassStrategy _)) -> (docLitS " anyclass", docEmpty) + (L _ (NewtypeStrategy _)) -> (docLitS " newtype", docEmpty) lVia@(L _ (ViaStrategy viaTypes)) -> ( docEmpty , case viaTypes of - HsIB _ext t -> - docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t] + XViaStrategyPs _epann (L _span (HsSig _sig _bndrs t)) -> + docSeq [docWrapNode (reLocA lVia) $ docLitS " via", docSeparator, layoutType t] ) docDeriving :: ToBriDocM BriDocNumbered docDeriving = docLitS "deriving" createDetailsDoc - :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) + :: Text -> HsConDeclH98Details GhcPs -> (ToBriDocM BriDocNumbered) createDetailsDoc consNameStr details = case details of - PrefixCon args -> do + PrefixCon _ args -> do indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let singleLine = docSeq @@ -421,9 +426,9 @@ createForallDoc lhsTyVarBndrs = createNamesAndTypeDoc :: Data.Data.Data ast - => Located ast + => LocatedAn an1 ast -> [GenLocated t (FieldOcc GhcPs)] - -> Located (HsType GhcPs) + -> LocatedAn AnnListItem (HsType GhcPs) -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) createNamesAndTypeDoc lField names t = ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 9e22b6e..6401c8d 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -19,9 +19,9 @@ import GHC.Types.Basic ( Activation(..) , InlinePragma(..) , InlineSpec(..) - , LexicalFixity(..) , RuleMatchInfo(..) ) +import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.ExactPrintUtils @@ -35,12 +35,12 @@ import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Types import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey) +-- import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey) import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint +import Language.Haskell.Brittany.Internal.EPCompat - -layoutDecl :: ToBriDoc HsDecl +layoutDecl :: ToBriDoc AnnListItem HsDecl layoutDecl d@(L loc decl) = case decl of SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case @@ -57,9 +57,9 @@ layoutDecl d@(L loc decl) = case decl of -- Sig -------------------------------------------------------------------------------- -layoutSig :: ToBriDoc Sig +layoutSig :: ToBriDoc AnnListItem Sig layoutSig lsig@(L _loc sig) = case sig of - TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ + TypeSig _ names (HsWC _ (L _ (HsSig _ _ typ))) -> layoutNamesAndType Nothing names typ InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> docWrapNode lsig $ do nameStr <- lrdrNameToTextAnn name @@ -80,8 +80,8 @@ layoutSig lsig@(L _loc sig) = case sig of $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) <> nameStr <> Text.pack " #-}" - ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ - PatSynSig _ names (HsIB _ typ) -> + ClassOpSig _ False names (L _ (HsSig _ _ typ)) -> layoutNamesAndType Nothing names typ + PatSynSig _ names (L _ (HsSig _ _ typ)) -> layoutNamesAndType (Just "pattern") names typ _ -> briDocByExactNoComment lsig -- TODO where @@ -121,12 +121,12 @@ layoutSig lsig@(L _loc sig) = case sig of specStringCompat :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String specStringCompat ast = \case - NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" + NoUserInlinePrag -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" Inline -> pure "INLINE " Inlinable -> pure "INLINABLE " NoInline -> pure "NOINLINE " -layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) +layoutGuardLStmt :: ToBriDoc' an (Stmt GhcPs (LHsExpr GhcPs)) layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of BodyStmt _ body _ _ -> layoutExpr body BindStmt _ lPat expr -> do @@ -145,7 +145,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of -------------------------------------------------------------------------------- layoutBind - :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) + :: ToBriDocC an (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do idStr <- lrdrNameToTextAnn fId @@ -160,7 +160,7 @@ layoutBind lbind@(L _ bind) = case bind of patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? + let mWhereArg = mWhereDocs <&> (,) (undefined lbind) -- TODO: is this the right AnnKey? binderDoc <- docLit $ Text.pack "=" hasComments <- hasAnyCommentsBelow lbind fmap Right $ docWrapNode lbind $ layoutPatternBindFinal @@ -173,7 +173,7 @@ layoutBind lbind@(L _ bind) = case bind of PatSynBind _ (PSB _ patID lpat rpat dir) -> do fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat _ -> Right <$> unknownNodeError "" lbind -layoutIPBind :: ToBriDoc IPBind +layoutIPBind :: ToBriDoc an IPBind layoutIPBind lipbind@(L _ bind) = case bind of IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right" IPBind _ (Left (L _ (HsIPName name))) expr -> do @@ -193,13 +193,14 @@ layoutIPBind lipbind@(L _ bind) = case bind of data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) | BagSig (LSig GhcPs) -bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan +bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpanAnnA bindOrSigtoSrcSpan (BagBind (L l _)) = l bindOrSigtoSrcSpan (BagSig (L l _)) = l layoutLocalBinds - :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) -layoutLocalBinds lbinds@(L _ binds) = case binds of + :: HsLocalBindsLR GhcPs GhcPs -> ToBriDocM (Maybe [BriDocNumbered]) + -- :: ToBriDocC an (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) +layoutLocalBinds binds = case binds of -- HsValBinds (ValBindsIn lhsBindsLR []) -> -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering -- x@(HsValBinds (ValBindsIn{})) -> @@ -209,8 +210,8 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of unordered = [ BagBind b | b <- Data.Foldable.toList bindlrs ] ++ [ BagSig s | s <- sigs ] - ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered - docs <- docWrapNode lbinds $ join <$> ordered `forM` \case + ordered = List.sortOn (la2r . bindOrSigtoSrcSpan) unordered + docs <- docWrapNode (noLocA binds) $ join <$> ordered `forM` \case BagBind b -> either id return <$> layoutBind b BagSig s -> return <$> layoutSig s return $ Just $ docs @@ -225,7 +226,7 @@ layoutGrhs :: LGRHS GhcPs (LHsExpr GhcPs) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do - guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards + guardDocs <- docWrapNode (reLocA lgrhs) $ layoutStmt `mapM` guards bodyDoc <- layoutExpr body return (guardDocs, bodyDoc, body) @@ -274,7 +275,7 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do $ (List.intersperse docSeparator $ docForceSingleline <$> ps) clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) + let mWhereArg = mWhereDocs <&> (,) ({-mkAnnKey-} undefined lmatch) let alignmentToken = if null pats then Nothing else funId hasComments <- hasAnyCommentsBelow lmatch layoutPatternBindFinal @@ -307,7 +308,7 @@ layoutPatternBindFinal -> BriDocNumbered -> Maybe BriDocNumbered -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] - -> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) + -> Maybe (AnnKey, [BriDocNumbered]) -- ^ AnnKey for the node that contains the AnnWhere position annotation -> Bool -> ToBriDocM BriDocNumbered @@ -610,8 +611,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha -- | Layout a pattern synonym binding layoutPatSynBind - :: Located (IdP GhcPs) - -> HsPatSynDetails (Located (IdP GhcPs)) + :: LIdP GhcPs + -> HsPatSynDetails GhcPs -> HsPatSynDir GhcPs -> LPat GhcPs -> ToBriDocM BriDocNumbered @@ -663,10 +664,10 @@ layoutPatSynBind name patSynDetails patDir rpat = do -- | Helper method for the left hand side of a pattern synonym layoutLPatSyn - :: Located (IdP GhcPs) - -> HsPatSynDetails (Located (IdP GhcPs)) + :: LIdP GhcPs + -> HsPatSynDetails GhcPs -> ToBriDocM BriDocNumbered -layoutLPatSyn name (PrefixCon vars) = do +layoutLPatSyn name (PrefixCon _ vars) = do docName <- lrdrNameToTextAnn name names <- mapM lrdrNameToTextAnn vars docSeq . fmap appSep $ docLit docName : (docLit <$> names) @@ -677,7 +678,7 @@ layoutLPatSyn name (InfixCon left right) = do docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] layoutLPatSyn name (RecCon recArgs) = do docName <- lrdrNameToTextAnn name - args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs + args <- mapM (lrdrNameToTextAnn . rdrNameFieldOcc . recordPatSynField) recArgs docSeq . fmap docLit $ [docName, Text.pack " { "] @@ -699,7 +700,7 @@ layoutPatSynWhere hs = case hs of -- TyClDecl -------------------------------------------------------------------------------- -layoutTyCl :: ToBriDoc TyClDecl +layoutTyCl :: Data.Data.Data an => ToBriDoc an TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of SynDecl _ name vars fixity typ -> do let @@ -720,7 +721,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of layoutSynDecl :: Bool -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) - -> Located (IdP GhcPs) + -> LIdP GhcPs -> [LHsTyVarBndr () GhcPs] -> LHsType GhcPs -> ToBriDocM BriDocNumbered @@ -756,7 +757,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do hasComments <- hasAnyCommentsConnected typ layoutLhsAndType hasComments sharedLhs "=" typeDoc -layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ()) +layoutTyVarBndr :: Bool -> ToBriDoc an (HsTyVarBndr ()) layoutTyVarBndr needsSep lbndr@(L _ bndr) = do docWrapNodePrior lbndr $ case bndr of UserTyVar _ _ name -> do @@ -783,13 +784,13 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do layoutTyFamInstDecl :: Data.Data.Data a => Bool - -> Located a + -> LocatedAn an a -> TyFamInstDecl GhcPs -> ToBriDocM BriDocNumbered layoutTyFamInstDecl inClass outerNode tfid = do let - FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid - -- bndrsMay isJust e.g. with + FamEqn _ name bndrs pats _fixity typ = tfid_eqn tfid + -- bndrs isJust e.g. with -- type instance forall a . MyType (Maybe a) = Either () a innerNode = outerNode docWrapNodePrior outerNode $ do @@ -810,7 +811,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do docWrapNode innerNode . docSeq $ [appSep instanceDoc] - ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] + ++ [ makeForallDoc foralls | HsOuterExplicit _ foralls <- [bndrs] ] ++ [ docParenL | needsParens ] ++ [appSep $ docWrapNode name $ docLit nameStr] ++ intersperse docSeparator (layoutHsTyPats pats) @@ -842,7 +843,7 @@ layoutHsTyPats pats = pats <&> \case -- Layout signatures and bindings using the corresponding layouters from the -- top-level. Layout the instance head, type family instances, and data family -- instances using ExactPrint. -layoutClsInst :: ToBriDoc ClsInstDecl +layoutClsInst :: Data.Data.Data an => ToBriDoc an ClsInstDecl layoutClsInst lcid@(L _ cid) = docLines [ layoutInstanceHead , docEnsureIndent BrIndentRegular @@ -872,18 +873,18 @@ layoutClsInst lcid@(L _ cid) = docLines -- | Like 'docLines', but sorts the lines based on location docSortedLines - :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered + :: [ToBriDocM (LocatedAn an BriDocNumbered)] -> ToBriDocM BriDocNumbered docSortedLines l = allocateNode . BDFLines . fmap unLoc - . List.sortOn (ExactPrint.rs . getLoc) + . List.sortOn (realSrcSpan . getLocA) =<< sequence l - layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) + layoutAndLocateSig :: ToBriDocC AnnListItem (Sig GhcPs) (LocatedA BriDocNumbered) layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig - layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) + layoutAndLocateBind :: ToBriDocC an (HsBind GhcPs) (LocatedAn an BriDocNumbered) layoutAndLocateBind lbind@(L loc _) = L loc <$> (joinBinds =<< layoutBind lbind) @@ -894,17 +895,17 @@ layoutClsInst lcid@(L _ cid) = docLines Right n -> return n layoutAndLocateTyFamInsts - :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) + :: ToBriDocC an (TyFamInstDecl GhcPs) (LocatedAn an BriDocNumbered) layoutAndLocateTyFamInsts ltfid@(L loc tfid) = L loc <$> layoutTyFamInstDecl True ltfid tfid layoutAndLocateDataFamInsts - :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) + :: Data.Data.Data an => ToBriDocC an (DataFamInstDecl GhcPs) (LocatedAn an BriDocNumbered) layoutAndLocateDataFamInsts ldfid@(L loc _) = L loc <$> layoutDataFamInstDecl ldfid -- | Send to ExactPrint then remove unecessary whitespace - layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl + layoutDataFamInstDecl :: Data.Data.Data an => ToBriDoc an DataFamInstDecl layoutDataFamInstDecl ldfid = fmap stripWhitespace <$> briDocByExactNoComment ldfid diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 138a748..8808b10 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -8,12 +8,13 @@ import qualified Data.Data import qualified Data.Semigroup as Semigroup import qualified Data.Sequence as Seq import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan) +import GHC (GenLocated(L), RdrName(..)) import qualified GHC.Data.FastString as FastString import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic import GHC.Types.Name +import GHC.Types.SourceText import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.Decl @@ -27,7 +28,7 @@ import Language.Haskell.Brittany.Internal.Utils -layoutExpr :: ToBriDoc HsExpr +layoutExpr :: ToBriDoc AnnListItem HsExpr layoutExpr lexpr@(L _ expr) = do indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let allowFreeIndent = indentPolicy == IndentPolicyFree @@ -38,7 +39,7 @@ layoutExpr lexpr@(L _ expr) = do HsRecFld{} -> do -- TODO briDocByExactInlineOnly "HsRecFld" lexpr - HsOverLabel _ext _reboundFromLabel name -> + HsOverLabel _ext name -> let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label HsIPVar _ext (HsIPName name) -> let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label @@ -49,7 +50,7 @@ layoutExpr lexpr@(L _ expr) = do HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) | pats <- m_pats match , GRHSs _ [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds{} <- llocals + , EmptyLocalBinds{} <- llocals , L _ (GRHS _ [] body) <- lgrhs -> do patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> @@ -86,7 +87,7 @@ layoutExpr lexpr@(L _ expr) = do [ docLit $ Text.pack "\\" , docWrapNode lmatch $ docForceSingleline funcPatternPartLine , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceSingleline bodyDoc + , docWrapNode (reLocA lgrhs) $ docForceSingleline bodyDoc ] -- double line , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar @@ -97,13 +98,13 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "->" ] ) - (docWrapNode lgrhs $ docForceSingleline bodyDoc) + (docWrapNode (reLocA lgrhs) $ docForceSingleline bodyDoc) -- wrapped par spacing , docSetParSpacing $ docSeq [ docLit $ Text.pack "\\" , docWrapNode lmatch $ docForceSingleline funcPatternPartLine , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceParSpacing bodyDoc + , docWrapNode (reLocA lgrhs) $ docForceParSpacing bodyDoc ] -- conservative , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar @@ -114,7 +115,7 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "->" ] ) - (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) + (docWrapNode (reLocA lgrhs) $ docNonBottomSpacing bodyDoc) ] HsLam{} -> unknownNodeError "HsLam too complex" lexpr HsLamCase _ (MG _ (L _ []) _) -> do @@ -378,14 +379,14 @@ layoutExpr lexpr@(L _ expr) = do ExplicitTuple _ args boxity -> do let argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e) - (L _ (Missing NoExtField)) -> (arg, Nothing) + (Present _ e) -> (arg, Just e) + (Missing _) -> (arg, Nothing) argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> - docWrapNode arg $ maybe docEmpty layoutExpr exprM + docWrapNode (noLocA arg) $ maybe docEmpty layoutExpr exprM hasComments <- orM (hasCommentsBetween lexpr AnnOpenP AnnCloseP - : map hasAnyCommentsBelow args + : map (hasAnyCommentsBelow . noLocA) args ) let (openLit, closeLit) = case boxity of @@ -758,7 +759,7 @@ layoutExpr lexpr@(L _ expr) = do _ -> do -- TODO unknownNodeError "HsDo{} unknown stmtCtx" lexpr - ExplicitList _ _ elems@(_ : _) -> do + ExplicitList _ elems@(_ : _) -> do elemDocs <- elems `forM` docSharedWrapper layoutExpr hasComments <- hasAnyCommentsBelow lexpr case splitFirstLast elemDocs of @@ -800,12 +801,12 @@ layoutExpr lexpr@(L _ expr) = do [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] end = docLit $ Text.pack "]" in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ExplicitList _ _ [] -> docLit $ Text.pack "[]" + ExplicitList _ [] -> docLit $ Text.pack "[]" RecordCon _ lname fields -> case fields of HsRecFields fs Nothing -> do let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname rFs <- - fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do + fs `forM` \lfield@(L _ (HsRecField _ (L _ fieldOcc) rFExpr pun)) -> do let FieldOcc _ lnameF = fieldOcc rFExpDoc <- if pun then return Nothing @@ -818,7 +819,7 @@ layoutExpr lexpr@(L _ expr) = do HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname fieldDocs <- - fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do + fs `forM` \fieldl@(L _ (HsRecField _ (L _ fieldOcc) fExpr pun)) -> do let FieldOcc _ lnameF = fieldOcc fExpDoc <- if pun then return Nothing @@ -826,10 +827,10 @@ layoutExpr lexpr@(L _ expr) = do return (fieldl, lrdrNameToText lnameF, fExpDoc) recordExpression True indentPolicy lexpr nameDoc fieldDocs _ -> unknownNodeError "RecordCon with puns" lexpr - RecordUpd _ rExpr fields -> do + RecordUpd _ rExpr (Left fields) -> do rExprDoc <- docSharedWrapper layoutExpr rExpr rFs <- - fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do + fields `forM` \lfield@(L _ (HsRecField _ (L _ ambName) rFExpr pun)) -> do rFExpDoc <- if pun then return Nothing else Just <$> docSharedWrapper layoutExpr rFExpr @@ -837,7 +838,11 @@ layoutExpr lexpr@(L _ expr) = do Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) recordExpression False indentPolicy lexpr rExprDoc rFs - ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do + RecordUpd _ _rExpr (Right _projections) -> do + -- TODO + briDocByExactInlineOnly "RecordUpd _ _ (Right _projections)" lexpr + + ExprWithTySig _ exp1 (HsWC _ (L _ (HsSig _ _ typ1))) -> do expDoc <- docSharedWrapper layoutExpr exp1 typDoc <- docSharedWrapper layoutType typ1 docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc] @@ -925,14 +930,21 @@ layoutExpr lexpr@(L _ expr) = do HsPragE{} -> do -- TODO briDocByExactInlineOnly "HsPragE{}" lexpr + HsGetField{} -> do + -- TODO + briDocByExactInlineOnly "HsGetField{}" lexpr + HsProjection{} -> do + -- TODO + briDocByExactInlineOnly "HsProjection{}" lexpr + recordExpression :: (Data.Data.Data lExpr, Data.Data.Data name) => Bool -> IndentPolicy - -> GenLocated SrcSpan lExpr + -> LocatedAn an1 lExpr -> ToBriDocM BriDocNumbered - -> [ ( GenLocated SrcSpan name + -> [ ( LocatedAn an2 name , Text , Maybe (ToBriDocM BriDocNumbered) ) @@ -1073,14 +1085,14 @@ litBriDoc = \case HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t - HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsRat _ (FL (SourceText t) _ _ _ _) _type -> BDFLit $ Text.pack t + HsFloatPrim _ (FL (SourceText t) _ _ _ _) -> BDFLit $ Text.pack t + HsDoublePrim _ (FL (SourceText t) _ _ _ _) -> BDFLit $ Text.pack t _ -> error "litBriDoc: literal with no SourceText" overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc = \case HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t + HsFractional (FL (SourceText t) _ _ _ _) -> BDFLit $ Text.pack t HsIsString (SourceText t) _ -> BDFLit $ Text.pack t _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot index 4f913c3..0ffc39e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -7,9 +7,7 @@ import Language.Haskell.Brittany.Internal.Types -layoutExpr :: ToBriDoc HsExpr - --- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) +layoutExpr :: ToBriDoc AnnListItem HsExpr litBriDoc :: HsLit GhcPs -> BriDocFInt diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 8684842..cee3d87 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -23,17 +23,17 @@ import Language.Haskell.Brittany.Internal.Utils -prepareName :: LIEWrappedName name -> Located name +prepareName :: LIEWrappedName name -> LocatedN name prepareName = ieLWrappedName -layoutIE :: ToBriDoc IE +layoutIE :: ToBriDoc an IE layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of IEVar _ x -> layoutWrapped lie x IEThingAbs _ x -> layoutWrapped lie x IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] - IEThingWith _ x (IEWildcard _) _ _ -> + IEThingWith _ x (IEWildcard _) _ -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] - IEThingWith _ x _ ns _ -> do + IEThingWith _ x _ ns -> do hasComments <- orM (hasCommentsBetween lie AnnOpenP AnnCloseP : hasAnyCommentsBelow x @@ -78,10 +78,10 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of where layoutWrapped _ = \case L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n - L _ (IEPattern n) -> do + L _ (IEPattern _ n) -> do name <- lrdrNameToTextAnn n docLit $ Text.pack "pattern " <> name - L _ (IEType n) -> do + L _ (IEType _ n) -> do name <- lrdrNameToTextAnn n docLit $ Text.pack "type " <> name @@ -95,7 +95,7 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted -- left to the caller since that is context sensitive layoutAnnAndSepLLIEs :: SortItemsFlag - -> Located [LIE GhcPs] + -> LocatedAn an [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do let makeIENode ie = docSeq [docCommaSep, ie] @@ -131,7 +131,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do isProperIEThing = \case L _ (IEThingAbs _ _wn) -> True L _ (IEThingAll _ _wn) -> True - L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True + L _ (IEThingWith _ _wn NoIEWildcard _) -> True _ -> False isIEVar :: LIE GhcPs -> Bool isIEVar = \case @@ -143,7 +143,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do thingFolder _ l2@(L _ IEThingAll{}) = l2 thingFolder l1 (L _ IEThingAbs{}) = l1 thingFolder (L _ IEThingAbs{}) l2 = l2 - thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) + thingFolder (L l (IEThingWith x wn _ consItems1)) (L _ (IEThingWith _ _ _ consItems2)) = L l (IEThingWith @@ -151,7 +151,6 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do wn NoIEWildcard (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) ) thingFolder _ _ = error "thingFolder should be exhaustive because we have a guard above" @@ -171,7 +170,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do -- ( -- a comment -- ) layoutLLIEs - :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered + :: Bool -> SortItemsFlag -> LocatedAn an [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs enableSingleline shouldSort llies = do ieDs <- layoutAnnAndSepLLIEs shouldSort llies hasComments <- hasAnyCommentsBelow llies @@ -199,8 +198,8 @@ layoutLLIEs enableSingleline shouldSort llies = do wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText = \case L _ (IEName n) -> lrdrNameToText n - L _ (IEPattern n) -> lrdrNameToText n - L _ (IEType n) -> lrdrNameToText n + L _ (IEPattern _ n) -> lrdrNameToText n + L _ (IEType _ n) -> lrdrNameToText n -- | Returns a "fingerprint string", not a full text representation, nor even -- a source code representation of this syntax node. @@ -210,7 +209,7 @@ lieToText = \case L _ (IEVar _ wn) -> wrappedNameToText wn L _ (IEThingAbs _ wn) -> wrappedNameToText wn L _ (IEThingAll _ wn) -> wrappedNameToText wn - L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn + L _ (IEThingWith _ wn _ _) -> wrappedNameToText wn -- TODO: These _may_ appear in exports! -- Need to check, and either put them at the top (for module) or do some -- other clever thing. @@ -219,6 +218,6 @@ lieToText = \case L _ IEDoc{} -> Text.pack "@IEDoc" L _ IEDocNamed{} -> Text.pack "@IEDocNamed" where - moduleNameToText :: Located ModuleName -> Text + moduleNameToText :: LocatedAn an ModuleName -> Text moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs index fc17cde..b8424ff 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -7,6 +7,7 @@ import qualified Data.Text as Text import GHC (GenLocated(L), Located, moduleNameString, unLoc) import GHC.Hs import GHC.Types.Basic +import qualified GHC.Types.SourceText import GHC.Unit.Types (IsBootInterface(..)) import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.LayouterBasics @@ -17,13 +18,13 @@ import Language.Haskell.Brittany.Internal.Types -prepPkg :: SourceText -> String +prepPkg :: GHC.Types.SourceText.SourceText -> String prepPkg rawN = case rawN of - SourceText n -> n + GHC.Types.SourceText.SourceText n -> n -- This would be odd to encounter and the -- result will most certainly be wrong - NoSourceText -> "" -prepModName :: Located e -> e + GHC.Types.SourceText.NoSourceText -> "" +prepModName :: LocatedAn an e -> e prepModName = unLoc layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered @@ -36,7 +37,7 @@ layoutImport importD = case importD of let compact = indentPolicy /= IndentPolicyFree modNameT = Text.pack $ moduleNameString modName - pkgNameT = Text.pack . prepPkg . sl_st <$> pkg + pkgNameT = Text.pack . prepPkg . GHC.Types.SourceText.sl_st <$> pkg masT = Text.pack . moduleNameString . prepModName <$> mas hiding = maybe False fst mllies minQLength = length "import qualified " diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 8de45d7..4b0e602 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -18,20 +18,21 @@ import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Types import Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.GHC.ExactPrint.Types - (DeltaPos(..), commentContents, deltaRow) + (commentContents) + +import Language.Haskell.Brittany.Internal.EPCompat (Annotation) - -layoutModule :: ToBriDoc' HsModule +layoutModule :: ToBriDoc' an HsModule layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule _ Nothing _ imports _ _ _ -> do + HsModule _ _ Nothing _ imports _ _ _ -> do commentedImports <- transformToCommentedImport imports -- groupify commentedImports `forM_` tellDebugMessShow docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- sortedImports <- sortImports imports -- docLines $ [layoutImport y i | (y, i) <- sortedImports] - HsModule _ (Just n) les imports _ _ _ -> do + HsModule _ _ (Just n) les imports _ _ _ -> do commentedImports <- transformToCommentedImport imports -- groupify commentedImports `forM_` tellDebugMessShow -- sortedImports <- sortImports imports @@ -99,11 +100,12 @@ transformToCommentedImport :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] transformToCommentedImport is = do nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do - annotionMay <- astAnn i + annotionMay <- undefined -- astAnn i pure (annotionMay, rawImport) let - convertComment (c, DP (y, x)) = - replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] + convertComment (c, _ {-DP (y, x)-}) = + undefined + -- replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] accumF :: [(Comment, DeltaPos)] -> (Maybe Annotation, ImportDecl GhcPs) @@ -120,21 +122,22 @@ transformToCommentedImport is = do ) Just ann -> let - blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1 + blanksBeforeImportDecl = undefined -- deltaRow (annEntryDelta ann) - 1 (newAccumulator, priorComments') = - List.span ((== 0) . deltaRow . snd) (annPriorComments ann) + List.span ((== 0) . {-deltaRow-} undefined . snd) ({-annPriorComments-} undefined ann) go :: [(Comment, DeltaPos)] -> [(Comment, DeltaPos)] -> ([CommentedImport], [(Comment, DeltaPos)], Int) go acc [] = ([], acc, 0) - go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) - go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs - go acc ((c1, DP (y, x)) : xs) = - ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine - , (c1, DP (1, x)) : acc - , 0 - ) + go acc _ = undefined + -- go acc [c1@(_, {DP (y, _)})] = ([], c1 : acc, y - 1) + -- go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs + -- go acc ((c1, DP (y, x)) : xs) = + -- ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine + -- , (c1, DP (1, x)) : acc + -- , 0 + -- ) (convertedIndependentComments, beforeComments, initialBlanks) = if blanksBeforeImportDecl /= 0 then (convertComment =<< priorComments', [], 0) @@ -194,4 +197,5 @@ commentedImportsToDoc = \case ImportStatement r -> docSeq (layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) where - commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) + commentToDoc (c, _ {-DP (_y, x)-}) = undefined + -- docLitS (replicate x ' ' ++ commentContents c) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 773d993..8e36274 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -57,7 +57,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- x1' <- docSeq [docLit $ Text.pack "(", return x1] -- xN' <- docSeq [return xN, docLit $ Text.pack ")"] -- return $ (x1' Seq.<| middle) Seq.|> xN' - ConPat _ lname (PrefixCon args) -> do + ConPat _ lname (PrefixCon _tyargs args) -> do -- Abc a b c -> expr nameDoc <- lrdrNameToTextAnn lname argDocs <- layoutPat `mapM` args @@ -84,7 +84,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do + fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do let FieldOcc _ lnameF = fieldOcc fExpDoc <- if pun then return Nothing @@ -111,7 +111,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of | dotdoti == length fs -> do -- Abc { a = locA, .. } let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do + fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do let FieldOcc _ lnameF = fieldOcc fExpDoc <- if pun then return Nothing @@ -171,7 +171,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of wrapPatPrepend pat1 (docLit $ Text.pack "~") NPat _ llit@(L _ ol) mNegative _ -> do -- -13 -> expr - litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol + litDoc <- docWrapNode (reLocA llit) $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol negDoc <- docLit $ Text.pack "-" pure $ case mNegative of Just{} -> Seq.fromList [negDoc, litDoc] diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs index 5ef19c7..7ce5aed 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -19,7 +19,7 @@ import Language.Haskell.Brittany.Internal.Types -layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) +layoutStmt :: ToBriDoc' AnnListItem (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt lstmt@(L _ stmt) = do indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indentAmount :: Int <- @@ -94,7 +94,7 @@ layoutStmt lstmt@(L _ stmt) = do $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do + RecStmt _ (L _ stmts) _ _ _ _ _ -> runFilteredAlternative $ do -- rec stmt1 -- stmt2 -- stmt3 diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot index 6cfd5c8..0eb826b 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -7,4 +7,4 @@ import Language.Haskell.Brittany.Internal.Types -layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) +layoutStmt :: ToBriDoc' AnnListItem (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 1662ffb..a384078 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -1,13 +1,15 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Type where import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L)) +import GHC (GenLocated(L)) import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic +import qualified GHC.Types.SourceText import GHC.Utils.Outputable (ftext, showSDocUnsafe) import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Prelude @@ -17,8 +19,8 @@ import Language.Haskell.Brittany.Internal.Utils (FirstLastView(..), splitFirstLast) - -layoutType :: ToBriDoc HsType +--- XXX: maybe push `Anno (sym GhcPs)` into ToBriDoc definition in place of a typevar +layoutType :: ToBriDoc AnnListItem HsType layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" HsTyVar _ promoted name -> do @@ -26,7 +28,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of case promoted of IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t] NotPromoted -> docWrapNode name $ docLit t - HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do + HsForAllTy _ hsf (L _ (HsQualTy _ (fromMaybeContext -> cntxts) typ2)) -> do let bndrs = getBinders hsf typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- layoutTyVarBndrs bndrs @@ -159,7 +161,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] ) ] - HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do + HsQualTy _ (fromMaybe (noLocA []) -> lcntxts@(L _ cntxts)) typ1 -> do typeDoc <- docSharedWrapper layoutType typ1 cntxtDocs <- cntxts `forM` docSharedWrapper layoutType let @@ -291,8 +293,6 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] HsTupleTy _ tupleSort typs -> case tupleSort of HsUnboxedTuple -> unboxed - HsBoxedTuple -> simple - HsConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple where unboxed = if null typs @@ -573,11 +573,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype HsTyLit _ lit -> case lit of - HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext - HsNumTy NoSourceText _ -> + HsNumTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext + HsNumTy GHC.Types.SourceText.NoSourceText _ -> error "overLitValBriDoc: literal with no SourceText" - HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext - HsStrTy NoSourceText _ -> + HsStrTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext + HsStrTy GHC.Types.SourceText.NoSourceText _ -> + error "overLitValBriDoc: literal with no SourceText" + HsCharTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext + HsCharTy GHC.Types.SourceText.NoSourceText _ -> error "overLitValBriDoc: literal with no SourceText" HsWildCardTy _ -> docLit $ Text.pack "_" HsSumTy{} -> -- TODO @@ -622,14 +625,12 @@ processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case , docLit $ Text.pack ")" ] -getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass] +getBinders :: HsForAllTelescope (GhcPass pass) -> [LHsTyVarBndr () (GhcPass pass)] getBinders x = case x of HsForAllVis _ b -> b HsForAllInvis _ b -> fmap withoutSpecificity b - XHsForAllTelescope _ -> [] -withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass +withoutSpecificity :: LHsTyVarBndr flag (GhcPass pass) -> LHsTyVarBndr () (GhcPass pass) withoutSpecificity = fmap $ \case UserTyVar a _ c -> UserTyVar a () c KindedTyVar a _ c d -> KindedTyVar a () c d - XTyVarBndr a -> XTyVarBndr a diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs index 03f83a5..22dc596 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs @@ -13,11 +13,11 @@ import qualified GHC.Driver.Session import qualified GHC.Parser.Header import qualified GHC.Platform import qualified GHC.Settings +import qualified GHC.Types.SafeHaskell import qualified GHC.Types.SrcLoc import qualified GHC.Utils.Error import qualified GHC.Utils.Fingerprint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -- | Parses a Haskell module. Although this nominally requires IO, it is -- morally pure. It should have no observable effects. @@ -27,7 +27,7 @@ parseModule -> FilePath -> (GHC.Driver.Session.DynFlags -> io (Either String a)) -> String - -> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) + -> io (Either String (GHC.ParsedSource, a)) parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do let dynFlags1 = GHC.Driver.Session.gopt_set @@ -36,7 +36,7 @@ parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do -- Neither passing in @"-XUnsafe"@ as a command line argument nor having -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help. initialDynFlags - { GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe + { GHC.Driver.Session.safeHaskell = GHC.Types.SafeHaskell.Sf_Unsafe } GHC.Driver.Session.Opt_KeepRawTokenStream (dynFlags2, leftovers1, _) <- @@ -56,7 +56,7 @@ parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string case parseResult of Left errorMessages -> handleErrorMessages errorMessages - Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult) + Right parsedSource -> pure (parsedSource, dynFlagsResult) handleLeftovers :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m () @@ -79,7 +79,6 @@ initialSettings = GHC.Driver.Session.Settings , GHC.Driver.Session.sTargetPlatform = initialTargetPlatform , GHC.Driver.Session.sToolSettings = initialToolSettings , GHC.Driver.Session.sPlatformMisc = initialPlatformMisc - , GHC.Driver.Session.sPlatformConstants = initialPlatformConstants , GHC.Driver.Session.sRawSettings = [] } @@ -101,10 +100,8 @@ initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion initialPlatformMisc :: GHC.Driver.Session.PlatformMisc initialPlatformMisc = GHC.Driver.Session.PlatformMisc - { GHC.Driver.Session.platformMisc_ghcDebugged = False - , GHC.Driver.Session.platformMisc_ghcRTSWays = "" + { GHC.Driver.Session.platformMisc_ghcRTSWays = "" , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False - , GHC.Driver.Session.platformMisc_ghcThreaded = False , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False , GHC.Driver.Session.platformMisc_ghcWithSMP = False , GHC.Driver.Session.platformMisc_libFFI = False @@ -118,143 +115,142 @@ initialLlvmConfig = GHC.Driver.Session.LlvmConfig , GHC.Driver.Session.llvmTargets = [] } -initialPlatformConstants :: GHC.Settings.PlatformConstants -initialPlatformConstants = GHC.Settings.PlatformConstants - { GHC.Settings.pc_AP_STACK_SPLIM = 0 - , GHC.Settings.pc_BITMAP_BITS_SHIFT = 0 - , GHC.Settings.pc_BLOCK_SIZE = 0 - , GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0 - , GHC.Settings.pc_CINT_SIZE = 0 - , GHC.Settings.pc_CLONG_LONG_SIZE = 0 - , GHC.Settings.pc_CLONG_SIZE = 0 - , GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0 - , GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False - , GHC.Settings.pc_ILDV_CREATE_MASK = 0 - , GHC.Settings.pc_ILDV_STATE_CREATE = 0 - , GHC.Settings.pc_ILDV_STATE_USE = 0 - , GHC.Settings.pc_LDV_SHIFT = 0 - , GHC.Settings.pc_MAX_CHARLIKE = 0 - , GHC.Settings.pc_MAX_Double_REG = 0 - , GHC.Settings.pc_MAX_Float_REG = 0 - , GHC.Settings.pc_MAX_INTLIKE = 0 - , GHC.Settings.pc_MAX_Long_REG = 0 - , GHC.Settings.pc_MAX_Real_Double_REG = 0 - , GHC.Settings.pc_MAX_Real_Float_REG = 0 - , GHC.Settings.pc_MAX_Real_Long_REG = 0 - , GHC.Settings.pc_MAX_Real_Vanilla_REG = 0 - , GHC.Settings.pc_MAX_Real_XMM_REG = 0 - , GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0 - , GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0 - , GHC.Settings.pc_MAX_Vanilla_REG = 0 - , GHC.Settings.pc_MAX_XMM_REG = 0 - , GHC.Settings.pc_MIN_CHARLIKE = 0 - , GHC.Settings.pc_MIN_INTLIKE = 0 - , GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0 - , GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0 - , GHC.Settings.pc_OFFSET_bdescr_blocks = 0 - , GHC.Settings.pc_OFFSET_bdescr_flags = 0 - , GHC.Settings.pc_OFFSET_bdescr_free = 0 - , GHC.Settings.pc_OFFSET_bdescr_start = 0 - , GHC.Settings.pc_OFFSET_Capability_r = 0 - , GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0 - , GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0 - , GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0 - , GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_link = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0 - , GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0 - , GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0 - , GHC.Settings.pc_OFFSET_stgGCEnter1 = 0 - , GHC.Settings.pc_OFFSET_stgGCFun = 0 - , GHC.Settings.pc_OFFSET_StgHeader_ccs = 0 - , GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0 - , GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0 - , GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0 - , GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0 - , GHC.Settings.pc_OFFSET_StgStack_sp = 0 - , GHC.Settings.pc_OFFSET_StgStack_stack = 0 - , GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0 - , GHC.Settings.pc_OFFSET_StgTSO_cccs = 0 - , GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0 - , GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0 - , GHC.Settings.pc_PROF_HDR_SIZE = 0 - , GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0 - , GHC.Settings.pc_REP_CostCentreStack_scc_count = 0 - , GHC.Settings.pc_REP_StgEntCounter_allocd = 0 - , GHC.Settings.pc_REP_StgEntCounter_allocs = 0 - , GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0 - , GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0 - , GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0 - , GHC.Settings.pc_RESERVED_STACK_WORDS = 0 - , GHC.Settings.pc_SIZEOF_CostCentreStack = 0 - , GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0 - , GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0 - , GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0 - , GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0 - , GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0 - , GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0 - , GHC.Settings.pc_STD_HDR_SIZE = 0 - , GHC.Settings.pc_TAG_BITS = 0 - , GHC.Settings.pc_TICKY_BIN_COUNT = 0 - , GHC.Settings.pc_WORD_SIZE = 0 +initialPlatformConstants :: GHC.Platform.PlatformConstants +initialPlatformConstants = GHC.Platform.PlatformConstants + { GHC.Platform.pc_AP_STACK_SPLIM = 0 + , GHC.Platform.pc_BITMAP_BITS_SHIFT = 0 + , GHC.Platform.pc_BLOCK_SIZE = 0 + , GHC.Platform.pc_BLOCKS_PER_MBLOCK = 0 + , GHC.Platform.pc_CINT_SIZE = 0 + , GHC.Platform.pc_CLONG_LONG_SIZE = 0 + , GHC.Platform.pc_CLONG_SIZE = 0 + , GHC.Platform.pc_CONTROL_GROUP_CONST_291 = 0 + , GHC.Platform.pc_ILDV_CREATE_MASK = 0 + , GHC.Platform.pc_ILDV_STATE_CREATE = 0 + , GHC.Platform.pc_ILDV_STATE_USE = 0 + , GHC.Platform.pc_LDV_SHIFT = 0 + , GHC.Platform.pc_MAX_CHARLIKE = 0 + , GHC.Platform.pc_MAX_Double_REG = 0 + , GHC.Platform.pc_MAX_Float_REG = 0 + , GHC.Platform.pc_MAX_INTLIKE = 0 + , GHC.Platform.pc_MAX_Long_REG = 0 + , GHC.Platform.pc_MAX_Real_Double_REG = 0 + , GHC.Platform.pc_MAX_Real_Float_REG = 0 + , GHC.Platform.pc_MAX_Real_Long_REG = 0 + , GHC.Platform.pc_MAX_Real_Vanilla_REG = 0 + , GHC.Platform.pc_MAX_Real_XMM_REG = 0 + , GHC.Platform.pc_MAX_SPEC_AP_SIZE = 0 + , GHC.Platform.pc_MAX_SPEC_SELECTEE_SIZE = 0 + , GHC.Platform.pc_MAX_Vanilla_REG = 0 + , GHC.Platform.pc_MAX_XMM_REG = 0 + , GHC.Platform.pc_MIN_CHARLIKE = 0 + , GHC.Platform.pc_MIN_INTLIKE = 0 + , GHC.Platform.pc_MIN_PAYLOAD_SIZE = 0 + , GHC.Platform.pc_MUT_ARR_PTRS_CARD_BITS = 0 + , GHC.Platform.pc_OFFSET_bdescr_blocks = 0 + , GHC.Platform.pc_OFFSET_bdescr_flags = 0 + , GHC.Platform.pc_OFFSET_bdescr_free = 0 + , GHC.Platform.pc_OFFSET_bdescr_start = 0 + , GHC.Platform.pc_OFFSET_Capability_r = 0 + , GHC.Platform.pc_OFFSET_CostCentreStack_mem_alloc = 0 + , GHC.Platform.pc_OFFSET_CostCentreStack_scc_count = 0 + , GHC.Platform.pc_OFFSET_StgArrBytes_bytes = 0 + , GHC.Platform.pc_OFFSET_stgEagerBlackholeInfo = 0 + , GHC.Platform.pc_OFFSET_StgEntCounter_allocd = 0 + , GHC.Platform.pc_OFFSET_StgEntCounter_allocs = 0 + , GHC.Platform.pc_OFFSET_StgEntCounter_entry_count = 0 + , GHC.Platform.pc_OFFSET_StgEntCounter_link = 0 + , GHC.Platform.pc_OFFSET_StgEntCounter_registeredp = 0 + , GHC.Platform.pc_OFFSET_StgFunInfoExtraFwd_arity = 0 + , GHC.Platform.pc_OFFSET_StgFunInfoExtraRev_arity = 0 + , GHC.Platform.pc_OFFSET_stgGCEnter1 = 0 + , GHC.Platform.pc_OFFSET_stgGCFun = 0 + , GHC.Platform.pc_OFFSET_StgHeader_ccs = 0 + , GHC.Platform.pc_OFFSET_StgHeader_ldvw = 0 + , GHC.Platform.pc_OFFSET_StgMutArrPtrs_ptrs = 0 + , GHC.Platform.pc_OFFSET_StgMutArrPtrs_size = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rCCCS = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rCurrentNursery = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rCurrentTSO = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rD1 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rD2 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rD3 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rD4 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rD5 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rD6 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rF1 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rF2 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rF3 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rF4 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rF5 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rF6 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rHp = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rHpAlloc = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rHpLim = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rL1 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rR1 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rR10 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rR2 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rR3 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rR4 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rR5 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rR6 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rR7 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rR8 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rR9 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rSp = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rSpLim = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rXMM1 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rXMM2 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rXMM3 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rXMM4 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rXMM5 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rXMM6 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rYMM1 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rYMM2 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rYMM3 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rYMM4 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rYMM5 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rYMM6 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rZMM1 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rZMM2 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rZMM3 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rZMM4 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rZMM5 = 0 + , GHC.Platform.pc_OFFSET_StgRegTable_rZMM6 = 0 + , GHC.Platform.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0 + , GHC.Platform.pc_OFFSET_StgStack_sp = 0 + , GHC.Platform.pc_OFFSET_StgStack_stack = 0 + , GHC.Platform.pc_OFFSET_StgTSO_alloc_limit = 0 + , GHC.Platform.pc_OFFSET_StgTSO_cccs = 0 + , GHC.Platform.pc_OFFSET_StgTSO_stackobj = 0 + , GHC.Platform.pc_OFFSET_StgUpdateFrame_updatee = 0 + , GHC.Platform.pc_PROF_HDR_SIZE = 0 + , GHC.Platform.pc_REP_CostCentreStack_mem_alloc = 0 + , GHC.Platform.pc_REP_CostCentreStack_scc_count = 0 + , GHC.Platform.pc_REP_StgEntCounter_allocd = 0 + , GHC.Platform.pc_REP_StgEntCounter_allocs = 0 + , GHC.Platform.pc_REP_StgFunInfoExtraFwd_arity = 0 + , GHC.Platform.pc_REP_StgFunInfoExtraRev_arity = 0 + , GHC.Platform.pc_RESERVED_C_STACK_BYTES = 0 + , GHC.Platform.pc_RESERVED_STACK_WORDS = 0 + , GHC.Platform.pc_SIZEOF_CostCentreStack = 0 + , GHC.Platform.pc_SIZEOF_StgArrBytes_NoHdr = 0 + , GHC.Platform.pc_SIZEOF_StgFunInfoExtraRev = 0 + , GHC.Platform.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0 + , GHC.Platform.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0 + , GHC.Platform.pc_SIZEOF_StgSMPThunkHeader = 0 + , GHC.Platform.pc_SIZEOF_StgUpdateFrame_NoHdr = 0 + , GHC.Platform.pc_STD_HDR_SIZE = 0 + , GHC.Platform.pc_TAG_BITS = 0 + , GHC.Platform.pc_TICKY_BIN_COUNT = 0 + , GHC.Platform.pc_WORD_SIZE = 0 } -initialPlatformMini :: GHC.Settings.PlatformMini -initialPlatformMini = GHC.Settings.PlatformMini - { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64 - , GHC.Settings.platformMini_os = GHC.Platform.OSLinux +initialPlatformArchOS :: GHC.Platform.ArchOS +initialPlatformArchOS = GHC.Platform.ArchOS + { GHC.Platform.archOS_arch = GHC.Platform.ArchX86_64 + , GHC.Platform.archOS_OS = GHC.Platform.OSLinux } initialTargetPlatform :: GHC.Settings.Platform @@ -265,7 +261,8 @@ initialTargetPlatform = GHC.Settings.Platform , GHC.Settings.platformHasSubsectionsViaSymbols = False , GHC.Settings.platformIsCrossCompiling = False , GHC.Settings.platformLeadingUnderscore = False - , GHC.Settings.platformMini = initialPlatformMini + , GHC.Settings.platformArchOS = initialPlatformArchOS + , GHC.Settings.platform_constants = Just initialPlatformConstants , GHC.Settings.platformTablesNextToCode = False , GHC.Settings.platformUnregisterised = False , GHC.Settings.platformWordSize = GHC.Platform.PW8 diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index 6a2c8af..9480332 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -18,33 +18,34 @@ import Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Kind as Kind import qualified Data.Strict.Maybe as Strict import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) +import GHC (AnnKeywordId, GenLocated, Located, LocatedAn, SrcSpan) import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Prelude import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint (AnnKey) +-- import Language.Haskell.GHC.ExactPrint (AnnKey) import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Types (Anns) +-- import Language.Haskell.GHC.ExactPrint.Types (Anns) import qualified Safe +import Language.Haskell.Brittany.Internal.EPCompat data PerItemConfig = PerItemConfig { _icd_perBinding :: Map String (CConfig Maybe) - , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) + , _icd_perKey :: Map AnnKey (CConfig Maybe) } deriving Data.Data.Data type PPM = MultiRWSS.MultiRWS - '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] + '[Map AnnKey Anns, PerItemConfig, Config, Anns] '[Text.Builder.Builder, [BrittanyError], Seq String] '[] type PPMLocal = MultiRWSS.MultiRWS - '[Config, ExactPrint.Anns] + '[Config, Anns] '[Text.Builder.Builder, [BrittanyError], Seq String] '[] -newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) +newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map AnnKey String) data LayoutState = LayoutState { _lstate_baseYs :: [Int] @@ -131,7 +132,7 @@ instance Show LayoutState where -- -- when creating zero-indentation -- -- multi-line list literals. -- , _lsettings_importColumn :: Int --- , _lsettings_initialAnns :: ExactPrint.Anns +-- , _lsettings_initialAnns :: Anns -- } data BrittanyError @@ -144,7 +145,7 @@ data BrittanyError -- output and second the corresponding, ill-formed input. | LayoutWarning String -- ^ some warning - | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast) + | forall ast an. Data.Data.Data ast => ErrorUnknownNode String (LocatedAn an ast) -- ^ internal error: pretty-printing is not implemented for type of node -- in the syntax-tree | ErrorOutputCheck @@ -218,9 +219,9 @@ type ToBriDocM = MultiRWSS.MultiRWS '[[BrittanyError], Seq String] -- writer '[NodeAllocIndex] -- state -type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered -type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered -type ToBriDocC sym c = Located sym -> ToBriDocM c +type ToBriDoc an (sym :: Kind.Type -> Kind.Type) = LocatedAn an (sym GhcPs) -> ToBriDocM BriDocNumbered +type ToBriDoc' an sym = LocatedAn an sym -> ToBriDocM BriDocNumbered +type ToBriDocC an sym c = LocatedAn an sym -> ToBriDocM c data DocMultiLine = MultiLineNo diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs index b62028f..154461d 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -17,9 +17,10 @@ import qualified Data.Sequence as Seq import DataTreePrint import qualified GHC.Data.FastString as GHC import qualified GHC.Driver.Session as GHC -import qualified GHC.Hs.Extension as HsExtension +import qualified GHC.Driver.Ppr as GHC import qualified GHC.OldList as List import GHC.Types.Name.Occurrence as OccName (occNameString) +import qualified GHC.Parser.Annotation as GHC import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Outputable as GHC import Language.Haskell.Brittany.Internal.Config.Types @@ -28,8 +29,10 @@ import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils +import qualified Language.Haskell.Syntax.Extension as HsExtension import qualified Text.PrettyPrint as PP +import Language.Haskell.Brittany.Internal.EPCompat parDoc :: String -> PP.Doc @@ -40,10 +43,10 @@ parDocW = PP.fsep . fmap PP.text . List.words . List.unwords showSDoc_ :: GHC.SDoc -> String -showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags +showSDoc_ = GHC.showSDoc undefined -- GHC.unsafeGlobalDynFlags showOutputable :: (GHC.Outputable a) => a -> String -showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags +showOutputable = GHC.showPpr undefined -- GHC.unsafeGlobalDynFlags fromMaybeIdentity :: Identity a -> Maybe a -> Identity a fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y @@ -72,8 +75,8 @@ instance Show ShowIsId where data A x = A ShowIsId x deriving Data -customLayouterF :: ExactPrint.Types.Anns -> LayouterF -customLayouterF anns layoutF = +customLayouterF :: LayouterF +customLayouterF layoutF = DataToLayouter $ f `extQ` showIsId @@ -104,12 +107,12 @@ customLayouterF anns layoutF = $ "{" ++ showOutputable ss ++ "}" - located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter + located :: (Data b, Data ann) => GHC.GenLocated ann b -> NodeLayouter located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a where annStr = case cast ss of - Just (s :: GHC.SrcSpan) -> - ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns) + Just (s :: GHC.SrcLoc) -> + ShowIsId $ "printing anns on 9.2.1: not implemented" ++ undefined Nothing -> ShowIsId "nnnnnnnn" customLayouterNoAnnsF :: LayouterF @@ -226,9 +229,9 @@ briDocToDoc = astToDoc . removeAnnotations briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns = astToDoc -annsDoc :: ExactPrint.Types.Anns -> PP.Doc +annsDoc :: EPAnns -> PP.Doc annsDoc = - printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) + printTreeWithCustom 100 customLayouterNoAnnsF breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) breakEither _ [] = ([], [])