Typefixing/hacking Decl (partial)
parent
c201bdda16
commit
75d03534e7
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue