From 75d03534e78483a00974aabb4f60aa4f33b4c17c Mon Sep 17 00:00:00 2001 From: mrkun Date: Mon, 31 Jan 2022 00:43:27 +0300 Subject: [PATCH] Typefixing/hacking Decl (partial) --- .../Brittany/Internal/ExactPrintUtils.hs | 147 +++++++++--------- .../Brittany/Internal/Layouters/Decl.hs | 54 +++---- .../Brittany/Internal/Layouters/Stmt.hs-boot | 2 +- .../Haskell/Brittany/Internal/Types.hs | 2 +- 4 files changed, 103 insertions(+), 102 deletions(-) diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 4635bac..6c4fefc 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -31,7 +31,7 @@ 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] @@ -50,72 +50,73 @@ parseModuleFromString -> 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 -- commentAnnFixTransformGlob does not include: Moving of comments for @@ -232,12 +233,12 @@ foldedAnnKeys ast = SYB.everything where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) -} -{- + 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 @@ -248,10 +249,10 @@ 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 warnExtractorCompat (GHC.Warn _ (L _ s)) = s diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 9e22b6e..2b759dd 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 an 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 an Sig layoutSig lsig@(L _loc sig) = case sig of - TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ + TypeSig _ names (HsWC _ (L _ 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 _ typ) -> layoutNamesAndType Nothing names typ + PatSynSig _ names (L _ 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 @@ -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 @@ -198,7 +198,7 @@ bindOrSigtoSrcSpan (BagBind (L l _)) = l bindOrSigtoSrcSpan (BagSig (L l _)) = l layoutLocalBinds - :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) + :: ToBriDocC an (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) layoutLocalBinds lbinds@(L _ binds) = case binds of -- HsValBinds (ValBindsIn lhsBindsLR []) -> -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering @@ -307,7 +307,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 @@ -663,10 +663,10 @@ layoutPatSynBind name patSynDetails patDir rpat = do -- | Helper method for the left hand side of a pattern synonym layoutLPatSyn - :: Located (IdP GhcPs) + :: LocatedAn an (IdP GhcPs) -> HsPatSynDetails (Located (IdP 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) @@ -699,7 +699,7 @@ layoutPatSynWhere hs = case hs of -- TyClDecl -------------------------------------------------------------------------------- -layoutTyCl :: ToBriDoc TyClDecl +layoutTyCl :: ToBriDoc an TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of SynDecl _ name vars fixity typ -> do let @@ -720,7 +720,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of layoutSynDecl :: Bool -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) - -> Located (IdP GhcPs) + -> LocatedAn an (IdP GhcPs) -> [LHsTyVarBndr () GhcPs] -> LHsType GhcPs -> ToBriDocM BriDocNumbered @@ -756,7 +756,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,12 +783,12 @@ 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 + FamEqn _ name bndrsMay pats _fixity typ = L_body $ tfid_eqn tfid -- bndrsMay isJust e.g. with -- type instance forall a . MyType (Maybe a) = Either () a innerNode = outerNode @@ -842,7 +842,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 :: ToBriDoc an ClsInstDecl layoutClsInst lcid@(L _ cid) = docLines [ layoutInstanceHead , docEnsureIndent BrIndentRegular @@ -880,10 +880,10 @@ layoutClsInst lcid@(L _ cid) = docLines . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l - layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) + layoutAndLocateSig :: ToBriDocC an (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig - layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) + layoutAndLocateBind :: ToBriDocC an (HsBind GhcPs) (Located BriDocNumbered) layoutAndLocateBind lbind@(L loc _) = L loc <$> (joinBinds =<< layoutBind lbind) @@ -894,17 +894,17 @@ layoutClsInst lcid@(L _ cid) = docLines Right n -> return n layoutAndLocateTyFamInsts - :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) + :: ToBriDocC an (TyFamInstDecl GhcPs) (Located BriDocNumbered) layoutAndLocateTyFamInsts ltfid@(L loc tfid) = L loc <$> layoutTyFamInstDecl True ltfid tfid layoutAndLocateDataFamInsts - :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) + :: ToBriDocC an (DataFamInstDecl GhcPs) (Located BriDocNumbered) layoutAndLocateDataFamInsts ldfid@(L loc _) = L loc <$> layoutDataFamInstDecl ldfid -- | Send to ExactPrint then remove unecessary whitespace - layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl + layoutDataFamInstDecl :: ToBriDoc an DataFamInstDecl layoutDataFamInstDecl ldfid = fmap stripWhitespace <$> briDocByExactNoComment ldfid 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..319e4ce 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' an (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index 3919eba..9480332 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -221,7 +221,7 @@ type ToBriDocM = MultiRWSS.MultiRWS 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 sym c = Located sym -> ToBriDocM c +type ToBriDocC an sym c = LocatedAn an sym -> ToBriDocM c data DocMultiLine = MultiLineNo