Typefixing/hacking Decl (partial)

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
+commentAnnFixTransformGlob ast = undefined
-  let
+--   do
-    extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
+--   let
-    extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
+--     extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
-      const Seq.empty
+--     extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
-        `SYB.ext1Q` (\l@(L span _) ->
+--       const Seq.empty
-                      Seq.singleton (span, ExactPrint.mkAnnKey l)
+--         `SYB.ext1Q` (\l@(L span _) ->
-                    )
+--                       Seq.singleton (span, ExactPrint.mkAnnKey l)
-  let nodes = SYB.everything (<>) extract ast
+--                     )
-  let
+--   let nodes = SYB.everything (<>) extract ast
-    annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
+--   let
-    annsMap = Map.fromListWith
+--     annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
-      (const id)
+--     annsMap = Map.fromListWith
-      [ (GHC.realSrcSpanEnd span, annKey)
+--       (const id)
-      | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
+--       [ (GHC.realSrcSpanEnd span, annKey)
-      ]
+--       | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
-  nodes `forM_` (snd .> processComs annsMap)
+--       ]
- where
+--   nodes `forM_` (snd .> processComs annsMap)
-  processComs annsMap annKey1 = do
+--  where
-    mAnn <- State.Class.gets fst <&> Map.lookup annKey1
+--   processComs annsMap annKey1 = do
-    mAnn `forM_` \ann1 -> do
+--     mAnn <- State.Class.gets fst <&> Map.lookup annKey1
-      let
+--     mAnn `forM_` \ann1 -> do
-        priors = ExactPrint.annPriorComments ann1
+--       let
-        follows = ExactPrint.annFollowingComments ann1
+--         priors = ExactPrint.annPriorComments ann1
-        assocs = ExactPrint.annsDP ann1
+--         follows = ExactPrint.annFollowingComments ann1
-      let
+--         assocs = ExactPrint.annsDP ann1
-        processCom
+--       let
-          :: (ExactPrint.Comment, ExactPrint.DeltaPos)
+--         processCom
-          -> ExactPrint.TransformT Identity Bool
+--           :: (ExactPrint.Comment, ExactPrint.DeltaPos)
-        processCom comPair@(com, _) =
+--           -> ExactPrint.TransformT Identity Bool
-          case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of
+--         processCom comPair@(com, _) =
-            comLoc -> case Map.lookupLE comLoc annsMap of
+--           case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of
-              Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
+--             comLoc -> case Map.lookupLE comLoc annsMap of
-                (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
+--               Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
-                  move $> False
+--                 (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
-                (x, y) | x == y -> move $> False
+--                   move $> False
-                _ -> return True
+--                 (x, y) | x == y -> move $> False
-               where
+--                 _ -> return True
-                ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
+--                where
-                ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
+--                 ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
-                loc1 = GHC.realSrcSpanStart annKeyLoc1
+--                 ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
-                loc2 = GHC.realSrcSpanStart annKeyLoc2
+--                 loc1 = GHC.realSrcSpanStart annKeyLoc1
-                move = ExactPrint.modifyAnnsT $ \anns ->
+--                 loc2 = GHC.realSrcSpanStart annKeyLoc2
-                  let
+--                 move = ExactPrint.modifyAnnsT $ \anns ->
-                    ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
+--                   let
-                    ann2' = ann2
+--                     ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
-                      { ExactPrint.annFollowingComments =
+--                     ann2' = ann2
-                        ExactPrint.annFollowingComments ann2 ++ [comPair]
+--                       { ExactPrint.annFollowingComments =
-                      }
+--                         ExactPrint.annFollowingComments ann2 ++ [comPair]
-                  in Map.insert annKey2 ann2' anns
+--                       }
-              _ -> return True -- retain comment at current node.
+--                   in Map.insert annKey2 ann2' anns
-      priors' <- filterM processCom priors
+--               _ -> return True -- retain comment at current node.
-      follows' <- filterM processCom follows
+--       priors' <- filterM processCom priors
-      assocs' <- flip filterM assocs $ \case
+--       follows' <- filterM processCom follows
-        (ExactPrint.AnnComment com, dp) -> processCom (com, dp)
+--       assocs' <- flip filterM assocs $ \case
-        _ -> return True
+--         (ExactPrint.AnnComment com, dp) -> processCom (com, dp)
-      let
+--         _ -> return True
-        ann1' = ann1
+--       let
-          { ExactPrint.annPriorComments = priors'
+--         ann1' = ann1
-          , ExactPrint.annFollowingComments = follows'
+--           { ExactPrint.annPriorComments = priors'
-          , ExactPrint.annsDP = assocs'
+--           , ExactPrint.annFollowingComments = follows'
-          }
+--           , ExactPrint.annsDP = assocs'
-      ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
+--           }
--}
+--       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 , Anns] w s a
-  -> MultiRWSS.MultiRWS '[Config , ExactPrint.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)
+        ExactPrint.runTransform (commentAnnFixTransformGlob ast)
-    in annsBalanced
+    in anns
--}
+
 
 warnExtractorCompat :: GHC.Warn -> String
 warnExtractorCompat (GHC.Warn _ (L _ s)) = s

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 an HsDecl
-layoutDecl :: ToBriDoc 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
+  ClassOpSig _ False names (L _ typ) -> layoutNamesAndType Nothing names typ
-  PatSynSig _ names (HsIB _ 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
 

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))

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