diff --git a/brittany.cabal b/brittany.cabal index e488cd8..e2a954d 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -26,14 +26,17 @@ library { hs-source-dirs: src exposed-modules: { - Language.Haskell.Brittany.Prelude Language.Haskell.Brittany + Language.Haskell.Brittany.Prelude Language.Haskell.Brittany.Types Language.Haskell.Brittany.Utils Language.Haskell.Brittany.Config Language.Haskell.Brittany.Config.Types + } + other-modules: { Language.Haskell.Brittany.LayoutBasics Language.Haskell.Brittany.BriLayouter + Language.Haskell.Brittany.ExactPrintUtils Language.Haskell.Brittany.Layouters.Type Language.Haskell.Brittany.Layouters.Decl Language.Haskell.Brittany.Layouters.Expr diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 0c1f774..f843166 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -6,17 +6,6 @@ module Main where #include "prelude.inc" -import DynFlags ( getDynFlags ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) -import qualified Parser as GHC.Parser -import RdrName ( RdrName(..) ) -import Control.Monad.IO.Class -import GHC.Paths (libdir) -import HsSyn -import SrcLoc ( SrcSpan, Located ) --- import Outputable ( ppr, runSDoc ) --- import DynFlags ( unsafeGlobalDynFlags ) - import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types @@ -28,7 +17,6 @@ import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Debug.Trace as Trace import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany.LayoutBasics import Language.Haskell.Brittany import Language.Haskell.Brittany.Config import Language.Haskell.Brittany.Config.Types @@ -93,20 +81,6 @@ mainCmdParser = do when printHelp $ do liftIO $ print $ ppHelpShallow desc System.Exit.exitSuccess - -- runGhc (Just libdir) $ do - -- dynflags <- getDynFlags - -- input <- liftIO $ readFile "local/Sample.hs" - -- let parseOutput = runParser dynflags parserModule input - -- liftIO $ case parseOutput of - -- Failure msg strloc -> do - -- putStrLn "some failed parse" - -- putStrLn msg - -- print strloc - -- Parsed a -> putStrLn "some successful parse." - -- Partial a (x,y) -> do - -- putStrLn "some partial parse" - -- print x - -- print y inputPathM <- case inputPaths of [] -> do return Nothing diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index 7765c75..2a846c1 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -3,6 +3,9 @@ module Language.Haskell.Brittany ( parsePrintModule , pPrintModule + -- re-export from utils: + , parseModule + , parseModuleFromString ) where @@ -10,29 +13,6 @@ where #include "prelude.inc" -import DynFlags ( getDynFlags ) -import GHC ( runGhc, GenLocated(L), moduleNameString ) -import qualified Parser as GHC -import qualified ApiAnnotation as GHC -import qualified DynFlags as GHC -import qualified FastString as GHC -import qualified GHC as GHC hiding (parseModule) -import qualified HeaderInfo as GHC -import qualified Lexer as GHC -import qualified MonadUtils as GHC -import qualified Outputable as GHC -import qualified Parser as GHC -import qualified SrcLoc as GHC -import qualified StringBuffer as GHC -import RdrName ( RdrName(..) ) -import Control.Monad.IO.Class -import GHC.Paths (libdir) -import HsSyn -import SrcLoc ( SrcSpan, Located ) --- import Outputable ( ppr, runSDoc ) --- import DynFlags ( unsafeGlobalDynFlags ) - -import ApiAnnotation ( AnnKeywordId(..) ) import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types @@ -54,14 +34,14 @@ import Language.Haskell.Brittany.Layouters.Type import Language.Haskell.Brittany.Layouters.Decl import Language.Haskell.Brittany.Utils import Language.Haskell.Brittany.BriLayouter +import Language.Haskell.Brittany.ExactPrintUtils +import qualified GHC as GHC hiding (parseModule) +import ApiAnnotation ( AnnKeywordId(..) ) import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) import SrcLoc ( SrcSpan ) import HsSyn -import Name -import qualified FastString -import BasicTypes @@ -120,55 +100,6 @@ parsePrintModule conf filename input = do LayoutErrorUnknownNode str _ -> str in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs --- TODO: move to separate module -commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () -commentAnnFixTransform modul = SYB.everything (>>) genF modul - where - genF :: Data.Data.Data a => a -> ExactPrint.Transform () - genF = (\_ -> return ()) `SYB.extQ` exprF - exprF :: Located (HsExpr RdrName) -> ExactPrint.Transform () - exprF lexpr@(L _ expr) = case expr of - RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) -> - moveTrailingComments lexpr (List.last fs) - RecordUpd _lname fs@(_:_) _ _ _ _ -> - moveTrailingComments lexpr (List.last fs) - _ -> return () - -moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) - => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () -moveTrailingComments astFrom astTo = do - let - breakHet :: (a -> Either b c) -> [a] -> ([b],[c]) - breakHet _ [] = ([],[]) - breakHet fn (a1:aR) = case fn a1 of - Left b -> (b:bs,cs) - Right c -> (bs,c:cs) - where - (bs,cs) = breakHet fn aR - - k1 = ExactPrint.Types.mkAnnKey astFrom - k2 = ExactPrint.Types.mkAnnKey astTo - moveComments ans = ans' - where - an1 = Data.Maybe.fromJust $ Map.lookup k1 ans - an2 = Data.Maybe.fromJust $ Map.lookup k2 ans - cs1f = ExactPrint.Types.annFollowingComments an1 - cs2f = ExactPrint.Types.annFollowingComments an2 - (comments, nonComments) = flip breakHet (ExactPrint.Types.annsDP an1) - $ \case - (ExactPrint.Types.AnnComment com, dp) -> Left (com, dp) - x -> Right x - an1' = an1 - { ExactPrint.annsDP = nonComments - , ExactPrint.annFollowingComments = [] - } - an2' = an2 - { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments - } - ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans - - ExactPrint.modifyAnnsT moveComments - -- this approach would for with there was a pure GHC.parseDynamicFilePragma. -- Unfortunately that does not exist yet, so we cannot provide a nominally -- pure interface. diff --git a/src/Language/Haskell/Brittany/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/ExactPrintUtils.hs new file mode 100644 index 0000000..9ae6216 --- /dev/null +++ b/src/Language/Haskell/Brittany/ExactPrintUtils.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.ExactPrintUtils + ( parseModule + , parseModuleFromString + , commentAnnFixTransform + ) +where + + + +#include "prelude.inc" + +import DynFlags ( getDynFlags ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import qualified Parser as GHC +import qualified ApiAnnotation as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified GHC as GHC hiding (parseModule) +import qualified HeaderInfo as GHC +import qualified Lexer as GHC +import qualified MonadUtils as GHC +import qualified Outputable as GHC +import qualified Parser as GHC +import qualified SrcLoc as GHC +import qualified StringBuffer as GHC +import RdrName ( RdrName(..) ) +import Control.Monad.IO.Class +import HsSyn +import SrcLoc ( SrcSpan, Located ) +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import Name +import qualified FastString +import BasicTypes + +import ApiAnnotation ( AnnKeywordId(..) ) +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint + +import qualified Data.Generics as SYB + +import qualified Data.Map as Map + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import qualified Debug.Trace as Trace + +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.LayoutBasics + + + +parseModule + :: [String] + -> System.IO.FilePath + -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource)) +parseModule = + parseModuleWithCpp ExactPrint.defaultCppOptions ExactPrint.normalLayout + +-- | Parse a module with specific instructions for the C pre-processor. +parseModuleWithCpp + :: ExactPrint.CppOptions + -> ExactPrint.DeltaOptions + -> [String] + -> System.IO.FilePath + -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource)) +parseModuleWithCpp cpp opts args fp = + ExactPrint.ghcWrapper $ EitherT.runEitherT $ do + dflags0 <- lift $ ExactPrint.initDynFlags fp + (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine + dflags0 + (GHC.noLoc <$> args) + when (not $ null leftover) + $ EitherT.left + $ "when parsing ghc flags: leftover flags: " + ++ show (leftover <&> \(L _ s) -> s) + when (not $ null warnings) + $ EitherT.left + $ "when parsing ghc flags: encountered warnings: " + ++ show (warnings <&> \(L _ s) -> s) + res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags1 fp + EitherT.hoistEither + $ either (\(span, err) -> Left $ show span ++ ": " ++ err) Right + $ ExactPrint.postParseTransform res opts + +parseModuleFromString + :: [String] + -> System.IO.FilePath + -> String + -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource)) +parseModuleFromString args fp str = + ExactPrint.ghcWrapper $ EitherT.runEitherT $ do + dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str + (dflags1, leftover, warnings) <- + lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) + when (not $ null leftover) + $ EitherT.left + $ "when parsing ghc flags: leftover flags: " + ++ show (leftover <&> \(L _ s) -> s) + when (not $ null warnings) + $ EitherT.left + $ "when parsing ghc flags: encountered warnings: " + ++ show (warnings <&> \(L _ s) -> s) + EitherT.hoistEither + $ either (\(span, err) -> Left $ show span ++ ": " ++ err) Right + $ ExactPrint.parseWith dflags1 fp GHC.parseModule str + +----------- + +-- data LNode = forall a . LNode (Located a) +-- +-- commentAnnFixTransformGlob :: GHC.ParsedSource -> ExactPrint.Transform () +-- commentAnnFixTransformGlob modul = do +-- let extract :: forall a . SYB.Data a => a -> Seq LNode +-- extract = const Seq.empty `SYB.ext1Q` (Seq.singleton . LNode) +-- let nodes = SYB.everything (<>) extract modul +-- let comp = _ +-- let sorted = Seq.sortBy (comparing _) nodes +-- _ + +commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () +commentAnnFixTransform modul = SYB.everything (>>) genF modul + where + genF :: Data.Data.Data a => a -> ExactPrint.Transform () + genF = (\_ -> return ()) `SYB.extQ` exprF + exprF :: Located (HsExpr RdrName) -> ExactPrint.Transform () + exprF lexpr@(L _ expr) = case expr of + RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) -> + moveTrailingComments lexpr (List.last fs) + RecordUpd _lname fs@(_:_) _ _ _ _ -> + moveTrailingComments lexpr (List.last fs) + _ -> return () + +moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) + => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () +moveTrailingComments astFrom astTo = do + let + breakHet :: (a -> Either b c) -> [a] -> ([b],[c]) + breakHet _ [] = ([],[]) + breakHet fn (a1:aR) = case fn a1 of + Left b -> (b:bs,cs) + Right c -> (bs,c:cs) + where + (bs,cs) = breakHet fn aR + + k1 = ExactPrint.mkAnnKey astFrom + k2 = ExactPrint.mkAnnKey astTo + moveComments ans = ans' + where + an1 = Data.Maybe.fromJust $ Map.lookup k1 ans + an2 = Data.Maybe.fromJust $ Map.lookup k2 ans + cs1f = ExactPrint.annFollowingComments an1 + cs2f = ExactPrint.annFollowingComments an2 + (comments, nonComments) = flip breakHet (ExactPrint.annsDP an1) + $ \case + (ExactPrint.AnnComment com, dp) -> Left (com, dp) + x -> Right x + an1' = an1 + { ExactPrint.annsDP = nonComments + , ExactPrint.annFollowingComments = [] + } + an2' = an2 + { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments + } + ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans + + ExactPrint.modifyAnnsT moveComments diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayoutBasics.hs index 15c80ad..d7d2cca 100644 --- a/src/Language/Haskell/Brittany/LayoutBasics.hs +++ b/src/Language/Haskell/Brittany/LayoutBasics.hs @@ -67,7 +67,6 @@ module Language.Haskell.Brittany.LayoutBasics , docDebug , briDocByExact , briDocByExactNoComment - , fromMaybeIdentity , foldedAnnKeys , unknownNodeError , appSep @@ -1086,11 +1085,6 @@ docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm docEnsureIndent :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd - -fromMaybeIdentity :: Identity a -> Maybe a -> Identity a -fromMaybeIdentity x y = Data.Coerce.coerce - $ fromMaybe (Data.Coerce.coerce x) y - unknownNodeError :: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered unknownNodeError infoStr ast = do diff --git a/src/Language/Haskell/Brittany/Utils.hs b/src/Language/Haskell/Brittany/Utils.hs index 1803e60..2981444 100644 --- a/src/Language/Haskell/Brittany/Utils.hs +++ b/src/Language/Haskell/Brittany/Utils.hs @@ -5,6 +5,7 @@ module Language.Haskell.Brittany.Utils ( (.=+) , (%=+) , parDoc + , fromMaybeIdentity , traceIfDumpConf , mModify , customLayouterF @@ -71,6 +72,10 @@ showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags showGhc :: (GHC.Outputable a) => a -> String showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags +fromMaybeIdentity :: Identity a -> Maybe a -> Identity a +fromMaybeIdentity x y = Data.Coerce.coerce + $ fromMaybe (Data.Coerce.coerce x) y + -- maximum monoid over N+0 -- or more than N, because Num is allowed. newtype Max a = Max { getMax :: a }