From d11141d34d011b4932dad406f11b4ef5bb28325b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 17 Dec 2022 14:48:55 +0100 Subject: [PATCH] Refactor+Rewrite+Adaptation for ghc-9.2 support --- brittany.cabal | 85 +- data/15-regressions.blt | 20 +- source/library/Language/Haskell/Brittany.hs | 9 +- .../Language/Haskell/Brittany/Internal.hs | 689 ++-------- .../Brittany/Internal/Components/BriDoc.hs | 275 ++++ .../Internal/{ => Components}/Obfuscation.hs | 3 +- .../Brittany/Internal/{ => Config}/Config.hs | 35 +- .../Brittany/Internal/Config/InlineParsing.hs | 194 +++ .../Haskell/Brittany/Internal/Config/Types.hs | 93 +- .../Types/{Instances.hs => Instances1.hs} | 6 +- .../Internal/Config/Types/Instances2.hs | 102 ++ .../Brittany/Internal/ExactPrintUtils.hs | 254 ---- .../Brittany/Internal/LayouterBasics.hs | 781 ----------- .../Brittany/Internal/Layouters/Expr.hs | 1086 --------------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 224 --- .../Brittany/Internal/Layouters/Module.hs | 197 --- .../Brittany/Internal/Layouters/Stmt.hs-boot | 10 - .../Brittany/Internal/Layouters/Type.hs | 635 --------- .../Haskell/Brittany/Internal/ParseModule.hs | 316 ----- .../Haskell/Brittany/Internal/Prelude.hs | 102 +- .../Haskell/Brittany/Internal/PreludeUtils.hs | 66 - .../Haskell/Brittany/Internal/S1_Parsing.hs | 346 +++++ .../Brittany/Internal/S2_SplitModule.hs | 380 +++++ .../Brittany/Internal/S3_ToBriDocTools.hs | 741 ++++++++++ .../Brittany/Internal/S4_WriteBriDoc.hs | 316 +++++ .../Brittany/Internal/StepOrchestrate.hs | 256 ++++ .../{Layouters => ToBriDoc}/DataDecl.hs | 292 ++-- .../Internal/{Layouters => ToBriDoc}/Decl.hs | 815 +++++------ .../Brittany/Internal/ToBriDoc/Expr.hs | 1222 +++++++++++++++++ .../{Layouters => ToBriDoc}/Expr.hs-boot | 5 +- .../Haskell/Brittany/Internal/ToBriDoc/IE.hs | 252 ++++ .../{Layouters => ToBriDoc}/Import.hs | 50 +- .../Brittany/Internal/ToBriDoc/Module.hs | 60 + .../{Layouters => ToBriDoc}/Pattern.hs | 39 +- .../Internal/{Layouters => ToBriDoc}/Stmt.hs | 73 +- .../Brittany/Internal/ToBriDoc/Stmt.hs-boot | 11 + .../Brittany/Internal/ToBriDoc/Type.hs | 535 ++++++++ .../Transformations/{Alt.hs => T1_Alt.hs} | 99 +- .../{Floating.hs => T2_Floating.hs} | 154 +-- .../Transformations/{Par.hs => T3_Par.hs} | 19 +- .../{Columns.hs => T4_Columns.hs} | 62 +- .../{Indent.hs => T5_Indent.hs} | 15 +- .../Haskell/Brittany/Internal/Types.hs | 594 +++----- .../Haskell/Brittany/Internal/Util/AST.hs | 40 + .../Haskell/Brittany/Internal/Utils.hs | 242 ++-- .../AlignmentAlgo.hs} | 632 +++------ .../Operators.hs} | 275 ++-- .../Brittany/Internal/WriteBriDoc/Types.hs | 94 ++ .../library/Language/Haskell/Brittany/Main.hs | 99 +- source/test-suite/Main.hs | 3 +- 50 files changed, 6739 insertions(+), 6164 deletions(-) create mode 100644 source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs rename source/library/Language/Haskell/Brittany/Internal/{ => Components}/Obfuscation.hs (95%) rename source/library/Language/Haskell/Brittany/Internal/{ => Config}/Config.hs (93%) create mode 100644 source/library/Language/Haskell/Brittany/Internal/Config/InlineParsing.hs rename source/library/Language/Haskell/Brittany/Internal/Config/Types/{Instances.hs => Instances1.hs} (98%) create mode 100644 source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances2.hs delete mode 100644 source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs delete mode 100644 source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs delete mode 100644 source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs delete mode 100644 source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs delete mode 100644 source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs delete mode 100644 source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot delete mode 100644 source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs delete mode 100644 source/library/Language/Haskell/Brittany/Internal/ParseModule.hs delete mode 100644 source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs create mode 100644 source/library/Language/Haskell/Brittany/Internal/S1_Parsing.hs create mode 100644 source/library/Language/Haskell/Brittany/Internal/S2_SplitModule.hs create mode 100644 source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs create mode 100644 source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs create mode 100644 source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs rename source/library/Language/Haskell/Brittany/Internal/{Layouters => ToBriDoc}/DataDecl.hs (58%) rename source/library/Language/Haskell/Brittany/Internal/{Layouters => ToBriDoc}/Decl.hs (53%) create mode 100644 source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs rename source/library/Language/Haskell/Brittany/Internal/{Layouters => ToBriDoc}/Expr.hs-boot (63%) create mode 100644 source/library/Language/Haskell/Brittany/Internal/ToBriDoc/IE.hs rename source/library/Language/Haskell/Brittany/Internal/{Layouters => ToBriDoc}/Import.hs (79%) create mode 100644 source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs rename source/library/Language/Haskell/Brittany/Internal/{Layouters => ToBriDoc}/Pattern.hs (85%) rename source/library/Language/Haskell/Brittany/Internal/{Layouters => ToBriDoc}/Stmt.hs (62%) create mode 100644 source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs-boot create mode 100644 source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs rename source/library/Language/Haskell/Brittany/Internal/Transformations/{Alt.hs => T1_Alt.hs} (93%) rename source/library/Language/Haskell/Brittany/Internal/Transformations/{Floating.hs => T2_Floating.hs} (55%) rename source/library/Language/Haskell/Brittany/Internal/Transformations/{Par.hs => T3_Par.hs} (66%) rename source/library/Language/Haskell/Brittany/Internal/Transformations/{Columns.hs => T4_Columns.hs} (72%) rename source/library/Language/Haskell/Brittany/Internal/Transformations/{Indent.hs => T5_Indent.hs} (79%) create mode 100644 source/library/Language/Haskell/Brittany/Internal/Util/AST.hs rename source/library/Language/Haskell/Brittany/Internal/{Backend.hs => WriteBriDoc/AlignmentAlgo.hs} (57%) rename source/library/Language/Haskell/Brittany/Internal/{BackendUtils.hs => WriteBriDoc/Operators.hs} (69%) create mode 100644 source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Types.hs diff --git a/brittany.cabal b/brittany.cabal index 8a2317e..23f0efa 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -38,9 +38,9 @@ flag pedantic common library build-depends: , aeson ^>= 2.0.1 - , base ^>= 4.15.0 + , base >= 4.15.0 && < 4.17 , butcher ^>= 2.0.0 - , bytestring ^>= 0.10.12 + , bytestring >= 0.10.12 && < 0.12 , cmdargs ^>= 0.10.21 , containers ^>= 0.6.4 , czipwith ^>= 1.0.1 @@ -49,17 +49,17 @@ 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.0.1 && < 9.3 + , ghc-boot >= 9.0.1 && < 9.3 + , ghc-boot-th >= 9.0.1 && < 9.3 + , ghc-exactprint >= 0.6.4 && < 1.6 , monad-memo ^>= 0.5.3 , mtl ^>= 2.2.2 , multistate ^>= 0.8.0 , pretty ^>= 1.1.3 , random ^>= 1.2.1 , safe ^>= 0.3.19 - , semigroups ^>= 0.19.2 + , semigroups >= 0.19.2 && < 0.21 , strict ^>= 0.4.0 , syb ^>= 0.7.2 , text ^>= 1.2.5 @@ -86,6 +86,21 @@ common library if flag(pedantic) ghc-options: -Werror + default-extensions: { + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + MultiParamTypeClasses + TypeApplications + RankNTypes + GADTs + BangPatterns + } + common executable import: library @@ -103,36 +118,42 @@ library autogen-modules: Paths_brittany hs-source-dirs: source/library exposed-modules: + Language.Haskell.Brittany.Main Language.Haskell.Brittany Language.Haskell.Brittany.Internal - Language.Haskell.Brittany.Internal.Backend - Language.Haskell.Brittany.Internal.BackendUtils - Language.Haskell.Brittany.Internal.Config + Language.Haskell.Brittany.Internal.Config.Config + Language.Haskell.Brittany.Internal.Config.InlineParsing Language.Haskell.Brittany.Internal.Config.Types - Language.Haskell.Brittany.Internal.Config.Types.Instances - Language.Haskell.Brittany.Internal.ExactPrintUtils - Language.Haskell.Brittany.Internal.LayouterBasics - Language.Haskell.Brittany.Internal.Layouters.DataDecl - Language.Haskell.Brittany.Internal.Layouters.Decl - Language.Haskell.Brittany.Internal.Layouters.Expr - Language.Haskell.Brittany.Internal.Layouters.IE - Language.Haskell.Brittany.Internal.Layouters.Import - Language.Haskell.Brittany.Internal.Layouters.Module - Language.Haskell.Brittany.Internal.Layouters.Pattern - Language.Haskell.Brittany.Internal.Layouters.Stmt - Language.Haskell.Brittany.Internal.Layouters.Type - Language.Haskell.Brittany.Internal.Obfuscation - Language.Haskell.Brittany.Internal.ParseModule + Language.Haskell.Brittany.Internal.Config.Types.Instances1 + Language.Haskell.Brittany.Internal.Config.Types.Instances2 + Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl + Language.Haskell.Brittany.Internal.ToBriDoc.Decl + Language.Haskell.Brittany.Internal.ToBriDoc.Expr + Language.Haskell.Brittany.Internal.ToBriDoc.IE + Language.Haskell.Brittany.Internal.ToBriDoc.Import + Language.Haskell.Brittany.Internal.ToBriDoc.Module + Language.Haskell.Brittany.Internal.ToBriDoc.Pattern + Language.Haskell.Brittany.Internal.ToBriDoc.Stmt + Language.Haskell.Brittany.Internal.ToBriDoc.Type + Language.Haskell.Brittany.Internal.Components.BriDoc + Language.Haskell.Brittany.Internal.Components.Obfuscation + Language.Haskell.Brittany.Internal.S1_Parsing + Language.Haskell.Brittany.Internal.S2_SplitModule + Language.Haskell.Brittany.Internal.S3_ToBriDocTools + Language.Haskell.Brittany.Internal.S4_WriteBriDoc + Language.Haskell.Brittany.Internal.StepOrchestrate Language.Haskell.Brittany.Internal.Prelude - Language.Haskell.Brittany.Internal.PreludeUtils - Language.Haskell.Brittany.Internal.Transformations.Alt - Language.Haskell.Brittany.Internal.Transformations.Columns - Language.Haskell.Brittany.Internal.Transformations.Floating - Language.Haskell.Brittany.Internal.Transformations.Indent - Language.Haskell.Brittany.Internal.Transformations.Par + Language.Haskell.Brittany.Internal.Transformations.T1_Alt + Language.Haskell.Brittany.Internal.Transformations.T2_Floating + Language.Haskell.Brittany.Internal.Transformations.T3_Par + Language.Haskell.Brittany.Internal.Transformations.T4_Columns + Language.Haskell.Brittany.Internal.Transformations.T5_Indent + Language.Haskell.Brittany.Internal.WriteBriDoc.AlignmentAlgo + Language.Haskell.Brittany.Internal.WriteBriDoc.Operators + Language.Haskell.Brittany.Internal.WriteBriDoc.Types Language.Haskell.Brittany.Internal.Types Language.Haskell.Brittany.Internal.Utils - Language.Haskell.Brittany.Main + Language.Haskell.Brittany.Internal.Util.AST Paths_brittany executable brittany @@ -145,7 +166,7 @@ test-suite brittany-test-suite import: executable build-depends: - , hspec ^>= 2.8.3 + , hspec >= 2.8.3 && < 2.10 , parsec ^>= 3.1.14 , these ^>= 1.1 hs-source-dirs: source/test-suite diff --git a/data/15-regressions.blt b/data/15-regressions.blt index 9a6b623..32cf6fe 100644 --- a/data/15-regressions.blt +++ b/data/15-regressions.blt @@ -116,7 +116,7 @@ func = do let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' -- default local dir target if there's no given target - utargets'' = "foo" + utargets'' = "foo" return () #test list comprehension comment placement @@ -872,3 +872,21 @@ func = do y >>= x + +#test nested-arrow-type +#pending +fieldWith + :: a + -> a + -> ( ( GHC.RealSrcLoc + , a + , Either + (Maybe GHC.RealSrcLoc, ToBriDocM BriDocNumbered) + ( Maybe GHC.RealSrcLoc + , ToBriDocM BriDocNumbered + , ToBriDocM BriDocNumbered + ) + ) + -> ToBriDocM BriDocNumbered + ) + -> [ToBriDocM BriDocNumbered] diff --git a/source/library/Language/Haskell/Brittany.hs b/source/library/Language/Haskell/Brittany.hs index a2726c8..8804fd1 100644 --- a/source/library/Language/Haskell/Brittany.hs +++ b/source/library/Language/Haskell/Brittany.hs @@ -1,9 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} module Language.Haskell.Brittany - ( parsePrintModule - , staticDefaultConfig - , forwardOptionsSyntaxExtsEnabled + -- ( parsePrintModule + -- , staticDefaultConfig + ( forwardOptionsSyntaxExtsEnabled , userConfigPath , findLocalConfigPath , readConfigs @@ -18,7 +18,6 @@ module Language.Haskell.Brittany , BrittanyError(..) ) where -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Config import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs index fc2f099..5ccfcdb 100644 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ b/source/library/Language/Haskell/Brittany/Internal.hs @@ -1,232 +1,42 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Brittany.Internal - ( parsePrintModule + ( Parsing.parseModule + , Parsing.parseModuleFromString + , parsePrintModule , parsePrintModuleTests - , pPrintModule + , processModule , pPrintModuleAndCheck -- re-export from utils: - , parseModule - , parseModuleFromString , extractCommentConfigs - , getTopLevelDeclNameMap - ) where + , TraceFunc(TraceFunc) + ) +where -import Control.Monad.Trans.Except -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Data.ByteString.Char8 -import Data.CZipWith -import Data.Char (isSpace) -import Data.HList.HList -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified Data.Yaml -import qualified GHC hiding (parseModule) -import GHC (GenLocated(L)) -import qualified GHC.Driver.Session as GHC -import GHC.Hs -import qualified GHC.LanguageExtensions.Type as GHC -import qualified GHC.OldList as List -import GHC.Parser.Annotation (AnnKeywordId(..)) -import GHC.Types.SrcLoc (SrcSpan) -import Language.Haskell.Brittany.Internal.Backend -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Module -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Transformations.Alt -import Language.Haskell.Brittany.Internal.Transformations.Columns -import Language.Haskell.Brittany.Internal.Transformations.Floating -import Language.Haskell.Brittany.Internal.Transformations.Indent -import Language.Haskell.Brittany.Internal.Transformations.Par -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.Types as ExactPrint -import qualified UI.Butcher.Monadic as Butcher +import Control.Monad.Trans.Except +import Data.CZipWith +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TextL +import qualified GHC hiding ( parseModule ) +import qualified GHC.Driver.Session as GHC +import GHC.Hs +import qualified GHC.LanguageExtensions.Type as GHC +import qualified GHC.OldList as List +import Language.Haskell.Brittany.Internal.Config.Config +import Language.Haskell.Brittany.Internal.Config.InlineParsing +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.Prelude +import qualified Language.Haskell.Brittany.Internal.S1_Parsing + as Parsing +import Language.Haskell.Brittany.Internal.StepOrchestrate + ( processModule ) +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types.Instances1 () -data InlineConfigTarget - = InlineConfigTargetModule - | InlineConfigTargetNextDecl -- really only next in module - | InlineConfigTargetNextBinding -- by name - | InlineConfigTargetBinding String - -extractCommentConfigs - :: ExactPrint.Anns - -> TopLevelDeclNameMap - -> Either (String, String) (CConfig Maybe, PerItemConfig) -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 - ] - ) - | (k, ann) <- Map.toList anns - ] - let - configLiness = commentLiness <&> second - (Data.Maybe.mapMaybe $ \line -> do - l1 <- - List.stripPrefix "-- BRITTANY" line - <|> List.stripPrefix "--BRITTANY" line - <|> List.stripPrefix "-- brittany" line - <|> List.stripPrefix "--brittany" line - <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") - let l2 = dropWhile isSpace l1 - guard - (("@" `isPrefixOf` l2) - || ("-disable" `isPrefixOf` l2) - || ("-next" `isPrefixOf` l2) - || ("{" `isPrefixOf` l2) - || ("--" `isPrefixOf` l2) - ) - pure l2 - ) - let - configParser = Butcher.addAlternatives - [ ( "commandline-config" - , \s -> "-" `isPrefixOf` dropWhile (== ' ') s - , cmdlineConfigParser - ) - , ( "yaml-config-document" - , \s -> "{" `isPrefixOf` dropWhile (== ' ') s - , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") - $ either - (\_ -> Butcher.Failure Nothing) - (\lconf -> Butcher.Success (mempty { _conf_layout = lconf }) "") - . Data.Yaml.decodeEither' - . Data.ByteString.Char8.pack - -- TODO: use some proper utf8 encoder instead? - ) - ] - parser = do -- we will (mis?)use butcher here to parse the inline config - -- line. - let - nextDecl = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) - Butcher.addCmd "-next-declaration" nextDecl - Butcher.addCmd "-Next-Declaration" nextDecl - Butcher.addCmd "-NEXT-DECLARATION" nextDecl - let - nextBinding = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) - Butcher.addCmd "-next-binding" nextBinding - Butcher.addCmd "-Next-Binding" nextBinding - Butcher.addCmd "-NEXT-BINDING" nextBinding - let - disableNextBinding = do - Butcher.addCmdImpl - ( InlineConfigTargetNextBinding - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) - Butcher.addCmd "-disable-next-binding" disableNextBinding - Butcher.addCmd "-Disable-Next-Binding" disableNextBinding - Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding - let - disableNextDecl = do - Butcher.addCmdImpl - ( InlineConfigTargetNextDecl - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) - Butcher.addCmd "-disable-next-declaration" disableNextDecl - Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl - Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl - let - disableFormatting = do - Butcher.addCmdImpl - ( InlineConfigTargetModule - , mempty { _conf_disable_formatting = pure $ pure True } - ) - Butcher.addCmd "-disable" disableFormatting - Butcher.addCmd "@" $ do - -- Butcher.addCmd "module" $ do - -- conf <- configParser - -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) - Butcher.addNullCmd $ do - bindingName <- Butcher.addParamString "BINDING" mempty - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetModule, conf) - lineConfigss <- configLiness `forM` \(k, ss) -> do - r <- ss `forM` \s -> case Butcher.runCmdParserSimpleString s parser of - Left err -> Left $ (err, s) - Right c -> Right $ c - pure (k, r) - - let - perModule = foldl' - (<>) - mempty - [ conf - | (_, lineConfigs) <- lineConfigss - , (InlineConfigTargetModule, conf) <- lineConfigs - ] - let - perBinding = Map.fromListWith - (<>) - [ (n, conf) - | (k, lineConfigs) <- lineConfigss - , (target, conf) <- lineConfigs - , n <- case target of - InlineConfigTargetBinding s -> [s] - InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> - [name] - _ -> [] - ] - let - perKey = Map.fromListWith - (<>) - [ (k, conf) - | (k, lineConfigs) <- lineConfigss - , (target, conf) <- lineConfigs - , case target of - InlineConfigTargetNextDecl -> True - InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> - True - _ -> False - ] - - pure - $ ( perModule - , PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey } - ) - - -getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap -getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = - TopLevelDeclNameMap $ Map.fromList - [ (ExactPrint.mkAnnKey decl, name) - | decl <- decls - , (name : _) <- [getDeclBindingNames decl] - ] - - -- | Exposes the transformation in an pseudo-pure fashion. The signature -- contains `IO` due to the GHC API not exposing a pure parsing function, but -- there should be no observable effects. @@ -238,143 +48,104 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = -- `mask_`, so cannot be killed easily. If you don't control the input, you -- may wish to put some proper upper bound on the input's size as a timeout -- won't do. -parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) -parsePrintModule configWithDebugs inputText = runExceptT $ do - let - config = configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } +parsePrintModule + :: TraceFunc -> Config -> Text -> IO (Either [BrittanyError] Text) +parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do + let config = + configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - let config_pp = config & _conf_preprocessor - let cppMode = config_pp & _ppconf_CPPMode & confUnpack - let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack - (anns, parsedSource, hasCPP) <- do - let - hackF s = - if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s - let - hackTransform = if hackAroundIncludes - then List.intercalate "\n" . fmap hackF . lines' - else id - let - cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False - parseResult <- lift $ parseModuleFromString + let config_pp = config & _conf_preprocessor + let cppMode = config_pp & _ppconf_CPPMode & confUnpack @CPPMode + let hackAroundIncludes = + config_pp & _ppconf_hackAroundIncludes & confUnpack @Bool + (parsedSource, hasCPP) <- do + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes + then List.intercalate "\n" . fmap hackF . lines' + else id + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False + parseResult <- lift $ Parsing.parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of - Left err -> throwE [ErrorInput err] - Right x -> pure x + Left err -> throwE [ErrorInput err] + Right x -> pure x (inlineConf, perItemConf) <- - either (throwE . (: []) . uncurry ErrorMacroConfig) pure - $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id) + $ extractCommentConfigs (useTraceFunc traceFunc) parsedSource let moduleConfig = cZipWith fromOptionIdentity config inlineConf - let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack + let disableFormatting = + moduleConfig & _conf_disable_formatting & confUnpack @Bool if disableFormatting then do return inputText else do (errsWarns, outputTextL) <- do - let - omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack + let omitCheck = + moduleConfig + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule moduleConfig perItemConf anns parsedSource - else lift - $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource - let - hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s + then lift $ processModule traceFunc moduleConfig perItemConf parsedSource + else lift $ pPrintModuleAndCheck traceFunc + moduleConfig + perItemConf + parsedSource + let hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes then ( ews , TextL.intercalate (TextL.pack "\n") - $ hackF + $ hackF <$> TextL.splitOn (TextL.pack "\n") outRaw ) else (ews, outRaw) - let - customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let - hasErrors = - if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack - then not $ null errsWarns - else 0 < maximum (-1 : fmap customErrOrder errsWarns) + let customErrOrder ErrorInput{} = 5 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnusedComments{} = 3 + customErrOrder ErrorUnknownNode{} = 4 + customErrOrder ErrorMacroConfig{} = 6 + let hasErrors = + if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + then not $ null errsWarns + else 0 < maximum (-1 : fmap customErrOrder errsWarns) if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL --- BrittanyErrors can be non-fatal warnings, thus both are returned instead --- of an Either. --- This should be cleaned up once it is clear what kinds of errors really --- can occur. -pPrintModule - :: Config - -> PerItemConfig - -> ExactPrint.Anns - -> GHC.ParsedSource - -> ([BrittanyError], TextL.Text) -pPrintModule conf inlineConf anns parsedModule = - let - ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader anns - $ MultiRWSS.withMultiReader conf - $ MultiRWSS.withMultiReader inlineConf - $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) - $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns - ppModule parsedModule - tracer = if Seq.null debugStrings - then id - else - trace ("---- DEBUGMESSAGES ---- ") - . foldr (seq . join trace) id debugStrings - in tracer $ (errs, Text.Builder.toLazyText out) - -- unless () $ do - -- - -- debugStrings `forM_` \s -> - -- trace s $ return () - -- | Additionally checks that the output compiles again, appending an error -- if it does not. pPrintModuleAndCheck - :: Config + :: TraceFunc + -> Config -> PerItemConfig - -> ExactPrint.Anns -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) -pPrintModuleAndCheck conf inlineConf anns parsedModule = do - let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity - let (errs, output) = pPrintModule conf inlineConf anns parsedModule - parseResult <- parseModuleFromString - ghcOptions - "output" - (\_ -> return $ Right ()) - (TextL.unpack output) - let - errs' = errs ++ case parseResult of - Left{} -> [ErrorOutputCheck] - Right{} -> [] +pPrintModuleAndCheck traceFunc conf inlineConf parsedModule = do + let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity + (errs, output) <- processModule traceFunc conf inlineConf parsedModule + parseResult <- Parsing.parseModuleFromString ghcOptions + "output" + (\_ -> return $ Right ()) + (TextL.unpack output) + let errs' = errs ++ case parseResult of + Left{} -> [ErrorOutputCheck] + Right{} -> [] return (errs', output) @@ -383,42 +154,48 @@ pPrintModuleAndCheck conf inlineConf anns parsedModule = do parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text) parsePrintModuleTests conf filename input = do let inputStr = Text.unpack input - parseResult <- parseModuleFromString + parseResult <- Parsing.parseModuleFromString (conf & _conf_forward & _options_ghc & runIdentity) filename (const . pure $ Right ()) inputStr case parseResult of - Left err -> return $ Left err - Right (anns, parsedModule, _) -> runExceptT $ do + Left err -> return $ Left err + Right (parsedModule, _) -> runExceptT $ do (inlineConf, perItemConf) <- - case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of - Left err -> throwE $ "error in inline config: " ++ show err - Right x -> pure x + mapExceptT + (fmap (bimap (\(a, _) -> "when parsing inline config: " ++ a) id)) + $ extractCommentConfigs (\_ -> pure ()) parsedModule let moduleConf = cZipWith fromOptionIdentity conf inlineConf - let - omitCheck = - conf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack + let omitCheck = + conf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (errs, ltext) <- if omitCheck - then return $ pPrintModule moduleConf perItemConf anns parsedModule - else lift - $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule + then lift $ processModule (TraceFunc $ \_ -> pure ()) + moduleConf + perItemConf + parsedModule + else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ()) + moduleConf + perItemConf + parsedModule if null errs then pure $ TextL.toStrict $ ltext - else - let - errStrs = errs <&> \case - ErrorInput str -> str - ErrorUnusedComment str -> str - LayoutWarning str -> str - ErrorUnknownNode str _ -> str - ErrorMacroConfig str _ -> "when parsing inline config: " ++ str - ErrorOutputCheck -> "Output is not syntactically valid." - in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs - + else throwE + $ "pretty printing error(s):\n" + ++ List.unlines (errorToString <$> errs) + where + errorToString :: BrittanyError -> String + errorToString = \case + ErrorInput str -> str + ErrorUnusedComment _ -> "ErrorUnusedComment" + ErrorUnusedComments _ _ _ -> "ErrorUnusedComments" + LayoutWarning str -> str + ErrorUnknownNode str _ -> str + ErrorMacroConfig str _ -> "when parsing inline config: " ++ str + ErrorOutputCheck -> "Output is not syntactically valid." -- this approach would for if there was a pure GHC.parseDynamicFilePragma. -- Unfortunately that does not exist yet, so we cannot provide a nominally -- pure interface. @@ -453,142 +230,7 @@ parsePrintModuleTests conf filename input = do -- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs -- else return $ TextL.toStrict $ Text.Builder.toLazyText out -toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a -toLocal conf anns m = do - (x, write) <- - lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m - MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) - pure x -ppModule :: GenLocated SrcSpan HsModule -> PPM () -ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do - defaultAnns <- do - anns <- mAsk - let annKey = 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 - - post <- ppPreamble lmod - decls `forM_` \decl -> do - let declAnnKey = ExactPrint.mkAnnKey decl - let declBindingNames = getDeclBindingNames decl - inlineConf <- mAsk - let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf - let - mBindingConfs = - declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf - filteredAnns <- mAsk <&> \annMap -> - Map.union defaultAnns $ Map.findWithDefault Map.empty declAnnKey annMap - - traceIfDumpConf - "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns - - config <- mAsk - - let - config' = cZipWith fromOptionIdentity config - $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) - - let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack - toLocal config' filteredAnns $ do - bd <- if exactprintOnly - then briDocMToPPM $ briDocByExactNoComment decl - else do - (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl - mTell debugs - mTell errs - if null errs - then pure r - else briDocMToPPM $ briDocByExactNoComment decl - layoutBriDoc bd - - 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) - _ -> return () - -getDeclBindingNames :: LHsDecl GhcPs -> [String] -getDeclBindingNames (L _ decl) = case decl of - SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) - ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] - - --- Prints the information associated with the module annotation --- This includes the imports -ppPreamble - :: GenLocated SrcSpan HsModule - -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -ppPreamble lmod@(L loc m@HsModule{}) = do - filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.mkAnnKey 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 - -- attached annotations that come after the module's where - -- from the module node - config <- mAsk - let - shouldReformatPreamble = - config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack - - let - (filteredAnns', post) = - case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of - Nothing -> (filteredAnns, []) - Just mAnn -> - let - modAnnsDp = ExactPrint.annsDP mAnn - isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False - isEof (ExactPrint.AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp - (pre, post') = case (whereInd, eofInd) of - (Nothing, Nothing) -> ([], modAnnsDp) - (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 } - filteredAnns'' = - Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns - in (filteredAnns'', post') - traceIfDumpConf - "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns' - - if shouldReformatPreamble - then toLocal config filteredAnns' $ withTransformedAnns lmod $ do - briDoc <- briDocMToPPM $ layoutModule lmod - layoutBriDoc briDoc - else - let emptyModule = L loc m { hsmodDecls = [] } - in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule - return post _sigHead :: Sig GhcPs -> String _sigHead = \case @@ -600,86 +242,7 @@ _bindHead :: HsBind GhcPs -> String _bindHead = \case FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) PatBind _ _pat _ ([], []) -> "PatBind smth" - _ -> "unknown bind" + _ -> "unknown bind" -layoutBriDoc :: BriDocNumbered -> PPMLocal () -layoutBriDoc briDoc = do - -- first step: transform the briDoc. - briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do - -- Note that briDoc is BriDocNumbered, but state type is BriDoc. - -- That's why the alt-transform looks a bit special here. - traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw - $ briDocToDoc - $ unwrapBriDocNumbered - $ briDoc - -- bridoc transformation: remove alts - transformAlts briDoc >>= mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt - -- bridoc transformation: float stuff in - mGet >>= transformSimplifyFloating .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf - "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating - -- bridoc transformation: par removal - mGet >>= transformSimplifyPar .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par - -- bridoc transformation: float stuff in - mGet >>= transformSimplifyColumns .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns - -- bridoc transformation: indent - mGet >>= transformSimplifyIndent .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final - -- -- convert to Simple type - -- simpl <- mGet <&> transformToSimple - -- return simpl - - anns :: ExactPrint.Anns <- mAsk - - let - state = LayoutState - { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left - -- here because moveToAnn stuff - -- of the first node needs to do - -- its thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = anns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 - } - - state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - - let - 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 - ] - remainingComments - `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) - - return $ () diff --git a/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs b/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs new file mode 100644 index 0000000..3d0cf07 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +module Language.Haskell.Brittany.Internal.Components.BriDoc where + +import Language.Haskell.Brittany.Internal.Prelude + +import Data.Generics.Uniplate.Direct as Uniplate +import qualified Data.Data +import GHC (RealSrcLoc, LEpaComment) + + + +-- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot +-- of transformations on `BriDocF Identity`s and it is really annoying to +-- `Identity`/`runIdentity` everywhere. +data BriDoc + = -- BDWrapAnnKey AnnKey BriDoc + BDEmpty + | BDLit !Text + | BDSeq [BriDoc] -- elements other than the last should + -- not contains BDPars. + | BDCols ColSig [BriDoc] -- elements other than the last + -- should not contains BDPars + | BDSeparator -- semantically, space-unless-at-end-of-line. + | BDAddBaseY BrIndent BriDoc + | BDBaseYPushCur BriDoc + | BDBaseYPop BriDoc + | BDIndentLevelPushCur BriDoc + | BDIndentLevelPop BriDoc + | BDPar + { _bdpar_indent :: BrIndent + , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars + , _bdpar_indented :: BriDoc + } + -- | BDAddIndent BrIndent (BriDocF f) + -- | BDNewline + | BDAlt [BriDoc] + | BDForwardLineMode BriDoc + | BDExternal -- AnnKey + -- (Set AnnKey) -- set of annkeys contained within the node + -- -- to be printed via exactprint + Bool -- should print extra comment ? + Text + | BDPlain !Text -- used for QuasiQuotes, content can be multi-line + -- (contrast to BDLit) + | BDQueueComments [LEpaComment] BriDoc + -- queue to be later flushed when the markers are reached + | BDFlushCommentsPrior RealSrcLoc BriDoc + -- process comments before loc from the queue + | BDFlushCommentsPost RealSrcLoc BriDoc + -- process comments before loc from the queue, but flow to end of + -- child-nodes + | BDLines [BriDoc] + | BDEnsureIndent BrIndent BriDoc + -- the following constructors are only relevant for the alt transformation + -- and are removed afterwards. They should never occur in any BriDoc + -- after the alt transformation. + | BDForceMultiline BriDoc + | BDForceSingleline BriDoc + | BDNonBottomSpacing Bool BriDoc + | BDSetParSpacing BriDoc + | BDForceParSpacing BriDoc + -- pseudo-deprecated + | BDDebug String BriDoc + deriving (Data.Data.Data, Eq, Ord) + +data BriDocF f + = -- BDWrapAnnKey AnnKey BriDoc + BDFEmpty + | BDFLit !Text + | BDFSeq [f (BriDocF f)] -- elements other than the last should + -- not contains BDPars. + | BDFCols ColSig [f (BriDocF f)] -- elements other than the last + -- should not contains BDPars + | BDFSeparator -- semantically, space-unless-at-end-of-line. + | BDFAddBaseY BrIndent (f (BriDocF f)) + | BDFBaseYPushCur (f (BriDocF f)) + | BDFBaseYPop (f (BriDocF f)) + | BDFIndentLevelPushCur (f (BriDocF f)) + | BDFIndentLevelPop (f (BriDocF f)) + | BDFPar + { _bdfpar_indent :: BrIndent + , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars + , _bdfpar_indented :: f (BriDocF f) + } + -- | BDAddIndent BrIndent (BriDocF f) + -- | BDNewline + | BDFAlt [f (BriDocF f)] + | BDFForwardLineMode (f (BriDocF f)) + | BDFExternal -- AnnKey + -- (Set AnnKey) -- set of annkeys contained within the node + -- -- to be printed via exactprint + Bool -- should print extra comment ? + Text + | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line + -- (contrast to BDLit) + | BDFQueueComments [LEpaComment] (f (BriDocF f)) + -- ^ true = comments will be left in the queue when the node is left + | BDFFlushCommentsPrior RealSrcLoc (f (BriDocF f)) + -- process comments before loc from the queue + | BDFFlushCommentsPost RealSrcLoc (f (BriDocF f)) + -- process comments before loc from the queue, but flow to end of + -- child-nodes + | BDFLines [(f (BriDocF f))] + | BDFEnsureIndent BrIndent (f (BriDocF f)) + | BDFForceMultiline (f (BriDocF f)) + | BDFForceSingleline (f (BriDocF f)) + | BDFNonBottomSpacing Bool (f (BriDocF f)) + | BDFSetParSpacing (f (BriDocF f)) + | BDFForceParSpacing (f (BriDocF f)) + | BDFDebug String (f (BriDocF f)) + +data BrIndent = BrIndentNone + | BrIndentRegular + | BrIndentSpecial Int + deriving (Eq, Ord, Data.Data.Data, Show) + +-- deriving instance Data.Data.Data (BriDocF Identity) +deriving instance Data.Data.Data (BriDocF ((,) Int)) + +type BriDocFInt = BriDocF ((,) Int) +type BriDocNumbered = (Int, BriDocFInt) + +instance Uniplate.Uniplate BriDoc where + uniplate x@BDEmpty{} = plate x + uniplate x@BDLit{} = plate x + uniplate (BDSeq list ) = plate BDSeq ||* list + uniplate (BDCols sig list) = plate BDCols |- sig ||* list + uniplate x@BDSeparator = plate x + uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented + uniplate (BDAlt alts ) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd + uniplate x@BDExternal{} = plate x + uniplate x@BDPlain{} = plate x + uniplate (BDQueueComments comms bd) = + plate BDQueueComments |- comms |* bd + uniplate (BDFlushCommentsPrior loc bd) = + plate BDFlushCommentsPrior |- loc |* bd + uniplate (BDFlushCommentsPost loc bd) = + plate BDFlushCommentsPost |- loc |* bd + uniplate (BDLines lines ) = plate BDLines ||* lines + uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd + uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd + uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd + uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd + uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd + +-- this might not work. is not used anywhere either. +briDocSeqSpine :: BriDoc -> () +briDocSeqSpine = \case + BDEmpty -> () + BDLit _t -> () + BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list + BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list + BDSeparator -> () + BDAddBaseY _ind bd -> briDocSeqSpine bd + BDBaseYPushCur bd -> briDocSeqSpine bd + BDBaseYPop bd -> briDocSeqSpine bd + BDIndentLevelPushCur bd -> briDocSeqSpine bd + BDIndentLevelPop bd -> briDocSeqSpine bd + BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented + BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts + BDForwardLineMode bd -> briDocSeqSpine bd + BDExternal{} -> () + BDPlain{} -> () + BDQueueComments _comms bd -> briDocSeqSpine bd + BDFlushCommentsPrior _loc bd -> briDocSeqSpine bd + BDFlushCommentsPost _loc bd -> briDocSeqSpine bd + BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines + BDEnsureIndent _ind bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing _ bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd + BDDebug _s bd -> briDocSeqSpine bd + +briDocForceSpine :: BriDoc -> BriDoc +briDocForceSpine bd = briDocSeqSpine bd `seq` bd + +isNotEmpty :: BriDoc -> Bool +isNotEmpty BDEmpty = False +isNotEmpty _ = True + +-- TODO: rename to "dropLabels" ? +unwrapBriDocNumbered :: BriDocNumbered -> BriDoc +unwrapBriDocNumbered tpl = case snd tpl of + BDFEmpty -> BDEmpty + BDFLit t -> BDLit t + BDFSeq list -> BDSeq $ rec <$> list + BDFCols sig list -> BDCols sig $ rec <$> list + BDFSeparator -> BDSeparator + BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd + BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd + BDFBaseYPop bd -> BDBaseYPop $ rec bd + BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd + BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd + BDFPar ind line indented -> BDPar ind (rec line) (rec indented) + BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen + BDFForwardLineMode bd -> BDForwardLineMode $ rec bd + BDFExternal c t -> BDExternal c t + BDFPlain t -> BDPlain t + BDFQueueComments comms bd -> BDQueueComments comms $ rec bd + BDFFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc $ rec bd + BDFFlushCommentsPost loc bd -> BDFlushCommentsPost loc $ rec bd + BDFLines lines -> BDLines $ rec <$> lines + BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd + where rec = unwrapBriDocNumbered + +data ColSig + = ColTyOpPrefix + -- any prefixed operator/paren/"::"/.. + -- expected to have exactly two colums. + -- e.g. ":: foo" + -- 111222 + -- "-> bar asd asd" + -- 11122222222222 + | ColPatternsFuncPrefix + -- pattern-part of the lhs, e.g. "func (foo a b) c _". + -- Has variable number of columns depending on the number of patterns. + | ColPatternsFuncInfix + -- pattern-part of the lhs, e.g. "Foo a <> Foo b". + -- Has variable number of columns depending on the number of patterns. + | ColPatterns + | ColCasePattern + | ColBindingLine (Maybe Text) + -- e.g. "func pat pat = expr" + -- 1111111111111222222 + -- or "pat | stmt -> expr" + -- 111111111112222222 + -- expected to have exactly two columns. + | ColGuard + -- e.g. "func pat pat | cond = ..." + -- 11111111111112222222 + -- or "pat | cond1, cond2 -> ..." + -- 1111222222222222222 + -- expected to have exactly two columns + | ColGuardedBody + -- e.g. | foofoo = 1 + -- | bar = 2 + -- 111111111222 + -- expected to have exactly two columns + | ColBindStmt + | ColDoLet -- the non-indented variant + | ColRec + | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? + | ColRecDecl + | ColListComp + | ColList + | ColApp Text + | ColTuple + | ColTuples + | ColOpPrefix -- merge with ColList ? other stuff? + | ColImport + + -- TODO + deriving (Eq, Ord, Data.Data.Data, Show) diff --git a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Components/Obfuscation.hs similarity index 95% rename from source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs rename to source/library/Language/Haskell/Brittany/Internal/Components/Obfuscation.hs index c1bd60a..97dd0b2 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Components/Obfuscation.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Obfuscation where +module Language.Haskell.Brittany.Internal.Components.Obfuscation where import Data.Char import qualified Data.Map as Map @@ -8,7 +8,6 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified GHC.OldList as List import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import System.Random diff --git a/source/library/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs similarity index 93% rename from source/library/Language/Haskell/Brittany/Internal/Config.hs rename to source/library/Language/Haskell/Brittany/Internal/Config/Config.hs index 040320b..7229129 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Config where +module Language.Haskell.Brittany.Internal.Config.Config where import qualified Data.Bool as Bool import qualified Data.ByteString as ByteString @@ -13,9 +13,8 @@ import qualified Data.Semigroup as Semigroup import qualified Data.Yaml import qualified GHC.OldList as List import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config.Types.Instances () +-- import Language.Haskell.Brittany.Internal.Config.Types.Instances () import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Utils import qualified System.Console.CmdArgs.Explicit as CmdArgs import qualified System.Directory @@ -208,7 +207,9 @@ cmdlineConfigParser = do -- If the second parameter is True and the file does not exist, writes the -- staticDefaultConfig to the file. readConfig - :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Maybe)) + :: (MonadIO m, Data.Yaml.FromJSON (CConfig Maybe)) + => System.IO.FilePath + -> MaybeT m (Maybe (CConfig Maybe)) readConfig path = do -- TODO: probably should catch IOErrors and then omit the existence check. exists <- liftIO $ System.Directory.doesFileExist path @@ -230,7 +231,9 @@ readConfig path = do -- | Looks for a user-global config file and return its path. -- If there is no global config in a system, one will be created. -userConfigPath :: IO System.IO.FilePath +userConfigPath + :: (Data.Yaml.ToJSON (CConfig Maybe), CFunctor CConfig) + => IO System.IO.FilePath userConfigPath = do userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" @@ -257,7 +260,11 @@ findLocalConfigPath dir = do -- | Reads specified configs. readConfigs - :: CConfig Maybe -- ^ Explicit options, take highest priority + :: ( Data.Yaml.FromJSON (CConfig Maybe) + , Monoid (CConfig Maybe) + , CZipWith CConfig + ) + => CConfig Maybe -- ^ Explicit options, take highest priority -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do @@ -270,19 +277,29 @@ readConfigs cmdlineConfig configPaths = do -- | Reads provided configs -- but also applies the user default configuration (with lowest priority) readConfigsWithUserConfig - :: CConfig Maybe -- ^ Explicit options, take highest priority + :: ( Data.Yaml.ToJSON (CConfig Maybe) + , Data.Yaml.FromJSON (CConfig Maybe) + , Monoid (CConfig Maybe) + , CFunctor CConfig + , CZipWith CConfig + ) + => CConfig Maybe -- ^ Explicit options, take highest priority -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first -> MaybeT IO Config readConfigsWithUserConfig cmdlineConfig configPaths = do defaultPath <- liftIO $ userConfigPath readConfigs cmdlineConfig (configPaths ++ [defaultPath]) -writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m () +writeDefaultConfig + :: (MonadIO m, Data.Yaml.ToJSON (CConfig Maybe), CFunctor CConfig) + => System.IO.FilePath + -> m () writeDefaultConfig path = liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap (Just . runIdentity) staticDefaultConfig -showConfigYaml :: Config -> String +showConfigYaml + :: (Data.Yaml.ToJSON (CConfig Maybe), CFunctor CConfig) => Config -> String showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap (\(Identity x) -> Just x) diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/InlineParsing.hs b/source/library/Language/Haskell/Brittany/Internal/Config/InlineParsing.hs new file mode 100644 index 0000000..c4c5c27 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Config/InlineParsing.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Config.InlineParsing + ( extractCommentConfigs + ) +where + +import Language.Haskell.Brittany.Internal.Prelude + +import qualified Data.ByteString.Char8 +import Data.Char ( isSpace ) +import qualified Data.Map as Map +import qualified Data.Yaml +import qualified GHC +import GHC ( EpaComment(EpaComment) + , GenLocated(L) + ) +import qualified GHC.OldList as List +import GHC.Parser.Annotation ( EpaCommentTok + ( EpaBlockComment + , EpaLineComment + ) + ) +import qualified UI.Butcher.Monadic as Butcher +-- import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils +import Control.Monad.Trans.Except + +import Language.Haskell.Brittany.Internal.Config.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Util.AST +import Language.Haskell.Brittany.Internal.Config.Types.Instances1 () +import Language.Haskell.Brittany.Internal.Config.Types.Instances2 () +-- import Language.Haskell.Brittany.Internal.Utils + + + +data InlineConfigTarget + = InlineConfigTargetModule + | InlineConfigTargetNextDecl -- really only next in module + | InlineConfigTargetNextBinding -- by name + | InlineConfigTargetBinding String + +extractCommentConfigs + :: (String -> IO ()) + -> GHC.ParsedSource + -> ExceptT (String, String) IO (CConfig Maybe, PerItemConfig) +extractCommentConfigs _putErrorLn modul = do + let (L _ (GHC.HsModule modAnn _ _ _ _ decls _ _)) = modul + let declMap :: Map GHC.RealSrcSpan [String] + declMap = Map.fromList + [ ( case span of + GHC.RealSrcSpan s _ -> s + GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan" + , getDeclBindingNames decl + ) + | decl <- decls + , let (L (GHC.SrcSpanAnn _ span) _) = decl + ] + let epAnnComms = \case + GHC.EpAnn _ _ (GHC.EpaComments prior) -> prior + GHC.EpAnn _ _ (GHC.EpaCommentsBalanced prior following) -> + prior ++ following + GHC.EpAnnNotUsed -> [] + let gatheredComments = + join + $ epAnnComms modAnn + : [ epAnnComms epAnn | L (GHC.SrcSpanAnn epAnn _) _x <- decls ] + -- gatheredComments `forM_` \comm@(L anchor _) -> do + -- liftIO $ putErrorLn $ showOutputable comm + -- case Map.lookupLE (GHC.anchor anchor) declMap of + -- Nothing -> pure () + -- Just (pos, le) -> do + -- liftIO $ putErrorLn $ " le = " ++ show (toConstr le) ++ " at " ++ show + -- (ExactPrint.Utils.ss2deltaEnd pos (GHC.anchor anchor)) + -- case Map.lookupGE (GHC.anchor anchor) declMap of + -- Nothing -> pure () + -- Just (pos, ge) -> do + -- liftIO $ putErrorLn $ " ge = " ++ show (toConstr ge) ++ " at " ++ show + -- (ExactPrint.Utils.ss2deltaStart (GHC.anchor anchor) pos) + lineConfigs <- sequence + [ case Butcher.runCmdParserSimpleString line2 parser of + Left err -> throwE (err, line2) + Right (target, conf) -> pure $ (GHC.anchor anchr, target, conf) + | L anchr (EpaComment comm _) <- gatheredComments + , Just line1 <- case comm of + EpaLineComment l -> + [ List.stripPrefix "-- BRITTANY" l + <|> List.stripPrefix "--BRITTANY" l + <|> List.stripPrefix "-- brittany" l + <|> List.stripPrefix "--brittany" l + ] + EpaBlockComment l -> + [List.stripPrefix "{- BRITTANY" l >>= stripSuffix "-}"] + _ -> [] + , let line2 = dropWhile isSpace line1 + , ( ("@" `isPrefixOf` line2) + || ("-disable" `isPrefixOf` line2) + || ("-next" `isPrefixOf` line2) + || ("{" `isPrefixOf` line2) + || ("--" `isPrefixOf` line2) + ) + ] + let perModule = foldl' + (<>) + mempty + [ conf | (_, InlineConfigTargetModule, conf) <- lineConfigs ] + let perBinding = Map.fromListWith + (<>) + [ (n, conf) + | (srcSpan, target, conf) <- lineConfigs + , let perBindRes = Map.lookupGT srcSpan declMap + , n <- case target of + InlineConfigTargetBinding s -> [s] + InlineConfigTargetNextBinding | Just (_, names) <- perBindRes -> names + _ -> [] + ] + let perSpan = Map.fromListWith + (<>) + [ (srcSpan, conf) + | (srcSpan, target, conf) <- lineConfigs + , let perBindRes = Map.lookupGT srcSpan declMap + , case target of + InlineConfigTargetNextDecl -> True + InlineConfigTargetNextBinding | Nothing <- perBindRes -> True + _ -> False + ] + + pure + $ ( perModule + , PerItemConfig { _icd_perBinding = perBinding, _icd_perAnchor = perSpan } + ) + where + configParser = Butcher.addAlternatives + [ ( "commandline-config" + , \s -> "-" `isPrefixOf` dropWhile (== ' ') s + , cmdlineConfigParser + ) + , ( "yaml-config-document" + , \s -> "{" `isPrefixOf` dropWhile (== ' ') s + , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") + $ either + (\_ -> Butcher.Failure Nothing) + (\lconf -> Butcher.Success (mempty { _conf_layout = lconf }) "") + . Data.Yaml.decodeEither' + . Data.ByteString.Char8.pack + -- TODO: use some proper utf8 encoder instead? + ) + ] + parser = do -- we will (mis?)use butcher here to parse the inline config + -- line. + let nextDecl = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) + Butcher.addCmd "-next-declaration" nextDecl + Butcher.addCmd "-Next-Declaration" nextDecl + Butcher.addCmd "-NEXT-DECLARATION" nextDecl + let nextBinding = do + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) + Butcher.addCmd "-next-binding" nextBinding + Butcher.addCmd "-Next-Binding" nextBinding + Butcher.addCmd "-NEXT-BINDING" nextBinding + let disableNextBinding = do + Butcher.addCmdImpl + ( InlineConfigTargetNextBinding + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) + Butcher.addCmd "-disable-next-binding" disableNextBinding + Butcher.addCmd "-Disable-Next-Binding" disableNextBinding + Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding + let disableNextDecl = do + Butcher.addCmdImpl + ( InlineConfigTargetNextDecl + , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } + ) + Butcher.addCmd "-disable-next-declaration" disableNextDecl + Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl + Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl + let disableFormatting = do + Butcher.addCmdImpl + ( InlineConfigTargetModule + , mempty { _conf_disable_formatting = pure $ pure True } + ) + Butcher.addCmd "-disable" disableFormatting + Butcher.addCmd "@" $ do + -- Butcher.addCmd "module" $ do + -- conf <- configParser + -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) + Butcher.addNullCmd $ do + bindingName <- Butcher.addParamString "BINDING" mempty + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) + conf <- configParser + Butcher.addCmdImpl (InlineConfigTargetModule, conf) diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs index 0f0075a..6779a05 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -7,19 +7,16 @@ module Language.Haskell.Brittany.Internal.Config.Types where -import Data.CZipWith import Data.Coerce (Coercible, coerce) import Data.Data (Data) import qualified Data.Semigroup as Semigroup -import Data.Semigroup (Last) -import Data.Semigroup.Generic import GHC.Generics +import GHC (RealSrcSpan) import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils () -confUnpack :: Coercible a b => Identity a -> b +confUnpack :: forall b a . Coercible a b => Identity a -> b confUnpack (Identity x) = coerce x data CDebugConfig f = DebugConfig @@ -196,74 +193,10 @@ type ForwardOptions = CForwardOptions Identity type ErrorHandlingConfig = CErrorHandlingConfig Identity type Config = CConfig Identity --- i wonder if any Show1 stuff could be leveraged. -deriving instance Show (CDebugConfig Identity) -deriving instance Show (CLayoutConfig Identity) -deriving instance Show (CErrorHandlingConfig Identity) -deriving instance Show (CForwardOptions Identity) -deriving instance Show (CPreProcessorConfig Identity) -deriving instance Show (CConfig Identity) - -deriving instance Show (CDebugConfig Maybe) -deriving instance Show (CLayoutConfig Maybe) -deriving instance Show (CErrorHandlingConfig Maybe) -deriving instance Show (CForwardOptions Maybe) -deriving instance Show (CPreProcessorConfig Maybe) -deriving instance Show (CConfig Maybe) - -deriving instance Data (CDebugConfig Identity) -deriving instance Data (CLayoutConfig Identity) -deriving instance Data (CErrorHandlingConfig Identity) -deriving instance Data (CForwardOptions Identity) -deriving instance Data (CPreProcessorConfig Identity) -deriving instance Data (CConfig Identity) - -deriving instance Data (CDebugConfig Maybe) -deriving instance Data (CLayoutConfig Maybe) -deriving instance Data (CErrorHandlingConfig Maybe) -deriving instance Data (CForwardOptions Maybe) -deriving instance Data (CPreProcessorConfig Maybe) -deriving instance Data (CConfig Maybe) - -instance Semigroup.Semigroup (CDebugConfig Maybe) where - (<>) = gmappend -instance Semigroup.Semigroup (CLayoutConfig Maybe) where - (<>) = gmappend -instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where - (<>) = gmappend -instance Semigroup.Semigroup (CForwardOptions Maybe) where - (<>) = gmappend -instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where - (<>) = gmappend -instance Semigroup.Semigroup (CConfig Maybe) where - (<>) = gmappend - -instance Semigroup.Semigroup (CDebugConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CLayoutConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CForwardOptions Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CPreProcessorConfig Identity) where - (<>) = gmappend -instance Semigroup.Semigroup (CConfig Identity) where - (<>) = gmappend - -instance Monoid (CDebugConfig Maybe) where - mempty = gmempty -instance Monoid (CLayoutConfig Maybe) where - mempty = gmempty -instance Monoid (CErrorHandlingConfig Maybe) where - mempty = gmempty -instance Monoid (CForwardOptions Maybe) where - mempty = gmempty -instance Monoid (CPreProcessorConfig Maybe) where - mempty = gmempty -instance Monoid (CConfig Maybe) where - mempty = gmempty - +data PerItemConfig = PerItemConfig + { _icd_perBinding :: Map String (CConfig Maybe) + , _icd_perAnchor :: Map RealSrcSpan (CConfig Maybe) + } data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more -- than old indentation + amount @@ -322,17 +255,3 @@ data ExactPrintFallbackMode -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF -- A PROGRAM BY TRANSFORMING IT. deriving (Show, Generic, Data) - -deriveCZipWith ''CDebugConfig -deriveCZipWith ''CLayoutConfig -deriveCZipWith ''CErrorHandlingConfig -deriveCZipWith ''CForwardOptions -deriveCZipWith ''CPreProcessorConfig -deriveCZipWith ''CConfig - -instance CFunctor CDebugConfig -instance CFunctor CLayoutConfig -instance CFunctor CErrorHandlingConfig -instance CFunctor CForwardOptions -instance CFunctor CPreProcessorConfig -instance CFunctor CConfig diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances1.hs similarity index 98% rename from source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs rename to source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances1.hs index c667038..31f9242 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances1.hs @@ -13,10 +13,12 @@ {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fignore-interface-pragmas #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} -module Language.Haskell.Brittany.Internal.Config.Types.Instances where + +module Language.Haskell.Brittany.Internal.Config.Types.Instances1 where import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Types as Aeson diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances2.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances2.hs new file mode 100644 index 0000000..100c5d2 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances2.hs @@ -0,0 +1,102 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} + + +module Language.Haskell.Brittany.Internal.Config.Types.Instances2 where + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import qualified Data.Semigroup as Semigroup +import Data.Semigroup.Generic +import Data.CZipWith +import Data.Data(Data) + + + +-- i wonder if any Show1 stuff could be leveraged. +deriving instance Show (CDebugConfig Identity) +deriving instance Show (CLayoutConfig Identity) +deriving instance Show (CErrorHandlingConfig Identity) +deriving instance Show (CForwardOptions Identity) +deriving instance Show (CPreProcessorConfig Identity) +deriving instance Show (CConfig Identity) + +deriving instance Show (CDebugConfig Maybe) +deriving instance Show (CLayoutConfig Maybe) +deriving instance Show (CErrorHandlingConfig Maybe) +deriving instance Show (CForwardOptions Maybe) +deriving instance Show (CPreProcessorConfig Maybe) +deriving instance Show (CConfig Maybe) + +instance Semigroup.Semigroup (CDebugConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CLayoutConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CForwardOptions Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (CConfig Maybe) where + (<>) = gmappend + +instance Semigroup.Semigroup (CDebugConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CLayoutConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CForwardOptions Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CPreProcessorConfig Identity) where + (<>) = gmappend +instance Semigroup.Semigroup (CConfig Identity) where + (<>) = gmappend + +instance Monoid (CDebugConfig Maybe) where + mempty = gmempty +instance Monoid (CLayoutConfig Maybe) where + mempty = gmempty +instance Monoid (CErrorHandlingConfig Maybe) where + mempty = gmempty +instance Monoid (CForwardOptions Maybe) where + mempty = gmempty +instance Monoid (CPreProcessorConfig Maybe) where + mempty = gmempty +instance Monoid (CConfig Maybe) where + mempty = gmempty + +deriveCZipWith ''CDebugConfig +deriveCZipWith ''CLayoutConfig +deriveCZipWith ''CErrorHandlingConfig +deriveCZipWith ''CForwardOptions +deriveCZipWith ''CPreProcessorConfig +deriveCZipWith ''CConfig + +instance CFunctor CDebugConfig +instance CFunctor CLayoutConfig +instance CFunctor CErrorHandlingConfig +instance CFunctor CForwardOptions +instance CFunctor CPreProcessorConfig +instance CFunctor CConfig + +deriving instance Data PerItemConfig + +deriving instance Data (CDebugConfig Identity) +deriving instance Data (CLayoutConfig Identity) +deriving instance Data (CErrorHandlingConfig Identity) +deriving instance Data (CForwardOptions Identity) +deriving instance Data (CPreProcessorConfig Identity) +deriving instance Data (CConfig Identity) + +deriving instance Data (CDebugConfig Maybe) +deriving instance Data (CLayoutConfig Maybe) +deriving instance Data (CErrorHandlingConfig Maybe) +deriving instance Data (CForwardOptions Maybe) +deriving instance Data (CPreProcessorConfig Maybe) +deriving instance Data (CConfig Maybe) diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs deleted file mode 100644 index 63d6b53..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal.ExactPrintUtils where - -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import Data.Data -import qualified Data.Foldable as Foldable -import qualified Data.Generics as SYB -import Data.HList.HList -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import GHC (GenLocated(L)) -import qualified GHC hiding (parseModule) -import qualified GHC.Driver.CmdLine as GHC -import GHC.Hs -import qualified GHC.Types.SrcLoc as GHC -import GHC.Types.SrcLoc (Located, SrcSpan) -import Language.Haskell.Brittany.Internal.Config.Types -import qualified Language.Haskell.Brittany.Internal.ParseModule as ParseModule -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified System.IO - - - -parseModule - :: [String] - -> System.IO.FilePath - -> (GHC.DynFlags -> IO (Either String a)) - -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModule args fp dynCheck = do - str <- System.IO.readFile fp - parseModuleFromString args fp dynCheck str - -parseModuleFromString - :: [String] - -> System.IO.FilePath - -> (GHC.DynFlags -> IO (Either String a)) - -> String - -> IO (Either String (ExactPrint.Anns, 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 - - --- TODO: this is unused by now, but it contains one detail that --- commentAnnFixTransformGlob does not include: Moving of comments for --- "RecordUpd"s. --- 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 GhcPs) -> ExactPrint.Transform () --- exprF lexpr@(L _ expr) = case expr of --- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ --- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> --- #else --- RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> --- #endif --- moveTrailingComments lexpr (List.last fs) --- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ --- RecordUpd _ _e fs@(_:_) -> --- #else --- RecordUpd _e fs@(_:_) _cons _ _ _ -> --- #endif --- moveTrailingComments lexpr (List.last fs) --- _ -> return () - --- 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 GhcPs) -> ExactPrint.Transform () --- exprF lexpr@(L _ expr) = case expr of --- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> --- moveTrailingComments lexpr (List.last fs) --- RecordUpd _ _e 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 --- 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 breakEither (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 - --- | 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 -extractToplevelAnns lmod anns = output - where - (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod - declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey - declMap1 = Map.unions $ ldecls <&> \ldecl -> - Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) - declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey - declMap2 = - Map.fromList - $ [ (captured, declMap1 Map.! k) - | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns - ] - declMap = declMap1 `Map.union` declMap2 - modKey = ExactPrint.mkAnnKey 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) -groupMap f = Map.foldlWithKey' - (\m k a -> Map.alter (insert k a) (f k a) m) - Map.empty - where - 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 ast = SYB.everything - Set.union - (\x -> maybe - Set.empty - Set.singleton - [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x - | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) - , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x - ] - -- for some reason, ghc-8.8 has forgotten how to infer the type of l, - -- even though it is passed to mkAnnKey above, which only accepts - -- SrcSpan. - ) - ast - 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 -withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case - readers@(conf :+: anns :+: HNil) -> do - -- TODO: implement `local` for MultiReader/MultiRWS - MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) - x <- m - MultiRWSS.mPutRawR readers - pure x - where - f anns = - let - ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced - - -warnExtractorCompat :: GHC.Warn -> String -warnExtractorCompat (GHC.Warn _ (L _ s)) = s diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs deleted file mode 100644 index 136468e..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ /dev/null @@ -1,781 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.LayouterBasics where - -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Control.Monad.Writer.Strict as Writer -import qualified Data.Char as Char -import Data.Data -import qualified Data.Map as Map -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -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 qualified GHC.OldList as List -import GHC.Parser.Annotation (AnnKeywordId(..)) -import GHC.Types.Name (getOccString) -import GHC.Types.Name.Occurrence (occNameString) -import GHC.Types.Name.Reader (RdrName(..)) -import qualified GHC.Types.SrcLoc as GHC -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -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 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 -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) -import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils - - - -processDefault - :: ( ExactPrint.Annotate.Annotate 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 - -- 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. - -- TODO: instead the appropriate annotation could be removed when "cleaning" - -- the module (header). This would remove the need for this hack! - case str of - "\n" -> return () - _ -> mTell $ Text.Builder.fromString str - --- | Use ExactPrint's output for this node; add a newly generated inline comment --- at insertion position (meant to point out to the user that this node is --- 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 - -> ToBriDocM BriDocNumbered -briDocByExact ast = do - anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (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 --- by ExactPrint might be different, and even incompatible with the indentation --- 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 - -> ToBriDocM BriDocNumbered -briDocByExactNoComment ast = do - anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (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) - => String - -> Located ast - -> ToBriDocM BriDocNumbered -briDocByExactInlineOnly infoStr ast = do - anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (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) - False - t - let - errorAction = do - mTell [ErrorUnknownNode infoStr ast] - docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" - case (fallbackMode, Text.lines exactPrinted) of - (ExactPrintFallbackModeNever, _) -> errorAction - (_, [t]) -> exactPrintNode - (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) - (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted - _ -> errorAction - -rdrNameToText :: RdrName -> Text --- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr -rdrNameToText (Unqual occname) = Text.pack $ occNameString occname -rdrNameToText (Qual mname occname) = - Text.pack $ moduleNameString mname ++ "." ++ occNameString occname -rdrNameToText (Orig modul occname) = - Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname -rdrNameToText (Exact name) = Text.pack $ getOccString name - -lrdrNameToText :: GenLocated l RdrName -> Text -lrdrNameToText (L _ n) = rdrNameToText n - -lrdrNameToTextAnnGen - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => (Text -> Text) - -> Located RdrName - -> m Text -lrdrNameToTextAnnGen f ast@(L _ n) = do - anns <- mAsk - let t = f $ rdrNameToText n - let - 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 - Nothing -> t - 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 - -lrdrNameToTextAnn - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => Located RdrName - -> m Text -lrdrNameToTextAnn = lrdrNameToTextAnnGen id - -lrdrNameToTextAnnTypeEqualityIsSpecial - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => Located RdrName - -> m Text -lrdrNameToTextAnnTypeEqualityIsSpecial ast = do - let - f x = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x - lrdrNameToTextAnnGen f ast - --- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects --- the annotations for a (parent) node for a tick to be added to the --- literal. --- Excessively long name to reflect on us having to work around such --- excessively obscure special cases in the exactprint API. -lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick - :: ( Data ast - , MonadMultiReader Config m - , MonadMultiReader (Map AnnKey Annotation) m - ) - => Located ast - -> Located RdrName - -> m Text -lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do - hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote - x <- lrdrNameToTextAnn ast2 - let - lit = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x - return $ if hasQuote then Text.cons '\'' lit else lit - -askIndent :: (MonadMultiReader Config m) => m Int -askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk - - -extractAllComments - :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] -extractAllComments ann = - ExactPrint.annPriorComments ann ++ extractRestComments ann - -extractRestComments - :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] -extractRestComments ann = - 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) - --- | 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 ast@(L l _) = - List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l) - <$> astConnectedComments ast - -hasCommentsBetween - :: Data ast - => GHC.Located ast - -> AnnKeywordId - -> AnnKeywordId - -> ToBriDocM Bool -hasCommentsBetween ast leftKey rightKey = do - mAnn <- astAnn ast - let - go1 [] = False - 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 (_ : rest) = go2 rest - case mAnn of - Nothing -> pure False - Just ann -> pure $ go1 $ ExactPrint.annsDP 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 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 ast = - any isRegularComment <$> astConnectedComments ast - --- | Regular comments are comments that are actually "source code comments", --- i.e. things that start with "--" or "{-". In contrast to comment-annotations --- used by ghc-exactprint for capturing symbols (and their exact positioning). --- --- Only the type instance layouter makes use of this filter currently, but --- it might make sense to apply it more aggressively or make it the default - --- 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 - -astConnectedComments - :: Data ast - => GHC.Located ast - -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)] -astConnectedComments ast = do - anns <- filterAnns ast <$> mAsk - pure $ extractAllComments =<< Map.elems anns - -hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsPrior ast = astAnn ast <&> \case - Nothing -> False - Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors - -hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyRegularCommentsRest ast = astAnn ast <&> \case - Nothing -> False - Just ann -> any isRegularComment (extractRestComments ann) - -hasAnnKeywordComment - :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool -hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case - Nothing -> False - Just ann -> any hasK (extractAllComments ann) - where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst - -hasAnnKeyword - :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) - => Located a - -> AnnKeywordId - -> m Bool -hasAnnKeyword ast annKeyword = astAnn ast <&> \case - Nothing -> False - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks - where - hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False - -astAnn - :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) - => GHC.Located ast - -> m (Maybe Annotation) -astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk - --- new BriDoc stuff - -allocateNode - :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered -allocateNode bd = do - i <- allocNodeIndex - return (i, bd) - -allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int -allocNodeIndex = do - NodeAllocIndex i <- mGet - mSet $ NodeAllocIndex (i + 1) - return i - --- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docEmpty = allocateNode BDFEmpty --- --- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered --- docLit t = allocateNode $ BDFLit t --- --- 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) --- (foldedAnnKeys x) --- shouldAddComment --- (Text.pack $ ExactPrint.exactPrint x anns) --- --- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered --- docAlt l = allocateNode . BDFAlt =<< sequence l --- --- --- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered --- docSeq l = allocateNode . BDFSeq =<< sequence l --- --- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered --- docLines l = allocateNode . BDFLines =<< sequence l --- --- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered --- docCols sig l = allocateNode . BDFCols sig =<< sequence l --- --- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered --- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm --- --- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm --- --- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm --- --- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docSeparator = allocateNode BDFSeparator --- --- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered --- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm --- --- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered --- docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm --- --- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm --- --- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- appSep x = docSeq [x, docSeparator] --- --- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docCommaSep = appSep $ docLit $ Text.pack "," --- --- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered --- docParenLSep = appSep $ docLit $ Text.pack "(" --- --- --- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m) --- => Located ast --- -> m BriDocNumbered --- -> m BriDocNumbered --- docPostComment ast bdm = do --- bd <- bdm --- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd --- --- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m) --- => Located ast --- -> m BriDocNumbered --- -> m BriDocNumbered --- docWrapNode ast bdm = do --- bd <- bdm --- i1 <- allocNodeIndex --- i2 <- allocNodeIndex --- return --- $ (,) i1 --- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) --- $ (,) i2 --- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) --- $ bd --- --- docPar :: MonadMultiState NodeAllocIndex m --- => m BriDocNumbered --- -> m BriDocNumbered --- -> m BriDocNumbered --- docPar lineM indentedM = do --- line <- lineM --- indented <- indentedM --- allocateNode $ BDFPar BrIndentNone line indented --- --- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm --- --- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered --- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm --- --- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered --- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd - -docEmpty :: ToBriDocM BriDocNumbered -docEmpty = allocateNode BDFEmpty - -docLit :: Text -> ToBriDocM BriDocNumbered -docLit t = allocateNode $ BDFLit t - -docLitS :: String -> ToBriDocM BriDocNumbered -docLitS s = allocateNode $ BDFLit $ Text.pack s - -docExt - :: (ExactPrint.Annotate.Annotate ast) - => Located ast - -> ExactPrint.Types.Anns - -> Bool - -> ToBriDocM BriDocNumbered -docExt x anns shouldAddComment = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey x) - (foldedAnnKeys x) - shouldAddComment - (Text.pack $ ExactPrint.exactPrint x anns) - -docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docAlt l = allocateNode . BDFAlt =<< sequence l - -newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) - deriving (Functor, Applicative, Monad) - -addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () -addAlternativeCond cond doc = when cond (addAlternative doc) - -addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () -addAlternative = CollectAltM . Writer.tell . (: []) - -runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered -runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action - - -docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docSeq [] = docEmpty -docSeq l = allocateNode . BDFSeq =<< sequence l - -docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docLines l = allocateNode . BDFLines =<< sequence l - -docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered -docCols sig l = allocateNode . BDFCols sig =<< sequence l - -docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm - -docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetBaseY bdm = do - bd <- bdm - -- the order here is important so that these two nodes can be treated - -- properly over at `transformAlts`. - n1 <- allocateNode $ BDFBaseYPushCur bd - n2 <- allocateNode $ BDFBaseYPop n1 - return n2 - -docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetIndentLevel bdm = do - bd <- bdm - n1 <- allocateNode $ BDFIndentLevelPushCur bd - n2 <- allocateNode $ BDFIndentLevelPop n1 - return n2 - -docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetBaseAndIndent = docSetBaseY . docSetIndentLevel - -docSeparator :: ToBriDocM BriDocNumbered -docSeparator = allocateNode BDFSeparator - -docAnnotationPrior - :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationPrior annKey bdm = - allocateNode . BDFAnnotationPrior annKey =<< bdm - -docAnnotationKW - :: AnnKey - -> Maybe AnnKeywordId - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docAnnotationKW annKey kw bdm = - allocateNode . BDFAnnotationKW annKey kw =<< bdm - -docMoveToKWDP - :: AnnKey - -> AnnKeywordId - -> Bool - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docMoveToKWDP annKey kw shouldRestoreIndent bdm = - allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm - -docAnnotationRest - :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm - -docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm - -docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm - -docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm - -docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm - -docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docDebug s bdm = allocateNode . BDFDebug s =<< bdm - -appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -appSep x = docSeq [x, docSeparator] - -docCommaSep :: ToBriDocM BriDocNumbered -docCommaSep = appSep $ docLit $ Text.pack "," - -docParenLSep :: ToBriDocM BriDocNumbered -docParenLSep = appSep docParenL - --- TODO: we don't make consistent use of these (yet). However, I think the --- most readable approach overall might be something else: define --- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`. --- I think those two would make the usage most readable. --- lit "(" and appSep (lit "(") are understandable and short without --- introducing a new top-level binding for all types of parentheses. -docParenL :: ToBriDocM BriDocNumbered -docParenL = docLit $ Text.pack "(" - -docParenR :: ToBriDocM BriDocNumbered -docParenR = docLit $ Text.pack ")" - -docParenHashLSep :: ToBriDocM BriDocNumbered -docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] - -docParenHashRSep :: ToBriDocM BriDocNumbered -docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] - -docBracketL :: ToBriDocM BriDocNumbered -docBracketL = docLit $ Text.pack "[" - -docBracketR :: ToBriDocM BriDocNumbered -docBracketR = docLit $ Text.pack "]" - - -docTick :: ToBriDocM BriDocNumbered -docTick = docLit $ Text.pack "'" - -docNodeAnnKW - :: Data.Data.Data ast - => Located ast - -> Maybe AnnKeywordId - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docNodeAnnKW ast kw bdm = - docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm - -docNodeMoveToKWDP - :: Data.Data.Data ast - => Located ast - -> AnnKeywordId - -> Bool - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = - docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm - -class DocWrapable a where - docWrapNode :: ( Data.Data.Data ast) - => Located ast - -> a - -> a - docWrapNodePrior :: ( Data.Data.Data ast) - => Located ast - -> a - -> a - docWrapNodeRest :: ( Data.Data.Data ast) - => Located ast - -> a - -> a - -instance DocWrapable (ToBriDocM BriDocNumbered) where - docWrapNode ast bdm = do - bd <- bdm - i1 <- allocNodeIndex - i2 <- allocNodeIndex - return - $ (,) i1 - $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) - $ (,) i2 - $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) - $ bd - docWrapNodePrior ast bdm = do - bd <- bdm - i1 <- allocNodeIndex - return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd - docWrapNodeRest ast bdm = do - bd <- bdm - i2 <- allocNodeIndex - return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd - -instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where - docWrapNode ast bdms = case bdms of - [] -> [] - [bd] -> [docWrapNode ast bd] - (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> - [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] - _ -> error "cannot happen (TM)" - docWrapNodePrior ast bdms = case bdms of - [] -> [] - [bd] -> [docWrapNodePrior ast bd] - (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR - docWrapNodeRest ast bdms = case reverse bdms of - [] -> [] - (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR - -instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where - docWrapNode ast bdsm = do - bds <- bdsm - case bds of - [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well. - [bd] -> do - bd' <- docWrapNode ast (return bd) - return [bd'] - (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do - bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) - return $ [bd1'] ++ reverse bdM ++ [bdN'] - _ -> error "cannot happen (TM)" - docWrapNodePrior ast bdsm = do - bds <- bdsm - case bds of - [] -> return [] - (bd1 : bdR) -> do - bd1' <- docWrapNodePrior ast (return bd1) - return (bd1' : bdR) - docWrapNodeRest ast bdsm = do - bds <- bdsm - case reverse bds of - [] -> return [] - (bdN : bdR) -> do - bdN' <- docWrapNodeRest ast (return bdN) - return $ reverse (bdN' : bdR) - -instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where - docWrapNode ast bdsm = do - bds <- bdsm - case Seq.viewl bds of - Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well. - bd1 Seq.:< rest -> case Seq.viewr rest of - Seq.EmptyR -> do - bd1' <- docWrapNode ast (return bd1) - return $ Seq.singleton bd1' - bdM Seq.:> bdN -> do - bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) - return $ (bd1' Seq.<| bdM) Seq.|> bdN' - docWrapNodePrior ast bdsm = do - bds <- bdsm - case Seq.viewl bds of - Seq.EmptyL -> return Seq.empty - bd1 Seq.:< bdR -> do - bd1' <- docWrapNodePrior ast (return bd1) - return $ bd1' Seq.<| bdR - docWrapNodeRest ast bdsm = do - bds <- bdsm - case Seq.viewr bds of - Seq.EmptyR -> return Seq.empty - bdR Seq.:> bdN -> do - bdN' <- docWrapNodeRest ast (return bdN) - return $ bdR Seq.|> bdN' - -instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where - docWrapNode ast stuffM = do - (bds, bd, x) <- stuffM - if null bds - then do - bd' <- docWrapNode ast (return bd) - return (bds, bd', x) - else do - bds' <- docWrapNodePrior ast (return bds) - bd' <- docWrapNodeRest ast (return bd) - return (bds', bd', x) - docWrapNodePrior ast stuffM = do - (bds, bd, x) <- stuffM - bds' <- docWrapNodePrior ast (return bds) - return (bds', bd, x) - docWrapNodeRest ast stuffM = do - (bds, bd, x) <- stuffM - bd' <- docWrapNodeRest ast (return bd) - return (bds, bd', x) - - - -docPar - :: ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docPar lineM indentedM = do - line <- lineM - indented <- indentedM - allocateNode $ BDFPar BrIndentNone line indented - -docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm - -docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm - -docEnsureIndent - :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd - -unknownNodeError - :: Data.Data.Data ast - => String - -> GenLocated GHC.SrcSpan ast - -> ToBriDocM BriDocNumbered -unknownNodeError infoStr ast = do - mTell [ErrorUnknownNode infoStr ast] - docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" - -spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered] -spacifyDocs [] = [] -spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds] - -briDocMToPPM :: ToBriDocM a -> PPMLocal a -briDocMToPPM m = do - (x, errs, debugs) <- briDocMToPPMInner m - mTell debugs - mTell errs - return x - -briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) -briDocMToPPMInner m = do - readers <- MultiRWSS.mGetRawR - let - ((x, errs), debugs) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) - $ MultiRWSS.withMultiReaders readers - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ m - pure (x, errs, debugs) - -docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) -docSharedWrapper f x = return <$> f x diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs deleted file mode 100644 index 138a748..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ /dev/null @@ -1,1086 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Expr where - -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 qualified GHC.Data.FastString as FastString -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic -import GHC.Types.Name -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - - - -layoutExpr :: ToBriDoc HsExpr -layoutExpr lexpr@(L _ expr) = do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - let allowFreeIndent = indentPolicy == IndentPolicyFree - docWrapNode lexpr $ case expr of - HsVar _ vname -> do - docLit =<< lrdrNameToTextAnn vname - HsUnboundVar _ oname -> docLit $ Text.pack $ occNameString oname - HsRecFld{} -> do - -- TODO - briDocByExactInlineOnly "HsRecFld" lexpr - HsOverLabel _ext _reboundFromLabel 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 - HsOverLit _ olit -> do - allocateNode $ overLitValBriDoc $ ol_val olit - HsLit _ lit -> do - allocateNode $ litBriDoc lit - HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) - | pats <- m_pats match - , GRHSs _ [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds{} <- llocals - , L _ (GRHS _ [] body) <- lgrhs - -> do - patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> - fmap return $ do - -- this code could be as simple as `colsWrapPat =<< layoutPat p` - -- if it was not for the following two cases: - -- \ !x -> x - -- \ ~x -> x - -- These make it necessary to special-case an additional separator. - -- (TODO: we create a BDCols here, but then make it ineffective - -- by wrapping it in docSeq below. We _could_ add alignments for - -- stuff like lists-of-lambdas. Nothing terribly important..) - let - shouldPrefixSeparator = case p of - L _ LazyPat{} -> isFirst - L _ BangPat{} -> isFirst - _ -> False - patDocSeq <- layoutPat p - fixed <- case Seq.viewl patDocSeq of - p1 Seq.:< pr | shouldPrefixSeparator -> do - p1' <- docSeq [docSeparator, pure p1] - pure (p1' Seq.<| pr) - _ -> pure patDocSeq - colsWrapPat fixed - bodyDoc <- - docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body - let - funcPatternPartLine = docCols - ColCasePattern - (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) - docAlt - [ -- single line - docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceSingleline bodyDoc - ] - -- double line - , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline - funcPatternPartLine - , docLit $ Text.pack "->" - ] - ) - (docWrapNode lgrhs $ docForceSingleline bodyDoc) - -- wrapped par spacing - , docSetParSpacing $ docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceParSpacing bodyDoc - ] - -- conservative - , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline - funcPatternPartLine - , docLit $ Text.pack "->" - ] - ) - (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) - ] - HsLam{} -> unknownNodeError "HsLam too complex" lexpr - HsLamCase _ (MG _ (L _ []) _) -> do - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ (docLit $ Text.pack "\\case {}") - HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- - docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc - `mapM` matches - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "\\case") - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs - ) - HsApp _ exp1@(L _ HsApp{}) exp2 -> do - let - gather - :: [LHsExpr GhcPs] - -> LHsExpr GhcPs - -> (LHsExpr GhcPs, [LHsExpr GhcPs]) - gather list = \case - L _ (HsApp _ l r) -> gather (r : list) l - x -> (x, list) - let (headE, paramEs) = gather [exp2] exp1 - let - colsOrSequence = case headE of - L _ (HsVar _ (L _ (Unqual occname))) -> - docCols (ColApp $ Text.pack $ occNameString occname) - _ -> docSeq - headDoc <- docSharedWrapper layoutExpr headE - paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs - hasComments <- hasAnyCommentsConnected exp2 - runFilteredAlternative $ do - -- foo x y - addAlternativeCond (not hasComments) - $ colsOrSequence - $ appSep (docForceSingleline headDoc) - : spacifyDocs (docForceSingleline <$> paramDocs) - -- foo x - -- y - addAlternativeCond allowFreeIndent $ docSeq - [ appSep (docForceSingleline headDoc) - , docSetBaseY - $ docAddBaseY BrIndentRegular - $ docLines - $ docForceSingleline - <$> paramDocs - ] - -- foo - -- x - -- y - addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docForceSingleline headDoc) - (docNonBottomSpacing $ docLines paramDocs) - -- ( multi - -- line - -- function - -- ) - -- x - -- y - addAlternative $ docAddBaseY BrIndentRegular $ docPar - headDoc - (docNonBottomSpacing $ docLines paramDocs) - HsApp _ exp1 exp2 -> do - -- TODO: if expDoc1 is some literal, we may want to create a docCols here. - expDoc1 <- docSharedWrapper layoutExpr exp1 - expDoc2 <- docSharedWrapper layoutExpr exp2 - docAlt - [ -- func arg - docSeq - [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] - , -- func argline1 - -- arglines - -- e.g. - -- func Abc - -- { member1 = True - -- , member2 = 13 - -- } - docSetParSpacing -- this is most likely superfluous because - -- this is a sequence of a one-line and a par-space - -- anyways, so it is _always_ par-spaced. - $ docAddBaseY BrIndentRegular - $ docSeq - [appSep $ docForceSingleline expDoc1, docForceParSpacing expDoc2] - , -- func - -- arg - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docForceSingleline expDoc1) - (docNonBottomSpacing expDoc2) - , -- fu - -- nc - -- ar - -- gument - docAddBaseY BrIndentRegular $ docPar expDoc1 expDoc2 - ] - HsAppType _ exp1 (HsWC _ ty1) -> do - t <- docSharedWrapper layoutType ty1 - e <- docSharedWrapper layoutExpr exp1 - docAlt - [ docSeq - [ docForceSingleline e - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline t - ] - , docPar e (docSeq [docLit $ Text.pack "@", t]) - ] - OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do - let - gather - :: [(LHsExpr GhcPs, LHsExpr GhcPs)] - -> LHsExpr GhcPs - -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) - gather opExprList = \case - (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1) : opExprList) l1 - final -> (final, opExprList) - (leftOperand, appList) = gather [] expLeft - leftOperandDoc <- docSharedWrapper layoutExpr leftOperand - appListDocs <- appList `forM` \(x, y) -> - [ (xD, yD) - | xD <- docSharedWrapper layoutExpr x - , yD <- docSharedWrapper layoutExpr y - ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight - allowSinglelinePar <- do - hasComLeft <- hasAnyCommentsConnected expLeft - hasComOp <- hasAnyCommentsConnected expOp - pure $ not hasComLeft && not hasComOp - let - allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - runFilteredAlternative $ do - -- > one + two + three - -- or - -- > one + two + case x of - -- > _ -> three - addAlternativeCond allowSinglelinePar $ docSeq - [ appSep $ docForceSingleline leftOperandDoc - , docSeq $ appListDocs <&> \(od, ed) -> docSeq - [appSep $ docForceSingleline od, appSep $ docForceSingleline ed] - , appSep $ docForceSingleline opLastDoc - , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc - ] - -- this case rather leads to some unfortunate layouting than to anything - -- useful; disabling for now. (it interfers with cols stuff.) - -- addAlternative - -- $ docSetBaseY - -- $ docPar - -- leftOperandDoc - -- ( docLines - -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - -- ) - -- > one - -- > + two - -- > + three - addAlternative $ docPar - leftOperandDoc - (docLines - $ (appListDocs <&> \(od, ed) -> - docCols ColOpPrefix [appSep od, docSetBaseY ed] - ) - ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - ) - OpApp _ expLeft expOp expRight -> do - expDocLeft <- docSharedWrapper layoutExpr expLeft - expDocOp <- docSharedWrapper layoutExpr expOp - expDocRight <- docSharedWrapper layoutExpr expRight - let - allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - let - leftIsDoBlock = case expLeft of - L _ HsDo{} -> True - _ -> False - runFilteredAlternative $ do - -- one-line - addAlternative $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceSingleline expDocRight - ] - -- -- line + freely indented block for right expression - -- addAlternative - -- $ docSeq - -- [ appSep $ docForceSingleline expDocLeft - -- , appSep $ docForceSingleline expDocOp - -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight - -- ] - -- two-line - addAlternative $ do - let - expDocOpAndRight = docForceSingleline $ docCols - ColOpPrefix - [appSep $ expDocOp, docSetBaseY expDocRight] - if leftIsDoBlock - then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight - -- TODO: in both cases, we don't force expDocLeft to be - -- single-line, which has certain.. interesting consequences. - -- At least, the "two-line" label is not entirely - -- accurate. - -- one-line + par - addAlternativeCond allowPar $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceParSpacing expDocRight - ] - -- more lines - addAlternative $ do - let - expDocOpAndRight = - docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] - if leftIsDoBlock - then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight - NegApp _ op _ -> do - opDoc <- docSharedWrapper layoutExpr op - docSeq [docLit $ Text.pack "-", opDoc] - HsPar _ innerExp -> do - innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp - docAlt - [ docSeq - [ docLit $ Text.pack "(" - , docForceSingleline innerExpDoc - , docLit $ Text.pack ")" - ] - , docSetBaseY $ docLines - [ docCols - ColOpPrefix - [ docLit $ Text.pack "(" - , docAddBaseY (BrIndentSpecial 2) innerExpDoc - ] - , docLit $ Text.pack ")" - ] - ] - SectionL _ left op -> do -- TODO: add to testsuite - leftDoc <- docSharedWrapper layoutExpr left - opDoc <- docSharedWrapper layoutExpr op - docSeq [leftDoc, docSeparator, opDoc] - SectionR _ op right -> do -- TODO: add to testsuite - opDoc <- docSharedWrapper layoutExpr op - rightDoc <- docSharedWrapper layoutExpr right - docSeq [opDoc, docSeparator, rightDoc] - ExplicitTuple _ args boxity -> do - let - argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e) - (L _ (Missing NoExtField)) -> (arg, Nothing) - argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> - docWrapNode arg $ maybe docEmpty layoutExpr exprM - hasComments <- - orM - (hasCommentsBetween lexpr AnnOpenP AnnCloseP - : map hasAnyCommentsBelow args - ) - let - (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docParenHashLSep, docParenHashRSep) - case splitFirstLast argDocs of - FirstLastEmpty -> - docSeq [openLit, docNodeAnnKW lexpr (Just AnnOpenP) closeLit] - FirstLastSingleton e -> docAlt - [ docCols - ColTuple - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e - , closeLit - ] - , docSetBaseY $ docLines - [ docSeq - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e - ] - , closeLit - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docCols ColTuple - $ [docSeq [openLit, docForceSingleline e1]] - ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [ docSeq - [ docCommaSep - , docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN) - , closeLit - ] - ] - addAlternative - $ let - start = docCols ColTuples [appSep openLit, e1] - linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] - lineN = docCols - ColTuples - [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] - HsCase _ cExp (MG _ (L _ []) _) -> do - cExpDoc <- docSharedWrapper layoutExpr cExp - docAlt - [ docAddBaseY BrIndentRegular $ docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of {}" - ] - , docPar - (docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docLit $ Text.pack "of {}") - ] - HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do - cExpDoc <- docSharedWrapper layoutExpr cExp - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- - docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc - `mapM` matches - docAlt - [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of" - ] - ) - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs - ) - , docPar - (docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "of") - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs - ) - ) - ] - HsIf _ ifExpr thenExpr elseExpr -> do - ifExprDoc <- docSharedWrapper layoutExpr ifExpr - thenExprDoc <- docSharedWrapper layoutExpr thenExpr - elseExprDoc <- docSharedWrapper layoutExpr elseExpr - hasComments <- hasAnyCommentsBelow lexpr - let - maySpecialIndent = case indentPolicy of - IndentPolicyLeft -> BrIndentRegular - IndentPolicyMultiple -> BrIndentRegular - IndentPolicyFree -> BrIndentSpecial 3 - -- TODO: some of the alternatives (especially last and last-but-one) - -- overlap. - docSetIndentLevel $ runFilteredAlternative $ do - -- if _ then _ else _ - addAlternativeCond (not hasComments) $ docSeq - [ appSep $ docLit $ Text.pack "if" - , appSep $ docForceSingleline ifExprDoc - , appSep $ docLit $ Text.pack "then" - , appSep $ docForceSingleline thenExprDoc - , appSep $ docLit $ Text.pack "else" - , docForceSingleline elseExprDoc - ] - -- either - -- if expr - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if expr - -- then - -- stuff - -- else - -- stuff - -- note that this has par-spacing - addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc - ] - ) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docNonBottomSpacing - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "then" - , docForceParSpacing thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "else" - , docForceParSpacing elseExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ] - ) - -- either - -- if multi - -- line - -- condition - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if multi - -- line - -- condition - -- then - -- stuff - -- else - -- stuff - -- note that this does _not_ have par-spacing - addAlternative $ docAddBaseY BrIndentRegular $ docPar - (docAddBaseY maySpecialIndent $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ] - ) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "then" - , docForceParSpacing thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "else" - , docForceParSpacing elseExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ] - ) - addAlternative $ docSetBaseY $ docLines - [ docAddBaseY maySpecialIndent $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ] - , docNodeAnnKW lexpr (Just AnnThen) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" - hasComments <- hasAnyCommentsBelow lexpr - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "if") - (layoutPatternBindFinal - Nothing - binderDoc - Nothing - clauseDocs - Nothing - hasComments - ) - HsLet _ binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 - -- We jump through some ugly hoops here to ensure proper sharing. - hasComments <- hasAnyCommentsBelow lexpr - mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds - let - ifIndentFreeElse :: a -> a -> a - ifIndentFreeElse x y = case indentPolicy of - IndentPolicyLeft -> y - IndentPolicyMultiple -> y - IndentPolicyFree -> x - -- this `docSetBaseAndIndent` might seem out of place (especially the - -- Indent part; setBase is necessary due to the use of docLines below), - -- but is here due to ghc-exactprint's DP handling of "let" in - -- particular. - -- Just pushing another indentation level is a straightforward approach - -- to making brittany idempotent, even though the result is non-optimal - -- if "let" is moved horizontally as part of the transformation, as the - -- comments before the first let item are moved horizontally with it. - docSetBaseAndIndent $ case mBindDocs of - Just [bindDoc] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ docSeq - [ appSep $ docLit $ Text.pack "let" - , docNodeAnnKW lexpr (Just AnnLet) $ appSep $ docForceSingleline - bindDoc - , appSep $ docLit $ Text.pack "in" - , docForceSingleline expDoc1 - ] - addAlternative $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline - $ bindDoc - ] - , docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent bindDoc) - ] - , docAlt - [ docSeq - [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" - , ifIndentFreeElse - docSetBaseAndIndent - docForceSingleline - expDoc1 - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "in") (docSetBaseY expDoc1) - ] - ] - Just bindDocs@(_ : _) -> runFilteredAlternative $ do - --either - -- let - -- a = b - -- c = d - -- in foo - -- bar - -- baz - --or - -- let - -- a = b - -- c = d - -- in - -- fooooooooooooooooooo - let - noHangingBinds = - [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 - ] - ] - addAlternative $ case indentPolicy of - IndentPolicyLeft -> docLines noHangingBinds - IndentPolicyMultiple -> docLines noHangingBinds - IndentPolicyFree -> docLines - [ docNodeAnnKW lexpr (Just AnnLet) $ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines bindDocs - ] - , docSeq [appSep $ docLit $ Text.pack "in ", docSetBaseY expDoc1] - ] - addAlternative $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "in") (docSetBaseY $ expDoc1) - ] - _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] - -- docSeq [appSep $ docLit "let in", expDoc1] - HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of - DoExpr _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - MDoExpr _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - x - | case x of - ListComp -> True - MonadComp -> True - _ -> False - -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq - $ List.intersperse docCommaSep - $ docForceSingleline - <$> List.init stmtDocs - , docLit $ Text.pack " ]" - ] - addAlternative - $ let - start = docCols - ColListComp - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack - "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1 : sM) = List.init stmtDocs - line1 = - docCols ColListComp [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] - _ -> do - -- TODO - unknownNodeError "HsDo{} unknown stmtCtx" lexpr - ExplicitList _ _ elems@(_ : _) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr - hasComments <- hasAnyCommentsBelow lexpr - case splitFirstLast elemDocs of - FirstLastEmpty -> docSeq - [ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]" - ] - FirstLastSingleton e -> docAlt - [ docSeq - [ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e - , docLit $ Text.pack "]" - ] - , docSetBaseY $ docLines - [ docSeq - [ docLit $ Text.pack "[" - , docSeparator - , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) e - ] - , docLit $ Text.pack "]" - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "["] - ++ List.intersperse - docCommaSep - (docForceSingleline - <$> (e1 : ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]) - ) - ++ [docLit $ Text.pack "]"] - addAlternative - $ let - start = docCols ColList [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> docCols ColList [docCommaSep, d] - lineN = docCols - ColList - [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - 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 - let FieldOcc _ lnameF = fieldOcc - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ (lfield, lrdrNameToText lnameF, rFExpDoc) - recordExpression False indentPolicy lexpr nameDoc rFs - HsRecFields [] (Just (L _ 0)) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " { .. }" - 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 - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr fExpr - return (fieldl, lrdrNameToText lnameF, fExpDoc) - recordExpression True indentPolicy lexpr nameDoc fieldDocs - _ -> unknownNodeError "RecordCon with puns" lexpr - RecordUpd _ rExpr fields -> do - rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs <- - fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ case ambName of - Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - recordExpression False indentPolicy lexpr rExprDoc rFs - ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do - expDoc <- docSharedWrapper layoutExpr exp1 - typDoc <- docSharedWrapper layoutType typ1 - docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc] - ArithSeq _ Nothing info -> case info of - From e1 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , docLit $ Text.pack "..]" - ] - FromThen e1 e2 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , docLit $ Text.pack "..]" - ] - FromTo e1 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - FromThenTo e1 e2 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr - HsBracket{} -> do - -- TODO - briDocByExactInlineOnly "HsBracket{}" lexpr - HsRnBracketOut{} -> do - -- TODO - briDocByExactInlineOnly "HsRnBracketOut{}" lexpr - HsTcBracketOut{} -> do - -- TODO - briDocByExactInlineOnly "HsTcBracketOut{}" lexpr - HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do - allocateNode $ BDFPlain - (Text.pack - $ "[" - ++ showOutputable quoter - ++ "|" - ++ showOutputable content - ++ "|]" - ) - HsSpliceE{} -> do - -- TODO - briDocByExactInlineOnly "HsSpliceE{}" lexpr - HsProc{} -> do - -- TODO - briDocByExactInlineOnly "HsProc{}" lexpr - HsStatic{} -> do - -- TODO - briDocByExactInlineOnly "HsStatic{}" lexpr - HsTick{} -> do - -- TODO - briDocByExactInlineOnly "HsTick{}" lexpr - HsBinTick{} -> do - -- TODO - briDocByExactInlineOnly "HsBinTick{}" lexpr - HsConLikeOut{} -> do - -- TODO - briDocByExactInlineOnly "HsWrap{}" lexpr - ExplicitSum{} -> do - -- TODO - briDocByExactInlineOnly "ExplicitSum{}" lexpr - HsPragE{} -> do - -- TODO - briDocByExactInlineOnly "HsPragE{}" lexpr - -recordExpression - :: (Data.Data.Data lExpr, Data.Data.Data name) - => Bool - -> IndentPolicy - -> GenLocated SrcSpan lExpr - -> ToBriDocM BriDocNumbered - -> [ ( GenLocated SrcSpan name - , Text - , Maybe (ToBriDocM BriDocNumbered) - ) - ] - -> ToBriDocM BriDocNumbered -recordExpression False _ lexpr nameDoc [] = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) - $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack "}" - ] -recordExpression True _ lexpr nameDoc [] = docSeq -- this case might still be incomplete, and is probably not used - -- atm anyway. - [ docNodeAnnKW lexpr (Just AnnOpenC) - $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack " .. }" - ] -recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1 : rFr) = do - let (rF1f, rF1n, rF1e) = rF1 - runFilteredAlternative $ do - -- container { fieldA = blub, fieldB = blub } - addAlternative $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc - , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> docWrapNode lfield $ docLit fieldStr - , if dotdot - then docSeq [docCommaSep, docLit $ Text.pack "..", docSeparator] - else docSeparator - , docLit $ Text.pack "}" - ] - -- hanging single-line fields - -- container { fieldA = blub - -- , fieldB = blub - -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq - [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc - , docSetBaseY - $ docLines - $ let - line1 = docCols - ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [appSep $ docLit $ Text.pack "=", docForceSingleline x] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> - docWrapNode lfield $ docCols - ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> - docSeq [appSep $ docLit $ Text.pack "=", docForceSingleline x] - Nothing -> docEmpty - ] - dotdotLine = if dotdot - then docCols - ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ] - -- non-hanging with expressions placed to the right of the names - -- container - -- { fieldA = blub - -- , fieldB = potentially - -- multiline - -- } - addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - (docNonBottomSpacing - $ docLines - $ let - line1 = docCols - ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> - docWrapNode lfield $ docCols - ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - dotdotLine = if dotdot - then docCols - ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ) - -litBriDoc :: HsLit GhcPs -> BriDocFInt -litBriDoc = \case - HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString - HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString - HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - 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 - _ -> 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 - HsIsString (SourceText t) _ -> BDFLit $ Text.pack t - _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs deleted file mode 100644 index 8684842..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.IE where - -import qualified Data.List.Extra -import qualified Data.Text as Text -import GHC - ( AnnKeywordId(..) - , GenLocated(L) - , Located - , ModuleName - , moduleNameString - , unLoc - ) -import GHC.Hs -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - - - -prepareName :: LIEWrappedName name -> Located name -prepareName = ieLWrappedName - -layoutIE :: ToBriDoc 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 _) _ _ -> - docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] - IEThingWith _ x _ ns _ -> do - hasComments <- orM - (hasCommentsBetween lie AnnOpenP AnnCloseP - : hasAnyCommentsBelow x - : map hasAnyCommentsBelow ns - ) - let sortedNs = List.sortOn wrappedNameToText ns - runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [layoutWrapped lie x, docLit $ Text.pack "("] - ++ intersperse docCommaSep (map nameDoc sortedNs) - ++ [docParenR] - addAlternative - $ docWrapNodeRest lie - $ docAddBaseY BrIndentRegular - $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) - where - nameDoc = docLit <=< lrdrNameToTextAnn . prepareName - layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] - layoutItems FirstLastEmpty = docSetBaseY $ docLines - [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty] - , docParenR - ] - layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines - [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n] - , docParenR - ] - layoutItems (FirstLast n1 nMs nN) = - docSetBaseY - $ docLines - $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] - ++ map layoutItem nMs - ++ [ docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN] - , docParenR - ] - IEModuleContents _ n -> docSeq - [ docLit $ Text.pack "module" - , docSeparator - , docLit . Text.pack . moduleNameString $ unLoc n - ] - _ -> docEmpty - where - layoutWrapped _ = \case - L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n - L _ (IEPattern n) -> do - name <- lrdrNameToTextAnn n - docLit $ Text.pack "pattern " <> name - L _ (IEType n) -> do - name <- lrdrNameToTextAnn n - docLit $ Text.pack "type " <> name - -data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted --- Helper function to deal with Located lists of LIEs. --- In particular this will also associate documentation --- from the located list that actually belongs to the last IE. --- It also adds docCommaSep to all but the first element --- This configuration allows both vertical and horizontal --- handling of the resulting list. Adding parens is --- left to the caller since that is context sensitive -layoutAnnAndSepLLIEs - :: SortItemsFlag - -> Located [LIE GhcPs] - -> ToBriDocM [ToBriDocM BriDocNumbered] -layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do - let makeIENode ie = docSeq [docCommaSep, ie] - let - sortedLies = - [ items - | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies - , items <- mergeGroup group - ] - let - ieDocs = fmap layoutIE $ case shouldSort of - ShouldSortItems -> sortedLies - KeepItemsUnsorted -> lies - ieCommaDocs <- - docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of - FirstLastEmpty -> [] - FirstLastSingleton ie -> [ie] - FirstLast ie1 ieMs ieN -> - [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] - pure $ fmap pure ieCommaDocs -- returned shared nodes - where - mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] - mergeGroup [] = [] - mergeGroup items@[_] = items - mergeGroup items = if - | all isProperIEThing items -> [List.foldl1' thingFolder items] - | all isIEVar items -> [List.foldl1' thingFolder items] - | otherwise -> items - -- proper means that if it is a ThingWith, it does not contain a wildcard - -- (because I don't know what a wildcard means if it is not already a - -- IEThingAll). - isProperIEThing :: LIE GhcPs -> Bool - isProperIEThing = \case - L _ (IEThingAbs _ _wn) -> True - L _ (IEThingAll _ _wn) -> True - L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True - _ -> False - isIEVar :: LIE GhcPs -> Bool - isIEVar = \case - L _ IEVar{} -> True - _ -> False - thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs - thingFolder l1@(L _ IEVar{}) _ = l1 - thingFolder l1@(L _ IEThingAll{}) _ = l1 - 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)) - = L - l - (IEThingWith - x - wn - NoIEWildcard - (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) - ) - thingFolder _ _ = - error "thingFolder should be exhaustive because we have a guard above" - - --- Builds a complete layout for the given located --- list of LIEs. The layout provides two alternatives: --- (item, item, ..., item) --- ( item --- , item --- ... --- , item --- ) --- If the llies contains comments the list will --- always expand over multiple lines, even when empty: --- () -- no comments --- ( -- a comment --- ) -layoutLLIEs - :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered -layoutLLIEs enableSingleline shouldSort llies = do - ieDs <- layoutAnnAndSepLLIEs shouldSort llies - hasComments <- hasAnyCommentsBelow llies - runFilteredAlternative $ case ieDs of - [] -> do - addAlternativeCond (not hasComments) $ docLit $ Text.pack "()" - addAlternativeCond hasComments $ docPar - (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - (ieDsH : ieDsT) -> do - addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] - ++ (docForceSingleline <$> ieDs) - ++ [docParenR] - addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT - ++ [docParenR] - --- | Returns a "fingerprint string", not a full text representation, nor even --- a source code representation of this syntax node. --- Used for sorting, not for printing the formatter's output source code. -wrappedNameToText :: LIEWrappedName RdrName -> Text -wrappedNameToText = \case - L _ (IEName 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. --- Used for sorting, not for printing the formatter's output source code. -lieToText :: LIE GhcPs -> Text -lieToText = \case - L _ (IEVar _ wn) -> wrappedNameToText wn - L _ (IEThingAbs _ wn) -> wrappedNameToText wn - L _ (IEThingAll _ 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. - L _ (IEModuleContents _ n) -> moduleNameToText n - L _ IEGroup{} -> Text.pack "@IEGroup" - L _ IEDoc{} -> Text.pack "@IEDoc" - L _ IEDocNamed{} -> Text.pack "@IEDocNamed" - where - moduleNameToText :: Located ModuleName -> Text - moduleNameToText (L _ name) = - Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs deleted file mode 100644 index 8de45d7..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Module where - -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc) -import GHC.Hs -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Layouters.Import -import Language.Haskell.Brittany.Internal.Prelude -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) - - - -layoutModule :: ToBriDoc' HsModule -layoutModule lmod@(L _ mod') = case mod' of - -- Implicit module Main - 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 - commentedImports <- transformToCommentedImport imports - -- groupify commentedImports `forM_` tellDebugMessShow - -- sortedImports <- sortImports imports - let tn = Text.pack $ moduleNameString $ unLoc n - allowSingleLineExportList <- - mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack - -- the config should not prevent single-line layout when there is no - -- export list - let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les - docLines - $ docSeq - [ docNodeAnnKW lmod Nothing docEmpty - -- A pseudo node that serves merely to force documentation - -- before the node - , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do - addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , docWrapNode lmod $ appSep $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs True KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - addAlternative $ docLines - [ docAddBaseY BrIndentRegular $ docPar - (docSeq [appSep $ docLit $ Text.pack "module", docLit tn]) - (docSeq - [ docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - ) - ] - ] - : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] - -data CommentedImport - = EmptyLine - | IndependentComment (Comment, DeltaPos) - | ImportStatement ImportStatementRecord - -instance Show CommentedImport where - show = \case - EmptyLine -> "EmptyLine" - IndependentComment _ -> "IndependentComment" - ImportStatement r -> - "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) - -data ImportStatementRecord = ImportStatementRecord - { commentsBefore :: [(Comment, DeltaPos)] - , commentsAfter :: [(Comment, DeltaPos)] - , importStatement :: ImportDecl GhcPs - } - -instance Show ImportStatementRecord where - show r = - "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) - -transformToCommentedImport - :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] -transformToCommentedImport is = do - nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do - annotionMay <- astAnn i - pure (annotionMay, rawImport) - let - convertComment (c, DP (y, x)) = - replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] - accumF - :: [(Comment, DeltaPos)] - -> (Maybe Annotation, ImportDecl GhcPs) - -> ([(Comment, DeltaPos)], [CommentedImport]) - accumF accConnectedComm (annMay, decl) = case annMay of - Nothing -> - ( [] - , [ ImportStatement ImportStatementRecord - { commentsBefore = [] - , commentsAfter = [] - , importStatement = decl - } - ] - ) - Just ann -> - let - blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1 - (newAccumulator, priorComments') = - List.span ((== 0) . deltaRow . snd) (annPriorComments 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 - ) - (convertedIndependentComments, beforeComments, initialBlanks) = - if blanksBeforeImportDecl /= 0 - then (convertComment =<< priorComments', [], 0) - else go [] (reverse priorComments') - in - ( newAccumulator - , convertedIndependentComments - ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine - ++ [ ImportStatement ImportStatementRecord - { commentsBefore = beforeComments - , commentsAfter = accConnectedComm - , importStatement = decl - } - ] - ) - let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations - pure $ join $ (convertComment =<< finalAcc) : finalList - -sortCommentedImports :: [CommentedImport] -> [CommentedImport] -sortCommentedImports = - unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify - where - unpackImports :: [CommentedImport] -> [CommentedImport] - unpackImports xs = xs >>= \case - l@EmptyLine -> [l] - l@IndependentComment{} -> [l] - ImportStatement r -> - map IndependentComment (commentsBefore r) ++ [ImportStatement r] - mergeGroups - :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] - mergeGroups xs = xs >>= \case - Left x -> [x] - Right y -> ImportStatement <$> y - sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] - sortGroups = - List.sortOn (moduleNameString . unLoc . ideclName . importStatement) - groupify - :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]] - groupify cs = go [] cs - where - go [] = \case - (l@EmptyLine : rest) -> Left l : go [] rest - (l@IndependentComment{} : rest) -> Left l : go [] rest - (ImportStatement r : rest) -> go [r] rest - [] -> [] - go acc = \case - (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest - (l@IndependentComment{} : rest) -> - Left l : Right (reverse acc) : go [] rest - (ImportStatement r : rest) -> go (r : acc) rest - [] -> [Right (reverse acc)] - -commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered -commentedImportsToDoc = \case - EmptyLine -> docLitS "" - IndependentComment c -> commentToDoc c - ImportStatement r -> docSeq - (layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) - where - commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot deleted file mode 100644 index 6cfd5c8..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Stmt where - -import GHC.Hs -import Language.Haskell.Brittany.Internal.Types - - - -layoutStmt :: ToBriDoc' (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 deleted file mode 100644 index 1662ffb..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ /dev/null @@ -1,635 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Type where - -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L)) -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic -import GHC.Utils.Outputable (ftext, showSDocUnsafe) -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - (FirstLastView(..), splitFirstLast) - - - -layoutType :: ToBriDoc HsType -layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of - -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" - HsTyVar _ promoted name -> do - t <- lrdrNameToTextAnnTypeEqualityIsSpecial name - case promoted of - IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t] - NotPromoted -> docWrapNode name $ docLit t - HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do - let bndrs = getBinders hsf - typeDoc <- docSharedWrapper layoutType typ2 - tyVarDocs <- layoutTyVarBndrs bndrs - cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - let - tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs - forallDoc = docAlt - [ let open = docLit $ Text.pack "forall" - in docSeq ([open] ++ tyVarDocLineList) - , docPar - (docLit (Text.pack "forall")) - (docLines $ tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines - [ docCols ColTyOpPrefix [docParenLSep, docLit tname] - , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] - , docLit $ Text.pack ")" - ] - ) - ] - contextDoc = case cntxtDocs of - [] -> docLit $ Text.pack "()" - [x] -> x - _ -> docAlt - [ let - open = docLit $ Text.pack "(" - close = docLit $ Text.pack ")" - list = - List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs - in docSeq ([open] ++ list ++ [close]) - , let - open = docCols - ColTyOpPrefix - [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs] - close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> docCols - ColTyOpPrefix - [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc] - in docPar open $ docLines $ list ++ [close] - ] - docAlt - -- :: forall a b c . (Foo a b c) => a b -> c - [ docSeq - [ if null bndrs - then docEmpty - else - let - open = docLit $ Text.pack "forall" - close = docLit $ Text.pack " . " - in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close]) - , docForceSingleline contextDoc - , docLit $ Text.pack " => " - , docForceSingleline typeDoc - ] - -- :: forall a b c - -- . (Foo a b c) - -- => a b - -- -> c - , docPar - forallDoc - (docLines - [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , docAddBaseY (BrIndentSpecial 3) $ contextDoc - ] - , docCols - ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc - ] - ] - ) - ] - HsForAllTy _ hsf typ2 -> do - let bndrs = getBinders hsf - typeDoc <- layoutType typ2 - tyVarDocs <- layoutTyVarBndrs bndrs - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs - docAlt - -- forall x . x - [ docSeq - [ if null bndrs - then docEmpty - else - let - open = docLit $ Text.pack "forall" - close = docLit $ Text.pack " . " - in docSeq ([open] ++ tyVarDocLineList ++ [close]) - , docForceSingleline $ return $ typeDoc - ] - -- :: forall x - -- . x - , docPar - (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ) - -- :: forall - -- (x :: *) - -- . x - , docPar - (docLit (Text.pack "forall")) - (docLines - $ (tyVarDocs <&> \case - (tname, Nothing) -> - docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines - [ docCols ColTyOpPrefix [docParenLSep, docLit tname] - , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] - , docLit $ Text.pack ")" - ] - ) - ++ [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ] - ) - ] - HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do - typeDoc <- docSharedWrapper layoutType typ1 - cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let - contextDoc = docWrapNode lcntxts $ case cntxtDocs of - [] -> docLit $ Text.pack "()" - [x] -> x - _ -> docAlt - [ let - open = docLit $ Text.pack "(" - close = docLit $ Text.pack ")" - list = - List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs - in docSeq ([open] ++ list ++ [close]) - , let - open = docCols - ColTyOpPrefix - [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs] - close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> docCols - ColTyOpPrefix - [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc] - in docPar open $ docLines $ list ++ [close] - ] - let - maybeForceML = case typ1 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - docAlt - -- (Foo a b c) => a b -> c - [ docSeq - [ docForceSingleline contextDoc - , docLit $ Text.pack " => " - , docForceSingleline typeDoc - ] - -- (Foo a b c) - -- => a b - -- -> c - , docPar - (docForceSingleline contextDoc) - (docCols - ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc - ] - ) - ] - HsFunTy _ _ typ1 typ2 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - typeDoc2 <- docSharedWrapper layoutType typ2 - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - hasComments <- hasAnyCommentsBelow ltype - docAlt - $ [ docSeq - [ appSep $ docForceSingleline typeDoc1 - , appSep $ docLit $ Text.pack "->" - , docForceSingleline typeDoc2 - ] - | not hasComments - ] - ++ [ docPar - (docNodeAnnKW ltype Nothing typeDoc1) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2 - ] - ) - ] - HsParTy _ typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack "(" - , docForceSingleline typeDoc1 - , docLit $ Text.pack ")" - ] - , docPar - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ] - ) - (docLit $ Text.pack ")") - ] - HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do - let - gather - :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) - gather list = \case - L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1 - final -> (final, list) - let (typHead, typRest) = gather [typ2] typ1 - docHead <- docSharedWrapper layoutType typHead - docRest <- docSharedWrapper layoutType `mapM` typRest - docAlt - [ docSeq - $ docForceSingleline docHead - : (docRest >>= \d -> [docSeparator, docForceSingleline d]) - , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) - ] - HsAppTy _ typ1 typ2 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - typeDoc2 <- docSharedWrapper layoutType typ2 - docAlt - [ docSeq - [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2] - , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) - ] - HsListTy _ typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack "[" - , docForceSingleline typeDoc1 - , docLit $ Text.pack "]" - ] - , docPar - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ] - ) - (docLit $ Text.pack "]") - ] - HsTupleTy _ tupleSort typs -> case tupleSort of - HsUnboxedTuple -> unboxed - HsBoxedTuple -> simple - HsConstraintTuple -> simple - HsBoxedOrConstraintTuple -> simple - where - unboxed = if null typs - then error "brittany internal error: unboxed unit" - else unboxedL - simple = if null typs then unitL else simpleL - unitL = docLit $ Text.pack "()" - simpleL = do - docs <- docSharedWrapper layoutType `mapM` typs - let - end = docLit $ Text.pack ")" - lines = - List.tail docs - <&> \d -> docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) - docAlt - [ docSeq - $ [docLit $ Text.pack "("] - ++ docWrapNodeRest ltype commaDocs - ++ [end] - , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] - in - docPar - (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ docWrapNodeRest ltype lines ++ [end]) - ] - unboxedL = do - docs <- docSharedWrapper layoutType `mapM` typs - let - start = docParenHashLSep - end = docParenHashRSep - docAlt - [ docSeq - $ [start] - ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) - ++ [end] - , let - line1 = docCols ColTyOpPrefix [start, head docs] - lines = - List.tail docs - <&> \d -> docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - in docPar - (docAddBaseY (BrIndentSpecial 2) line1) - (docLines $ lines ++ [end]) - ] - HsOpTy{} -> -- TODO - briDocByExactInlineOnly "HsOpTy{}" ltype - -- HsOpTy typ1 opName typ2 -> do - -- -- TODO: these need some proper fixing. precedences don't add up. - -- -- maybe the parser just returns some trivial right recursion - -- -- parse result for any type level operators. - -- -- need to check how things are handled on the expression level. - -- let opStr = lrdrNameToText opName - -- let opLen = Text.length opStr - -- layouter1@(Layouter desc1 _ _) <- layoutType typ1 - -- layouter2@(Layouter desc2 _ _) <- layoutType typ2 - -- let line = do -- Maybe - -- l1 <- _ldesc_line desc1 - -- l2 <- _ldesc_line desc2 - -- let len1 = _lColumns_min l1 - -- let len2 = _lColumns_min l2 - -- let len = 2 + opLen + len1 + len2 - -- return $ LayoutColumns - -- { _lColumns_key = ColumnKeyUnique - -- , _lColumns_lengths = [len] - -- , _lColumns_min = len - -- } - -- let block = do -- Maybe - -- rol1 <- descToBlockStart desc1 - -- (min2, max2) <- descToMinMax (1+opLen) desc2 - -- let (minR, maxR) = case descToBlockMinMax desc1 of - -- Nothing -> (min2, max2) - -- Just (min1, max1) -> (max min1 min2, max max1 max2) - -- return $ BlockDesc - -- { _bdesc_blockStart = rol1 - -- , _bdesc_min = minR - -- , _bdesc_max = maxR - -- , _bdesc_opIndentFloatUp = Just (1+opLen) - -- } - -- return $ Layouter - -- { _layouter_desc = LayoutDesc - -- { _ldesc_line = line - -- , _ldesc_block = block - -- } - -- , _layouter_func = \params -> do - -- remaining <- getCurRemaining - -- let allowSameLine = _params_sepLines params /= SepLineTypeOp - -- case line of - -- Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do - -- applyLayouterRestore layouter1 defaultParams - -- layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " " - -- applyLayouterRestore layouter2 defaultParams - -- _ -> do - -- let upIndent = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params - -- let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2 - -- layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams - -- layoutWriteNewline - -- layoutWriteAppend $ opStr <> Text.pack " " - -- layoutWriteEnsureBlockPlusN downIndent - -- applyLayouterRestore layouter2 defaultParams - -- { _params_sepLines = SepLineTypeOp - -- , _params_opIndent = Just downIndent - -- } - -- , _layouter_ast = ltype - -- } - HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack - ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") - , docForceSingleline typeDoc1 - ] - , docPar - (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 2) typeDoc1 - ] - ) - ] - -- TODO: test KindSig - HsKindSig _ typ1 kind1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - kindDoc1 <- docSharedWrapper layoutType kind1 - hasParens <- hasAnnKeyword ltype AnnOpenP - docAlt - [ if hasParens - then docSeq - [ docLit $ Text.pack "(" - , docForceSingleline typeDoc1 - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , docForceSingleline kindDoc1 - , docLit $ Text.pack ")" - ] - else docSeq - [ docForceSingleline typeDoc1 - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , docForceSingleline kindDoc1 - ] - , if hasParens - then docLines - [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 3) $ typeDoc1 - ] - , docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) kindDoc1 - ] - , (docLit $ Text.pack ")") - ] - else docPar - typeDoc1 - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) kindDoc1 - ] - ) - ] - HsBangTy{} -> -- TODO - briDocByExactInlineOnly "HsBangTy{}" ltype - -- HsBangTy bang typ1 -> do - -- let bangStr = case bang of - -- HsSrcBang _ unpackness strictness -> - -- (++) - -- (case unpackness of - -- SrcUnpack -> "{-# UNPACK -#} " - -- SrcNoUnpack -> "{-# NOUNPACK -#} " - -- NoSrcUnpack -> "" - -- ) - -- (case strictness of - -- SrcLazy -> "~" - -- SrcStrict -> "!" - -- NoSrcStrict -> "" - -- ) - -- let bangLen = length bangStr - -- layouter@(Layouter desc _ _) <- layoutType typ1 - -- let line = do -- Maybe - -- l <- _ldesc_line desc - -- let len = bangLen + _lColumns_min l - -- return $ LayoutColumns - -- { _lColumns_key = ColumnKeyUnique - -- , _lColumns_lengths = [len] - -- , _lColumns_min = len - -- } - -- let block = do -- Maybe - -- rol <- descToBlockStart desc - -- (minR,maxR) <- descToBlockMinMax desc - -- return $ BlockDesc - -- { _bdesc_blockStart = rol - -- , _bdesc_min = minR - -- , _bdesc_max = maxR - -- , _bdesc_opIndentFloatUp = Nothing - -- } - -- return $ Layouter - -- { _layouter_desc = LayoutDesc - -- { _ldesc_line = line - -- , _ldesc_block = block - -- } - -- , _layouter_func = \_params -> do - -- remaining <- getCurRemaining - -- case line of - -- Just (LayoutColumns _ _ m) | m <= remaining -> do - -- layoutWriteAppend $ Text.pack $ bangStr - -- applyLayouterRestore layouter defaultParams - -- _ -> do - -- layoutWriteAppend $ Text.pack $ bangStr - -- layoutWritePostCommentsRestore ltype - -- applyLayouterRestore layouter defaultParams - -- , _layouter_ast = ltype - -- } - HsSpliceTy{} -> -- TODO - briDocByExactInlineOnly "HsSpliceTy{}" ltype - HsDocTy{} -> -- TODO - briDocByExactInlineOnly "HsDocTy{}" ltype - HsRecTy{} -> -- TODO - briDocByExactInlineOnly "HsRecTy{}" ltype - HsExplicitListTy _ _ typs -> do - typDocs <- docSharedWrapper layoutType `mapM` typs - hasComments <- hasAnyCommentsBelow ltype - let specialCommaSep = appSep $ docLit $ Text.pack " ," - docAlt - [ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) - ++ [docLit $ Text.pack "]"] - , case splitFirstLast typDocs of - FirstLastEmpty -> docSeq - [ docLit $ Text.pack "'[" - , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]" - ] - FirstLastSingleton e -> docAlt - [ docSeq - [ docLit $ Text.pack "'[" - , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e - , docLit $ Text.pack "]" - ] - , docSetBaseY $ docLines - [ docSeq - [ docLit $ Text.pack "'[" - , docSeparator - , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e - ] - , docLit $ Text.pack " ]" - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse - specialCommaSep - (docForceSingleline - <$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]) - ) - ++ [docLit $ Text.pack " ]"] - addAlternative - $ let - start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1] - linesM = ems <&> \d -> docCols ColList [specialCommaSep, d] - lineN = docCols - ColList - [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] - end = docLit $ Text.pack " ]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ] - HsExplicitTupleTy{} -> -- TODO - briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype - HsTyLit _ lit -> case lit of - HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext - HsNumTy NoSourceText _ -> - error "overLitValBriDoc: literal with no SourceText" - HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext - HsStrTy NoSourceText _ -> - error "overLitValBriDoc: literal with no SourceText" - HsWildCardTy _ -> docLit $ Text.pack "_" - HsSumTy{} -> -- TODO - briDocByExactInlineOnly "HsSumTy{}" ltype - HsStarTy _ isUnicode -> do - if isUnicode - then docLit $ Text.pack "\x2605" -- Unicode star - else docLit $ Text.pack "*" - XHsType{} -> error "brittany internal error: XHsType" - HsAppKindTy _ ty kind -> do - t <- docSharedWrapper layoutType ty - k <- docSharedWrapper layoutType kind - docAlt - [ docSeq - [ docForceSingleline t - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline k - ] - , docPar t (docSeq [docLit $ Text.pack "@", k]) - ] - -layoutTyVarBndrs - :: [LHsTyVarBndr () GhcPs] - -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] -layoutTyVarBndrs = mapM $ \case - (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing) - (L _ (KindedTyVar _ _ lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - --- there is no specific reason this returns a list instead of a single --- BriDoc node. -processTyVarBndrsSingleline - :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered] -processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case - (tname, Nothing) -> [docSeparator, docLit tname] - (tname, Just doc) -> - [ docSeparator - , docLit $ Text.pack "(" <> tname <> Text.pack " :: " - , docForceSingleline $ doc - , docLit $ Text.pack ")" - ] - -getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass] -getBinders x = case x of - HsForAllVis _ b -> b - HsForAllInvis _ b -> fmap withoutSpecificity b - XHsForAllTelescope _ -> [] - -withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () 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 deleted file mode 100644 index 03f83a5..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs +++ /dev/null @@ -1,316 +0,0 @@ -{-# OPTIONS_GHC -Wno-implicit-prelude #-} - -module Language.Haskell.Brittany.Internal.ParseModule where - -import qualified Control.Monad as Monad -import qualified Control.Monad.IO.Class as IO -import qualified Control.Monad.Trans.Except as Except -import qualified GHC -import qualified GHC.ByteOrder -import qualified GHC.Data.Bag -import qualified GHC.Data.StringBuffer -import qualified GHC.Driver.Session -import qualified GHC.Parser.Header -import qualified GHC.Platform -import qualified GHC.Settings -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. -parseModule - :: IO.MonadIO io - => [String] - -> FilePath - -> (GHC.Driver.Session.DynFlags -> io (Either String a)) - -> String - -> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do - let - dynFlags1 = GHC.Driver.Session.gopt_set - -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both - -- of those modes have trouble parsing safe imports (@import safe ...@). - -- 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.Opt_KeepRawTokenStream - (dynFlags2, leftovers1, _) <- - GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1 - $ fmap GHC.Types.SrcLoc.noLoc arguments1 - handleLeftovers leftovers1 - let - stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string - arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath - (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma - dynFlags2 - arguments2 - handleLeftovers leftovers2 - dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3 - let - parseResult = - ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string - case parseResult of - Left errorMessages -> handleErrorMessages errorMessages - Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult) - -handleLeftovers - :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m () -handleLeftovers leftovers = - Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show - (fmap GHC.Types.SrcLoc.unLoc leftovers) - -handleErrorMessages - :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a -handleErrorMessages = - Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList - -initialDynFlags :: GHC.Driver.Session.DynFlags -initialDynFlags = GHC.Driver.Session.defaultDynFlags initialSettings initialLlvmConfig - -initialSettings :: GHC.Driver.Session.Settings -initialSettings = GHC.Driver.Session.Settings - { GHC.Driver.Session.sGhcNameVersion = initialGhcNameVersion - , GHC.Driver.Session.sFileSettings = initialFileSettings - , GHC.Driver.Session.sTargetPlatform = initialTargetPlatform - , GHC.Driver.Session.sToolSettings = initialToolSettings - , GHC.Driver.Session.sPlatformMisc = initialPlatformMisc - , GHC.Driver.Session.sPlatformConstants = initialPlatformConstants - , GHC.Driver.Session.sRawSettings = [] - } - -initialFileSettings :: GHC.Driver.Session.FileSettings -initialFileSettings = GHC.Driver.Session.FileSettings - { GHC.Driver.Session.fileSettings_ghciUsagePath = "" - , GHC.Driver.Session.fileSettings_ghcUsagePath = "" - , GHC.Driver.Session.fileSettings_globalPackageDatabase = "" - , GHC.Driver.Session.fileSettings_tmpDir = "" - , GHC.Driver.Session.fileSettings_toolDir = Nothing - , GHC.Driver.Session.fileSettings_topDir = "" - } - -initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion -initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion - { GHC.Driver.Session.ghcNameVersion_programName = "" - , GHC.Driver.Session.ghcNameVersion_projectVersion = "" - } - -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_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 - , GHC.Driver.Session.platformMisc_llvmTarget = "" - , GHC.Driver.Session.platformMisc_targetPlatformString = "" - } - -initialLlvmConfig :: GHC.Driver.Session.LlvmConfig -initialLlvmConfig = GHC.Driver.Session.LlvmConfig - { GHC.Driver.Session.llvmPasses = [] - , 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 - } - -initialPlatformMini :: GHC.Settings.PlatformMini -initialPlatformMini = GHC.Settings.PlatformMini - { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64 - , GHC.Settings.platformMini_os = GHC.Platform.OSLinux - } - -initialTargetPlatform :: GHC.Settings.Platform -initialTargetPlatform = GHC.Settings.Platform - { GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian - , GHC.Settings.platformHasGnuNonexecStack = False - , GHC.Settings.platformHasIdentDirective = False - , GHC.Settings.platformHasSubsectionsViaSymbols = False - , GHC.Settings.platformIsCrossCompiling = False - , GHC.Settings.platformLeadingUnderscore = False - , GHC.Settings.platformMini = initialPlatformMini - , GHC.Settings.platformTablesNextToCode = False - , GHC.Settings.platformUnregisterised = False - , GHC.Settings.platformWordSize = GHC.Platform.PW8 - } - -initialToolSettings :: GHC.Settings.ToolSettings -initialToolSettings = GHC.Settings.ToolSettings - { GHC.Settings.toolSettings_ccSupportsNoPie = False - , GHC.Settings.toolSettings_extraGccViaCFlags = [] - , GHC.Settings.toolSettings_ldIsGnuLd = False - , GHC.Settings.toolSettings_ldSupportsBuildId = False - , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False - , GHC.Settings.toolSettings_ldSupportsFilelist = False - , GHC.Settings.toolSettings_opt_a = [] - , GHC.Settings.toolSettings_opt_c = [] - , GHC.Settings.toolSettings_opt_cxx = [] - , GHC.Settings.toolSettings_opt_F = [] - , GHC.Settings.toolSettings_opt_i = [] - , GHC.Settings.toolSettings_opt_l = [] - , GHC.Settings.toolSettings_opt_L = [] - , GHC.Settings.toolSettings_opt_lc = [] - , GHC.Settings.toolSettings_opt_lcc = [] - , GHC.Settings.toolSettings_opt_lm = [] - , GHC.Settings.toolSettings_opt_lo = [] - , GHC.Settings.toolSettings_opt_P = [] - , GHC.Settings.toolSettings_opt_P_fingerprint = - GHC.Utils.Fingerprint.fingerprint0 - , GHC.Settings.toolSettings_opt_windres = [] - , GHC.Settings.toolSettings_pgm_a = ("", []) - , GHC.Settings.toolSettings_pgm_ar = "" - , GHC.Settings.toolSettings_pgm_c = "" - , GHC.Settings.toolSettings_pgm_dll = ("", []) - , GHC.Settings.toolSettings_pgm_F = "" - , GHC.Settings.toolSettings_pgm_i = "" - , GHC.Settings.toolSettings_pgm_install_name_tool = "" - , GHC.Settings.toolSettings_pgm_l = ("", []) - , GHC.Settings.toolSettings_pgm_L = "" - , GHC.Settings.toolSettings_pgm_lc = ("", []) - , GHC.Settings.toolSettings_pgm_lcc = ("", []) - , GHC.Settings.toolSettings_pgm_libtool = "" - , GHC.Settings.toolSettings_pgm_lm = ("", []) - , GHC.Settings.toolSettings_pgm_lo = ("", []) - , GHC.Settings.toolSettings_pgm_otool = "" - , GHC.Settings.toolSettings_pgm_P = ("", []) - , GHC.Settings.toolSettings_pgm_ranlib = "" - , GHC.Settings.toolSettings_pgm_T = "" - , GHC.Settings.toolSettings_pgm_windres = "" - } diff --git a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs index 8198533..d61ef6e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,5 +1,8 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Language.Haskell.Brittany.Internal.Prelude ( module E + , module Language.Haskell.Brittany.Internal.Prelude ) where import Control.Applicative as E (Alternative(..), Applicative(..)) @@ -75,8 +78,6 @@ import Data.List as E , mapAccumR , maximum , minimum - , notElem - , nub , null , partition , repeat @@ -110,7 +111,7 @@ import Data.Monoid as E import Data.Ord as E (Down(..), Ordering(..), comparing) import Data.Proxy as E (Proxy(..)) import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator) -import Data.Semigroup as E ((<>), Semigroup(..)) +import Data.Semigroup as E ((<>), Semigroup(..), Last(Last)) import Data.Sequence as E (Seq) import Data.Set as E (Set) import Data.String as E (String) @@ -135,6 +136,7 @@ import Foreign.ForeignPtr as E (ForeignPtr) import Foreign.Storable as E (Storable) import GHC.Exts as E (Constraint) import GHC.Hs.Extension as E (GhcPs) +import GHC.Stack as E (HasCallStack) import GHC.Types.Name.Reader as E (RdrName) import Prelude as E ( ($) @@ -143,7 +145,6 @@ import Prelude as E , (++) , (.) , (<$>) - , Bounded(..) , Double , Enum(..) , Eq(..) @@ -163,10 +164,8 @@ import Prelude as E , and , any , const - , curry , error , flip - , foldl , foldr , foldr1 , fromIntegral @@ -192,3 +191,94 @@ import Prelude as E ) import System.IO as E (IO, hFlush, stdout) import Text.Read as E (readMaybe) + +import qualified Data.Strict.Maybe as Strict +import Control.DeepSeq (NFData, force) +import System.IO (hPutStrLn, stderr, hPutStr) +import qualified Data.Data +import GHC.Types.SrcLoc ( RealSrcLoc ) +import qualified GHC.Utils.Misc +import qualified Data.Generics.Uniplate.Direct as Uniplate +import qualified Data.Sequence as Seq + + + +instance Applicative Strict.Maybe where + pure = Strict.Just + Strict.Just f <*> Strict.Just x = Strict.Just (f x) + _ <*> _ = Strict.Nothing + +instance Monad Strict.Maybe where + Strict.Nothing >>= _ = Strict.Nothing + Strict.Just x >>= f = f x + +instance Alternative Strict.Maybe where + empty = Strict.Nothing + x <|> Strict.Nothing = x + _ <|> x = x + +traceFunctionWith + :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) +traceFunctionWith name s1 s2 f x = trace traceStr y + where + y = f x + traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y + +(<&!>) :: Monad m => m a -> (a -> b) -> m b +(<&!>) = flip (<$!>) + +putStrErrLn :: String -> IO () +putStrErrLn s = hPutStrLn stderr s + +putStrErr :: String -> IO () +putStrErr s = hPutStr stderr s + +printErr :: Show a => a -> IO () +printErr = putStrErrLn . show + +errorIf :: Bool -> a -> a +errorIf False = id +errorIf True = error "errorIf" + +errorIfNote :: Maybe String -> a -> a +errorIfNote Nothing = id +errorIfNote (Just x) = error x + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip fmap +infixl 4 <&> + +(.>) :: (a -> b) -> (b -> c) -> (a -> c) +f .> g = g . f +infixl 9 .> + +evaluateDeep :: NFData a => a -> IO a +evaluateDeep = evaluate . force + +instance Data.Data.Data RealSrcLoc where + -- don't traverse? + toConstr _ = GHC.Utils.Misc.abstractConstr "RealSrcLoc" + gunfold _ _ = error "gunfold" + dataTypeOf _ = GHC.Utils.Misc.mkNoRepType "RealSrcLoc" + +-- TODO: move to uniplate upstream? +-- aka `transform` +transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) +transformUp f = g where g = f . Uniplate.descend g +_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on) +_transformDown f = g where g = Uniplate.descend g . f +transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) +transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x +_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) +_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x + +-- i should really put that into multistate.. +mModify :: MonadMultiState s m => (s -> s) -> m () +mModify f = mGet >>= mSet . f + +tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m () +tellDebugMess s = mTell $ Seq.singleton s + +tellDebugMessShow + :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () +tellDebugMessShow = tellDebugMess . show diff --git a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs deleted file mode 100644 index 394a78d..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Haskell.Brittany.Internal.PreludeUtils where - -import Control.Applicative -import Control.DeepSeq (NFData, force) -import Control.Exception.Base (evaluate) -import Control.Monad -import qualified Data.Strict.Maybe as Strict -import Debug.Trace -import Prelude -import System.IO - - - -instance Applicative Strict.Maybe where - pure = Strict.Just - Strict.Just f <*> Strict.Just x = Strict.Just (f x) - _ <*> _ = Strict.Nothing - -instance Monad Strict.Maybe where - Strict.Nothing >>= _ = Strict.Nothing - Strict.Just x >>= f = f x - -instance Alternative Strict.Maybe where - empty = Strict.Nothing - x <|> Strict.Nothing = x - _ <|> x = x - -traceFunctionWith - :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) -traceFunctionWith name s1 s2 f x = trace traceStr y - where - y = f x - traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y - -(<&!>) :: Monad m => m a -> (a -> b) -> m b -(<&!>) = flip (<$!>) - -putStrErrLn :: String -> IO () -putStrErrLn s = hPutStrLn stderr s - -putStrErr :: String -> IO () -putStrErr s = hPutStr stderr s - -printErr :: Show a => a -> IO () -printErr = putStrErrLn . show - -errorIf :: Bool -> a -> a -errorIf False = id -errorIf True = error "errorIf" - -errorIfNote :: Maybe String -> a -> a -errorIfNote Nothing = id -errorIfNote (Just x) = error x - -(<&>) :: Functor f => f a -> (a -> b) -> f b -(<&>) = flip fmap -infixl 4 <&> - -(.>) :: (a -> b) -> (b -> c) -> (a -> c) -f .> g = g . f -infixl 9 .> - -evaluateDeep :: NFData a => a -> IO a -evaluateDeep = evaluate . force diff --git a/source/library/Language/Haskell/Brittany/Internal/S1_Parsing.hs b/source/library/Language/Haskell/Brittany/Internal/S1_Parsing.hs new file mode 100644 index 0000000..98d0baf --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/S1_Parsing.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.S1_Parsing + ( parseModule + , parseModuleFromString + ) +where + +import Language.Haskell.Brittany.Internal.Prelude + +import qualified Control.Monad +import qualified Control.Monad.Trans.Except as Except +import qualified GHC hiding ( parseModule ) +import qualified GHC.ByteOrder +import qualified GHC.Data.Bag +import qualified GHC.Data.StringBuffer +import qualified GHC.Driver.Session +import qualified GHC.Parser.Header +import qualified GHC.Platform +import qualified GHC.Settings +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 System.IO + + + +-- TODO why are redirecting to parseModuleFromString here? +parseModule + :: [String] + -> System.IO.FilePath + -> (GHC.DynFlags -> IO (Either String a)) + -> IO (Either String (GHC.ParsedSource, a)) +parseModule args fp dynCheck = do + str <- System.IO.readFile fp + parseModuleFromString args fp dynCheck str + +-- | Parses a Haskell module. Although this nominally requires IO, it is +-- morally pure. It should have no observable effects. +parseModuleFromString + :: [String] + -> System.IO.FilePath + -> (GHC.DynFlags -> IO (Either String a)) + -> String + -> IO (Either String (GHC.ParsedSource, a)) +parseModuleFromString arguments1 filePath checkDynFlags string = + Except.runExceptT $ do + let dynFlags1 = GHC.Driver.Session.gopt_set + -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both + -- of those modes have trouble parsing safe imports (@import safe ...@). + -- 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.Sf_Unsafe } + GHC.Driver.Session.Opt_KeepRawTokenStream + (dynFlags2, leftovers1, _) <- + GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1 + $ fmap GHC.Types.SrcLoc.noLoc arguments1 + handleLeftovers leftovers1 + let stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string + arguments2 = + GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath + (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma + dynFlags2 + arguments2 + handleLeftovers leftovers2 + dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3 + let parseResult = + ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string + case parseResult of + Left errorMessages -> handleErrorMessages errorMessages + -- Right parsedMod -> case ExactPrint.makeDeltaAst' parsedMod of + -- res -> pure (res, dynFlagsResult) + -- Right (L l (GHC.HsModule ann lay name xprt imp decls depr hdr)) -> + -- case ExactPrint.runTransform (ExactPrint.balanceCommentsList decls) of + -- (decls', _, _) -> + -- pure + -- ( L l (GHC.HsModule ann lay name xprt imp decls' depr hdr) + -- , dynFlagsResult + -- ) + Right res -> pure (res, dynFlagsResult) + +handleLeftovers + :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m () +handleLeftovers leftovers = + Control.Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show + (fmap GHC.Types.SrcLoc.unLoc leftovers) + +handleErrorMessages + :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a +handleErrorMessages = + Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList + +initialDynFlags :: GHC.Driver.Session.DynFlags +initialDynFlags = + GHC.Driver.Session.defaultDynFlags initialSettings initialLlvmConfig + +initialSettings :: GHC.Driver.Session.Settings +initialSettings = GHC.Driver.Session.Settings + { GHC.Driver.Session.sGhcNameVersion = initialGhcNameVersion + , GHC.Driver.Session.sFileSettings = initialFileSettings + , GHC.Driver.Session.sTargetPlatform = initialTargetPlatform + , GHC.Driver.Session.sToolSettings = initialToolSettings + , GHC.Driver.Session.sPlatformMisc = initialPlatformMisc + , GHC.Driver.Session.sRawSettings = [] + } + +initialFileSettings :: GHC.Driver.Session.FileSettings +initialFileSettings = GHC.Driver.Session.FileSettings + { GHC.Driver.Session.fileSettings_ghciUsagePath = "" + , GHC.Driver.Session.fileSettings_ghcUsagePath = "" + , GHC.Driver.Session.fileSettings_globalPackageDatabase = "" + , GHC.Driver.Session.fileSettings_tmpDir = "" + , GHC.Driver.Session.fileSettings_toolDir = Nothing + , GHC.Driver.Session.fileSettings_topDir = "" + } + +initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion +initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion + { GHC.Driver.Session.ghcNameVersion_programName = "" + , GHC.Driver.Session.ghcNameVersion_projectVersion = "" + } + +initialPlatformMisc :: GHC.Driver.Session.PlatformMisc +initialPlatformMisc = GHC.Driver.Session.PlatformMisc + { GHC.Driver.Session.platformMisc_ghcRTSWays = "" + , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False + , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False + , GHC.Driver.Session.platformMisc_ghcWithSMP = False + , GHC.Driver.Session.platformMisc_libFFI = False + , GHC.Driver.Session.platformMisc_llvmTarget = "" + , GHC.Driver.Session.platformMisc_targetPlatformString = "" + } + +initialLlvmConfig :: GHC.Driver.Session.LlvmConfig +initialLlvmConfig = GHC.Driver.Session.LlvmConfig + { GHC.Driver.Session.llvmPasses = [] + , GHC.Driver.Session.llvmTargets = [] + } + +_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 +-- } + +initialTargetPlatform :: GHC.Settings.Platform +initialTargetPlatform = GHC.Settings.Platform + { GHC.Settings.platformArchOS = initialArchOS + , GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian + , GHC.Settings.platformHasGnuNonexecStack = False + , GHC.Settings.platformHasIdentDirective = False + , GHC.Settings.platformHasSubsectionsViaSymbols = False + , GHC.Settings.platformIsCrossCompiling = False + , GHC.Settings.platformLeadingUnderscore = False + -- , GHC.Settings.platformMini = initialPlatformMini + , GHC.Settings.platformTablesNextToCode = False + , GHC.Settings.platformUnregisterised = False + , GHC.Settings.platformWordSize = GHC.Platform.PW8 + , GHC.Settings.platform_constants = Nothing + } + +initialArchOS :: GHC.Platform.ArchOS +initialArchOS = GHC.Platform.ArchOS + { GHC.Platform.archOS_arch = GHC.Platform.ArchUnknown -- why do we need to specify these? + , GHC.Platform.archOS_OS = GHC.Platform.OSUnknown -- why do we need to specify these? + } + +initialToolSettings :: GHC.Settings.ToolSettings +initialToolSettings = GHC.Settings.ToolSettings + { GHC.Settings.toolSettings_ccSupportsNoPie = False + , GHC.Settings.toolSettings_extraGccViaCFlags = [] + , GHC.Settings.toolSettings_ldIsGnuLd = False + , GHC.Settings.toolSettings_ldSupportsBuildId = False + , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False + , GHC.Settings.toolSettings_ldSupportsFilelist = False + , GHC.Settings.toolSettings_opt_a = [] + , GHC.Settings.toolSettings_opt_c = [] + , GHC.Settings.toolSettings_opt_cxx = [] + , GHC.Settings.toolSettings_opt_F = [] + , GHC.Settings.toolSettings_opt_i = [] + , GHC.Settings.toolSettings_opt_l = [] + , GHC.Settings.toolSettings_opt_L = [] + , GHC.Settings.toolSettings_opt_lc = [] + , GHC.Settings.toolSettings_opt_lcc = [] + , GHC.Settings.toolSettings_opt_lm = [] + , GHC.Settings.toolSettings_opt_lo = [] + , GHC.Settings.toolSettings_opt_P = [] + , GHC.Settings.toolSettings_opt_P_fingerprint = + GHC.Utils.Fingerprint.fingerprint0 + , GHC.Settings.toolSettings_opt_windres = [] + , GHC.Settings.toolSettings_pgm_a = ("", []) + , GHC.Settings.toolSettings_pgm_ar = "" + , GHC.Settings.toolSettings_pgm_c = "" + , GHC.Settings.toolSettings_pgm_dll = ("", []) + , GHC.Settings.toolSettings_pgm_F = "" + , GHC.Settings.toolSettings_pgm_i = "" + , GHC.Settings.toolSettings_pgm_install_name_tool = "" + , GHC.Settings.toolSettings_pgm_l = ("", []) + , GHC.Settings.toolSettings_pgm_L = "" + , GHC.Settings.toolSettings_pgm_lc = ("", []) + , GHC.Settings.toolSettings_pgm_lcc = ("", []) + , GHC.Settings.toolSettings_pgm_libtool = "" + , GHC.Settings.toolSettings_pgm_lm = ("", []) + , GHC.Settings.toolSettings_pgm_lo = ("", []) + , GHC.Settings.toolSettings_pgm_otool = "" + , GHC.Settings.toolSettings_pgm_P = ("", []) + , GHC.Settings.toolSettings_pgm_ranlib = "" + , GHC.Settings.toolSettings_pgm_T = "" + , GHC.Settings.toolSettings_pgm_windres = "" + } + + diff --git a/source/library/Language/Haskell/Brittany/Internal/S2_SplitModule.hs b/source/library/Language/Haskell/Brittany/Internal/S2_SplitModule.hs new file mode 100644 index 0000000..a106526 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/S2_SplitModule.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- TODO92 + +module Language.Haskell.Brittany.Internal.S2_SplitModule + ( splitModule + ) +where + + + +import Language.Haskell.Brittany.Internal.Prelude + +import qualified Data.Generics as SYB +import qualified GHC +import GHC ( AddEpAnn(AddEpAnn) + , Anchor(Anchor) + , EpAnn(EpAnn, EpAnnNotUsed) + , EpAnnComments + ( EpaComments + , EpaCommentsBalanced + ) + , EpaComment(EpaComment) + , EpaCommentTok + ( EpaBlockComment + , EpaDocCommentNamed + , EpaDocCommentNext + , EpaDocCommentPrev + , EpaDocOptions + , EpaDocSection + , EpaEofComment + , EpaLineComment + ) + , EpaLocation(EpaSpan) + , GenLocated(L) + , HsModule(HsModule) + , LEpaComment + , LHsDecl + , LImportDecl + , SrcSpan + ( RealSrcSpan + , UnhelpfulSpan + ) + , SrcSpanAnn'(SrcSpanAnn) + , anchor + , ideclName + , moduleNameString + , srcLocCol + , srcLocLine + , unLoc + ) +import qualified GHC.OldList as List +import GHC.Parser.Annotation ( DeltaPos + ( DifferentLine + , SameLine + ) + , EpaCommentTok(EpaEofComment) + ) +import GHC.Types.SrcLoc ( realSrcSpanEnd ) +import qualified Language.Haskell.GHC.ExactPrint.Types + as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Utils + as ExactPrint +import Safe ( maximumMay ) + +import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.ToBriDoc.Module +import Language.Haskell.Brittany.Internal.Types + + + +splitModule + :: Bool + -> GHC.ParsedSource + -> Maybe GHC.RealSrcLoc + -> FinalList ModuleElement ExactPrint.Pos +splitModule shouldReformatHead lmod posWhere = do + let L moduleSpan modl = lmod + HsModule _ _layout _name _exports imports decls _ _ = modl + (hsModAnn', finalComments) = case GHC.hsmodAnn modl of + EpAnn a modAnns (EpaCommentsBalanced prior post) -> + (EpAnn a modAnns (EpaCommentsBalanced prior []), post) + _ -> (GHC.hsmodAnn modl, []) + moduleWithoutComments = + L moduleSpan modl { GHC.hsmodAnn = hsModAnn', GHC.hsmodDecls = [] } + lastSpan <- if shouldReformatHead + then do + finalYield $ MEPrettyModuleHead moduleWithoutComments + let locBeforeImports = + maximumMay + $ [ realSrcSpanEnd $ anchor a + | L a _ <- case hsModAnn' of + EpAnn _ _ (EpaComments cs ) -> cs + EpAnn _ _ (EpaCommentsBalanced cs1 cs2) -> cs1 ++ cs2 + EpAnnNotUsed -> error "unexpected EpAnnNotUsed" + ] + ++ [ pos | Just pos <- [posWhere] ] + let (importLines, lastSpan) = finalToList $ transformToImportLine + ( maybe 0 srcLocLine locBeforeImports + , maybe 1 srcLocCol locBeforeImports + ) + imports + let commentedImports = groupifyImportLines importLines + sortCommentedImports commentedImports `forM_` \case + EmptyLines n -> + finalYield $ MEWhitespace $ DifferentLine n 1 + SamelineComment{} -> + error "brittany internal error: splitModule SamelineComment" + NewlineComment comm -> finalYield $ MEComment comm + ImportStatement record -> do + forM_ (commentsBefore record) $ finalYield . MEComment + finalYield + $ MEImportDecl (importStatement record) (commentsSameline record) + forM_ (commentsAfter record) $ finalYield . MEComment + pure $ lastSpan + else do + finalYield $ MEExactModuleHead moduleWithoutComments + pure + $ maybe (1, 1) (ExactPrint.ss2posEnd) + $ maximumMay + $ [ GHC.anchor a + | L a _ <- GHC.priorComments $ case hsModAnn' of + EpAnn _ _ cs -> cs + EpAnnNotUsed -> error "unexpected EpAnnNotUsed" + ] + ++ [ s | AddEpAnn _ (EpaSpan s) <- GHC.am_main $ GHC.anns hsModAnn' ] + ++ [ GHC.anchor a + | L da _ <- GHC.hsmodImports modl + , L a _ <- case GHC.ann da of + EpAnn _ _ (EpaComments l ) -> l + EpAnn _ _ (EpaCommentsBalanced _ l) -> l + EpAnnNotUsed -> [] + ] + ++ [ span + | L (SrcSpanAnn _ (GHC.RealSrcSpan span _)) _ <- GHC.hsmodImports + modl + ] + spanAfterDecls <- enrichDecls lastSpan decls + enrichComms spanAfterDecls finalComments + + +enrichComms + :: ExactPrint.Pos -> [LEpaComment] -> FinalList ModuleElement ExactPrint.Pos +enrichComms lastSpanEnd = \case + [] -> pure lastSpanEnd + (L (Anchor span _) (EpaComment EpaEofComment _) : commRest) -> do + finalYield $ MEWhitespace $ case ExactPrint.ss2delta lastSpanEnd span of -- TODO92 move this (l-1) bit into utility function + SameLine i -> SameLine i + DifferentLine l c -> DifferentLine (l - 1) c + enrichComms (ExactPrint.ss2posEnd span) commRest + (L (Anchor span _) (EpaComment comm _) : commRest) -> do + case ExactPrint.ss2delta lastSpanEnd span of + SameLine i -> do + finalYield $ MEComment (i, comm) + DifferentLine l c -> do + finalYield $ MEWhitespace $ DifferentLine (l - 1) c + finalYield $ MEComment (0, comm) + enrichComms (ExactPrint.ss2posEnd span) commRest + +enrichDecls + :: ExactPrint.Pos -> [LHsDecl GhcPs] -> FinalList ModuleElement ExactPrint.Pos +enrichDecls lastSpanEnd = \case + [] -> finalPure $ lastSpanEnd + (L (SrcSpanAnn dAnn rlspan@(GHC.RealSrcSpan span _)) decl : declRest) -> + case dAnn of + EpAnn dAnchor items (EpaComments dComments) -> do + let + withoutComments = + (L (SrcSpanAnn (EpAnn dAnchor items (EpaComments [])) rlspan) decl) + commentExtract = \case + L (GHC.Anchor anch _) EpaComment{} -> ExactPrint.ss2posEnd anch + -- It would be really nice if `ExactPrint.ss2posEnd span` was + -- sufficient. But for some reason the comments are not + -- (consistently) included in the length of the anchor. I.e. + -- there are cases where a syntax tree node has an anchor from + -- pos A -> pos B. But then somewhere _below_ that node is a + -- comment that has an anchor pos B -> pos C. + -- We simply detect this here. + -- We probably do some redundant `SYB.everything` lookups + -- throughout the code now. But optimizing it is not easy, and + -- at worst it is larger constant factor on the size of the + -- input, so it isn't _that_ bad. + fixedSpanEnd = SYB.everything + max + (SYB.mkQ (ExactPrint.ss2posEnd span) commentExtract) + decl + case ExactPrint.ss2delta lastSpanEnd span of + SameLine{} -> pure () + DifferentLine n _ -> + finalYield $ MEWhitespace $ DifferentLine (n - 1) 1 + let (afterComms, span2) = finalToList $ enrichComms fixedSpanEnd (reverse dComments) + let (immediate, later) = List.span (\case + MEComment{} -> True + _ -> False + ) afterComms + finalYield $ MEDecl withoutComments [ comm | MEComment comm <- immediate ] + later `forM_` finalYield + enrichDecls span2 declRest + EpAnn _anchor _items (EpaCommentsBalanced{}) -> + error "EpaCommentsBalanced" + EpAnnNotUsed -> error "EpAnnNotUsed" + (L (SrcSpanAnn _ann (GHC.UnhelpfulSpan{})) _decl : _declRest) -> + error "UnhelpfulSpan" + + +-- module head pretty-printing + +data ImportLine + = EmptyLines Int + | SamelineComment (Int, EpaCommentTok) + | NewlineComment (Int, EpaCommentTok) -- indentation and comment + | ImportStatement ImportStatementRecord + +instance Show ImportLine where + show = \case + EmptyLines n -> "EmptyLines " ++ show n + SamelineComment{} -> "SamelineComment" + NewlineComment{} -> "NewlineComment" + ImportStatement r -> + "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) + +data ImportStatementRecord = ImportStatementRecord + { commentsBefore :: [(Int, EpaCommentTok)] + , importStatement :: LImportDecl GhcPs + , commentsSameline :: [(Int, EpaCommentTok)] + , commentsAfter :: [(Int, EpaCommentTok)] + } + +instance Show ImportStatementRecord where + show r = + "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show + (length $ commentsAfter r) + + +transformToImportLine + :: ExactPrint.Pos + -> [LImportDecl GhcPs] + -> FinalList ImportLine ExactPrint.Pos +transformToImportLine startPos is = + let + flattenComms + :: [LEpaComment] -> ExactPrint.Pos -> FinalList ImportLine ExactPrint.Pos + flattenComms = \case + [] -> finalPure + (L (Anchor span _) (EpaComment comm _) : commRest) -> \lastSpanEnd -> do + case ExactPrint.ss2delta lastSpanEnd span of + SameLine i -> do + finalYield $ SamelineComment (i, comm) + DifferentLine l c -> do + finalYield $ EmptyLines (l - 1) + finalYield $ NewlineComment (c - 1, comm) + flattenComms commRest (ExactPrint.ss2posEnd span) + flattenDecls + :: [LImportDecl GhcPs] + -> ExactPrint.Pos + -> FinalList ImportLine ExactPrint.Pos + flattenDecls = \case + [] -> finalPure + (L (SrcSpanAnn epAnn srcSpan@(RealSrcSpan declSpan _)) decl : declRest) + -> \lastSpanEnd -> + let (commsBefore, commsAfter, cleanEpAnn) = case epAnn of + EpAnn anch s (EpaComments cs) -> + ([], reverse cs, EpAnn anch s (EpaComments [])) + EpAnn anch s (EpaCommentsBalanced cs1 cs2) -> + (reverse cs1, reverse cs2, EpAnn anch s (EpaComments [])) + EpAnnNotUsed -> ([], [], EpAnnNotUsed) + in + do + span1 <- flattenComms commsBefore lastSpanEnd + let newlines = case ExactPrint.ss2delta span1 declSpan of + SameLine _ -> 0 + DifferentLine i _ -> i - 1 + finalYield + $ EmptyLines newlines + finalYield $ ImportStatement ImportStatementRecord + { commentsBefore = [] + , importStatement = L (SrcSpanAnn cleanEpAnn srcSpan) decl + , commentsSameline = [] + , commentsAfter = [] + } + span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan) + flattenDecls declRest span2 + (L (SrcSpanAnn _epAnn UnhelpfulSpan{}) _decl : _declRest) -> + error "UnhelpfulSpan" + in + flattenDecls is startPos + +data Partial = PartialCommsOnly [(Int, EpaCommentTok)] + | PartialImport ImportStatementRecord + +groupifyImportLines :: [ImportLine] -> [ImportLine] +groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls + where + go acc [] = case acc of + PartialCommsOnly comms -> + reverse comms `forM_` \comm -> finalYield $ NewlineComment comm + PartialImport partialRecord -> + finalYield $ ImportStatement $ unpartial partialRecord + go acc (line1 : lineR) = do + newAcc <- case acc of + PartialCommsOnly comms -> case line1 of + e@EmptyLines{} -> do + reverse comms `forM_` \comm -> finalYield $ NewlineComment comm + finalYield e + pure $ PartialCommsOnly [] + SamelineComment comm -> do + pure $ PartialCommsOnly (comm : comms) + NewlineComment comm -> pure $ PartialCommsOnly (comm : comms) + ImportStatement record -> + pure $ PartialImport $ record { commentsBefore = comms } + PartialImport partialRecord -> case line1 of + e@EmptyLines{} -> do + finalYield $ ImportStatement $ unpartial partialRecord + finalYield e + pure $ PartialCommsOnly [] + SamelineComment comm -> do + if (null $ commentsAfter partialRecord) + then pure $ PartialImport partialRecord + { commentsSameline = comm : commentsSameline partialRecord + } + else pure $ PartialImport partialRecord + { commentsAfter = comm : commentsAfter partialRecord + } + NewlineComment comm -> pure $ PartialImport $ partialRecord + { commentsAfter = comm : commentsAfter partialRecord + } + ImportStatement record -> do + let contestedComments = commentsAfter partialRecord + finalYield $ ImportStatement $ unpartial $ partialRecord + { commentsAfter = [] + } + pure $ PartialImport $ record { commentsBefore = contestedComments } + -- comments in between will stay connected to the following decl + go newAcc lineR + unpartial :: ImportStatementRecord -> ImportStatementRecord + unpartial partialRecord = ImportStatementRecord + { commentsBefore = reverse (commentsBefore partialRecord) + , importStatement = importStatement partialRecord + , commentsSameline = reverse (commentsSameline partialRecord) + , commentsAfter = reverse (commentsAfter partialRecord) + } + + +sortCommentedImports :: [ImportLine] -> [ImportLine] +sortCommentedImports = + -- TODO92 we don't need this unpackImports, it is implied later in the process + mergeGroups . map (fmap (sortGroups)) . groupify + where + -- unpackImports :: [ImportLine] -> [ImportLine] + -- unpackImports xs = xs >>= \case + -- l@EmptyLines{} -> [l] + -- l@NewlineComment{} -> [l] + -- l@SamelineComment{} -> [l] + -- ImportStatement r -> + -- map NewlineComment (commentsBefore r) ++ [ImportStatement r] ++ map + -- NewlineComment + -- (commentsAfter r) + mergeGroups :: [Either ImportLine [ImportStatementRecord]] -> [ImportLine] + mergeGroups xs = xs >>= \case + Left x -> [x] + Right y -> ImportStatement <$> y + sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] + sortGroups = + List.sortOn (moduleNameString . unLoc . ideclName . unLoc . importStatement) + groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]] + groupify cs = go [] cs + where + go [] = \case + (l@EmptyLines{} : rest) -> Left l : go [] rest + (l@NewlineComment{} : rest) -> Left l : go [] rest + (l@SamelineComment{} : rest) -> Left l : go [] rest + (ImportStatement r : rest) -> go [r] rest + [] -> [] + go acc = \case + (l@EmptyLines{} : rest) -> Right (reverse acc) : Left l : go [] rest + (l@NewlineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest + (l@SamelineComment{} : rest) -> Left l : Right (reverse acc) : go [] rest + (ImportStatement r : rest) -> go (r : acc) rest + [] -> [Right (reverse acc)] diff --git a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs new file mode 100644 index 0000000..c97263a --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs @@ -0,0 +1,741 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Language.Haskell.Brittany.Internal.S3_ToBriDocTools where + +import qualified Control.Monad.Writer.Strict as Writer +import qualified Data.Char as Char +import Data.Data +import qualified Data.Generics as SYB +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import DataTreePrint +import GHC ( EpAnn(EpAnn, EpAnnNotUsed) + , EpAnnComments + ( EpaComments + , EpaCommentsBalanced + ) + , GenLocated(L) + , LEpaComment + , Located + , LocatedA + , moduleName + , moduleNameString + ) +import qualified GHC +import GHC.Data.FastString ( FastString ) +import qualified GHC.OldList as List +import GHC.Parser.Annotation ( AnnKeywordId(..) ) +import GHC.Types.Name ( getOccString ) +import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Types.Name.Reader ( RdrName(..) ) +import qualified GHC.Types.SrcLoc as GHC +import GHC.Utils.Outputable ( Outputable ) +import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +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.Utils + as ExactPrint + + + +-- | Use ExactPrint's output for this node; add a newly generated inline comment +-- at insertion position (meant to point out to the user that this node is +-- not handled by brittany yet). Useful when starting implementing new +-- syntactic constructs when children are not handled yet. +briDocByExact + :: (ExactPrint.ExactPrint ast, Data ast) + => LocatedA ast + -> ToBriDocM BriDocNumbered +briDocByExact ast = do + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 160 customLayouterF ast) + mModify (+ connectedCommentCount ast) + docExt ast True + +-- | Use ExactPrint's output for this node. +-- Consider that for multi-line input, the indentation of the code produced +-- by ExactPrint might be different, and even incompatible with the indentation +-- of its surroundings as layouted by brittany. But there are safe uses of +-- this, e.g. for any top-level declarations. +briDocByExactNoComment + :: (ExactPrint.ExactPrint (GenLocated l ast), Data ast, Data l) + => GenLocated l ast + -> ToBriDocM BriDocNumbered +briDocByExactNoComment ast = do + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 160 customLayouterF ast) + mModify (+ connectedCommentCount ast) + docExt ast 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.ExactPrint (GHC.XRec GhcPs a) + , Data (GHC.XRec GhcPs a) + , Data a + , Data (GHC.Anno a) + , Outputable (GHC.Anno a) + ) + => String + -> GHC.XRec GhcPs a + -> ToBriDocM BriDocNumbered +briDocByExactInlineOnly infoStr ast = do + traceIfDumpConf + "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 160 customLayouterF ast) + let exactPrinted = Text.pack $ ExactPrint.exactPrint ast + fallbackMode <- + mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack + let + exactPrintNode t = + allocateNode $ BDFExternal + -- (ExactPrint.Types.mkAnnKey ast) + -- (foldedAnnKeys ast) + False t + let + errorAction = do + mTell [ErrorUnknownNode infoStr ast] + docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + mModify (+ connectedCommentCount ast) + case (fallbackMode, Text.lines exactPrinted) of + (ExactPrintFallbackModeNever, _) -> errorAction + (_, [t]) -> exactPrintNode + (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) + (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted + _ -> errorAction + +rdrNameToText :: RdrName -> Text +-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr +rdrNameToText (Unqual occname) = Text.pack $ occNameString occname +rdrNameToText (Qual mname occname) = + Text.pack $ moduleNameString mname ++ "." ++ occNameString occname +rdrNameToText (Orig modul occname) = + Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname +rdrNameToText (Exact name) = Text.pack $ getOccString name + +lrdrNameToText :: GenLocated l RdrName -> Text +lrdrNameToText (L _ n) = rdrNameToText n + +class PrintRdrNameWithAnns l where + printRdrNameWithAnns :: GenLocated l RdrName -> Text + +instance PrintRdrNameWithAnns GHC.SrcSpanAnnN where + printRdrNameWithAnns (L (GHC.SrcSpanAnn epAnn _) name) = + case epAnn of + EpAnn _ (GHC.NameAnn GHC.NameParens _ _ _ _) _ -> f "(" name ")" + EpAnn _ (GHC.NameAnn GHC.NameParensHash _ _ _ _) _ -> f "(#" name "#)" + EpAnn _ (GHC.NameAnn GHC.NameBackquotes _ _ _ _) _ -> f "`" name "`" + EpAnn _ (GHC.NameAnn GHC.NameSquare _ _ _ _) _ -> f "[" name "]" + -- TODO92 There are way more possible constructors here + -- see https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC-Parser-Annotation.html#t:NameAnn + EpAnn _ _ _ -> rdrNameToText name + EpAnnNotUsed -> rdrNameToText name + where + f a b c = Text.pack a <> rdrNameToText b <> Text.pack c + +lrdrNameToTextAnnGen + :: (MonadMultiReader Config m, PrintRdrNameWithAnns l) + => (Text -> Text) + -> GenLocated l RdrName + -> m Text + -- TODO this doesn't need to be monadic. I am pretty sure it started of as + -- a pure function, then at some point annotations were inspected + -- (from reader) but now it is pure again. + -- Leaving it as pseudo-monadic is harmless though (I think? Maybe I should + -- check I don't force some mapM/sequence/… garbage at common callsides + -- for this). +lrdrNameToTextAnnGen f ast = pure $ f $ printRdrNameWithAnns ast + +lrdrNameToTextAnn + :: (MonadMultiReader Config m, PrintRdrNameWithAnns l) + => GenLocated l RdrName + -> m Text +lrdrNameToTextAnn = lrdrNameToTextAnnGen id + +lrdrNameToTextAnnTypeEqualityIsSpecial + :: (MonadMultiReader Config m, PrintRdrNameWithAnns l) + => GenLocated l RdrName + -> m Text +lrdrNameToTextAnnTypeEqualityIsSpecial ast = do + let + f x = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x + lrdrNameToTextAnnGen f ast + +-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects +-- the annotations for a (parent) node for a tick to be added to the +-- literal. +-- Excessively long name to reflect on us having to work around such +-- excessively obscure special cases in the exactprint API. +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick + :: (MonadMultiReader Config m, PrintRdrNameWithAnns l) + => Located ast + -> GenLocated l RdrName + -> m Text +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick _ast1 ast2 = do + -- TODO92 + -- hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote + x <- lrdrNameToTextAnn ast2 + let + lit = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x + return lit -- $ if hasQuote then Text.cons '\'' lit else lit + +askIndent :: (MonadMultiReader Config m) => m Int +askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk + +-- TODO92 this is not filtering enough yet, see old code below +hasAnyCommentsBelow :: Data ast => ast -> Bool +hasAnyCommentsBelow = + getAny . SYB.everything (<>) (SYB.mkQ (Any False) (\(_ :: LEpaComment) -> Any True)) +-- -- | 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 ast@(L l _) = +-- List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l) +-- <$> astConnectedComments ast + +-- extractRestComments +-- :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] +-- extractRestComments ann = +-- 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) + +hasCommentsBetween + :: Data ast + => ast + -> Maybe GHC.RealSrcLoc + -> Maybe GHC.RealSrcLoc + -> Bool +hasCommentsBetween ast left right = do + getAny $ SYB.everything + (<>) + (SYB.mkQ + (Any False) + (\(L (GHC.Anchor pos _) _ :: LEpaComment) -> Any + ( (maybe True (GHC.realSrcSpanStart pos >=) left) + && (maybe True (GHC.realSrcSpanEnd pos <=) right) + ) + ) + ) + ast + + + + -- mAnn <- astAnn ast + -- let + -- go1 [] = False + -- 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 (_ : rest) = go2 rest + -- case mAnn of + -- Nothing -> pure False + -- Just ann -> pure $ go1 $ ExactPrint.annsDP ann + +-- | True if there are any comments that are connected to any node below (in AST +-- sense) the given node +hasAnyCommentsConnected :: (Data ann, Data ast) => GHC.GenLocated ann ast -> Bool +hasAnyCommentsConnected = + getAny . SYB.everything (<>) (SYB.mkQ (Any False) (\(_ :: LEpaComment) -> Any True)) + +connectedCommentCount :: (Data ann, Data ast) => GHC.GenLocated ann ast -> CommentCounter +connectedCommentCount = + getSum . SYB.everything (<>) (SYB.mkQ (Sum 0) (\(_ :: LEpaComment) -> Sum 1)) + +-- | True if there are any regular comments connected to any node below (in AST +-- sense) the given node +-- hasAnyRegularCommentsConnected :: GenLocated ann ast -> Bool +-- hasAnyRegularCommentsConnected ast = +-- any isRegularComment $ astConnectedComments ast + +-- | Regular comments are comments that are actually "source code comments", +-- i.e. things that start with "--" or "{-". In contrast to comment-annotations +-- used by ghc-exactprint for capturing symbols (and their exact positioning). +-- +-- Only the type instance layouter makes use of this filter currently, but +-- it might make sense to apply it more aggressively or make it the default - +-- 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 + +astConnectedComments + :: (Data ann, Data ast) + => GHC.GenLocated ann ast + -> [LEpaComment] +astConnectedComments = + SYB.listify (\(_ :: LEpaComment) -> True) + -- anns <- filterAnns ast <$> mAsk + -- pure $ extractAllComments =<< Map.elems anns +-- +-- hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool +-- hasAnyCommentsPrior ast = astAnn ast <&> \case +-- Nothing -> False +-- Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors + +-- hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool +-- hasAnyRegularCommentsRest ast = astAnn ast <&> \case +-- Nothing -> False +-- Just ann -> any isRegularComment (extractRestComments ann) + +-- hasAnnKeywordComment +-- :: GHC.LocatedA ast -> AnnKeywordId -> Bool +-- hasAnnKeywordComment (L (GHC.SrcSpanAnn ann _) _) annKeyword = False -- _ ann + -- Nothing -> False + -- Just ann -> any hasK (extractAllComments ann) + -- where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst + +-- new BriDoc stuff + +allocateNode + :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered +allocateNode bd = do + i <- allocNodeIndex + return (i, bd) + +allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int +allocNodeIndex = do + NodeAllocIndex i <- mGet + mSet $ NodeAllocIndex (i + 1) + return i + +docEmpty :: ToBriDocM BriDocNumbered +docEmpty = allocateNode BDFEmpty + +docLit :: Text -> ToBriDocM BriDocNumbered +docLit t = allocateNode $ BDFLit t + +docLitS :: String -> ToBriDocM BriDocNumbered +docLitS s = allocateNode $ BDFLit $ Text.pack s + +docExt + :: (ExactPrint.ExactPrint (GenLocated l ast)) + => GenLocated l ast + -> Bool + -> ToBriDocM BriDocNumbered +docExt x shouldAddComment = allocateNode $ BDFExternal + -- (ExactPrint.Types.mkAnnKey x) + -- (foldedAnnKeys x) + shouldAddComment + (Text.pack + $ List.dropWhile ((==) '\n') + $ ExactPrint.exactPrint + $ ExactPrint.makeDeltaAst x + ) + +docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docAlt l = allocateNode . BDFAlt =<< sequence l + +newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) + deriving (Functor, Applicative, Monad) + +addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () +addAlternativeCond cond doc = when cond (addAlternative doc) + +addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () +addAlternative = CollectAltM . Writer.tell . (: []) + +runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered +runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action + + +docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docSeq [] = docEmpty +docSeq l = allocateNode . BDFSeq =<< sequence l + +docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docLines l = allocateNode . BDFLines =<< sequence l + +docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +docCols sig l = allocateNode . BDFCols sig =<< sequence l + +docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm + +docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetBaseY bdm = do + bd <- bdm + -- the order here is important so that these two nodes can be treated + -- properly over at `transformAlts`. + n1 <- allocateNode $ BDFBaseYPushCur bd + n2 <- allocateNode $ BDFBaseYPop n1 + return n2 + +docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetIndentLevel bdm = do + bd <- bdm + n1 <- allocateNode $ BDFIndentLevelPushCur bd + n2 <- allocateNode $ BDFIndentLevelPop n1 + return n2 + +docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetBaseAndIndent = docSetBaseY . docSetIndentLevel + +docSeparator :: ToBriDocM BriDocNumbered +docSeparator = allocateNode BDFSeparator + +docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm + +docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm + +docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm + +docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm + +docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docDebug s bdm = allocateNode . BDFDebug s =<< bdm + +appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +appSep x = docSeq [x, docSeparator] + +docCommaSep :: ToBriDocM BriDocNumbered +docCommaSep = appSep $ docLit $ Text.pack "," + +docParenLSep :: ToBriDocM BriDocNumbered +docParenLSep = appSep docParenL + +-- TODO: we don't make consistent use of these (yet). However, I think the +-- most readable approach overall might be something else: define +-- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`. +-- I think those two would make the usage most readable. +-- lit "(" and appSep (lit "(") are understandable and short without +-- introducing a new top-level binding for all types of parentheses. +docParenL :: ToBriDocM BriDocNumbered +docParenL = docLit $ Text.pack "(" + +docParenR :: ToBriDocM BriDocNumbered +docParenR = docLit $ Text.pack ")" + +docParenHashLSep :: ToBriDocM BriDocNumbered +docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] + +docParenHashRSep :: ToBriDocM BriDocNumbered +docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] + +docBracketL :: ToBriDocM BriDocNumbered +docBracketL = docLit $ Text.pack "[" + +docBracketR :: ToBriDocM BriDocNumbered +docBracketR = docLit $ Text.pack "]" + + +docTick :: ToBriDocM BriDocNumbered +docTick = docLit $ Text.pack "'" + + +docPar + :: ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docPar lineM indentedM = do + line <- lineM + indented <- indentedM + allocateNode $ BDFPar BrIndentNone line indented + +docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm + +docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm + +docEnsureIndent + :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd + + +docFlushRemaining :: FastString -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docFlushRemaining fileThing = docFlushCommsPost + (Just $ GHC.mkRealSrcLoc fileThing 999999 999999) + +-- CLASS DocHandleComms -------------------------------------------------------- + +class DocHandleComms ann a where + docHandleComms :: HasCallStack => ann -> a -> a + +instance DocHandleComms [LEpaComment] (ToBriDocM BriDocNumbered) where + docHandleComms comms bdm = do + bd <- bdm + i1 <- allocNodeIndex + pure (i1, BDFQueueComments comms bd) + +instance DocHandleComms (EpAnn a) (ToBriDocM BriDocNumbered) where + docHandleComms epAnn bdm = case epAnn of + EpAnn anch _ (EpaComments []) -> do + bd <- bdm + i1 <- allocNodeIndex + pure + (i1, BDFFlushCommentsPrior (GHC.realSrcSpanStart $ GHC.anchor anch) bd) + EpAnn anch _ (EpaComments comms) -> do + bd <- bdm + i1 <- allocNodeIndex + i2 <- allocNodeIndex + pure + ( i1 + , BDFFlushCommentsPrior (GHC.realSrcSpanStart $ GHC.anchor anch) + (i2, BDFQueueComments (reverse comms) bd) + ) + EpAnn anch _ (EpaCommentsBalanced commsB commsA) -> do + bd <- bdm + i1 <- allocNodeIndex + i2 <- allocNodeIndex + pure + ( i1 + , BDFQueueComments + (reverse commsB ++ reverse commsA) + ( i2 + , BDFFlushCommentsPrior (GHC.realSrcSpanStart $ GHC.anchor anch) bd + ) + ) + EpAnnNotUsed -> bdm + +instance DocHandleComms (GHC.RealSrcSpan) (ToBriDocM BriDocNumbered) where + docHandleComms loc = docHandleComms (GHC.realSrcSpanStart loc) + +instance DocHandleComms (GHC.RealSrcLoc) (ToBriDocM BriDocNumbered) where + docHandleComms loc bdm = do + bd <- bdm + i1 <- allocNodeIndex + pure (i1, BDFFlushCommentsPrior loc bd) + +instance DocHandleComms (Maybe GHC.RealSrcSpan) (ToBriDocM BriDocNumbered) where + docHandleComms Nothing bdm = bdm + docHandleComms (Just loc) bdm = docHandleComms loc bdm + +instance DocHandleComms (Maybe GHC.RealSrcLoc) (ToBriDocM BriDocNumbered) where + docHandleComms Nothing bdm = bdm + docHandleComms (Just loc) bdm = docHandleComms loc bdm + +instance DocHandleComms (GHC.SrcLoc) (ToBriDocM BriDocNumbered) where + docHandleComms (GHC.RealSrcLoc loc _) bdm = docHandleComms loc bdm + docHandleComms (GHC.UnhelpfulLoc _) bdm = bdm + +instance DocHandleComms (GHC.LocatedA ast) (ToBriDocM BriDocNumbered) where + docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of + GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm + GHC.UnhelpfulSpan _ -> bdm + +instance DocHandleComms (GHC.LocatedL ast) (ToBriDocM BriDocNumbered) where + docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of + GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm + GHC.UnhelpfulSpan _ -> bdm + +instance DocHandleComms (GHC.LocatedC ast) (ToBriDocM BriDocNumbered) where + docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of + GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm + GHC.UnhelpfulSpan _ -> bdm + +instance DocHandleComms (GHC.LocatedN ast) (ToBriDocM BriDocNumbered) where + docHandleComms (L (GHC.SrcSpanAnn epAnn span) _) bdm = case span of + GHC.RealSrcSpan s _ -> docHandleComms s $ docHandleComms epAnn bdm + GHC.UnhelpfulSpan _ -> bdm + + +instance DocHandleComms ann (ToBriDocM BriDocNumbered) + => DocHandleComms ann (ToBriDocM [BriDocNumbered]) where + docHandleComms ann bdm = do + x <- bdm + case x of + [] -> error "docHandleComms empty list" + -- TODO92 + -- do + -- el <- docHandleComms ann docEmpty + -- pure [el] + (bd1:bdR) -> do + bd1' <- docHandleComms ann (pure bd1) + pure (bd1':bdR) + +instance DocHandleComms ann (ToBriDocM BriDocNumbered) + => DocHandleComms ann (ToBriDocM (Seq BriDocNumbered)) + where + docHandleComms ast bdsm = do + bds <- bdsm + case Seq.viewl bds of + Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well. + bd1 Seq.:< rest -> do + bd1' <- docHandleComms ast (return bd1) + return $ bd1' Seq.<| rest + + +instance DocHandleComms ann (ToBriDocM BriDocNumbered) + => DocHandleComms ann [ToBriDocM BriDocNumbered] where + docHandleComms ann bdms = do + case bdms of + [] -> error "docHandleComms empty list" + -- [docHandleComms ann docEmpty] + (bd1:bdR) -> (docHandleComms ann bd1:bdR) + +instance DocHandleComms GHC.EpaLocation (ToBriDocM BriDocNumbered) where + docHandleComms loc bdm = docHandleComms (GHC.epaLocationRealSrcSpan loc) bdm + +instance DocHandleComms GHC.SrcSpan (ToBriDocM BriDocNumbered) where + docHandleComms (GHC.RealSrcSpan s _) bdm = docHandleComms s bdm + docHandleComms (GHC.UnhelpfulSpan _) bdm = bdm + + +-- CLASS ObtainAnnPos ---------------------------------------------------------- + +class ObtainAnnPos key ann where + obtainAnnPos :: ann -> key -> Maybe GHC.RealSrcLoc + +instance ObtainAnnPos AnnKeywordId GHC.AddEpAnn where + obtainAnnPos (GHC.AddEpAnn eKW loc) kw = if eKW == kw + then Just (epaLocationRealSrcSpanStart loc) + else Nothing + +instance ObtainAnnPos AnnKeywordId (EpAnn GHC.AnnsModule) where + obtainAnnPos = \case + EpAnnNotUsed -> \_kw -> Nothing + EpAnn _ (GHC.AnnsModule l annList) _ -> \kw -> + obtainAnnPos l kw <|> obtainAnnPos annList kw + +instance ObtainAnnPos AnnKeywordId (Maybe GHC.AddEpAnn) where + obtainAnnPos Nothing _ = Nothing + obtainAnnPos (Just addEpAnn) kw = obtainAnnPos addEpAnn kw + +instance ObtainAnnPos AnnKeywordId [GHC.AddEpAnn] where + obtainAnnPos list kw = + case [ loc | GHC.AddEpAnn eKW loc <- list, eKW == kw ] of + [] -> Nothing + locs -> Just (epaLocationRealSrcSpanStart $ minimum locs) + +instance ObtainAnnPos AnnKeywordId (EpAnn [GHC.AddEpAnn]) where + obtainAnnPos EpAnnNotUsed _kw = Nothing + obtainAnnPos (EpAnn _ list _) kw = obtainAnnPos list kw + +instance ObtainAnnPos AnnKeywordId (EpAnn GHC.AnnList) where + obtainAnnPos = \case + EpAnnNotUsed -> \_kw -> Nothing + EpAnn _ annList _ -> \kw -> obtainAnnPos annList kw + +instance ObtainAnnPos AnnKeywordId GHC.AnnList where + obtainAnnPos (GHC.AnnList _ op cl addEpAnn _) kw = + obtainAnnPos op kw <|> obtainAnnPos cl kw <|> obtainAnnPos addEpAnn kw + +instance ObtainAnnPos AnnKeywordId (EpAnn GHC.GrhsAnn) where + obtainAnnPos = \case + EpAnn _ (GHC.GrhsAnn _ addEpAnn) _ -> obtainAnnPos addEpAnn + EpAnnNotUsed -> \_kw -> Nothing + +instance ObtainAnnPos AnnKeywordId GHC.SrcSpanAnnL where + obtainAnnPos = \case + GHC.SrcSpanAnn epAnn _ -> obtainAnnPos epAnn + +class ObtainAnnPos AnnKeywordId ann => ObtainAnnDeltaPos ann where + obtainAnnDeltaPos :: ann -> AnnKeywordId -> Maybe GHC.DeltaPos + +instance ObtainAnnDeltaPos (EpAnn GHC.AnnsModule) where + obtainAnnDeltaPos = \case + EpAnnNotUsed -> \_kw -> Nothing + EpAnn _ (GHC.AnnsModule l annList) epaComms -> \kw -> do + loc <- obtainAnnPos l kw <|> obtainAnnPos annList kw + let pos = (GHC.srcLocLine loc, GHC.srcLocCol loc) + pure $ ExactPrint.pos2delta + (maximum $ (0, 1) : + [ ExactPrint.ss2posEnd $ GHC.anchor anch + | L anch _ <- case epaComms of + EpaCommentsBalanced cs1 cs2 -> cs1 ++ cs2 + EpaComments cs -> cs + , let compPos = ExactPrint.ss2posEnd (GHC.anchor anch) + , compPos <= pos + ] + ) + pos + +class DocFlushCommsPost a where + docFlushCommsPost :: Maybe GHC.RealSrcLoc -> a -> a + +instance DocFlushCommsPost (ToBriDocM BriDocNumbered) where + docFlushCommsPost = \case + Nothing -> id + Just span -> \bdm -> do + i1 <- allocNodeIndex + bd <- bdm + pure (i1, BDFFlushCommentsPost span bd) + +instance DocFlushCommsPost (ToBriDocM [BriDocNumbered]) where + docFlushCommsPost loc bdm = do + bds <- bdm + case bds of + [] -> do + e <- docFlushCommsPost loc docEmpty + pure [e] + _ -> do + e <- docFlushCommsPost loc (pure $ List.last bds) + pure (List.init bds ++ [e]) + +unknownNodeError + :: (Data a, Data (GHC.Anno a), Outputable (GHC.Anno a)) + => String + -> GHC.XRec GhcPs a + -> ToBriDocM BriDocNumbered +unknownNodeError infoStr ast = do + mTell [ErrorUnknownNode infoStr ast] + docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + +spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered] +spacifyDocs [] = [] +spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds] + +shareDoc :: ToBriDocM a -> ToBriDocM (ToBriDocM a) +shareDoc = fmap pure + + +obtainListElemStartCommaLocs + :: LocatedA ast -> (Maybe GHC.RealSrcLoc, Maybe GHC.RealSrcLoc) +obtainListElemStartCommaLocs = \case + L (GHC.SrcSpanAnn elemEpAnn _) _ -> case elemEpAnn of + EpAnn anch (GHC.AnnListItem [item]) _ -> + ( Just $ GHC.realSrcSpanStart $ GHC.anchor anch + -- yes, we want `realSrcSpanStart span2` here, but have it flow + -- to the end of bd. We want any comments _before_ the _start_ + -- of the comma to be inserted _after_ the element. + , Just $ GHC.realSrcSpanStart $ case item of + GHC.AddCommaAnn span -> GHC.epaLocationRealSrcSpan span + GHC.AddSemiAnn span -> GHC.epaLocationRealSrcSpan span + GHC.AddVbarAnn span -> GHC.epaLocationRealSrcSpan span + GHC.AddRarrowAnn span -> GHC.epaLocationRealSrcSpan span + GHC.AddRarrowAnnU span -> GHC.epaLocationRealSrcSpan span + GHC.AddLollyAnnU span -> GHC.epaLocationRealSrcSpan span + ) + EpAnn anch _ _ -> (Just $ GHC.realSrcSpanStart $ GHC.anchor anch, Nothing) + EpAnnNotUsed -> (Nothing, Nothing) + + +docHandleListElemComms + :: (LocatedA ast -> ToBriDocM BriDocNumbered) + -> LocatedA ast + -> ToBriDocM BriDocNumbered +docHandleListElemComms layouter e = case obtainListElemStartCommaLocs e of + (posStart, posComma) -> + docHandleComms posStart $ docFlushCommsPost posComma $ layouter e + +epaLocationRealSrcSpanStart :: GHC.EpaLocation -> GHC.RealSrcLoc +epaLocationRealSrcSpanStart = GHC.realSrcSpanStart . GHC.epaLocationRealSrcSpan diff --git a/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs new file mode 100644 index 0000000..24d2ed3 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.S4_WriteBriDoc + ( ppBriDoc + ) +where + +import Language.Haskell.Brittany.Internal.Prelude + +import qualified Control.Monad.Trans.MultiRWS.Strict + as MultiRWSS +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as TextL.Builder +import GHC ( Anchor(Anchor) + , AnchorOperation + ( MovedAnchor + , UnchangedAnchor + ) + , EpaComment(EpaComment) + , EpaCommentTok + ( EpaBlockComment + , EpaDocCommentNamed + , EpaDocCommentNext + , EpaDocCommentPrev + , EpaDocOptions + , EpaDocSection + , EpaEofComment + , EpaLineComment + ) + , GenLocated(L) + , LEpaComment + , RealSrcLoc + ) +import GHC.Types.SrcLoc ( realSrcSpanEnd ) +import qualified GHC.OldList as List + +import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Transformations.T1_Alt +import Language.Haskell.Brittany.Internal.Transformations.T2_Floating +import Language.Haskell.Brittany.Internal.Transformations.T3_Par +import Language.Haskell.Brittany.Internal.Transformations.T4_Columns +import Language.Haskell.Brittany.Internal.Transformations.T5_Indent +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.WriteBriDoc.AlignmentAlgo +import Language.Haskell.Brittany.Internal.WriteBriDoc.Types +import Language.Haskell.Brittany.Internal.WriteBriDoc.Operators +import Language.Haskell.Brittany.Internal.Components.BriDoc +-- import Language.Haskell.Brittany.Internal.S3_ToBriDocTools + + +ppBriDoc :: BriDocNumbered -> PPMLocal () +ppBriDoc briDoc = do + -- first step: transform the briDoc. + briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do + -- Note that briDoc is BriDocNumbered, but state type is BriDoc. + -- That's why the alt-transform looks a bit special here. + traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw + $ briDocToDoc + $ unwrapBriDocNumbered + $ briDoc + -- bridoc transformation: remove alts + transformAlts briDoc >>= mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt + -- bridoc transformation: float stuff in + mGet >>= transformSimplifyFloating .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating + -- bridoc transformation: par removal + mGet >>= transformSimplifyPar .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par + -- bridoc transformation: float stuff in + mGet >>= transformSimplifyColumns .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns + -- bridoc transformation: indent + mGet >>= transformSimplifyIndent .> mSet + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent + mGet + >>= briDocToDoc + .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final + -- -- convert to Simple type + -- simpl <- mGet <&> transformToSimple + -- return simpl + + let state = LayoutState { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left + -- here because moveToAnn stuff + -- of the first node needs to do + -- its thing properly. + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 + } + state' <- + MultiRWSS.withMultiStateS state + $ MultiRWSS.withMultiStateS ([] :: [LEpaComment]) + $ do + layoutBriDocM briDoc' + layoutWriteEnsureBlock + case _lstate_curYOrAddNewline state' of + Left{} -> mTell $ TextL.Builder.fromString "\n" + Right{} -> pure () + pure () + + +layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () +layoutBriDocM = \case + BDEmpty -> do + return () -- can it be that simple + BDLit t -> do + layoutIndentRestorePostComment + layoutRemoveIndentLevelLinger + layoutWriteAppend t + BDSeq list -> do + list `forM_` layoutBriDocM + -- in this situation, there is nothing to do about cols. + -- i think this one does not happen anymore with the current simplifications. + -- BDCols cSig list | BDPar sameLine lines <- List.last list -> + -- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines + BDCols _ list -> do + list `forM_` layoutBriDocM + BDSeparator -> do + layoutAddSepSpace + BDAddBaseY indent bd -> do + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ layoutBriDocM bd + BDBaseYPushCur bd -> do + layoutBaseYPushCur + layoutBriDocM bd + BDBaseYPop bd -> do + layoutBriDocM bd + layoutBaseYPop + BDIndentLevelPushCur bd -> do + layoutIndentLevelPushCur + layoutBriDocM bd + BDIndentLevelPop bd -> do + layoutBriDocM bd + layoutIndentLevelPop + BDEnsureIndent indent bd -> do + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ do + layoutWriteEnsureBlock + layoutBriDocM bd + BDPar indent sameLine indented -> do + layoutBriDocM sameLine + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ do + layoutWriteNewlineBlock + layoutBriDocM indented + BDLines lines -> alignColsLines layoutBriDocM lines + BDAlt [] -> error "empty BDAlt" + BDAlt (alt : _) -> layoutBriDocM alt + BDForceMultiline bd -> layoutBriDocM bd + BDForceSingleline bd -> layoutBriDocM bd + BDForwardLineMode bd -> layoutBriDocM bd + BDExternal shouldAddComment t -> do + let tlines = Text.lines $ t <> Text.pack "\n" + tlineCount = length tlines + when shouldAddComment $ do + layoutWriteAppend $ Text.pack $ "{- via external! -}" + zip [1 ..] tlines `forM_` \(i, l) -> do + layoutWriteAppend $ l + unless (i == tlineCount) layoutWriteNewlineBlock + BDPlain t -> do + layoutWriteAppend t + -- BDAnnotationPrior comms bd -> do + -- -- state <- mGet + -- -- let m = _lstate_comments state + -- -- let + -- -- moveToExactLocationAction = case _lstate_curYOrAddNewline state of + -- -- Left{} -> pure () + -- -- Right{} -> moveToExactAnn annKey + -- -- case mAnn of + -- -- Nothing -> moveToExactLocationAction + -- -- Just [] -> moveToExactLocationAction + -- -- Just priors -> do + -- -- -- layoutResetSepSpace + -- -- priors + -- -- `forM_` \(ExactPrint.Types.Comment comment _ _, DifferentLine (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 + -- printComments comms + -- mModify (\s -> s + CommentCounter (length comms)) + -- layoutBriDocM bd + -- BDAnnotationPost comms bd -> do + -- layoutBriDocM bd + -- printComments comms + -- mModify (\s -> s + CommentCounter (length comms)) + -- annMay <- do + -- state <- mGet + -- let m = _lstate_comments state + -- pure $ Map.lookup annKey m + -- let mComments = nonEmpty . extractAllComments =<< annMay + -- -- let + -- -- semiCount = length + -- -- [ () + -- -- | Just ann <- [annMay] + -- -- , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann + -- -- ] + -- shouldAddSemicolonNewlines <- + -- mAsk + -- <&> _conf_layout + -- .> _lconfig_experimentalSemicolonNewlines + -- .> confUnpack + -- case mComments of + -- Nothing -> do + -- when shouldAddSemicolonNewlines $ do + -- [1 .. semiCount] `forM_` const layoutWriteNewline + -- Just comments -> do + -- comments + -- `forM_` \(ExactPrint.Types.Comment comment _ _, DifferentLine (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 } + BDQueueComments comms bd -> do + existing :: [GHC.LEpaComment] <- mGet + mSet $ mergeOn (\(L l _) -> l) existing comms + layoutBriDocM bd + BDFlushCommentsPrior loc bd -> do + comms <- takeBefore loc + printComments comms + mModify (\s -> s + CommentCounter (length comms)) + layoutBriDocM bd + BDFlushCommentsPost loc bd -> do + layoutBriDocM bd + comms <- takeBefore loc + mModify (\s -> s + CommentCounter (length comms)) + printComments comms + BDNonBottomSpacing _ bd -> layoutBriDocM bd + BDSetParSpacing bd -> layoutBriDocM bd + BDForceParSpacing bd -> layoutBriDocM bd + BDDebug s bd -> do + mTell $ TextL.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" + layoutBriDocM bd + +mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a] +mergeOn _f xs [] = xs +mergeOn _f [] ys = ys +mergeOn f xs@(x:xr) ys@(y:yr) + | f x <= f y = x : mergeOn f xr ys + | otherwise = y : mergeOn f xs yr + +takeBefore + :: MonadMultiState [LEpaComment] m => RealSrcLoc -> m [LEpaComment] +takeBefore loc = do + comms <- mGet + let (before, after) = List.span + (\(L (Anchor spanC _) _) -> realSrcSpanEnd spanC <= loc) + comms + mSet after + pure before + +printComments :: LayoutConstraints m => [GHC.LEpaComment] -> m () +printComments comms = do + let + addComment s anchor prior = do + case anchor of + Anchor span UnchangedAnchor -> + moveToCommentPos True $ ExactPrint.ss2deltaEnd prior span + Anchor _span (MovedAnchor dp) -> moveToCommentPos False dp + -- ppmMoveToExactLoc $ ExactPrint.ss2deltaEnd prior span + layoutWriteAppend $ Text.pack s + comms `forM_` \case + L anch (EpaComment (EpaDocCommentNext s) prior) -> addComment s anch prior + L anch (EpaComment (EpaDocCommentPrev s) prior) -> addComment s anch prior + L anch (EpaComment (EpaDocCommentNamed s) prior) -> addComment s anch prior + L anch (EpaComment (EpaDocSection _ s) prior) -> addComment s anch prior + L anch (EpaComment (EpaDocOptions s) prior) -> addComment s anch prior + L anch (EpaComment (EpaLineComment s) prior) -> addComment s anch prior + L anch (EpaComment (EpaBlockComment s) prior) -> addComment s anch prior + L _anch (EpaComment (EpaEofComment) _prior) -> pure () diff --git a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs new file mode 100644 index 0000000..b953b1e --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.StepOrchestrate + ( processModule + ) +where + +import Language.Haskell.Brittany.Internal.Prelude + +import qualified Control.Monad.Trans.MultiRWS.Strict + as MultiRWSS +import Data.CZipWith +import qualified Data.Map.Strict as Map +-- import qualified Data.Sequence as Seq +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Builder as TextL.Builder +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified GHC +import GHC ( EpaCommentTok + ( EpaBlockComment + , EpaEofComment + , EpaLineComment + ) + , GenLocated(L) + , HsModule(HsModule) + , LHsDecl + , SrcSpanAnn'(SrcSpanAnn) + ) +import qualified GHC.OldList as List +import GHC.Types.SrcLoc ( srcSpanFileName_maybe ) +import qualified Language.Haskell.GHC.ExactPrint + as ExactPrint + +import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config.Types.Instances2 + ( ) +import Language.Haskell.Brittany.Internal.S2_SplitModule + ( splitModule ) +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.S4_WriteBriDoc + ( ppBriDoc ) +import Language.Haskell.Brittany.Internal.ToBriDoc.Decl +import Language.Haskell.Brittany.Internal.ToBriDoc.Import +import Language.Haskell.Brittany.Internal.ToBriDoc.Module +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Util.AST +import Language.Haskell.Brittany.Internal.Utils + + + +-- BrittanyErrors can be non-fatal warnings, thus both are returned instead +-- of an Either. +-- This should be cleaned up once it is clear what kinds of errors really +-- can occur. +processModule + :: TraceFunc + -> Config + -> PerItemConfig + -> GHC.ParsedSource + -> IO ([BrittanyError], TextL.Text) +processModule traceFunc conf inlineConf parsedModule = do + let shouldReformatHead = + conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack @Bool + let + wrapNonDeclToBriDoc = MultiRWSS.withMultiReader conf + . MultiRWSS.withMultiState_ (CommentCounter 0) + FinalList moduleElementsStream = splitModule + shouldReformatHead + parsedModule + (obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc parsedModule) GHC.AnnWhere) + ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader traceFunc + $ moduleElementsStream + (\modElem cont -> do + case modElem of + MEExactModuleHead modHead -> wrapNonDeclToBriDoc $ do + bdMay <- ppModuleHead modHead + case bdMay of + Nothing -> pure () + Just bd -> ppBriDoc bd + MEPrettyModuleHead (L loc modHead) -> wrapNonDeclToBriDoc $ do + case modHead of + HsModule epAnn _layoutInfo Nothing Nothing _ _ _ _ -> do + (bd, _) <- + briDocMToPPM + $ maybe id + docFlushRemaining + (srcSpanFileName_maybe loc) + $ docHandleComms epAnn docSeparator + ppBriDoc bd + HsModule _ _layoutInfo Nothing Just{} _ _ _ _ -> error + "brittany internal error: exports without module name" + HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do + let startDelta = obtainAnnDeltaPos epAnn GHC.AnnModule + tellDebugMess (show startDelta) + case startDelta of + Nothing -> pure () + Just GHC.SameLine{} -> pure () + Just (GHC.DifferentLine r _) -> + mTell $ TextL.Builder.fromString $ replicate (r - 1) '\n' + (bd, _) <- + briDocMToPPM + $ maybe id + docFlushRemaining + (srcSpanFileName_maybe loc) + $ moduleNameExportBridoc epAnn n les + ppBriDoc bd + MEImportDecl importDecl immediateAfterComms -> + wrapNonDeclToBriDoc $ do + (bd, _) <- + briDocMToPPM + $ docSeq + ( layoutImport importDecl + : map commentToDoc immediateAfterComms + ) + ppBriDoc bd + MEDecl decl immediateAfterComms -> do + let declConfig = getDeclConfig conf inlineConf decl + MultiRWSS.withMultiReader declConfig + $ MultiRWSS.withMultiState_ (CommentCounter 0) + $ ppToplevelDecl decl immediateAfterComms + MEComment (ind, EpaLineComment str) -> do + mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str) + mTell $ TextL.Builder.fromString "\n" + MEComment (ind, EpaBlockComment str) -> do + mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str) + mTell $ TextL.Builder.fromString "\n" + MEComment (_, EpaEofComment) -> pure () + MEComment _ -> + mTell $ TextL.Builder.fromString "some other comment" + MEWhitespace dp -> do + -- mTell $ TextL.Builder.fromString "B" + -- mTell $ TextL.Builder.fromString ("whitespace " ++ show dp) + ppmMoveToExactLoc dp + cont + ) + (\x -> do + -- mTell $ TextL.Builder.fromString "\n" + pure x + ) + -- _tracer = + -- -- if Seq.null debugStrings + -- -- then id + -- -- else + -- trace ("---- DEBUGMESSAGES ---- ") + -- . foldr (seq . join trace) id debugStrings + debugStrings `forM_` \s -> useTraceFunc traceFunc s + moduleElementsStream + (\el rest -> do + case el of + MEExactModuleHead{} -> useTraceFunc traceFunc "MEExactModuleHead" + MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead" + MEImportDecl{} -> useTraceFunc traceFunc "MEImportDecl" + MEDecl{} -> useTraceFunc traceFunc "MEDecl" + MEComment{} -> useTraceFunc traceFunc "MEComment" + MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp) + rest + ) + (\_ -> pure ()) + pure (errs, TextL.Builder.toLazyText out) + +commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered +commentToDoc (indent, c) = case c of + GHC.EpaDocCommentNext str -> docLitS (replicate indent ' ' ++ str) + GHC.EpaDocCommentPrev str -> docLitS (replicate indent ' ' ++ str) + GHC.EpaDocCommentNamed str -> docLitS (replicate indent ' ' ++ str) + GHC.EpaDocSection _ str -> docLitS (replicate indent ' ' ++ str) + GHC.EpaDocOptions str -> docLitS (replicate indent ' ' ++ str) + GHC.EpaLineComment str -> docLitS (replicate indent ' ' ++ str) + GHC.EpaBlockComment str -> docLitS (replicate indent ' ' ++ str) + GHC.EpaEofComment -> docEmpty + + +-- Prints the information associated with the module annotation +-- This includes the imports +-- This returns a `Maybe` because it only produces a BriDocNumbered if +-- re-formatting the module head is enabled. We maybe should change that +-- for consistency. +ppModuleHead :: GHC.ParsedSource -> PPMLocal (Maybe BriDocNumbered) +ppModuleHead lmod = do + processDefault lmod $> Nothing + +processDefault + :: (ExactPrint.ExactPrint ast, MonadMultiWriter Text.Builder.Builder m) + -- , MonadMultiReader ExactPrint.Types.Anns m + => GHC.Located ast + -> m () +processDefault x = do + let str = ExactPrint.exactPrint x + -- 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. + -- TODO: instead the appropriate annotation could be removed when "cleaning" + -- the module (header). This would remove the need for this hack! + case str of + "\n" -> return () + _ -> mTell $ Text.Builder.fromString $ List.dropWhileEnd ((==) '\n') str + + +getDeclConfig + :: Config + -> PerItemConfig + -> GHC.LHsDecl GhcPs + -> Config +getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config + $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) + where + declBindingNames = getDeclBindingNames decl + mBindingConfs = + declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf + mDeclConf = case GHC.locA $ GHC.getLoc decl of + GHC.RealSrcSpan x _ -> Map.lookup x $ _icd_perAnchor inlineConf + GHC.UnhelpfulSpan{} -> Nothing + +ppToplevelDecl :: LHsDecl GhcPs -> [(Int, EpaCommentTok)] -> PPMLocal () +ppToplevelDecl decl immediateAfterComms = do + exactprintOnly <- mAsk <&> \declConfig -> + declConfig & _conf_roundtrip_exactprint_only & confUnpack @Bool + bd <- fmap fst $ if exactprintOnly + then briDocMToPPM + $ docSeq (briDocByExact decl : map commentToDoc immediateAfterComms) + else do + let innerDoc = case decl of + L (SrcSpanAnn _ (GHC.RealSrcSpan s _)) _ -> + docFlushRemaining (GHC.srcSpanFile s) $ layoutDecl decl + _ -> layoutDecl decl + (r, errorCount) <- briDocMToPPM + $ docSeq (innerDoc : map commentToDoc immediateAfterComms) + if errorCount == 0 then pure (r, 0) else briDocMToPPM $ briDocByExact decl + ppBriDoc bd + let commCntIn = connectedCommentCount decl + commCntOut <- mGet + when (commCntIn /= commCntOut) $ if commCntOut < commCntIn + then mTell + [ ErrorUnusedComments decl + (unCommentCounter commCntIn) + (unCommentCounter commCntOut) + ] + else mTell + [ ErrorUnusedComments decl + (unCommentCounter commCntIn) + (unCommentCounter commCntOut) + ] + -- error + -- $ "internal brittany error: inconsistent comment count (" + -- ++ show commCntOut + -- ++ ">" + -- ++ show commCntIn + -- ++ ")!" + diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs similarity index 58% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs rename to source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs index 37f648e..95a8a58 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs @@ -1,81 +1,92 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.DataDecl where +module Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl where -import qualified Data.Data -import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import GHC (GenLocated(L), Located) -import qualified GHC +import GHC (GenLocated(L)) import GHC.Hs import qualified GHC.OldList as List import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.ToBriDoc.Type import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Components.BriDoc layoutDataDecl - :: Located (TyClDecl GhcPs) - -> Located RdrName + :: LTyClDecl GhcPs + -> LIdP GhcPs -> LHsQTyVars GhcPs + -> [LHsTypeArg GhcPs] -> HsDataDefn GhcPs -> ToBriDocM BriDocNumbered -layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of +layoutDataDecl ltycl name (HsQTvs _ bndrs) pats defn = case defn of -- newtype MyType a b = MyType .. - HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> + HsDataDefn NoExtField NewType Nothing _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) - -> docWrapNode ltycl $ do - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - -- headDoc <- fmap return $ docSeq - -- [ appSep $ docLitS "newtype") - -- , appSep $ docLit nameStr - -- , appSep tyVarLine - -- ] - rhsDoc <- return <$> createDetailsDoc consNameStr details - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "newtype" - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - , docLitS "=" - , docSeparator - , rhsDoc - ] + (L _ (ConDeclH98 epAnn consName False _qvars ctxMay details _conDoc)) -> + let isSimple = case ctxMay of + Nothing -> True + Just (L _ []) -> True + _ -> False + in if isSimple + then do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- shareDoc $ createBndrDoc bndrs + patDocs <- mapM shareDoc $ layoutHsTyPats pats + -- headDoc <- fmap return $ docSeq + -- [ appSep $ docLitS "newtype") + -- , appSep $ docLit nameStr + -- , appSep tyVarLine + -- ] + rhsDoc <- return <$> createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "newtype" + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]] + , docSeparator + , docLitS "=" + , docSeparator + , docHandleComms epAnn $ rhsDoc + ] + else briDocByExactNoComment ltycl _ -> briDocByExactNoComment ltycl -- data MyData a b -- (zero constructors) - HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> - docWrapNode ltycl $ do - lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - tyVarLine <- return <$> createBndrDoc bndrs - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "data" - , lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - ] + HsDataDefn NoExtField DataType ctxMay _ctype Nothing [] mDerivs -> do + lhsContextDoc <- case ctxMay of + Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext + Nothing -> pure docEmpty + nameStr <- lrdrNameToTextAnn name + tyVarLine <- return <$> createBndrDoc bndrs + patDocs <- mapM shareDoc $ layoutHsTyPats pats + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "data" + , lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]] + ] -- data MyData = MyData .. -- data MyData = MyData { .. } - HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> + HsDataDefn NoExtField DataType ctxMay _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) - -> docWrapNode ltycl $ do - lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + (L _ (ConDeclH98 epAnn consName _hasExt qvars mRhsContext details _conDoc)) + -> do + lhsContextDoc <- case ctxMay of + Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext + Nothing -> pure docEmpty nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName tyVarLine <- return <$> createBndrDoc bndrs + patDocs <- mapM shareDoc $ layoutHsTyPats pats forallDocMay <- case createForallDoc qvars of Nothing -> pure Nothing Just x -> Just . pure <$> x @@ -83,8 +94,11 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of Nothing -> pure Nothing Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt rhsDoc <- return <$> createDetailsDoc consNameStr details + let posEqual = obtainAnnPos epAnn AnnEqual consDoc <- - fmap pure + shareDoc + $ docHandleComms epAnn + $ docHandleComms posEqual $ docNonBottomSpacing $ case (forallDocMay, rhsContextDocMay) of (Just forallDoc, Just rhsContextDoc) -> docLines @@ -111,14 +125,15 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of createDerivingPar mDerivs $ docAlt [ -- data D = forall a . Show a => D a docSeq - [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + [ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $ + docSeq [ appSep $ docLitS "data" , docForceSingleline $ lhsContextDoc , appSep $ docLit nameStr , appSep tyVarLine - , docSeparator + , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]] ] - , docLitS "=" + , docHandleComms epAnn $ docHandleComms posEqual $ docLitS "=" , docSeparator , docSetIndentLevel $ docSeq [ case forallDocMay of @@ -137,15 +152,17 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , -- data D -- = forall a . Show a => D a docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + ( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $ + docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr , tyVarLine + , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]] ] ) (docSeq - [ docLitS "=" + [ docHandleComms epAnn $ docHandleComms posEqual $ docLitS "=" , docSeparator , docSetIndentLevel $ docSeq [ case forallDocMay of @@ -167,11 +184,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of -- . Show a => -- D a docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + ( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $ + docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr , tyVarLine + , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]] ] ) consDoc @@ -190,8 +209,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of (docLitS "data") (docLines [ lhsContextDoc - , docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq [appSep $ docLit nameStr, tyVarLine] + , -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $ + docSeq [appSep $ docLit nameStr, tyVarLine, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]] , consDoc ] ) @@ -200,13 +219,23 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of _ -> briDocByExactNoComment ltycl +layoutHsTyPats + :: [LHsTypeArg GhcPs] -> [ToBriDocM BriDocNumbered] +layoutHsTyPats pats = pats <&> \case + HsValArg tm -> layoutType tm + HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] + -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change + -- is a bit strange. Hopefully this does not ignore any important + -- annotations. + HsArgPar _l -> error "brittany internal error: HsArgPar{}" + 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 + t1Doc <- shareDoc $ layoutType t1 + tRDocs <- tR `forM` (shareDoc . layoutType) docAlt [ docSeq [ docLitS "(" @@ -228,7 +257,7 @@ createBndrDoc bs = do tyVarDocs <- bs `forM` \case (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing) (L _ (KindedTyVar _ _ext lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind + d <- shareDoc $ layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) -> case mKind of @@ -247,57 +276,73 @@ createDerivingPar :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered createDerivingPar derivs mainDoc = do case derivs of - (L _ []) -> mainDoc - (L _ types) -> + [] -> mainDoc + types -> docPar mainDoc $ docEnsureIndent BrIndentRegular $ docLines - $ docWrapNode derivs + -- TODO92 $ docWrapNode derivs $ derivingClauseDoc <$> types derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered -derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of - (L _ []) -> docSeq [] - (L _ ts) -> - let - tsLength = length ts - whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS "" - (lhsStrategy, rhsStrategy) = - maybe (docEmpty, docEmpty) strategyLeftRight mStrategy - in docSeq - [ docDeriving - , docWrapNodePrior types $ lhsStrategy - , docSeparator - , whenMoreThan1Type "(" - , docWrapNodeRest types - $ docSeq - $ List.intersperse docCommaSep - $ ts - <&> \case - HsIB _ t -> layoutType t - , whenMoreThan1Type ")" - , rhsStrategy - ] +derivingClauseDoc (L _ (HsDerivingClause epAnn mStrategy types)) = + case types of + L _ (DctSingle _ ty) -> + let + (lhsStrategy, rhsStrategy) = + maybe (docEmpty, docEmpty) strategyLeftRight mStrategy + in docSeq + [ docDeriving + , docHandleComms types $ lhsStrategy + , docSeparator + , docHandleListElemComms layoutSigType ty -- TODO92 `docHandleRemaining types` here ? + -- \case + -- HsIB _ t -> layoutType t + , rhsStrategy + ] + (L (SrcSpanAnn _multiEpAnn _) (DctMulti NoExtField [])) -> docSeq [] + (L (SrcSpanAnn multiEpAnn _) (DctMulti NoExtField ts)) -> + let + tsLength = length ts + whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS "" + (lhsStrategy, rhsStrategy) = + maybe (docEmpty, docEmpty) strategyLeftRight mStrategy + posClose = case multiEpAnn of + EpAnn _ (AnnContext _ _ [s]) _ -> Just $ epaLocationRealSrcSpanStart s + _ -> Nothing + in docSeq + [ docDeriving + , docHandleComms types $ lhsStrategy + , docSeparator + , whenMoreThan1Type "(" + , docSeq -- TODO92 `docHandleRemaining types` here ? + $ List.intersperse docCommaSep + $ ts <&> docHandleListElemComms layoutSigType + , docHandleComms posClose $ whenMoreThan1Type ")" + , rhsStrategy + ] where + posDeriving = obtainAnnPos epAnn AnnDeriving + docDeriving = docHandleComms epAnn $ docHandleComms posDeriving $ docLitS "deriving" strategyLeftRight = \case - (L _ StockStrategy) -> (docLitS " stock", docEmpty) - (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty) - (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty) - lVia@(L _ (ViaStrategy viaTypes)) -> + (L _ (StockStrategy _)) -> (docLitS " stock", docEmpty) + (L _ (AnyclassStrategy _)) -> (docLitS " anyclass", docEmpty) + (L _ (NewtypeStrategy _)) -> (docLitS " newtype", docEmpty) + _lVia@(L _ (ViaStrategy (XViaStrategyPs viaEpAnn viaType))) -> ( docEmpty - , case viaTypes of - HsIB _ext t -> - docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t] + , docSeq + [ docHandleComms viaEpAnn $ docLitS " via" + , docSeparator + , docHandleListElemComms layoutSigType viaType + ] ) -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 @@ -331,8 +376,12 @@ createDetailsDoc consNameStr details = case details of docAlt [singleLine, multiAppended, multiIndented, leftIndented] RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] - RecCon lRec@(L _ fields@(_ : _)) -> do - let ((fName1, fType1) : fDocR) = mkFieldDocs fields + RecCon (L (SrcSpanAnn epAnn _) fields@(_ : _)) -> do + let posOpen = obtainAnnPos epAnn AnnOpenC + let posClose = obtainAnnPos epAnn AnnCloseC + let ((fName1, fType1), fDocR) = case mkFieldDocs fields of + (doc1:docR) -> (doc1, docR) + _ -> error "cannot happen (TM)" -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack let allowSingleline = False docAddBaseY BrIndentRegular $ runFilteredAlternative $ do @@ -340,10 +389,10 @@ createDetailsDoc consNameStr details = case details of addAlternativeCond allowSingleline $ docSeq [ docLit consNameStr , docSeparator - , docWrapNodePrior lRec $ docLitS "{" + , docHandleComms posOpen $ docLitS "{" , docSeparator - , docWrapNodeRest lRec - $ docForceSingleline + , docForceSingleline + $ docHandleComms epAnn $ docSeq $ join $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] @@ -358,28 +407,28 @@ createDetailsDoc consNameStr details = case details of | (fName, fType) <- fDocR ] , docSeparator - , docLitS "}" + , docHandleComms posClose $ docLitS "}" ] addAlternative $ docPar (docLit consNameStr) - (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines + (docNonBottomSpacingS $ docLines [ docAlt [ docCols ColRecDecl - [ appSep (docLitS "{") - , appSep $ docForceSingleline fName1 + [ docHandleComms posOpen $ appSep (docLitS "{") + , docHandleComms epAnn $ appSep $ docForceSingleline fName1 , docSeq [docLitS "::", docSeparator] , docForceSingleline $ fType1 ] , docSeq - [ docLitS "{" + [ docHandleComms posOpen $ docLitS "{" , docSeparator , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar fName1 (docSeq [docLitS "::", docSeparator, fType1]) ] ] - , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> + , docLines $ fDocR <&> \(fName, fType) -> docAlt [ docCols ColRecDecl @@ -396,7 +445,7 @@ createDetailsDoc consNameStr details = case details of (docSeq [docLitS "::", docSeparator, fType]) ] ] - , docLitS "}" + , docHandleComms posClose $ docLitS "}" ] ) InfixCon arg1 arg2 -> docSeq @@ -410,8 +459,7 @@ createDetailsDoc consNameStr details = case details of mkFieldDocs :: [LConDeclField GhcPs] -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] - mkFieldDocs = fmap $ \lField -> case lField of - L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t + mkFieldDocs = map createNamesAndTypeDoc createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) @@ -420,15 +468,19 @@ createForallDoc lhsTyVarBndrs = Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs] createNamesAndTypeDoc - :: Data.Data.Data ast - => Located ast - -> [GenLocated t (FieldOcc GhcPs)] - -> Located (HsType GhcPs) + :: LConDeclField GhcPs -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) -createNamesAndTypeDoc lField names t = - ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq - [ docSeq $ List.intersperse docCommaSep $ names <&> \case - L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName - ] - , docWrapNodeRest lField $ layoutType t +createNamesAndTypeDoc lField@(L _ (ConDeclField epAnn names t _)) = + ( docFlushCommsPost posColon + $ docHandleComms posStart + $ docHandleComms epAnn + $ docSeq + [ docSeq $ List.intersperse docCommaSep $ names <&> \case + L _ (FieldOcc _ fieldName) -> + docLit =<< lrdrNameToTextAnn fieldName + ] + , docFlushCommsPost posComma (layoutType t) ) + where + (posStart, posComma) = obtainListElemStartCommaLocs lField + posColon = obtainAnnPos epAnn AnnDcolon diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs similarity index 53% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs rename to source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs index 9e22b6e..a7e4a8f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs @@ -2,142 +2,147 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} -module Language.Haskell.Brittany.Internal.Layouters.Decl where +module Language.Haskell.Brittany.Internal.ToBriDoc.Decl where import qualified Data.Data import qualified Data.Foldable import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L)) +import GHC (GenLocated(L), LexicalFixity(Prefix, Infix), SrcSpan) import GHC.Data.Bag (bagToList, emptyBag) import qualified GHC.Data.FastString as FastString import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic - ( Activation(..) - , InlinePragma(..) - , InlineSpec(..) - , LexicalFixity(..) - , RuleMatchInfo(..) - ) -import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) + (Activation(..), InlinePragma(..), InlineSpec(..), RuleMatchInfo(..)) +import GHC.Types.SrcLoc (Located, getLoc, unLoc) +import qualified GHC.Types.SrcLoc as GHC import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.DataDecl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.ToBriDoc.DataDecl +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr +import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Stmt +import Language.Haskell.Brittany.Internal.ToBriDoc.Type 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 qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint +import Language.Haskell.Brittany.Internal.Components.BriDoc 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 - Left ns -> docLines $ return <$> ns - Right n -> return n - TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) - InstD _ (TyFamInstD _ tfid) -> - withTransformedAnns d $ layoutTyFamInstDecl False d tfid - InstD _ (ClsInstD _ inst) -> - withTransformedAnns d $ layoutClsInst (L loc inst) + SigD _ sig -> layoutSig d sig + ValD _ bind -> layoutBind (L loc bind) >>= \case + Left ns -> docLines $ return <$> ns + Right n -> return n + TyClD _ tycl -> layoutTyCl (L loc tycl) + InstD NoExtField (TyFamInstD NoExtField tfid) -> + layoutTyFamInstDecl False d tfid + InstD NoExtField (ClsInstD NoExtField inst) -> layoutClsInst d inst _ -> briDocByExactNoComment d -------------------------------------------------------------------------------- -- Sig -------------------------------------------------------------------------------- -layoutSig :: ToBriDoc Sig -layoutSig lsig@(L _loc sig) = case sig of - TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ - InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> - docWrapNode lsig $ do - nameStr <- lrdrNameToTextAnn name - specStr <- specStringCompat lsig spec - let - phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - FinalActive -> error "brittany internal error: FinalActive" - let - conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " - docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) - <> nameStr - <> Text.pack " #-}" - ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ - PatSynSig _ names (HsIB _ typ) -> - layoutNamesAndType (Just "pattern") names typ - _ -> briDocByExactNoComment lsig -- TODO +layoutSig :: (Data.Data.Data ast, ExactPrint.ExactPrint ast) => (LocatedA ast) -> ToBriDocP Sig +layoutSig fallback sig = case sig of + TypeSig epAnn names (HsWC _ sigTy) -> + layoutNamesAndType epAnn Nothing names sigTy + InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> do + nameStr <- lrdrNameToTextAnn name + specStr <- specStringCompat spec + let + phaseStr = case phaseAct of + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + FinalActive -> error "brittany internal error: FinalActive" + let + conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " + docLit + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + <> nameStr + <> Text.pack " #-}" + ClassOpSig epAnn False names sigTy -> + layoutNamesAndType epAnn Nothing names sigTy -- TODO92 we ignore an ann here + PatSynSig epAnn names sigTy -> -- TODO92 we ignore an ann here + layoutNamesAndType epAnn (Just "pattern") names sigTy + _ -> briDocByExactNoComment fallback -- TODO where - layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do + layoutNamesAndType + :: EpAnn AnnSig + -> Maybe String + -> [LIdP GhcPs] + -> LHsSigType GhcPs + -> ToBriDocM BriDocNumbered + layoutNamesAndType epAnn mKeyword names sigTy = docHandleComms epAnn $ do + -- TODO92 epAnn might contain interesting bits (the key loc?) let keyDoc = case mKeyword of Just key -> [appSep . docLit $ Text.pack key] Nothing -> [] + let (AnnSig addEpAnn _) = anns epAnn + let posColon = obtainAnnPos addEpAnn AnnDcolon nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs - typeDoc <- docSharedWrapper layoutType typ - hasComments <- hasAnyCommentsBelow lsig + typeDoc <- shareDoc $ layoutSigType sigTy + let hasComments = hasAnyCommentsBelow fallback shouldBeHanging <- mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack if shouldBeHanging then docSeq $ [ appSep - $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] , docSetBaseY $ docLines [ docCols ColTyOpPrefix - [ docLit $ Text.pack ":: " + [ docHandleComms posColon $ docLit $ Text.pack ":: " , docAddBaseY (BrIndentSpecial 3) $ typeDoc ] ] ] else layoutLhsAndType hasComments - (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) - "::" - typeDoc + (appSep . docSeq $ keyDoc <> [docLit nameStr]) + (docHandleComms posColon $ docLit $ Text.pack "::") + 2 + (typeDoc) specStringCompat - :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String -specStringCompat ast = \case - NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" + :: MonadMultiWriter [BrittanyError] m => InlineSpec -> m String +specStringCompat = \case + -- TODO92 better error for this? + NoUserInlinePrag -> error "NoUserInlinePrag" Inline -> pure "INLINE " Inlinable -> pure "INLINABLE " NoInline -> pure "NOINLINE " -layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) -layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of - BodyStmt _ body _ _ -> layoutExpr body - BindStmt _ lPat expr -> do - patDoc <- docSharedWrapper layoutPat lPat - expDoc <- docSharedWrapper layoutExpr expr - docCols - ColBindStmt - [ appSep $ colsWrapPat =<< patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] - ] - _ -> unknownNodeError "" lgstmt -- TODO +-- layoutGuardLStmt :: ToBriDoc' (StmtLR rdL rdR) -- ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) +-- layoutGuardLStmt lgstmt@(L _ stmtLR) = case stmtLR of -- TODO92 we had an `docWrapNode lgstmt` here +-- -- but it seems we can't have comments in 92? +-- BodyStmt _ body _ _ -> briDocByExactNoComment body -- TODO92 layoutExpr body +-- BindStmt _ lPat expr -> do +-- patDoc <- docSharedWrapper briDocByExactNoComment lPat -- TODO92 layoutPat +-- expDoc <- docSharedWrapper briDocByExactNoComment expr -- TODO92 layoutExpr +-- docCols +-- ColBindStmt +-- [ appSep $ patDoc -- TODO92 colsWrapPat =<< patDoc +-- , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] +-- ] +-- _ -> unknownNodeError "" lgstmt -- TODO -------------------------------------------------------------------------------- @@ -145,33 +150,29 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of -------------------------------------------------------------------------------- layoutBind - :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) + :: ToBriDocC (HsBindLR GhcPs) (Either [BriDocNumbered] BriDocNumbered) layoutBind lbind@(L _ bind) = case bind of - FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do + FunBind NoExtField fId (MG NoExtField _lmatches@(L _ matches) _) [] -> do idStr <- lrdrNameToTextAnn fId binderDoc <- docLit $ Text.pack "=" - funcPatDocs <- - docWrapNode lbind - $ docWrapNode lmatches - $ layoutPatternBind (Just idStr) binderDoc - `mapM` matches + funcPatDocs <- docHandleComms lbind + $ matches `forM` layoutPatternBind (Just idStr) binderDoc return $ Left $ funcPatDocs - PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do + PatBind _epAnn pat (GRHSs _ grhss whereBinds) ([], []) -> do -- TODO92 are we ignoring something in whereBinds? patDocs <- colsWrapPat =<< layoutPat pat - clauseDocs <- layoutGrhs `mapM` grhss - mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? + mWhereDocs <- layoutLocalBinds $ whereBinds + -- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? binderDoc <- docLit $ Text.pack "=" - hasComments <- hasAnyCommentsBelow lbind - fmap Right $ docWrapNode lbind $ layoutPatternBindFinal + let hasComments = hasAnyCommentsBelow lbind + fmap Right $ docHandleComms lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) - clauseDocs - mWhereArg + (Right grhss) + mWhereDocs hasComments PatSynBind _ (PSB _ patID lpat rpat dir) -> do - fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat + fmap Right $ docHandleComms lbind $ layoutPatSynBind patID lpat dir rpat _ -> Right <$> unknownNodeError "" lbind layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of @@ -179,13 +180,12 @@ layoutIPBind lipbind@(L _ bind) = case bind of IPBind _ (Left (L _ (HsIPName name))) expr -> do ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name binderDoc <- docLit $ Text.pack "=" - exprDoc <- layoutExpr expr - hasComments <- hasAnyCommentsBelow lipbind + let hasComments = hasAnyCommentsBelow lipbind layoutPatternBindFinal Nothing binderDoc (Just ipName) - [([], exprDoc, expr)] + (Left expr) Nothing hasComments @@ -194,96 +194,114 @@ data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) | BagSig (LSig GhcPs) bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan -bindOrSigtoSrcSpan (BagBind (L l _)) = l -bindOrSigtoSrcSpan (BagSig (L l _)) = l +bindOrSigtoSrcSpan (BagBind (L (SrcSpanAnn _ l) _)) = l +bindOrSigtoSrcSpan (BagSig (L (SrcSpanAnn _ l) _)) = l layoutLocalBinds - :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) -layoutLocalBinds lbinds@(L _ binds) = case binds of + :: HsLocalBindsLR GhcPs GhcPs + -> ToBriDocM + ( Maybe + ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered + , [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{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x - HsValBinds _ (ValBinds _ bindlrs sigs) -> do - let - 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 - BagBind b -> either id return <$> layoutBind b - BagSig s -> return <$> layoutSig s - return $ Just $ docs + HsValBinds epAnn (ValBinds _ bindlrs sigs) -> do + let locWhere = obtainAnnPos epAnn AnnWhere + let unordered = + [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered + ds <- docHandleComms epAnn $ join <$> ordered `forM` \case + BagBind b -> either id return <$> layoutBind b + BagSig s@(L _ sig) -> do + doc <- layoutSig s sig + pure [doc] + pure $ Just (docHandleComms locWhere, ds) -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" - HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb - EmptyLocalBinds{} -> return $ Nothing + HsIPBinds epAnn (IPBinds _ bb) -> do + ds <- docHandleComms epAnn $ mapM layoutIPBind bb + pure $ Just (id, ds) -- TODO92 do we need to replace id? + EmptyLocalBinds NoExtField -> return $ Nothing --- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is --- parSpacing stuff.B layoutGrhs :: LGRHS GhcPs (LHsExpr GhcPs) - -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) -layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do - guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards + -> ToBriDocM + ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered + , [BriDocNumbered] + , BriDocNumbered + ) +layoutGrhs (L _ (GRHS epAnn guards body)) = do + let posArrow = obtainAnnPos epAnn AnnRarrow + guardDocs <- case guards of + [] -> pure [] + _ -> docFlushCommsPost posArrow $ layoutStmt `mapM` guards bodyDoc <- layoutExpr body - return (guardDocs, bodyDoc, body) + return (docHandleComms epAnn, guardDocs, bodyDoc) layoutPatternBind :: Maybe Text -> BriDocNumbered -> LMatch GhcPs (LHsExpr GhcPs) -> ToBriDocM BriDocNumbered -layoutPatternBind funId binderDoc lmatch@(L _ match) = do - let pats = m_pats match - let (GRHSs _ grhss whereBinds) = m_grhss match - patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p - let isInfix = isInfixMatch match - mIdStr <- case match of - Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId - _ -> pure Nothing - let mIdStr' = fixPatternBindIdentifier match <$> mIdStr - patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of - (Just idStr, p1 : p2 : pr) | isInfix -> if null pr - then docCols - ColPatternsFuncInfix - [ appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - ] - else docCols - ColPatternsFuncInfix - ([ docCols - ColPatterns - [ docParenL - , appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - , appSep $ docParenR - ] - ] - ++ (spacifyDocs $ docForceSingleline <$> pr) - ) - (Just idStr, []) -> docLit idStr - (Just idStr, ps) -> - docCols ColPatternsFuncPrefix - $ appSep (docLit $ idStr) - : (spacifyDocs $ docForceSingleline <$> ps) - (Nothing, ps) -> - docCols ColPatterns - $ (List.intersperse docSeparator $ docForceSingleline <$> ps) - clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss - mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) - let alignmentToken = if null pats then Nothing else funId - hasComments <- hasAnyCommentsBelow lmatch - layoutPatternBindFinal - alignmentToken - binderDoc - (Just patDoc) - clauseDocs - mWhereArg - hasComments +layoutPatternBind funId binderDoc lmatch@(L _ match) = + docHandleComms lmatch $ do + let pats = m_pats match + let (GRHSs _ grhss whereBinds) = m_grhss match + patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p + let isInfix = isInfixMatch match + mIdDoc <- case match of + Match epAnn (FunRhs matchId _ _) _ _ -> + fmap Just $ docHandleComms epAnn $ do + t <- lrdrNameToTextAnn matchId + let t' = fixPatternBindIdentifier match t + docLit t' + _ -> pure Nothing + patDoc <- docHandleComms lmatch $ case (mIdDoc, patDocs) of + (Just idDoc, p1 : p2 : pr) | isInfix -> if null pr + then docCols + ColPatternsFuncInfix + [ appSep $ docForceSingleline p1 + , appSep $ pure idDoc + , docForceSingleline p2 + ] + else docCols + ColPatternsFuncInfix + ([ docCols + ColPatterns + [ docParenL + , appSep $ docForceSingleline p1 + , appSep $ pure idDoc + , docForceSingleline p2 + , appSep $ docParenR + ] + ] + ++ (spacifyDocs $ docForceSingleline <$> pr) + ) + (Just idDoc, []) -> pure idDoc + (Just idDoc, ps) -> + docCols ColPatternsFuncPrefix + $ appSep (pure idDoc) + : (spacifyDocs $ docForceSingleline <$> ps) + (Nothing, ps) -> + docCols ColPatterns + $ (List.intersperse docSeparator $ docForceSingleline <$> ps) + mWhereDocs <- layoutLocalBinds whereBinds + -- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) + let alignmentToken = if null pats then Nothing else funId + let hasComments = hasAnyCommentsBelow lmatch + layoutPatternBindFinal + alignmentToken + binderDoc + (Just patDoc) + (Right grhss) + mWhereDocs + hasComments fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier match idStr = go $ m_ctxt match @@ -306,12 +324,15 @@ layoutPatternBindFinal :: Maybe Text -> BriDocNumbered -> Maybe BriDocNumbered - -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] - -> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) - -- ^ AnnKey for the node that contains the AnnWhere position annotation + -> Either (LHsExpr GhcPs) [LGRHS GhcPs (LHsExpr GhcPs)] + -> ( Maybe + ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered + , [BriDocNumbered] + ) + ) -> Bool -> ToBriDocM BriDocNumbered -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses mWhereDocs hasComments = do let patPartInline = case mPatDoc of @@ -332,15 +353,15 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha -- be shared between alternatives. wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of Nothing -> return $ [] - Just (annKeyWhere, [w]) -> pure . pure <$> docAlt + Just (wrapWhere, [w]) -> pure . pure <$> docAlt [ docEnsureIndent BrIndentRegular $ docSeq - [ docLit $ Text.pack "where" + [ wrapWhere $ docLit $ Text.pack "where" , docSeparator , docForceSingleline $ return w ] - , docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent + , -- docMoveToKWDP annKeyWhere AnnWhere False -- TODO92 + docEnsureIndent whereIndent $ docLines [ docLit $ Text.pack "where" , docEnsureIndent whereIndent @@ -349,12 +370,12 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha $ return w ] ] - Just (annKeyWhere, ws) -> + Just (wrapWhere, ws) -> fmap (pure . pure) - $ docMoveToKWDP annKeyWhere AnnWhere False + -- $ docMoveToKWDP annKeyWhere AnnWhere False -- TODO92 $ docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" + [ wrapWhere $ docLit $ Text.pack "where" , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing @@ -376,20 +397,26 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ) wherePart = case mWhereDocs of Nothing -> Just docEmpty - Just (_, [w]) -> Just $ docSeq + Just (wrapWhere, [w]) -> Just $ docSeq [ docSeparator - , appSep $ docLit $ Text.pack "where" + , wrapWhere $ appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w ] _ -> Nothing indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + clauseDocs <- case clauses of + Left expr -> do + e <- layoutExpr expr + pure [(id, [], e)] + Right grhss -> layoutGrhs `mapM` grhss + runFilteredAlternative $ do case clauseDocs of - [(guards, body, _bodyRaw)] -> do - let guardPart = singleLineGuardsDoc guards + [(wrapClause, guards, body)] -> do + let guardPart = wrapClause $ singleLineGuardsDoc guards forM_ wherePart $ \wherePart' -> -- one-line solution addAlternativeCond (not hasComments) $ docCols @@ -409,8 +436,9 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha [ docSeq (patPartInline ++ [guardPart]) , docSeq [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return - body + , docForceParSpacing + $ docAddBaseY BrIndentRegular + $ return body ] ] ] @@ -420,8 +448,9 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha $ docLines $ [ docForceSingleline $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return - body + , docEnsureIndent BrIndentRegular + $ docForceSingleline + $ return body ] ++ wherePartMultiLine -- pattern and exactly one clause in single line, body as par; @@ -433,8 +462,9 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha [ docSeq (patPartInline ++ [guardPart]) , docSeq [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return - body + , docForceParSpacing + $ docAddBaseY BrIndentRegular + $ return body ] ] ] @@ -469,7 +499,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha , docSetBaseY $ docLines $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do + <&> \(wrapClause, guardDocs, bodyDoc) -> wrapClause $ do -- TODO92 let guardPart = singleLineGuardsDoc guardDocs -- the docForceSingleline might seems superflous, but it -- helps the alternative resolving impl. @@ -495,7 +525,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha $ docLines $ map docSetBaseY $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do + <&> \(wrapClause, guardDocs, bodyDoc) -> wrapClause $ do -- TODO92 let guardPart = singleLineGuardsDoc guardDocs -- the docForceSingleline might seems superflous, but it -- helps the alternative resolving impl. @@ -504,7 +534,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha [ guardPart , docSeq [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc + , docForceSingleline + $ return bodyDoc -- i am not sure if there is a benefit to using -- docForceParSpacing additionally here: -- , docAddBaseY BrIndentRegular $ return bodyDoc @@ -521,8 +552,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha $ docLines $ map docSetBaseY $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> - docSeq + <&> \(wrapClause, guardDocs, bodyDoc) -> -- TODO92 + wrapClause $ docSeq $ (case guardDocs of [] -> [] [g] -> @@ -556,15 +587,15 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha $ docLines $ map docSetBaseY $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> + >>= \(wrapClause, guardDocs, bodyDoc) -> -- TODO92 (case guardDocs of - [] -> [] + [] -> [wrapClause docEmpty] [g] -> - [ docForceSingleline + [ wrapClause $ docForceSingleline $ docSeq [appSep $ docLit $ Text.pack "|", return g] ] gs -> - [ docForceSingleline + [ wrapClause $ docForceSingleline $ docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse docCommaSep (return <$> gs) @@ -588,12 +619,14 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha $ docLines $ map docSetBaseY $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> + >>= \(wrapClause, guardDocs, bodyDoc) -> -- TODO92 (case guardDocs of - [] -> [] - [g] -> [docSeq [appSep $ docLit $ Text.pack "|", return g]] + [] -> [wrapClause docEmpty] + [g] -> + [ wrapClause $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] (g1 : gr) -> - (docSeq [appSep $ docLit $ Text.pack "|", return g1] + ( (wrapClause $ docSeq [appSep $ docLit $ Text.pack "|", return g1]) : (gr <&> \g -> docSeq [appSep $ docLit $ Text.pack ",", return g] ) @@ -610,8 +643,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 +696,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 +710,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 " { "] @@ -689,10 +722,10 @@ layoutLPatSyn name (RecCon recArgs) = do layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) layoutPatSynWhere hs = case hs of - ExplicitBidirectional (MG _ (L _ lbinds) _) -> do + ExplicitBidirectional (MG NoExtField lbinds@(L _ binds) _) -> do binderDoc <- docLit $ Text.pack "=" - Just - <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds + bindDocs <- mapM (shareDoc . layoutPatternBind Nothing binderDoc) binds + pure $ Just $ docHandleComms lbinds bindDocs _ -> pure Nothing -------------------------------------------------------------------------------- @@ -701,77 +734,71 @@ layoutPatSynWhere hs = case hs of layoutTyCl :: ToBriDoc TyClDecl layoutTyCl ltycl@(L _loc tycl) = case tycl of - SynDecl _ name vars fixity typ -> do + SynDecl epAnn name vars fixity typ -> do let isInfix = case fixity of Prefix -> False Infix -> True + let posEqual = obtainAnnPos epAnn AnnEqual + let posOpen = obtainAnnPos epAnn AnnOpenP -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- let parenWrapper = if hasTrailingParen -- then appSep . docWrapNodeRest ltycl -- else id - let wrapNodeRest = docWrapNodeRest ltycl - docWrapNodePrior ltycl - $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ - DataDecl _ext name tyVars _ dataDefn -> - layoutDataDecl ltycl name tyVars dataDefn + docHandleComms ltycl $ docHandleComms epAnn $ do + nameStr <- lrdrNameToTextAnn name + let lhs = appSep $ if isInfix + then do + let (a, b, rest) = case hsq_explicit vars of + (v1 : v2 : vR) -> (v1, v2, vR) + _ -> error "unexpected vars, expected at least 2" + -- This isn't quite right, but does give syntactically valid results + let needsParens = not (null rest) || Data.Maybe.isJust posOpen + docSeq + $ [docLit $ Text.pack "type", docSeparator] + ++ [ docParenL | needsParens ] + ++ [ layoutTyVarBndr False a + , docSeparator + , docLit nameStr + , docSeparator + , layoutTyVarBndr False b + ] + ++ [ docParenR | needsParens ] + ++ fmap (layoutTyVarBndr True) rest + else + docSeq + $ [ docLit $ Text.pack "type" + , docSeparator + , docHandleComms name $ docLit nameStr + ] + ++ fmap (layoutTyVarBndr True) (hsq_explicit vars) + sharedLhs <- shareDoc $ id lhs + typeDoc <- shareDoc $ layoutType typ + let hasComments = hasAnyCommentsConnected ltycl + layoutLhsAndType hasComments + sharedLhs + (docHandleComms posEqual $ docLit $ Text.pack "=") + 1 + typeDoc + DataDecl epAnn name tyVars _ dataDefn -> + docHandleComms epAnn $ layoutDataDecl ltycl name tyVars [] dataDefn _ -> briDocByExactNoComment ltycl -layoutSynDecl - :: Bool - -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) - -> Located (IdP GhcPs) - -> [LHsTyVarBndr () GhcPs] - -> LHsType GhcPs - -> ToBriDocM BriDocNumbered -layoutSynDecl isInfix wrapNodeRest name vars typ = do - nameStr <- lrdrNameToTextAnn name - let - lhs = appSep . wrapNodeRest $ if isInfix - then do - let (a : b : rest) = vars - hasOwnParens <- hasAnnKeywordComment a AnnOpenP - -- This isn't quite right, but does give syntactically valid results - let needsParens = not (null rest) || hasOwnParens - docSeq - $ [docLit $ Text.pack "type", docSeparator] - ++ [ docParenL | needsParens ] - ++ [ layoutTyVarBndr False a - , docSeparator - , docLit nameStr - , docSeparator - , layoutTyVarBndr False b - ] - ++ [ docParenR | needsParens ] - ++ fmap (layoutTyVarBndr True) rest - else - docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - , docWrapNode name $ docLit nameStr - ] - ++ fmap (layoutTyVarBndr True) vars - sharedLhs <- docSharedWrapper id lhs - typeDoc <- docSharedWrapper layoutType typ - hasComments <- hasAnyCommentsConnected typ - layoutLhsAndType hasComments sharedLhs "=" typeDoc - layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ()) -layoutTyVarBndr needsSep lbndr@(L _ bndr) = do - docWrapNodePrior lbndr $ case bndr of - UserTyVar _ _ name -> do - nameStr <- lrdrNameToTextAnn name - docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr] - KindedTyVar _ _ name kind -> do - nameStr <- lrdrNameToTextAnn name - docSeq - $ [ docSeparator | needsSep ] - ++ [ docLit $ Text.pack "(" - , appSep $ docLit nameStr - , appSep . docLit $ Text.pack "::" - , docForceSingleline $ layoutType kind - , docLit $ Text.pack ")" - ] +layoutTyVarBndr needsSep (L _ bndr) = case bndr of + UserTyVar _ _ name -> do + nameStr <- lrdrNameToTextAnn name + docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr] + KindedTyVar _ _ name kind -> do + nameStr <- lrdrNameToTextAnn name + docSeq + $ [ docSeparator | needsSep ] + ++ [ docLit $ Text.pack "(" + , appSep $ docLit nameStr + , appSep . docLit $ Text.pack "::" + , docForceSingleline $ layoutType kind + , docLit $ Text.pack ")" + ] -------------------------------------------------------------------------------- @@ -783,56 +810,47 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do layoutTyFamInstDecl :: Data.Data.Data a => Bool - -> Located a + -> LocatedA a -> TyFamInstDecl GhcPs -> ToBriDocM BriDocNumbered layoutTyFamInstDecl inClass outerNode tfid = do let - FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid + posType = obtainAnnPos (tfid_xtn tfid) AnnType + FamEqn epAnn name bndrsMay pats _fixity typ = tfid_eqn tfid + posEqual = obtainAnnPos epAnn AnnEqual -- bndrsMay isJust e.g. with -- type instance forall a . MyType (Maybe a) = Either () a - innerNode = outerNode - docWrapNodePrior outerNode $ do - nameStr <- lrdrNameToTextAnn name - needsParens <- hasAnnKeyword outerNode AnnOpenP - let - instanceDoc = if inClass - then docLit $ Text.pack "type" - else docSeq - [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] - makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered - makeForallDoc bndrs = do - bndrDocs <- layoutTyVarBndrs bndrs - docSeq - ([docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs - ) - lhs = - docWrapNode innerNode - . docSeq - $ [appSep instanceDoc] - ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] - ++ [ docParenL | needsParens ] - ++ [appSep $ docWrapNode name $ docLit nameStr] - ++ intersperse docSeparator (layoutHsTyPats pats) - ++ [ docParenR | needsParens ] - hasComments <- - (||) - <$> hasAnyRegularCommentsConnected outerNode - <*> hasAnyRegularCommentsRest innerNode - typeDoc <- docSharedWrapper layoutType typ - layoutLhsAndType hasComments lhs "=" typeDoc + nameStr <- lrdrNameToTextAnn name + -- TODO92 needsParens <- hasAnnKeyword outerNode AnnOpenP + let needsParens = False + let + instanceDoc = docHandleComms posType $ if inClass + then docLit $ Text.pack "type" + else docSeq + [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] + makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered + makeForallDoc bndrs = do + bndrDocs <- layoutTyVarBndrs bndrs + docSeq + ([docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs + ) + lhs = + docHandleComms epAnn $ docSeq + $ [appSep instanceDoc] + ++ [ makeForallDoc foralls | (HsOuterExplicit _ foralls) <- [bndrsMay] ] + ++ [ docParenL | needsParens ] + ++ [appSep $ docHandleComms name $ docLit nameStr] + ++ intersperse docSeparator (layoutHsTyPats pats) + ++ [ docParenR | needsParens ] + -- TODO92 hasComments <- + -- (||) + -- <$> hasAnyRegularCommentsConnected outerNode + -- <*> hasAnyRegularCommentsRest innerNode + let hasComments = hasAnyCommentsConnected outerNode + typeDoc <- shareDoc $ layoutType typ + layoutLhsAndType hasComments lhs (docHandleComms posEqual $ docLit $ Text.pack "=") 1 typeDoc -layoutHsTyPats - :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] -layoutHsTyPats pats = pats <&> \case - HsValArg tm -> layoutType tm - HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] - -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change - -- is a bit strange. Hopefully this does not ignore any important - -- annotations. - HsArgPar _l -> error "brittany internal error: HsArgPar{}" - -------------------------------------------------------------------------------- -- ClsInstDecl -------------------------------------------------------------------------------- @@ -842,25 +860,38 @@ 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 lcid@(L _ cid) = docLines - [ layoutInstanceHead - , docEnsureIndent BrIndentRegular - $ docSetIndentLevel - $ docSortedLines - $ fmap layoutAndLocateSig (cid_sigs cid) - ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) - ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) - ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) - ] +layoutClsInst :: LHsDecl GhcPs -> ClsInstDecl GhcPs -> ToBriDocM BriDocNumbered +layoutClsInst (L declLoc _) cid = do + -- _ x + docLines + [ layoutInstanceHead + , docEnsureIndent BrIndentRegular + $ docSetIndentLevel + $ docSortedLines + $ fmap layoutAndLocateSig (cid_sigs cid) + ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) + ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) + ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) + ] where layoutInstanceHead :: ToBriDocM BriDocNumbered - layoutInstanceHead = - briDocByExactNoComment - $ InstD NoExtField - . ClsInstD NoExtField - . removeChildren - <$> lcid + layoutInstanceHead = case cid_ext cid of + (EpAnn annAnchor addEpAnns (EpaComments comms), sortKey) -> do + let posWhere = obtainAnnPos addEpAnns AnnWhere + let (commsBefore, commsAfter) = partition (\(L anch _) -> (Just $ GHC.realSrcSpanStart $ anchor anch) < posWhere) comms + docHandleComms (reverse commsAfter) + $ briDocByExactNoComment + $ L declLoc + $ InstD NoExtField + $ ClsInstD NoExtField + $ (removeChildren cid) { + cid_ext = (EpAnn annAnchor addEpAnns (EpaComments commsBefore), sortKey) + } + _ -> briDocByExactNoComment + $ L declLoc + $ InstD NoExtField + $ ClsInstD NoExtField + $ removeChildren cid removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs removeChildren c = c @@ -880,11 +911,11 @@ layoutClsInst lcid@(L _ cid) = docLines . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l - layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) - layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig + layoutAndLocateSig :: ToBriDocC Sig (Located BriDocNumbered) + layoutAndLocateSig lsig@(L (SrcSpanAnn _ loc) sig) = L loc <$> layoutSig lsig sig - layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) - layoutAndLocateBind lbind@(L loc _) = + layoutAndLocateBind :: LHsBind GhcPs -> ToBriDocM (Located BriDocNumbered) + layoutAndLocateBind lbind@(L (SrcSpanAnn _ loc) _) = L loc <$> (joinBinds =<< layoutBind lbind) joinBinds @@ -894,79 +925,50 @@ layoutClsInst lcid@(L _ cid) = docLines Right n -> return n layoutAndLocateTyFamInsts - :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) - layoutAndLocateTyFamInsts ltfid@(L loc tfid) = + :: ToBriDocC TyFamInstDecl (Located BriDocNumbered) + layoutAndLocateTyFamInsts ltfid@(L (SrcSpanAnn _ loc) tfid) = L loc <$> layoutTyFamInstDecl True ltfid tfid layoutAndLocateDataFamInsts - :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) - layoutAndLocateDataFamInsts ldfid@(L loc _) = + :: ToBriDocC DataFamInstDecl (Located BriDocNumbered) + layoutAndLocateDataFamInsts ldfid@(L (SrcSpanAnn _ loc) _) = L loc <$> layoutDataFamInstDecl ldfid -- | Send to ExactPrint then remove unecessary whitespace layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl - layoutDataFamInstDecl ldfid = - fmap stripWhitespace <$> briDocByExactNoComment ldfid - - -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations - stripWhitespace :: BriDocF f -> BriDocF f - stripWhitespace (BDFExternal ann anns b t) = - BDFExternal ann anns b $ stripWhitespace' t - stripWhitespace b = b - - -- | This fixes two issues of output coming from Exactprinting - -- associated (data) type decls. Firstly we place the output into docLines, - -- so one newline coming from Exactprint is superfluous, so we drop the - -- first (empty) line. The second issue is Exactprint indents the first - -- member in a strange fashion: - -- - -- input: - -- - -- > instance MyClass Int where - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- output of just exactprinting the associated data type syntax node - -- - -- > - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- To fix this, we strip whitespace from the start of the comments and the - -- first line of the declaration, stopping when we see "data" or "type" at - -- the start of a line. I.e., this function yields - -- - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- Downside apart from being a hacky and brittle fix is that this removes - -- possible additional indentation from comments before the first member. - -- - -- But the whole thing is just a temporary measure until brittany learns - -- to layout data/type decls. - stripWhitespace' :: Text -> Text - stripWhitespace' t = - Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t - where - go [] = [] - go (line1 : lineR) = case Text.stripStart line1 of - st - | isTypeOrData st -> st : lineR - | otherwise -> st : go lineR - isTypeOrData t' = - (Text.pack "type" `Text.isPrefixOf` t') - || (Text.pack "newtype" `Text.isPrefixOf` t') - || (Text.pack "data" `Text.isPrefixOf` t') - + layoutDataFamInstDecl ldfid@(L _ (DataFamInstDecl famEqn)) = + docHandleComms ldfid $ case famEqn of + FamEqn epAnn tycon bndrs pats Prefix rhs -> do + docHandleComms epAnn $ layoutDataDecl + (error "Unsupported form of DataFamInstDecl") + tycon + (case bndrs of + HsOuterImplicit NoExtField -> HsQTvs NoExtField [] + HsOuterExplicit _ innerBndrs -> HsQTvs NoExtField $ innerBndrs + ) + pats + rhs + _ -> error "Unsupported DataFamInstDecl" + -- case rhs of + -- HsDataDefn NoExtField NewType Nothing Nothing Nothing [lcons] [] -> + -- let L _ cons = lcons + -- case cons of + -- ConDeclH98 _ext cName False _qvars ctxMay details _conDoc -> do + -- -- (Just (L _ [])) = ctxMay + -- nameStr <- lrdrNameToTextAnn tycon + -- consNameStr <- lrdrNameToTextAnn cName + -- tyVarLine <- return <$> createBndrDoc bndrs + -- let + -- isInfix = case fixity of + -- Prefix -> False + -- Infix -> True + -- _ x + -- docHandleComms epAnn + -- $ docSeq + -- $ [appSep $ docLitS "newtype", appSep $ docLit nameStr] + -- ++ [ makeForallDoc foralls | (HsOuterExplicit _ foralls) <- [bndrs] ] + -- ++ [ _ pats ] + -- fmap stripWhitespace <$> undefined -- TODO92 !!! briDocByExactNoComment ldfid -------------------------------------------------------------------------------- -- Common Helpers @@ -975,16 +977,17 @@ layoutClsInst lcid@(L _ cid) = docLines layoutLhsAndType :: Bool -> ToBriDocM BriDocNumbered - -> String + -> ToBriDocM BriDocNumbered + -> Int -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -layoutLhsAndType hasComments lhs sep typeDoc = do +layoutLhsAndType hasComments lhs sep sepLen typeDoc = do runFilteredAlternative $ do -- (separators probably are "=" or "::") -- lhs = type -- lhs :: type addAlternativeCond (not hasComments) $ docSeq - [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] + [lhs, docSeparator, sep, docSeparator, docForceSingleline typeDoc] -- lhs -- :: typeA -- -> typeB @@ -993,6 +996,6 @@ layoutLhsAndType hasComments lhs sep typeDoc = do -- -> typeB addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols ColTyOpPrefix - [ appSep $ docLitS sep - , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc + [ appSep sep + , docAddBaseY (BrIndentSpecial (sepLen + 1)) typeDoc ] diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs new file mode 100644 index 0000000..ae7652a --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs @@ -0,0 +1,1222 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.ToBriDoc.Expr where + +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import GHC (GenLocated(L), RdrName(..)) +import qualified GHC.Data.FastString as FastString +import GHC.Types.SourceText + (IntegralLit(IL), FractionalLit(FL), SourceText(SourceText)) +import GHC.Hs +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.OldList as List +import GHC.Types.Basic +import GHC.Types.Name +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.ToBriDoc.Decl +import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Stmt +import Language.Haskell.Brittany.Internal.ToBriDoc.Type +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Components.BriDoc + + + +layoutExpr :: ToBriDoc HsExpr +layoutExpr lexpr@(L _ expr) = do + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + let allowFreeIndent = indentPolicy == IndentPolicyFree + docHandleComms lexpr $ case expr of + HsVar NoExtField vname -> docHandleComms lexpr $ do + docLit =<< lrdrNameToTextAnn vname + HsUnboundVar epAnn oname -> docHandleComms epAnn $ do + docLit $ Text.pack $ occNameString oname + HsRecFld{} -> docHandleComms lexpr $ do + -- TODO + briDocByExactInlineOnly "HsRecFld" lexpr + HsOverLabel _ext name -> -- TODO92 + let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label + HsIPVar _ext (HsIPName name) -> -- TODO92 + let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label + HsOverLit epAnn olit -> docHandleComms epAnn $ do + allocateNode $ overLitValBriDoc $ ol_val olit + HsLit epAnn lit -> docHandleComms epAnn $ do + allocateNode $ litBriDoc lit + HsLam _ (MG _ (L _ [(L _ match)]) _) + | pats <- m_pats match + , GRHSs _ [lgrhs] llocals <- m_grhss match + , EmptyLocalBinds{} <- llocals + , L _ (GRHS epAnn [] body) <- lgrhs + -> do + patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> + fmap return $ do + -- this code could be as simple as `colsWrapPat =<< layoutPat p` + -- if it was not for the following two cases: + -- \ !x -> x + -- \ ~x -> x + -- These make it necessary to special-case an additional separator. + -- (TODO: we create a BDCols here, but then make it ineffective + -- by wrapping it in docSeq below. We _could_ add alignments for + -- stuff like lists-of-lambdas. Nothing terribly important..) + let + shouldPrefixSeparator = case p of + L _ LazyPat{} -> isFirst + L _ BangPat{} -> isFirst + _ -> False + patDocSeq <- layoutPat p + fixed <- case Seq.viewl patDocSeq of + p1 Seq.:< pr | shouldPrefixSeparator -> do + p1' <- docSeq [docSeparator, pure p1] + pure (p1' Seq.<| pr) + _ -> pure patDocSeq + colsWrapPat fixed + bodyDoc <- shareDoc + $ docAddBaseY BrIndentRegular + $ docHandleComms epAnn $ layoutExpr body + let + funcPatternPartLine = docCols + ColCasePattern + (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + docAlt + [ -- single line + docSeq + [ docLit $ Text.pack "\\" + , docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docForceSingleline bodyDoc + ] + -- double line + , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , appSep $ docForceSingleline + funcPatternPartLine + , docLit $ Text.pack "->" + ] + ) + (docForceSingleline bodyDoc) + -- wrapped par spacing + , docSetParSpacing $ docSeq + [ docLit $ Text.pack "\\" + , docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docForceParSpacing bodyDoc + ] + -- conservative + , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , appSep $ docForceSingleline + funcPatternPartLine + , docLit $ Text.pack "->" + ] + ) + (docNonBottomSpacing bodyDoc) + ] + HsLam{} -> unknownNodeError "HsLam too complex" lexpr + HsLamCase _ (MG _ (L _ []) _) -> do + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ (docLit $ Text.pack "\\case {}") + HsLamCase _ (MG _ _lmatches@(L _ matches) _) -> do + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- + -- docWrapNode lmatches + layoutPatternBind Nothing binderDoc + `mapM` matches + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "\\case") + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) + HsApp _ exp1 _ -> do + let + gather + :: [ToBriDocM BriDocNumbered] + -> LHsExpr GhcPs + -> (LHsExpr GhcPs, [ToBriDocM BriDocNumbered]) + gather list = \case + L _ (HsApp epAnn l r) -> gather + (docHandleComms epAnn $ layoutExpr r : list) l + x -> (x, list) + let (headE, paramEs) = gather + [] + lexpr + let + colsOrSequence = case headE of + L _ (HsVar _ (L _ (Unqual occname))) -> + docCols (ColApp $ Text.pack $ occNameString occname) + _ -> docSeq + headDoc <- shareDoc $ layoutExpr headE + paramDocs <- shareDoc `mapM` paramEs + let hasComments = hasAnyCommentsConnected exp1 + runFilteredAlternative $ do + -- foo x y + addAlternativeCond (not hasComments) + $ colsOrSequence + $ appSep (docForceSingleline headDoc) + : spacifyDocs (docForceSingleline <$> paramDocs) + -- foo x + -- y + addAlternativeCond allowFreeIndent $ docSeq + [ appSep (docForceSingleline headDoc) + , docSetBaseY + $ docAddBaseY BrIndentRegular + $ docLines + $ docForceSingleline + <$> paramDocs + ] + -- foo + -- x + -- y + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docForceSingleline headDoc) + (docNonBottomSpacing $ docLines paramDocs) + -- ( multi + -- line + -- function + -- ) + -- x + -- y + addAlternative $ docAddBaseY BrIndentRegular $ docPar + headDoc + (docNonBottomSpacing $ docLines paramDocs) + HsAppType _ exp1 (HsWC _ ty1) -> do + t <- shareDoc $ layoutType ty1 + e <- shareDoc $ layoutExpr exp1 + docAlt + [ docSeq + [ docForceSingleline e + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline t + ] + , docPar e (docSeq [docLit $ Text.pack "@", t]) + ] + OpApp _topEpAnn expLeft@(L _ OpApp{}) expOp expRight -> do + let + allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True + let + gather + :: Bool + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered, Bool)] + -> LHsExpr GhcPs + -> ( ToBriDocM BriDocNumbered + , [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered, Bool)] + ) + gather last opExprList = \case + (L _ (OpApp epAnn l1 op1 r1)) -> + gather + False + ( ( docHandleComms epAnn $ layoutExpr op1 + , layoutExpr r1 + , last + ) + : opExprList + ) + l1 + final -> (layoutExpr final, opExprList) + (leftOperand, appList) = gather True [] lexpr + leftOperandDoc <- shareDoc leftOperand + appListDocs <- appList `forM` \(x, y, last) -> + [ (xD, yD, last) + | xD <- shareDoc x + , yD <- shareDoc y + ] + let allowSinglelinePar = not (hasAnyCommentsConnected expLeft) + && not (hasAnyCommentsConnected expOp) + runFilteredAlternative $ do + -- > one + two + three + -- or + -- > one + two + case x of + -- > _ -> three + addAlternativeCond allowSinglelinePar $ docSeq + [ appSep $ docForceSingleline leftOperandDoc + , docSeq $ appListDocs <&> \(od, ed, last) -> docSeq + [ appSep $ docForceSingleline od + , if last + then if allowPar + then docForceParSpacing ed + else docForceSingleline ed + else appSep $ docForceSingleline ed + ] + ] + -- this case rather leads to some unfortunate layouting than to anything + -- useful; disabling for now. (it interfers with cols stuff.) + -- addAlternative + -- $ docSetBaseY + -- $ docPar + -- leftOperandDoc + -- ( docLines + -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + -- ) + -- > one + -- > + two + -- > + three + addAlternative $ docPar + leftOperandDoc + (docLines $ appListDocs <&> \(od, ed, _) -> + docCols ColOpPrefix [appSep od, docSetBaseY ed] + ) + OpApp epAnn expLeft expOp expRight -> docHandleComms epAnn $ do + expDocLeft <- shareDoc $ layoutExpr expLeft + expDocOp <- shareDoc $ layoutExpr expOp + expDocRight <- shareDoc $ layoutExpr expRight + let + allowPar = case (expOp, expRight) of + (L _ (HsVar _ (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False + _ -> True + let + leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False + runFilteredAlternative $ do + -- one-line + addAlternative $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceSingleline expDocRight + ] + -- -- line + freely indented block for right expression + -- addAlternative + -- $ docSeq + -- [ appSep $ docForceSingleline expDocLeft + -- , appSep $ docForceSingleline expDocOp + -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight + -- ] + -- two-line + addAlternative $ do + let + expDocOpAndRight = docForceSingleline $ docCols + ColOpPrefix + [appSep $ expDocOp, docSetBaseY expDocRight] + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular + $ docPar expDocLeft expDocOpAndRight + -- TODO: in both cases, we don't force expDocLeft to be + -- single-line, which has certain.. interesting consequences. + -- At least, the "two-line" label is not entirely + -- accurate. + -- one-line + par + addAlternativeCond allowPar $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceParSpacing expDocRight + ] + -- more lines + addAlternative $ do + let + expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular + $ docPar expDocLeft expDocOpAndRight + NegApp _ op _ -> do + opDoc <- shareDoc $ layoutExpr op + docSeq [docLit $ Text.pack "-", opDoc] + HsPar epAnn innerExp -> docHandleComms epAnn $ do + let AnnParen _ spanOpen spanClose = anns epAnn + let wrapOpen = docHandleComms spanOpen + let wrapClose = docHandleComms spanClose + innerExpDoc <- shareDoc $ layoutExpr innerExp + docAlt + [ docSeq + [ wrapOpen $ docLit $ Text.pack "(" + , docForceSingleline innerExpDoc + , wrapClose $ docLit $ Text.pack ")" + ] + , docSetBaseY $ docLines + [ docCols + ColOpPrefix + [ wrapOpen $ docLit $ Text.pack "(" + , docAddBaseY (BrIndentSpecial 2) innerExpDoc + ] + , wrapClose $ docLit $ Text.pack ")" + ] + ] + SectionL _ left op -> do -- TODO: add to testsuite + leftDoc <- shareDoc $ layoutExpr left + opDoc <- shareDoc $ layoutExpr op + docSeq [leftDoc, docSeparator, opDoc] + SectionR _ op right -> do -- TODO: add to testsuite + opDoc <- shareDoc $ layoutExpr op + rightDoc <- shareDoc $ layoutExpr right + docSeq [opDoc, docSeparator, rightDoc] + ExplicitTuple epAnn args boxity -> docHandleComms epAnn $ do + let (wrapOpen, wrapClose) = case anns epAnn of + [open, close] -> case boxity of + Boxed -> + ( docHandleComms $ obtainAnnPos open AnnOpenP + , docHandleComms $ obtainAnnPos close AnnCloseP + ) + Unboxed -> + ( docHandleComms $ obtainAnnPos open AnnOpenPH + , docHandleComms $ obtainAnnPos close AnnClosePH + ) + _ -> (id, id) + argDocs <- forM args $ \case + Present _ e -> shareDoc $ docHandleListElemComms layoutExpr e + Missing missingEpAnn -> shareDoc $ docHandleComms missingEpAnn docEmpty + -- let ((c1, argsWithC, c2), cRemain) = case epAnn of + -- EpAnn _ [open, close] comms -> + -- enterCommentsSplitC comms $ do + -- comms1 <- getCommentsBeforeKW open AnnOpenP + -- elems' <- args `forM` \arg -> case arg of + -- Present _ e@(L (SrcSpanAnn elEpAnn loc) _) -> do + -- commsB <- case loc of + -- GHC.RealSrcSpan span _ -> getCommentsBeforeSpan span + -- _ -> pure [] + -- case elEpAnn of + -- EpAnn _ (AnnListItem items) _ -> do + -- commsA <- items `forM` \case + -- AddCommaAnn span -> + -- getCommentsBeforeEpaLocation span + -- ann1 -> + -- error $ "unexpected TrailingAnn: " + -- ++ showSDocUnsafe (ppr ann1) + -- pure $ docWrapNode (commsB, join commsA) $ layoutExpr e + -- EpAnnNotUsed -> do + -- pure $ prependComments commsB $ layoutExpr e + -- Missing (EpAnn _ epa _) -> do + -- commsB <- getCommentsBeforeEpaLocation epa + -- pure $ prependComments commsB docEmpty + -- Missing EpAnnNotUsed -> pure $ docEmpty + -- comm2 <- getCommentsBeforeKW close AnnCloseP + -- pure (comms1, elems', comm2) + -- EpAnn _ _ _ -> error "unexpected ExplicitTuple ann!" + -- EpAnnNotUsed -> + -- let argsDocs = [ case arg of + -- Present _ e -> layoutExpr e + -- Missing _ -> docEmpty + -- | arg <- args ] + -- in (([], argsDocs, []), []) + let hasComments = hasAnyCommentsBelow lexpr -- TODO92 this is slightly + -- overzealous for comments before open & after close + let + (openLit, closeLit) = case boxity of + Boxed -> + ( wrapOpen $ docLit $ Text.pack "(" + , wrapClose $ docLit $ Text.pack ")" + ) + Unboxed -> + ( wrapOpen $ docParenHashLSep + , wrapClose $ docParenHashRSep + ) + case splitFirstLast argDocs of + FirstLastEmpty -> + docSeq [openLit, closeLit] + FirstLastSingleton e -> docAlt + [ docCols + ColTuple + [ openLit + , docForceSingleline e + , closeLit + ] + , docSetBaseY $ docLines + [ docSeq + [ openLit + , docForceSingleline e + ] + , closeLit + ] + ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docCols ColTuple + $ [docSeq [openLit, docForceSingleline e1]] + ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) + ++ [ docSeq + [ docCommaSep + , -- TODO92 docNodeAnnKW lexpr (Just AnnOpenP) + (docForceSingleline eN) + , closeLit + ] + ] + addAlternative + $ let + start = docCols ColTuples [appSep openLit, e1] + linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] + lineN = docCols + ColTuples + [docCommaSep, -- TODO92 docNodeAnnKW lexpr (Just AnnOpenP) + eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] + HsCase epAnn cExp (MG _ (L _ []) _) -> docHandleComms epAnn $ do + cExpDoc <- shareDoc $ layoutExpr cExp + docAlt + [ docAddBaseY BrIndentRegular $ docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of {}" + ] + , docPar + (docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docLit $ Text.pack "of {}") + ] + HsCase epAnn cExp (MG _ _lmatches@(L _ matches) _) -> docHandleComms epAnn $ do + cExpDoc <- shareDoc $ layoutExpr cExp + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- + -- docWrapNode lmatches + layoutPatternBind Nothing binderDoc + `mapM` matches + docAlt + [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of" + ] + ) + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) + , docPar + (docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + (docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "of") + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ return + <$> funcPatDocs + ) + ) + ] + HsIf epAnn ifExpr thenExpr elseExpr -> docHandleComms epAnn $ do + let AnnsIf spanIf spanThen spanElse _ _ = anns epAnn + let ifDoc = docHandleComms spanIf $ docLit $ Text.pack "if" + let thenDoc = docHandleComms spanThen $ docLit $ Text.pack "then" + let elseDoc = docHandleComms spanElse $ docLit $ Text.pack "else" + ifExprDoc <- shareDoc $ layoutExpr ifExpr + thenExprDoc <- shareDoc $ layoutExpr thenExpr + elseExprDoc <- shareDoc $ layoutExpr elseExpr + let hasComments = hasAnyCommentsBelow lexpr + let + maySpecialIndent = case indentPolicy of + IndentPolicyLeft -> BrIndentRegular + IndentPolicyMultiple -> BrIndentRegular + IndentPolicyFree -> BrIndentSpecial 3 + -- TODO: some of the alternatives (especially last and last-but-one) + -- overlap. + docSetIndentLevel $ runFilteredAlternative $ do + -- if _ then _ else _ + addAlternativeCond (not hasComments) $ docSeq + [ appSep $ ifDoc + , appSep $ docForceSingleline ifExprDoc + , appSep $ thenDoc + , appSep $ docForceSingleline thenExprDoc + , appSep $ elseDoc + , docForceSingleline elseExprDoc + ] + -- either + -- if expr + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if expr + -- then + -- stuff + -- else + -- stuff + -- note that this has par-spacing + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docSeq + [ -- TODO92 docNodeAnnKW lexpr Nothing $ + appSep $ ifDoc + , -- TODO92 docNodeAnnKW lexpr (Just AnnIf) $ + docForceSingleline ifExprDoc + ] + ) + (docLines + [ docAddBaseY BrIndentRegular + -- TODO92 $ docNodeAnnKW lexpr (Just AnnThen) + $ docNonBottomSpacing + $ docAlt + [ docSeq + [ appSep $ thenDoc + , docForceParSpacing thenExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (thenDoc) thenExprDoc + ] + , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt + [ docSeq + [ appSep $ elseDoc + , docForceParSpacing elseExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar elseDoc elseExprDoc + ] + ] + ) + -- either + -- if multi + -- line + -- condition + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if multi + -- line + -- condition + -- then + -- stuff + -- else + -- stuff + -- note that this does _not_ have par-spacing + addAlternative $ docAddBaseY BrIndentRegular $ docPar + (docAddBaseY maySpecialIndent $ docSeq + [ -- TODO92 docNodeAnnKW lexpr Nothing $ + appSep $ ifDoc + , -- TODO92 docNodeAnnKW lexpr (Just AnnIf) $ + ifExprDoc + ] + ) + (docLines + [ docAddBaseY BrIndentRegular + -- TODO92 $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq + [ appSep $ thenDoc + , docForceParSpacing thenExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (thenDoc) thenExprDoc + ] + , docAddBaseY BrIndentRegular $ docAlt + [ docSeq + [ appSep $ elseDoc + , docForceParSpacing elseExprDoc + ] + , docAddBaseY BrIndentRegular + $ docPar elseDoc elseExprDoc + ] + ] + ) + addAlternative $ docSetBaseY $ docLines + [ docAddBaseY maySpecialIndent $ docSeq + [ -- TODO92 docNodeAnnKW lexpr Nothing $ + appSep $ ifDoc + , -- TODO92 docNodeAnnKW lexpr (Just AnnIf) $ + ifExprDoc + ] + , -- TODO92 docNodeAnnKW lexpr (Just AnnThen) $ + docAddBaseY BrIndentRegular + $ docPar (thenDoc) thenExprDoc + , docAddBaseY BrIndentRegular + $ docPar elseDoc elseExprDoc + ] + HsMultiIf _ cases -> do + binderDoc <- docLit $ Text.pack "->" + let hasComments = hasAnyCommentsBelow lexpr + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "if") + (layoutPatternBindFinal + Nothing + binderDoc + Nothing + (Right cases) + Nothing + hasComments + ) + HsLet epAnn binds exp1 -> docHandleComms epAnn $ do + let AnnsLet spanLet spanIn = anns epAnn + let hasComments = hasAnyCommentsBelow lexpr + let wrapLet = docHandleComms spanLet + let wrapIn = docHandleComms spanIn + mBindDocs <- layoutLocalBinds binds + let + ifIndentFreeElse :: a -> a -> a + ifIndentFreeElse x y = case indentPolicy of + IndentPolicyLeft -> y + IndentPolicyMultiple -> y + IndentPolicyFree -> x + expDoc1 <- shareDoc $ layoutExpr exp1 + -- this `docSetBaseAndIndent` might seem out of place (especially the + -- Indent part; setBase is necessary due to the use of docLines below), + -- but is here due to ghc-exactprint's DP handling of "let" in + -- particular. + -- Just pushing another indentation level is a straightforward approach + -- to making brittany idempotent, even though the result is non-optimal + -- if "let" is moved horizontally as part of the transformation, as the + -- comments before the first let item are moved horizontally with it. + letDoc <- shareDoc $ wrapLet $ docLit $ Text.pack "let" + inDoc <- shareDoc $ wrapIn $ docLit $ Text.pack "in" + docSetBaseAndIndent $ case fmap snd mBindDocs of + Just [bindDoc] -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [ appSep $ letDoc + , appSep $ docForceSingleline (pure bindDoc) + , appSep $ inDoc + , docForceSingleline expDoc1 + ] + addAlternative $ docLines + [ docAlt + [ docSeq + [ appSep $ letDoc + , ifIndentFreeElse docSetBaseAndIndent docForceSingleline + $ pure bindDoc + ] + , docAddBaseY BrIndentRegular $ docPar + (letDoc) + (docSetBaseAndIndent $ pure bindDoc) + ] + , docAlt + [ docSeq + [ appSep $ wrapIn $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" + , ifIndentFreeElse + docSetBaseAndIndent + docForceSingleline + expDoc1 + ] + , docAddBaseY BrIndentRegular + $ docPar (inDoc) (docSetBaseY expDoc1) + ] + ] + Just bindDocs@(_ : _) -> runFilteredAlternative $ do + --either + -- let + -- a = b + -- c = d + -- in foo + -- bar + -- baz + --or + -- let + -- a = b + -- c = d + -- in + -- fooooooooooooooooooo + let + noHangingBinds = + [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar + (letDoc) + (docSetBaseAndIndent $ docLines $ pure <$> bindDocs) + , docSeq + [ wrapIn $ docLit $ Text.pack "in " + , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 + ] + ] + addAlternative $ case indentPolicy of + IndentPolicyLeft -> docLines noHangingBinds + IndentPolicyMultiple -> docLines noHangingBinds + IndentPolicyFree -> docLines + [ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $ + docSeq + [ appSep $ letDoc + , docSetBaseAndIndent $ docLines $ pure <$> bindDocs + ] + , docSeq [appSep $ wrapIn $ docLit $ Text.pack "in ", docSetBaseY expDoc1] + ] + addAlternative $ docLines + [ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $ + docAddBaseY BrIndentRegular + $ docPar + (letDoc) + (docSetBaseAndIndent $ docLines $ pure <$> bindDocs) + , docAddBaseY BrIndentRegular + $ docPar (inDoc) (docSetBaseY $ expDoc1) + ] + _ -> docSeq + [ docForceSingleline $ docSeq + [ letDoc + , docSeparator + , inDoc + ] + , docSeparator + , expDoc1 + ] + -- docSeq [appSep $ docLit "let in", expDoc1] + HsDo epAnn stmtCtx (L (SrcSpanAnn stmtEpAnn _) stmts) -> + docHandleComms epAnn $ do + case stmtCtx of + DoExpr _ -> do + stmtDocs <- docHandleComms stmtEpAnn $ do + stmts `forM` docHandleListElemComms layoutStmt + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ pure <$> stmtDocs + ) + MDoExpr _ -> do + stmtDocs <- docHandleComms stmtEpAnn $ do + stmts `forM` docHandleListElemComms layoutStmt + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent + $ docNonBottomSpacing + $ docLines + $ pure <$> stmtDocs + ) + x + | case x of + ListComp -> True + MonadComp -> True + _ -> False + -> do + stmtDocs <- docHandleComms stmtEpAnn $ + stmts `forM` docHandleListElemComms layoutStmt + let hasComments = hasAnyCommentsBelow lexpr + runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [ -- TODO92 docNodeAnnKW lexpr Nothing $ + appSep $ docLit $ Text.pack "[" + , -- TODO92 docNodeAnnKW lexpr (Just AnnOpenS) $ + appSep + $ docForceSingleline + $ pure (List.last stmtDocs) + , appSep $ docLit $ Text.pack "|" + , docSeq + $ List.intersperse docCommaSep + $ (docForceSingleline . pure) <$> List.init stmtDocs + , docLit $ Text.pack " ]" + ] + addAlternative + $ let + start = docCols + ColListComp + [ -- TODO92 docNodeAnnKW lexpr Nothing $ + appSep $ docLit $ Text.pack "[" + , docSetBaseY + -- TODO92 $ docNodeAnnKW lexpr (Just AnnOpenS) + $ pure (List.last stmtDocs) + ] + (s1, sM) = case List.init stmtDocs of + (a: b) -> (a, b) + _ -> error "layoutExp: stmtDocs list too short" + line1 = + docCols ColListComp [appSep $ docLit $ Text.pack "|", pure s1] + lineM = sM <&> \d -> docCols ColListComp [docCommaSep, pure d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + _ -> do + -- TODO + unknownNodeError "HsDo{} unknown stmtCtx" lexpr + ExplicitList listEpAnn elems@(_ : _) -> docHandleComms listEpAnn $ do + let posOpen = obtainAnnPos listEpAnn AnnOpenS + let posClose = obtainAnnPos listEpAnn AnnCloseS + let openDoc = docHandleComms posOpen $ docLitS "[" + let closeDoc = docHandleComms posClose $ docLitS "]" + elemDocs <- elems `forM` (shareDoc . docHandleListElemComms layoutExpr) + let hasComments = hasAnyCommentsBelow lexpr + case splitFirstLast elemDocs of + FirstLastEmpty -> docSeq + [ docLit $ Text.pack "[" + , closeDoc + ] + FirstLastSingleton e -> docAlt + [ docSeq + [ openDoc + , docForceSingleline e + , closeDoc + ] + , docSetBaseY $ docLines + [ docSeq + [ openDoc + , docSeparator + , docSetBaseY $ e + ] + , closeDoc + ] + ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + $ [openDoc] + ++ List.intersperse + docCommaSep + (docForceSingleline + <$> (e1 : ems ++ [eN]) + ) + ++ [closeDoc] + addAlternative + $ let + start = docCols ColList [appSep $ openDoc, e1] + linesM = ems <&> \d -> docCols ColList [docCommaSep, d] + lineN = docCols + ColList + [docCommaSep, eN] + in docSetBaseY $ + docLines $ [start] ++ linesM ++ [lineN] ++ [closeDoc] + ExplicitList epAnn [] -> docHandleComms epAnn $ docLit $ Text.pack "[]" + RecordCon epAnn lname fields -> docHandleComms epAnn $ do + let (wrapOpen, wrapClose) = case epAnn of + EpAnn _ [open, close] _ -> + ( docHandleComms (obtainAnnPos open AnnOpenC) + , docHandleComms (obtainAnnPos close AnnCloseC) + ) + _ -> (id, id) + fieldLayouter = \case + FieldOcc _ lnameF -> docLit (lrdrNameToText lnameF) + XFieldOcc _ -> error "XFieldOcc" + case fields of + HsRecFields fs Nothing -> do + let nameDoc = docHandleComms lname $ docLit $ lrdrNameToText lname + recordExpression False wrapOpen id wrapClose indentPolicy lexpr nameDoc fieldLayouter fs + HsRecFields [] (Just (L dotdotLoc 0)) -> do + let wrapDotDot = docHandleComms dotdotLoc + let t = lrdrNameToText lname + docHandleComms lname $ docSeq + [ docLit t + , docSeparator + , wrapOpen $ docLitS "{" + , docSeparator + , wrapDotDot $ docLitS ".." + , docSeparator + , wrapClose $ docLitS "}" + ] + HsRecFields fs@(_ : _) (Just (L dotdotLoc dotdoti)) | dotdoti == length fs -> do + let nameDoc = docHandleComms lname $ docLit $ lrdrNameToText lname + let wrapDotDot = docHandleComms dotdotLoc + recordExpression True wrapOpen wrapDotDot wrapClose indentPolicy lexpr nameDoc fieldLayouter fs + _ -> unknownNodeError "RecordCon with puns" lexpr + RecordUpd epAnn rExpr (Left fields) -> docHandleComms epAnn $ do + let (wrapOpen, wrapClose) = case epAnn of + EpAnn _ [open, close] _ -> + ( docHandleComms $ obtainAnnPos open AnnOpenC + , docHandleComms $ obtainAnnPos close AnnCloseC + ) + _ -> (id, id) + let fieldLayouter = \case + Unambiguous _ n -> docLit (lrdrNameToText n) + Ambiguous _ n -> docLit (lrdrNameToText n) + XAmbiguousFieldOcc _ -> error "XAmbiguousFieldOcc" + rExprDoc <- shareDoc $ layoutExpr rExpr + recordExpression False wrapOpen id wrapClose indentPolicy lexpr rExprDoc fieldLayouter fields + RecordUpd epAnn rExpr (Right fields) -> do + let (wrapOpen, wrapClose) = case epAnn of + EpAnn _ [open, close] _ -> + ( docHandleComms $ obtainAnnPos open AnnOpenC + , docHandleComms $ obtainAnnPos close AnnCloseC + ) + _ -> (id, id) + rExprDoc <- shareDoc $ layoutExpr rExpr + let labelLayouter label = case label of + L flAnn (HsFieldLabel _ (L _ n)) -> + docHandleComms flAnn $ docLitS $ FastString.unpackFS n + L _ann (XHsFieldLabel _) -> error "XHsFieldLabel" + let fieldLayouter = \case + FieldLabelStrings [] -> docEmpty + FieldLabelStrings [label] -> labelLayouter label + FieldLabelStrings labels -> docSeq + $ List.intersperse docCommaSep + $ map labelLayouter labels + recordExpression False wrapOpen id wrapClose indentPolicy lexpr rExprDoc fieldLayouter fields + ExprWithTySig _ exp1 (HsWC _ typ1) -> do + expDoc <- shareDoc $ layoutExpr exp1 + typDoc <- shareDoc $ layoutSigType typ1 + docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc] + ArithSeq _ Nothing info -> case info of + From e1 -> do + e1Doc <- shareDoc $ layoutExpr e1 + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , docLit $ Text.pack "..]" + ] + FromThen e1 e2 -> do + e1Doc <- shareDoc $ layoutExpr e1 + e2Doc <- shareDoc $ layoutExpr e2 + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , docLit $ Text.pack "..]" + ] + FromTo e1 eN -> do + e1Doc <- shareDoc $ layoutExpr e1 + eNDoc <- shareDoc $ layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + FromThenTo e1 e2 eN -> do + e1Doc <- shareDoc $ layoutExpr e1 + e2Doc <- shareDoc $ layoutExpr e2 + eNDoc <- shareDoc $ layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr + HsBracket{} -> do + -- TODO + briDocByExactInlineOnly "HsBracket{}" lexpr + HsRnBracketOut{} -> do + -- TODO + briDocByExactInlineOnly "HsRnBracketOut{}" lexpr + HsTcBracketOut{} -> do + -- TODO + briDocByExactInlineOnly "HsTcBracketOut{}" lexpr + HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do + allocateNode $ BDFPlain + (Text.pack + $ "[" + ++ showOutputable quoter + ++ "|" + ++ showOutputable content + ++ "|]" + ) + HsSpliceE{} -> do + -- TODO + briDocByExactInlineOnly "HsSpliceE{}" lexpr + HsProc{} -> do + -- TODO + briDocByExactInlineOnly "HsProc{}" lexpr + HsStatic{} -> do + -- TODO + briDocByExactInlineOnly "HsStatic{}" lexpr + HsTick{} -> do + -- TODO + briDocByExactInlineOnly "HsTick{}" lexpr + HsBinTick{} -> do + -- TODO + briDocByExactInlineOnly "HsBinTick{}" lexpr + HsConLikeOut{} -> do + -- TODO + briDocByExactInlineOnly "HsWrap{}" lexpr + ExplicitSum{} -> do + -- TODO + briDocByExactInlineOnly "ExplicitSum{}" lexpr + HsPragE{} -> do + -- TODO + briDocByExactInlineOnly "HsPragE{}" lexpr + HsGetField{} -> do + -- TODO + briDocByExactInlineOnly "HsGetField{}" lexpr + HsProjection{} -> do + -- TODO + briDocByExactInlineOnly "HsGetField{}" lexpr + +recordExpression + :: Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> IndentPolicy + -> LocatedA lExpr + -> ToBriDocM BriDocNumbered + -> (field -> ToBriDocM BriDocNumbered) + -- -> [LHsFieldBind GhcPs (LFieldOcc p) (LHsExpr GhcPs)] + -> [LHsRecField' GhcPs field (LHsExpr GhcPs)] + -> ToBriDocM BriDocNumbered +recordExpression False wrapO _wrapDD wrapC _ _lexpr nameDoc _ [] = docSeq + [ -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) $ + docSeq [nameDoc, wrapO $ docLit $ Text.pack "{"] + , wrapC $ docLit $ Text.pack "}" + ] +recordExpression True wrapO wrapDD wrapC _ _lexpr nameDoc _ [] = docSeq -- this case might still be incomplete, and is probably not used + -- atm anyway. + [ nameDoc + , wrapO $ docLit $ Text.pack "{" + , docSeparator + , wrapDD $ docLitS ".." + , docSeparator + , wrapC $ docLit $ Text.pack "}" + ] +recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayouter (rF1 : rFr) = do + let mkFieldTuple = \case + L srcSpan (HsRecField fEpAnn (L _ nameThing) rFExpr pun) -> do + let (posStart, _posSomething) = case fEpAnn of -- TODO92 not sure what posSomething is + EpAnn anch [AddEpAnn _ span] _ -> + ( Just $ GHC.realSrcSpanStart $ anchor anch + , Just $ epaLocationRealSrcSpanStart span + ) + _ -> (Nothing, Nothing) + let posComma = case srcSpan of + SrcSpanAnn (EpAnn _ (AnnListItem items) _) _ -> case items of + [AddCommaAnn span] -> Just $ epaLocationRealSrcSpanStart span + _ -> Nothing + SrcSpanAnn EpAnnNotUsed _ -> Nothing + fnameDoc <- shareDoc $ nameLayouter nameThing + if pun + then pure $ Left (posStart, fnameDoc) + else do + expDoc <- shareDoc $ docFlushCommsPost posComma $ layoutExpr rFExpr + pure $ Right (posStart, fnameDoc, expDoc) + fieldTuple1 <- mkFieldTuple rF1 + fieldTupleR <- rFr `forM` mkFieldTuple + let fieldWiths + :: a + -> a + -> ( a + -> Either + (Maybe GHC.RealSrcLoc, ToBriDocM BriDocNumbered) + ( Maybe GHC.RealSrcLoc + , ToBriDocM BriDocNumbered + , ToBriDocM BriDocNumbered + ) + -> ToBriDocM BriDocNumbered + ) + -> [ToBriDocM BriDocNumbered] + fieldWiths extra1 extraR f = + f extra1 fieldTuple1 : map (f extraR) fieldTupleR + runFilteredAlternative $ do + -- container { fieldA = blub, fieldB = blub } + addAlternative $ docSeq + [ -- TODO92 docNodeAnnKW lexpr Nothing $ + appSep $ docForceSingleline nameDoc + , appSep $ wrapO $ docLit $ Text.pack "{" + , docSeq + $ List.intersperse docCommaSep + $ fieldWiths () () $ \() -> \case + Left (pos, fnameDoc) -> docHandleComms pos $ fnameDoc + Right (pos, fnameDoc, expDoc) -> docHandleComms pos $ docSeq + [ appSep $ fnameDoc + , appSep $ docLit $ Text.pack "=" + , docForceSingleline $ expDoc + ] + , if dotdot + then docSeq [docCommaSep, wrapDD $ docLit $ Text.pack "..", docSeparator] + else docSeparator + , wrapC $ docLit $ Text.pack "}" + ] + -- hanging single-line fields + -- container { fieldA = blub + -- , fieldB = blub + -- } + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq + [ -- TODO92 docNodeAnnKW lexpr Nothing $ + docForceSingleline $ appSep nameDoc + , docSetBaseY + $ docLines + $ let + fieldLines = fieldWiths + (appSep $ wrapO $ docLit $ Text.pack "{") + docCommaSep + $ \prep -> \case + Left (pos, fnameDoc) -> docCols + ColRec + [ prep + , docHandleComms pos $ fnameDoc + ] + Right (pos, fnameDoc, expDoc) -> docCols + ColRec + [ prep + , docHandleComms pos $ appSep $ fnameDoc + , docSeq + [appSep $ docLit $ Text.pack "=", docForceSingleline expDoc] + ] + dotdotLine = if dotdot + then docCols + ColRec + [ -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) + docCommaSep + , wrapDD $ docLit $ Text.pack ".." + ] + else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) + docEmpty + lineN = wrapC $ docLit $ Text.pack "}" + in fieldLines ++ [dotdotLine, lineN] + ] + -- non-hanging with expressions placed to the right of the names + -- container + -- { fieldA = blub + -- , fieldB = potentially + -- multiline + -- } + addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (-- TODO92 docNodeAnnKW lexpr Nothing + nameDoc) + (docNonBottomSpacing + $ docLines + $ let + fieldLines = fieldWiths + (appSep $ wrapO $ docLit $ Text.pack "{") + docCommaSep + $ \prep -> \case + Left (pos, fnameDoc) -> docCols ColRec + [ prep + , docHandleComms pos $ fnameDoc + ] + Right (pos, fnameDoc, expDoc) -> docCols ColRec + [ prep + , docHandleComms pos $ appSep $ fnameDoc + , runFilteredAlternative $ do + addAlternativeCond (indentPolicy == IndentPolicyFree) $ do + docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY expDoc] + addAlternative $ do + docSeq + [appSep $ docLit $ Text.pack "=", docForceParSpacing expDoc] + addAlternative $ do + docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") expDoc + ] + dotdotLine = if dotdot + then docCols + ColRec + [ -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) + docCommaSep + , wrapDD $ docLit $ Text.pack ".." + ] + else -- TODO92 docNodeAnnKW lexpr (Just AnnOpenC) + docEmpty + lineN = wrapC $ docLit $ Text.pack "}" + in fieldLines ++ [dotdotLine, lineN] + ) + +litBriDoc :: HsLit GhcPs -> BriDocFInt +litBriDoc = \case + HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + 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 + _ -> 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 + 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/ToBriDoc/Expr.hs-boot similarity index 63% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot rename to source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs-boot index 4f913c3..a1f52d3 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs-boot @@ -1,16 +1,15 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Expr where +module Language.Haskell.Brittany.Internal.ToBriDoc.Expr where import GHC.Hs import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Components.BriDoc layoutExpr :: ToBriDoc HsExpr --- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) - litBriDoc :: HsLit GhcPs -> BriDocFInt overLitValBriDoc :: OverLitVal -> BriDocFInt diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/IE.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/IE.hs new file mode 100644 index 0000000..c4f3535 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/IE.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.ToBriDoc.IE where + +import qualified Data.List.Extra +import qualified Data.Text as Text +import GHC ( GenLocated(L) + , ModuleName + , moduleNameString + , unLoc + ) +import GHC.Hs +import qualified GHC.OldList as List +import qualified Data.Data + +import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils + + + +prepareName :: LIEWrappedName name -> LocatedN name +prepareName = ieLWrappedName + +layoutIE :: Data.Data.Data ast => ast -> ToBriDoc IE +layoutIE commAst lie@(L _ ie) = docHandleComms lie $ case ie of + IEVar _ x -> layoutWrapped lie x + IEThingAbs _ x -> layoutWrapped lie x + IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] + IEThingWith epAnn x (IEWildcard _) _ -> do + let posOpen = obtainAnnPos epAnn AnnOpenP + let posClose = obtainAnnPos epAnn AnnCloseP + let posDotDot = obtainAnnPos epAnn AnnDotdot + docSeq + [ layoutWrapped lie x + , docHandleComms posOpen $ docLitS "(" + , docHandleComms posDotDot $ docLitS ".." + , docHandleComms posClose $ docLitS ")" + ] + IEThingWith epAnn x _ ns -> do + let hasComments = or + ( hasCommentsBetween commAst posOpen posClose + : hasAnyCommentsBelow x + : map hasAnyCommentsBelow ns + ) + let sortedNs = List.sortOn wrappedNameToText ns + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + $ [layoutWrapped lie x, docHandleComms posOpen $ docLit $ Text.pack "("] + ++ intersperse docCommaSep (map nameDoc sortedNs) + ++ [docHandleComms posClose docParenR] + addAlternative + -- $ docWrapNodeRest lie + $ docAddBaseY BrIndentRegular + $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) + where + posOpen = obtainAnnPos epAnn AnnOpenP + posClose = obtainAnnPos epAnn AnnCloseP + nameDoc = docHandleListElemComms (docLit <=< lrdrNameToTextAnn . prepareName) + layoutItem n = docSeq + [ docCommaSep + , -- TODO92 docWrapNode n $ + nameDoc n + ] + layoutItems FirstLastEmpty = docSetBaseY $ docLines + [ docSeq + [ docHandleComms posOpen docParenLSep + , -- TODO92 docNodeAnnKW lie (Just AnnOpenP) + docEmpty + ] + , docHandleComms posClose docParenR + ] + layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines + [ docSeq + [ docHandleComms posOpen docParenLSep + , -- TODO92 docNodeAnnKW lie (Just AnnOpenP) $ + nameDoc n + ] + , docHandleComms posClose docParenR + ] + layoutItems (FirstLast n1 nMs nN) = + docSetBaseY + $ docLines + $ [ docSeq + [ docHandleComms posOpen docParenLSep + , -- TODO92 docWrapNode n1 $ + nameDoc n1 + ] + ] + ++ map layoutItem nMs + ++ [ docSeq + [ docCommaSep + , -- TODO92 docNodeAnnKW lie (Just AnnOpenP) $ + nameDoc nN + ] + , docHandleComms posClose docParenR + ] + IEModuleContents _ n -> docSeq + [ docLit $ Text.pack "module" + , docSeparator + , docLit . Text.pack . moduleNameString $ unLoc n + ] + _ -> docEmpty + where + layoutWrapped _ = \case + L _ (IEName n ) -> docLit =<< lrdrNameToTextAnn n + L _ (IEPattern loc n) -> do + name <- lrdrNameToTextAnn n + docHandleComms loc $ docLit $ Text.pack "pattern " <> name + L _ (IEType loc n) -> do + name <- lrdrNameToTextAnn n + docHandleComms loc $ docLit $ Text.pack "type " <> name + +data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted +-- Helper function to deal with Located lists of LIEs. +-- In particular this will also associate documentation +-- from the located list that actually belongs to the last IE. +-- It also adds docCommaSep to all but the first element +-- This configuration allows both vertical and horizontal +-- handling of the resulting list. Adding parens is +-- left to the caller since that is context sensitive +layoutAnnAndSepLLIEs + :: (Data.Data.Data a, HasCallStack) + => SortItemsFlag + -> a + -> [LIE GhcPs] + -> ToBriDocM [ToBriDocM BriDocNumbered] +layoutAnnAndSepLLIEs shouldSort commAst lies = do + let makeIENode ie = docSeq [docCommaSep, ie] + let sortedLies = + [ items + | group <- Data.List.Extra.groupOn lieToText + $ List.sortOn lieToText lies + , items <- mergeGroup group + ] + let ieDocs = fmap (docHandleListElemComms (layoutIE commAst)) $ case shouldSort of + ShouldSortItems -> sortedLies + KeepItemsUnsorted -> lies + ieCommaDocs <- sequence $ case splitFirstLast ieDocs of + FirstLastEmpty -> [] + FirstLastSingleton ie -> [ie] + FirstLast ie1 ieMs ieN -> [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] + pure $ fmap pure ieCommaDocs -- returned shared nodes + where + mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] + mergeGroup [] = [] + mergeGroup items@[_] = items + mergeGroup items = if + | all isProperIEThing items -> [List.foldl1' thingFolder items] + | all isIEVar items -> [List.foldl1' thingFolder items] + | otherwise -> items + -- proper means that if it is a ThingWith, it does not contain a wildcard + -- (because I don't know what a wildcard means if it is not already a + -- IEThingAll). + isProperIEThing :: LIE GhcPs -> Bool + isProperIEThing = \case + L _ (IEThingAbs _ _wn) -> True + L _ (IEThingAll _ _wn) -> True + L _ (IEThingWith _ _wn NoIEWildcard _) -> True + _ -> False + isIEVar :: LIE GhcPs -> Bool + isIEVar = \case + L _ IEVar{} -> True + _ -> False + thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs + thingFolder l1@(L _ IEVar{} ) _ = l1 + thingFolder l1@(L _ IEThingAll{}) _ = l1 + thingFolder _ l2@(L _ IEThingAll{}) = l2 + thingFolder l1 ( L _ IEThingAbs{}) = l1 + thingFolder (L _ IEThingAbs{}) l2 = l2 + thingFolder (L l (IEThingWith x wn _ items1)) (L _ (IEThingWith _ _ _ items2)) + = L l (IEThingWith x wn NoIEWildcard (items1 ++ items2)) + thingFolder _ _ = + error "thingFolder should be exhaustive because we have a guard above" + + +-- Builds a complete layout for the given located +-- list of LIEs. The layout provides two alternatives: +-- (item, item, ..., item) +-- ( item +-- , item +-- ... +-- , item +-- ) +-- If the llies contains comments the list will +-- always expand over multiple lines, even when empty: +-- () -- no comments +-- ( -- a comment +-- ) +layoutLLIEs + :: HasCallStack + => Bool + -> SortItemsFlag + -> LocatedL [LIE GhcPs] + -> ToBriDocM BriDocNumbered +layoutLLIEs enableSingleline shouldSort llies@(L epAnn lies) = do + let posOpen = obtainAnnPos epAnn AnnOpenP + let posClose = obtainAnnPos epAnn AnnCloseP + ieDs <- layoutAnnAndSepLLIEs shouldSort llies lies + let hasComments = hasAnyCommentsBelow llies + docOpen <- shareDoc $ docHandleComms posOpen docParenL + docClose <- shareDoc $ docHandleComms posClose docParenR + docHandleComms llies $ runFilteredAlternative $ case ieDs of + [] -> do + addAlternativeCond (not hasComments) $ docLit $ Text.pack "()" + addAlternativeCond hasComments $ docPar docOpen docClose + (ieDsH : ieDsT) -> do + addAlternativeCond (not hasComments && enableSingleline) + $ docSeq + $ [docOpen] + ++ (docForceSingleline <$> ieDs) + ++ [docClose] + addAlternative + $ docPar (docSetBaseY $ docSeq [docOpen, docSeparator, ieDsH]) + $ docLines + $ ieDsT + ++ [docClose] + +-- | Returns a "fingerprint string", not a full text representation, nor even +-- a source code representation of this syntax node. +-- Used for sorting, not for printing the formatter's output source code. +wrappedNameToText :: LIEWrappedName RdrName -> Text +wrappedNameToText = \case + L _ (IEName n ) -> lrdrNameToText n + L _ (IEPattern _loc n) -> lrdrNameToText n + L _ (IEType _loc n) -> lrdrNameToText n + +-- | Returns a "fingerprint string", not a full text representation, nor even +-- a source code representation of this syntax node. +-- Used for sorting, not for printing the formatter's output source code. +lieToText :: LIE GhcPs -> Text +lieToText = \case + L _ (IEVar _ wn ) -> wrappedNameToText wn + L _ (IEThingAbs _ wn ) -> wrappedNameToText wn + L _ (IEThingAll _ 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. + L _ (IEModuleContents _ n) -> moduleNameToText n + L _ IEGroup{} -> Text.pack "@IEGroup" + L _ IEDoc{} -> Text.pack "@IEDoc" + L _ IEDocNamed{} -> Text.pack "@IEDocNamed" + where + moduleNameToText :: LocatedA 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/ToBriDoc/Import.hs similarity index 79% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs rename to source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Import.hs index fc17cde..09f4070 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Import.hs @@ -1,19 +1,23 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Import where +-- TODO92 +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Language.Haskell.Brittany.Internal.ToBriDoc.Import where import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import GHC (GenLocated(L), Located, moduleNameString, unLoc) import GHC.Hs import GHC.Types.Basic +import GHC.Types.SourceText(SourceText(SourceText, NoSourceText), sl_st) import GHC.Unit.Types (IsBootInterface(..)) import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.ToBriDoc.IE import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Components.BriDoc @@ -23,11 +27,11 @@ prepPkg rawN = case rawN of -- This would be odd to encounter and the -- result will most certainly be wrong NoSourceText -> "" -prepModName :: Located e -> e +prepModName :: LocatedA e -> e prepModName = unLoc -layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered -layoutImport importD = case importD of +layoutImport :: LImportDecl GhcPs -> ToBriDocM BriDocNumbered +layoutImport ldecl@(L _ importD) = docHandleComms ldecl $ case importD of ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack importAsCol <- @@ -75,8 +79,12 @@ layoutImport importD = case importD of importHead = docSeq [importQualifiers, modNameD] bindingsD = case mllies of Nothing -> docEmpty - Just (_, llies) -> do - hasComments <- hasAnyCommentsBelow llies + Just (_, llies@(L llEpAnn lies)) -> do + let hasComments = hasAnyCommentsBelow llies + let posOpen = obtainAnnPos llEpAnn AnnOpenP + let posClose = obtainAnnPos llEpAnn AnnCloseP + docOpen <- shareDoc $ docHandleComms posOpen $ docParenLSep + docClose <- shareDoc $ docHandleComms posClose $ docParenR if compact then docAlt [ docSeq @@ -90,48 +98,48 @@ layoutImport importD = case importD of in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) ] else do - ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies - docWrapNodeRest llies - $ docEnsureIndent (BrIndentSpecial hidDocCol) + ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies lies + -- TODO92 docWrapNodeRest llies + docHandleComms llies $ docEnsureIndent (BrIndentSpecial hidDocCol) $ case ieDs of -- ..[hiding].( ) [] -> if hasComments then docPar (docSeq - [hidDoc, docParenLSep, docWrapNode llies docEmpty] + [hidDoc, docOpen, docEmpty] ) (docEnsureIndent (BrIndentSpecial hidDocColDiff) - docParenR + docClose ) else docSeq - [hidDoc, docParenLSep, docSeparator, docParenR] + [hidDoc, docOpen, docSeparator, docClose] -- ..[hiding].( b ) [ieD] -> runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq [ hidDoc - , docParenLSep + , docOpen , docForceSingleline ieD , docSeparator - , docParenR + , docClose ] addAlternative $ docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + (docSeq [hidDoc, docOpen, docNonBottomSpacing ieD]) (docEnsureIndent (BrIndentSpecial hidDocColDiff) - docParenR + docClose ) -- ..[hiding].( b -- , b' -- ) (ieD : ieDs') -> docPar - (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]] + (docSeq [hidDoc, docSetBaseY $ docSeq [docOpen, ieD]] ) (docEnsureIndent (BrIndentSpecial hidDocColDiff) $ docLines $ ieDs' - ++ [docParenR] + ++ [docClose] ) makeAsDoc asT = docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs new file mode 100644 index 0000000..2323cb0 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.ToBriDoc.Module where + +import qualified Data.Maybe +import qualified Data.Text as Text +import GHC ( ModuleName + , moduleNameString + , unLoc + ) +import GHC.Hs + +import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.ToBriDoc.IE +import Language.Haskell.Brittany.Internal.Types + + + +moduleNameExportBridoc + :: EpAnn AnnsModule + -> LocatedA ModuleName + -> Maybe (LocatedL [LIE GhcPs]) + -> ToBriDocM BriDocNumbered +moduleNameExportBridoc epAnn modName les = do + let posModule = obtainAnnPos epAnn AnnModule + let posWhere = obtainAnnPos epAnn AnnWhere + allowSingleLineExportList <- + mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack + let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les + -- the config should not prevent single-line layout when there is no + -- export list + let tn = Text.pack $ moduleNameString $ unLoc modName + docHandleComms epAnn $ docHandleComms posModule $ runFilteredAlternative $ do + addAlternativeCond allowSingleLine $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docForceSingleline $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True KeepItemsUnsorted x + , docSeparator + , docHandleComms posWhere $ docLit $ Text.pack "where" + ] + addAlternative $ docLines + [ docAddBaseY BrIndentRegular $ docPar + (docSeq + [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docSeq + [ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False KeepItemsUnsorted x + , docSeparator + , docHandleComms posWhere $ docLit $ Text.pack "where" + ] + ) + ] + diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Pattern.hs similarity index 85% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs rename to source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Pattern.hs index 773d993..db54e36 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Pattern.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Layouters.Pattern where +module Language.Haskell.Brittany.Internal.ToBriDoc.Pattern where import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq @@ -10,12 +10,12 @@ import GHC (GenLocated(L), ol_val) import GHC.Hs import qualified GHC.OldList as List import GHC.Types.Basic -import Language.Haskell.Brittany.Internal.LayouterBasics -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr +import Language.Haskell.Brittany.Internal.ToBriDoc.Type import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Components.BriDoc @@ -30,7 +30,7 @@ import Language.Haskell.Brittany.Internal.Types -- We will use `case .. of` as the imagined prefix to the examples used in -- the different cases below. layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) -layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of +layoutPat lpat@(L _ pat) = docHandleComms lpat $ case pat of WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" -- _ -> expr VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n @@ -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 -- TODO92 is it safe to ignore tyargs?? -- Abc a b c -> expr nameDoc <- lrdrNameToTextAnn lname argDocs <- layoutPat `mapM` args @@ -84,11 +84,11 @@ 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 - else Just <$> docSharedWrapper layoutPat fPat + else fmap Just $ shareDoc $ layoutPat fPat return (lrdrNameToText lnameF, fExpDoc) Seq.singleton <$> docSeq [ appSep $ docLit t @@ -111,11 +111,11 @@ 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 - else Just <$> docSharedWrapper layoutPat fPat + else Just <$> shareDoc (layoutPat fPat) return (lrdrNameToText lnameF, fExpDoc) Seq.singleton <$> docSeq [ appSep $ docLit t @@ -142,7 +142,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of SigPat _ pat1 (HsPS _ ty1) -> do -- i :: Int -> expr patDocs <- layoutPat pat1 - tyDoc <- docSharedWrapper layoutType ty1 + tyDoc <- shareDoc $ layoutType ty1 case Seq.viewr patDocs of Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd" xR Seq.:> xN -> do @@ -169,14 +169,23 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of LazyPat _ pat1 -> do -- ~nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "~") - NPat _ llit@(L _ ol) mNegative _ -> do + NPat _ _llit@(L _ ol) mNegative _ -> do -- -13 -> expr - litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol + -- TODO92 we had `docWrapNode llit` below, but I don't think that is + -- necessary/possible any longer.. + litDoc <- allocateNode $ overLitValBriDoc $ GHC.ol_val ol negDoc <- docLit $ Text.pack "-" pure $ case mNegative of Just{} -> Seq.fromList [negDoc, litDoc] Nothing -> Seq.singleton litDoc - + ViewPat epAnn pat1 pat2 -> do + pat1Doc <- docHandleComms epAnn $ layoutExpr pat1 + let arrowLoc = obtainAnnPos epAnn AnnRarrow + pat1DocC <- appSep $ pure pat1Doc + pat2Docs <- layoutPat pat2 + arrowDoc <- docHandleComms arrowLoc $ appSep $ docLitS "->" + pure $ pat1DocC Seq.<| arrowDoc Seq.<| pat2Docs + _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs similarity index 62% rename from source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs rename to source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs index 5ef19c7..f7fe21f 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs @@ -2,34 +2,36 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.Layouters.Stmt where +module Language.Haskell.Brittany.Internal.ToBriDoc.Stmt where -import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import GHC (GenLocated(L)) import GHC.Hs import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.ToBriDoc.Decl +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.ToBriDoc.Expr +import Language.Haskell.Brittany.Internal.ToBriDoc.Pattern import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Components.BriDoc -layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) +layoutStmt :: GuardLStmt GhcPs -> ToBriDocM BriDocNumbered layoutStmt lstmt@(L _ stmt) = do indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indentAmount :: Int <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - docWrapNode lstmt $ case stmt of - LastStmt _ body Nothing _ -> do - layoutExpr body - BindStmt _ lPat expr -> do + case stmt of + LastStmt NoExtField body Nothing _ -> do + -- at least the "|" of a monadcomprehension for _some_ reason + -- is connected to the _body_ of the "result" stmt. So we need + -- to docHandleListElemComms here.. + docHandleListElemComms layoutExpr body + BindStmt epAnn lPat expr -> docHandleComms epAnn $ do patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat - expDoc <- docSharedWrapper layoutExpr expr + expDoc <- shareDoc $ layoutExpr expr docAlt [ docCols ColBindStmt @@ -46,14 +48,14 @@ layoutStmt lstmt@(L _ stmt) = do $ docPar (docLit $ Text.pack "<-") (expDoc) ] ] - LetStmt _ binds -> do + LetStmt epAnn binds -> docHandleComms epAnn $ do let isFree = indentPolicy == IndentPolicyFree let indentFourPlus = indentAmount >= 4 layoutLocalBinds binds >>= \case Nothing -> docLit $ Text.pack "let" -- i just tested the above, and it is indeed allowed. heh. - Just [] -> docLit $ Text.pack "let" -- this probably never happens - Just [bindDoc] -> docAlt + Just (_, []) -> docLit $ Text.pack "let" -- this probably never happens + Just (_, [bindDoc]) -> docAlt [ -- let bind = expr docCols ColDoLet @@ -73,7 +75,7 @@ layoutStmt lstmt@(L _ stmt) = do (docLit $ Text.pack "let") (docSetBaseAndIndent $ return bindDoc) ] - Just bindDocs -> runFilteredAlternative $ do + Just (_, bindDocs) -> runFilteredAlternative $ do -- let aaa = expra -- bbb = exprb -- ccc = exprc @@ -94,23 +96,24 @@ layoutStmt lstmt@(L _ stmt) = do $ docPar (docLit $ Text.pack "let") (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do - -- rec stmt1 - -- stmt2 - -- stmt3 - addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq - [ docLit (Text.pack "rec") - , docSeparator - , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts - ] - -- rec - -- stmt1 - -- stmt2 - -- stmt3 - addAlternative $ docAddBaseY BrIndentRegular $ docPar - (docLit (Text.pack "rec")) - (docLines $ layoutStmt <$> stmts) - BodyStmt _ expr _ _ -> do - expDoc <- docSharedWrapper layoutExpr expr + RecStmt epAnn (L _ stmts) _ _ _ _ _ -> + docHandleComms epAnn $ runFilteredAlternative $ do + -- rec stmt1 + -- stmt2 + -- stmt3 + addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq + [ docLit (Text.pack "rec") + , docSeparator + , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts + ] + -- rec + -- stmt1 + -- stmt2 + -- stmt3 + addAlternative $ docAddBaseY BrIndentRegular $ docPar + (docLit (Text.pack "rec")) + (docLines $ layoutStmt <$> stmts) + BodyStmt NoExtField expr _ _ -> do + expDoc <- shareDoc $ layoutExpr expr docAddBaseY BrIndentRegular $ expDoc _ -> briDocByExactInlineOnly "some unknown statement" lstmt diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs-boot new file mode 100644 index 0000000..5e4694f --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs-boot @@ -0,0 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.ToBriDoc.Stmt where + +import GHC.Hs +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Components.BriDoc + + + +layoutStmt :: GuardLStmt GhcPs -> ToBriDocM BriDocNumbered diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs new file mode 100644 index 0000000..e982996 --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs @@ -0,0 +1,535 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.ToBriDoc.Type where + +import qualified Data.Text as Text +import GHC (GenLocated(L)) +import GHC.Hs +import GHC.Types.Var(Specificity) +import GHC.Types.SourceText(SourceText(SourceText, NoSourceText)) +import qualified GHC.OldList as List +import GHC.Types.Basic +import GHC.Utils.Outputable (ftext, showSDocUnsafe) +import Language.Haskell.Brittany.Internal.S3_ToBriDocTools +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.Utils + (FirstLastView(..), splitFirstLast) + + + +layoutSigType :: ToBriDoc HsSigType +-- TODO92 we ignore an ann here +layoutSigType (L _ (HsSig _ outerVarBind typ)) = case outerVarBind of + HsOuterImplicit _ -> layoutType typ + HsOuterExplicit _ bndrs -> do + parts <- splitHsForallTypeFromBinders (map withoutSpecificity bndrs) typ + joinSplitArrowType (hasAnyCommentsBelow typ) parts + +splitArrowType + :: LHsType GhcPs + -> ToBriDocM + (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)]) +splitArrowType ltype@(L _ typ) = case typ of + HsForAllTy NoExtField hsf typ1 -> + splitHsForallTypeFromBinders (getBinders hsf) typ1 + HsQualTy NoExtField ctxMay typ1 -> do + (innerHead, innerBody) <- splitArrowType typ1 + pure + $ ( do + cntxtDocs <- case ctxMay of + Nothing -> pure [] + Just (L _ ctxs) -> ctxs `forM` (shareDoc . layoutType) + case cntxtDocs of + [] -> docLit $ Text.pack "()" + [x] -> x + docs -> docAlt + [ let + open = docLit $ Text.pack "(" + close = docLit $ Text.pack ")" + list = + List.intersperse docCommaSep $ docForceSingleline <$> docs + in + docSeq ([open] ++ list ++ [close]) + , let open = docCols + ColTyOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ head docs + ] + close = docLit $ Text.pack ")" + list = List.tail docs <&> \cntxtDoc -> docCols + ColTyOpPrefix + [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc] + in docPar open $ docLines $ list ++ [close] + ] + , (("=>", innerHead) : innerBody) + ) + HsFunTy epAnn _ typ1 typ2 -> do + (typ1Doc, (innerHead, innerBody)) <- do + let + wrapper = case epAnn of + EpAnn _ AddSemiAnn{} _ -> + error "brittany internal error: HsFunTy EpAnn" + EpAnn _ AddCommaAnn{} _ -> + error "brittany internal error: HsFunTy EpAnn" + EpAnn _ AddVbarAnn{} _ -> + error "brittany internal error: HsFunTy EpAnn" + EpAnn _ (AddRarrowAnn loc) _ -> + docFlushCommsPost (Just $ epaLocationRealSrcSpanStart loc) + EpAnn _ AddRarrowAnnU{} _ -> + error "brittany internal error: HsFunTy EpAnn" + EpAnn _ AddLollyAnnU{} _ -> + error "brittany internal error: HsFunTy EpAnn" + EpAnnNotUsed -> id + typ1Doc <- docHandleComms epAnn $ wrapper $ layoutType typ1 + typ2Tuple <- splitArrowType typ2 + pure (typ1Doc, typ2Tuple) + pure $ (pure typ1Doc, ("->", innerHead) : innerBody) + _ -> pure (layoutType ltype, []) + +splitHsForallTypeFromBinders + :: [LHsTyVarBndr () GhcPs] + -> LHsType GhcPs + -> ToBriDocM + (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)]) +splitHsForallTypeFromBinders binders typ = do + (innerHead, innerBody) <- splitArrowType typ + pure + $ ( do + tyVarDocs <- layoutTyVarBndrs binders + docAlt + -- :: forall x + -- . x + [ let open = docLit $ Text.pack "forall" + in docSeq (open : processTyVarBndrsSingleline tyVarDocs) + -- :: forall + -- (x :: *) + -- . x + , docPar + (docLit (Text.pack "forall")) + (docLines $ tyVarDocs <&> \case + (tname, Nothing) -> + docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines + [ docCols ColTyOpPrefix [docParenLSep, docLit tname] + , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] + , docLit $ Text.pack ")" + ] + ) + ] + , (".", innerHead) : innerBody + ) + + +joinSplitArrowType + :: Bool + -> (ToBriDocM BriDocNumbered, [(String, ToBriDocM BriDocNumbered)]) + -> ToBriDocM BriDocNumbered +joinSplitArrowType hasComments (dHead, body) = + runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docForceSingleline $ docSeq $ dHead : join + [ [docSeparator, docLit (Text.pack prefix), docSeparator, doc] + | (prefix, doc) <- body + ] + addAlternative $ docPar (docSetBaseY dHead) $ docLines + [ docCols + ColTyOpPrefix + [ appSep $ docLit $ Text.pack $ if length prefix < 2 + then " " ++ prefix -- special case for "forall dot" + -- in multi-line layout case + else prefix + , docEnsureIndent (BrIndentSpecial (length prefix + 1)) doc + ] + | (prefix, doc) <- body + ] + +layoutType :: ToBriDoc HsType +layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of + -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" + HsTyVar epAnn promoted name -> docHandleComms epAnn $ do + t <- lrdrNameToTextAnnTypeEqualityIsSpecial name + case promoted of + IsPromoted -> docSeq [docSeparator, docTick, docHandleComms name $ docLit t] + NotPromoted -> docHandleComms name $ docLit t + HsForAllTy{} -> do + parts <- splitArrowType ltype + joinSplitArrowType (hasAnyCommentsBelow typ) parts + HsQualTy{} -> do + parts <- splitArrowType ltype + joinSplitArrowType (hasAnyCommentsBelow typ) parts + HsFunTy{} -> do + parts <- splitArrowType ltype + joinSplitArrowType (hasAnyCommentsBelow typ) parts + HsParTy epAnn typ1 -> docHandleComms epAnn $ do + let (wrapOpen, wrapClose) = case epAnn of + EpAnn _ (AnnParen _ spanOpen spanClose) _ -> + (docHandleComms spanOpen, docHandleComms spanClose) + EpAnnNotUsed -> (id, id) + typeDoc1 <- shareDoc $ layoutType typ1 + docAlt + [ docSeq + [ wrapOpen $ docLit $ Text.pack "(" + , docForceSingleline typeDoc1 + , wrapClose $ docLit $ Text.pack ")" + ] + , docPar + (docCols + ColTyOpPrefix + [ wrapOpen $ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ] + ) + (wrapClose $ docLit $ Text.pack ")") + ] + HsAppTy NoExtField typ1@(L _ HsAppTy{}) typ2 -> do + let + gather + :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) + gather list = \case + L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1 + final -> (final, list) + let (typHead, typRest) = gather [typ2] typ1 + docHead <- shareDoc $ layoutType typHead + docRest <- (shareDoc . layoutType) `mapM` typRest + docAlt + [ docSeq + $ docForceSingleline docHead + : (docRest >>= \d -> [docSeparator, docForceSingleline d]) + , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) + ] + HsAppTy NoExtField typ1 typ2 -> do + typeDoc1 <- shareDoc $ layoutType typ1 + typeDoc2 <- shareDoc $ layoutType typ2 + docAlt + [ docSeq + [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2] + , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) + ] + HsListTy epAnn typ1 -> docHandleComms epAnn $ do + let (wrapOpen, wrapClose) = case epAnn of + EpAnn _ (AnnParen _ spanOpen spanClose) _ -> + (docHandleComms spanOpen, docHandleComms spanClose) + EpAnnNotUsed -> (id, id) + typeDoc1 <- shareDoc $ layoutType typ1 + docAlt + [ docSeq + [ wrapOpen $ docLit $ Text.pack "[" + , docForceSingleline typeDoc1 + , wrapClose $ docLit $ Text.pack "]" + ] + , docPar + (docCols + ColTyOpPrefix + [ wrapOpen $ docLit $ Text.pack "[ " + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ] + ) + (wrapClose $ docLit $ Text.pack "]") + ] + HsTupleTy epAnn tupleSort typs -> docHandleComms epAnn $ case tupleSort of + HsUnboxedTuple -> unboxed + HsBoxedOrConstraintTuple -> simple + where + unboxed = if null typs + then error "brittany internal error: unboxed unit" + else docWith docParenHashLSep docParenHashRSep + simple = if null typs + then unitL + else docWith (docLit (Text.pack "(")) (docLit (Text.pack ")")) + unitL = docLit $ Text.pack "()" + AnnParen _ open close = anns epAnn + wrapStart = docHandleComms open + wrapEnd = docHandleComms close + docWith start end = do + typDocs <- typs `forM` \ty -> do + shareDoc $ docHandleListElemComms layoutType ty + let + line1 = docCols ColTyOpPrefix [wrapStart $ appSep start, head typDocs] + lines = + List.tail typDocs + <&> \d -> docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + commaDocs = List.intersperse docCommaSep (docForceSingleline <$> typDocs) + docAlt + [ docSeq + $ [wrapStart start] + ++ commaDocs + ++ [wrapEnd end] + , docPar + (docAddBaseY (BrIndentSpecial 2) line1) + (docLines $ lines ++ [wrapEnd end]) + ] + HsOpTy{} -> -- TODO + briDocByExactInlineOnly "HsOpTy{}" ltype + -- HsOpTy typ1 opName typ2 -> do + -- -- TODO: these need some proper fixing. precedences don't add up. + -- -- maybe the parser just returns some trivial right recursion + -- -- parse result for any type level operators. + -- -- need to check how things are handled on the expression level. + -- let opStr = lrdrNameToText opName + -- let opLen = Text.length opStr + -- layouter1@(Layouter desc1 _ _) <- layoutType typ1 + -- layouter2@(Layouter desc2 _ _) <- layoutType typ2 + -- let line = do -- Maybe + -- l1 <- _ldesc_line desc1 + -- l2 <- _ldesc_line desc2 + -- let len1 = _lColumns_min l1 + -- let len2 = _lColumns_min l2 + -- let len = 2 + opLen + len1 + len2 + -- return $ LayoutColumns + -- { _lColumns_key = ColumnKeyUnique + -- , _lColumns_lengths = [len] + -- , _lColumns_min = len + -- } + -- let block = do -- Maybe + -- rol1 <- descToBlockStart desc1 + -- (min2, max2) <- descToMinMax (1+opLen) desc2 + -- let (minR, maxR) = case descToBlockMinMax desc1 of + -- Nothing -> (min2, max2) + -- Just (min1, max1) -> (max min1 min2, max max1 max2) + -- return $ BlockDesc + -- { _bdesc_blockStart = rol1 + -- , _bdesc_min = minR + -- , _bdesc_max = maxR + -- , _bdesc_opIndentFloatUp = Just (1+opLen) + -- } + -- return $ Layouter + -- { _layouter_desc = LayoutDesc + -- { _ldesc_line = line + -- , _ldesc_block = block + -- } + -- , _layouter_func = \params -> do + -- remaining <- getCurRemaining + -- let allowSameLine = _params_sepLines params /= SepLineTypeOp + -- case line of + -- Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do + -- applyLayouterRestore layouter1 defaultParams + -- layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " " + -- applyLayouterRestore layouter2 defaultParams + -- _ -> do + -- let upIndent = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params + -- let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2 + -- layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams + -- layoutWriteNewline + -- layoutWriteAppend $ opStr <> Text.pack " " + -- layoutWriteEnsureBlockPlusN downIndent + -- applyLayouterRestore layouter2 defaultParams + -- { _params_sepLines = SepLineTypeOp + -- , _params_opIndent = Just downIndent + -- } + -- , _layouter_ast = ltype + -- } + HsIParamTy epAnn (L _ (HsIPName ipName)) typ1 -> do + let posColon = obtainAnnPos epAnn AnnDcolon + typeDoc1 <- shareDoc $ layoutType typ1 + docHandleComms epAnn $ docAlt + [ docSeq + [ docLitS $ "?" ++ showSDocUnsafe (ftext ipName) + , docHandleComms posColon $ docLitS "::" + , docForceSingleline typeDoc1 + ] + , docPar + (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))) + (docCols + ColTyOpPrefix + [ docHandleComms posColon $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 2) typeDoc1 + ] + ) + ] + -- TODO: test KindSig + HsKindSig epAnn typ1 kind1 -> do + let posColon = obtainAnnPos epAnn AnnDcolon + typeDoc1 <- shareDoc $ layoutType typ1 + kindDoc1 <- shareDoc $ layoutType kind1 + docAlt + [ docSeq + [ docForceSingleline typeDoc1 + , docSeparator + , docHandleComms posColon $ docLit $ Text.pack "::" + , docSeparator + , docForceSingleline kindDoc1 + ] + , docPar + typeDoc1 + (docCols + ColTyOpPrefix + [ docHandleComms posColon $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) kindDoc1 + ] + ) + ] + HsBangTy{} -> -- TODO + briDocByExactInlineOnly "HsBangTy{}" ltype + -- HsBangTy bang typ1 -> do + -- let bangStr = case bang of + -- HsSrcBang _ unpackness strictness -> + -- (++) + -- (case unpackness of + -- SrcUnpack -> "{-# UNPACK #-} " + -- SrcNoUnpack -> "{-# NOUNPACK #-} " + -- NoSrcUnpack -> "" + -- ) + -- (case strictness of + -- SrcLazy -> "~" + -- SrcStrict -> "!" + -- NoSrcStrict -> "" + -- ) + -- let bangLen = length bangStr + -- layouter@(Layouter desc _ _) <- layoutType typ1 + -- let line = do -- Maybe + -- l <- _ldesc_line desc + -- let len = bangLen + _lColumns_min l + -- return $ LayoutColumns + -- { _lColumns_key = ColumnKeyUnique + -- , _lColumns_lengths = [len] + -- , _lColumns_min = len + -- } + -- let block = do -- Maybe + -- rol <- descToBlockStart desc + -- (minR,maxR) <- descToBlockMinMax desc + -- return $ BlockDesc + -- { _bdesc_blockStart = rol + -- , _bdesc_min = minR + -- , _bdesc_max = maxR + -- , _bdesc_opIndentFloatUp = Nothing + -- } + -- return $ Layouter + -- { _layouter_desc = LayoutDesc + -- { _ldesc_line = line + -- , _ldesc_block = block + -- } + -- , _layouter_func = \_params -> do + -- remaining <- getCurRemaining + -- case line of + -- Just (LayoutColumns _ _ m) | m <= remaining -> do + -- layoutWriteAppend $ Text.pack $ bangStr + -- applyLayouterRestore layouter defaultParams + -- _ -> do + -- layoutWriteAppend $ Text.pack $ bangStr + -- layoutWritePostCommentsRestore ltype + -- applyLayouterRestore layouter defaultParams + -- , _layouter_ast = ltype + -- } + HsSpliceTy{} -> -- TODO + briDocByExactInlineOnly "HsSpliceTy{}" ltype + HsDocTy{} -> -- TODO + briDocByExactInlineOnly "HsDocTy{}" ltype + HsRecTy{} -> -- TODO + briDocByExactInlineOnly "HsRecTy{}" ltype + HsExplicitListTy epAnn _ typs -> docHandleComms epAnn $ do + typDocs <- typs `forM` (shareDoc . docHandleListElemComms layoutType) + let hasComments = hasAnyCommentsBelow ltype + let specialCommaSep = appSep $ docLit $ Text.pack " ," + docAlt + [ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) + ++ [docLit $ Text.pack "]"] + , case splitFirstLast typDocs of + FirstLastEmpty -> docSeq + [ docLit $ Text.pack "'[]" -- TODO92 comments AnnOpenS + ] + FirstLastSingleton e -> docAlt + [ docSeq + [ docLit $ Text.pack "'[" + , docForceSingleline e -- TODO92 comments AnnOpenS + , docLit $ Text.pack "]" + ] + , docSetBaseY $ docLines + [ docSeq + [ docLit $ Text.pack "'[" + , docSeparator + , docSetBaseY $ e -- TODO92 comments AnnOpenS + ] + , docLit $ Text.pack " ]" + ] + ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse + specialCommaSep + (docForceSingleline + <$> (e1 : ems ++ [eN]) -- TODO92 comments AnnOpenS + ) + ++ [docLit $ Text.pack " ]"] + addAlternative + $ let + start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1] + linesM = ems <&> \d -> docCols ColList [specialCommaSep, d] + lineN = docCols + ColList + [specialCommaSep, eN] -- TODO92 comments AnnOpenS + end = docLit $ Text.pack " ]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ] + HsExplicitTupleTy{} -> -- TODO + briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype + HsTyLit _ lit -> case lit of + HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext + HsNumTy NoSourceText _ -> + error "overLitValBriDoc: literal with no SourceText" + HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext + HsStrTy NoSourceText _ -> + error "overLitValBriDoc: literal with no SourceText" + HsCharTy (SourceText srctext) _ -> docLit $ Text.pack srctext + HsCharTy NoSourceText _ -> + error "overLitValBriDoc: literal with no SourceText" + HsWildCardTy _ -> docLit $ Text.pack "_" + HsSumTy{} -> -- TODO + briDocByExactInlineOnly "HsSumTy{}" ltype + HsStarTy _ isUnicode -> do + if isUnicode + then docLit $ Text.pack "\x2605" -- Unicode star + else docLit $ Text.pack "*" + XHsType{} -> error "brittany internal error: XHsType" + HsAppKindTy _ ty kind -> do + t <- shareDoc $ layoutType ty + k <- shareDoc $ layoutType kind + docAlt + [ docSeq + [ docForceSingleline t + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline k + ] + , docPar t (docSeq [docLit $ Text.pack "@", k]) + ] + + +layoutTyVarBndrs + :: [LHsTyVarBndr () GhcPs] + -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] +layoutTyVarBndrs = mapM $ \case + (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar _ _ lrdrName kind)) -> do + d <- shareDoc $ layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + +-- there is no specific reason this returns a list instead of a single +-- BriDoc node. +processTyVarBndrsSingleline + :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered] +processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case + (tname, Nothing) -> [docSeparator, docLit tname] + (tname, Just doc) -> + [ docSeparator + , docLit $ Text.pack "(" <> tname <> Text.pack " :: " + , docForceSingleline $ doc + , docLit $ Text.pack ")" + ] + +getBinders :: HsForAllTelescope GhcPs -> [LHsTyVarBndr () GhcPs] +getBinders x = case x of + HsForAllVis _ b -> b + HsForAllInvis _ b -> fmap withoutSpecificity b + +withoutSpecificity :: LHsTyVarBndr GHC.Types.Var.Specificity GhcPs -> LHsTyVarBndr () GhcPs +withoutSpecificity = fmap $ \case + UserTyVar a _ c -> UserTyVar a () c + KindedTyVar a _ c d -> KindedTyVar a () c d diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs similarity index 93% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs index 5cca1ca..7624be1 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs @@ -1,29 +1,55 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Language.Haskell.Brittany.Internal.Transformations.Alt where +module Language.Haskell.Brittany.Internal.Transformations.T1_Alt where import qualified Control.Monad.Memo as Memo import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import Data.HList.ContainsType import qualified Data.List.Extra -import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified GHC.OldList as List +import qualified Data.Strict.Maybe as Strict + import Language.Haskell.Brittany.Internal.Config.Types 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.Brittany.Internal.Components.BriDoc +-- import Language.Haskell.Brittany.Internal.Utils +data VerticalSpacingPar + = VerticalSpacingParNone -- no indented lines + | VerticalSpacingParSome Int -- indented lines, requiring this much + -- vertical space at most + | VerticalSpacingParAlways Int -- indented lines, requiring this much + -- vertical space at most, but should + -- be considered as having space for + -- any spacing validity check. + -- TODO: it might be wrong not to extend "always" to the none case, i.e. + -- we might get better properties of spacing operators by having a + -- product like (Normal|Always, None|Some Int). + deriving (Eq, Show) + +data VerticalSpacing + = VerticalSpacing + { _vs_sameLine :: !Int + , _vs_paragraph :: !VerticalSpacingPar + , _vs_parFlag :: !Bool + } + deriving (Eq, Show) + +newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) + deriving (Functor, Applicative, Monad, Show, Alternative) + +pattern LineModeValid :: forall t. t -> LineModeValidity t +pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t +pattern LineModeInvalid :: forall t. LineModeValidity t +pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t + data AltCurPos = AltCurPos { _acp_line :: Int -- chars in the current line , _acp_indent :: Int -- current indentation level @@ -108,7 +134,7 @@ transformAlts = -- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd -- BDExternal k ks c t -> return $ BDFExternal k ks c t -- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd - -- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd + -- BDAnnotationPost annKey bd -> BDFAnnotationPost annKey <$> go bd -- BDLines lines -> BDFLines <$> go `mapM` lines -- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd -- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd @@ -267,18 +293,18 @@ transformAlts = return $ x BDFExternal{} -> processSpacingSimple bdX $> bdX BDFPlain{} -> processSpacingSimple bdX $> bdX - BDFAnnotationPrior annKey bd -> do - acp <- mGet - mSet - $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - bd' <- rec bd - return $ reWrap $ BDFAnnotationPrior annKey bd' - BDFAnnotationRest annKey bd -> - reWrap . BDFAnnotationRest annKey <$> rec bd - BDFAnnotationKW annKey kw bd -> - reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw b bd -> - reWrap . BDFMoveToKWDP annKey kw b <$> rec bd + BDFQueueComments comms bd -> + reWrap . BDFQueueComments comms <$> rec bd + BDFFlushCommentsPrior loc bd -> + -- TODO92 for AnnotationPrior we had this here: + -- > acp <- mGet + -- > mSet + -- > $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + -- > bd' <- rec bd + -- not sure if the lineModeDecay is relevant any longer though.. + reWrap . BDFFlushCommentsPrior loc <$> rec bd + BDFFlushCommentsPost loc bd -> + reWrap . BDFFlushCommentsPost loc <$> rec bd BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. BDFLines (l : lr) -> do ind <- _acp_indent <$> mGet @@ -456,21 +482,21 @@ getSpacing !bridoc = rec bridoc VerticalSpacingParNone -> mVs _ -> LineModeInvalid BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of + BDFExternal _ txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False _ -> VerticalSpacing 999 VerticalSpacingParNone False BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False _ -> VerticalSpacing 999 VerticalSpacingParNone False - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd + BDFQueueComments _comms bd -> rec bd + BDFFlushCommentsPrior _loc bd -> rec bd + BDFFlushCommentsPost _loc bd -> rec bd BDFLines [] -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLines ls@(_ : _) -> do - lSps <- rec `mapM` ls - let (mVs : _) = lSps -- separated into let to avoid MonadFail + BDFLines (l1 : lR) -> do + mVs <- rec l1 + mVRs <- rec `mapM` lR + let lSps = mVs : mVRs return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False | VerticalSpacing lsp _ _ <- mVs @@ -751,7 +777,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc mVs <- filterAndLimit <$> rec bd return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt | [t] <- Text.lines txt -> + BDFExternal _ txt | [t] <- Text.lines txt -> return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout -- this. @@ -764,10 +790,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc VerticalSpacing (Text.length t1) (VerticalSpacingParAlways 0) True | allowHangingQuasiQuotes ] - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd + BDFQueueComments _comms bd -> rec bd + BDFFlushCommentsPrior _loc bd -> rec bd + BDFFlushCommentsPost _loc bd -> rec bd BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDFLines ls@(_ : _) -> do -- we simply assume that lines is only used "properly", i.e. in diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs similarity index 55% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs index 919decf..470cea8 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs @@ -1,14 +1,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Floating where +module Language.Haskell.Brittany.Internal.Transformations.T2_Floating where import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified GHC.OldList as List 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.Brittany.Internal.Components.BriDoc @@ -29,68 +27,48 @@ transformSimplifyFloating = stepBO .> stepFull -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence -- the push/pop cases would need to be copied over where - descendPrior = transformDownMay $ \case + descendCommsPrior = transformDownMay $ \case -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x - BDAnnotationPrior annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationPrior annKey1 x + BDFlushCommentsPrior loc1 (BDFlushCommentsPrior loc2 x) -> + Just $ BDFlushCommentsPrior (max loc1 loc2) x + BDFlushCommentsPrior loc1 (BDPar ind line indented) -> + Just $ BDPar ind (BDFlushCommentsPrior loc1 line) indented + BDFlushCommentsPrior loc1 (BDSeq (l : lr)) -> + Just $ BDSeq (BDFlushCommentsPrior loc1 l : lr) + BDFlushCommentsPrior loc1 (BDLines (l : lr)) -> + Just $ BDLines (BDFlushCommentsPrior loc1 l : lr) + BDFlushCommentsPrior loc1 (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDFlushCommentsPrior loc1 l : lr) + BDFlushCommentsPrior loc1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDFlushCommentsPrior loc1 x + BDFlushCommentsPrior loc1 (BDDebug s x) -> + Just $ BDDebug s $ BDFlushCommentsPrior loc1 x _ -> Nothing - descendRest = transformDownMay $ \case + descendCommsPost = transformDownMay $ \case -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> + BDFlushCommentsPost loc1 (BDFlushCommentsPost loc2 x) -> + Just $ BDFlushCommentsPost (max loc1 loc2) x + BDFlushCommentsPost loc1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDFlushCommentsPost loc1 indented + BDFlushCommentsPost loc1 (BDSeq list) -> Just $ BDSeq $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> + ++ [BDFlushCommentsPost loc1 $ List.last list] + BDFlushCommentsPost loc1 (BDLines list) -> Just $ BDLines $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> + ++ [BDFlushCommentsPost loc1 $ List.last list] + BDFlushCommentsPost loc1 (BDCols sig cols) -> Just $ BDCols sig $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationRest annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x - BDAnnotationRest annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationRest annKey1 x - _ -> Nothing - descendKW = transformDownMay $ \case - -- post floating in - BDAnnotationKW annKey1 kw (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationKW annKey1 kw $ List.last cols] - BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x - BDAnnotationKW annKey1 kw (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationKW annKey1 kw x + ++ [BDFlushCommentsPost loc1 $ List.last cols] + BDFlushCommentsPost loc1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDFlushCommentsPost loc1 x + BDFlushCommentsPost loc1 (BDDebug s x) -> + Just $ BDDebug s $ BDFlushCommentsPost loc1 x _ -> Nothing descendBYPush = transformDownMay $ \case BDBaseYPushCur (BDCols sig cols@(_ : _)) -> @@ -124,12 +102,12 @@ transformSimplifyFloating = stepBO .> stepFull -- merge AddIndent and Par BDAddBaseY ind1 (BDPar ind2 line indented) -> Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> - Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationRest annKey1 x) -> - Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> - Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) + BDAddBaseY ind (BDFlushCommentsPrior loc x) -> + Just $ BDFlushCommentsPrior loc (BDAddBaseY ind x) + BDAddBaseY ind (BDFlushCommentsPost loc x) -> + Just $ BDFlushCommentsPost loc (BDAddBaseY ind x) + BDAddBaseY ind (BDQueueComments comms x) -> + Just $ BDQueueComments comms (BDAddBaseY ind x) BDAddBaseY ind (BDSeq list) -> Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] BDAddBaseY _ lit@BDLit{} -> Just $ lit @@ -149,9 +127,9 @@ transformSimplifyFloating = stepBO .> stepFull transformUp f where f = \case - x@BDAnnotationPrior{} -> descendPrior x - x@BDAnnotationKW{} -> descendKW x - x@BDAnnotationRest{} -> descendRest x + BDSeq xs -> BDSeq (dropWhile (\case BDEmpty -> True; _ -> False) xs) + x@BDFlushCommentsPrior{} -> descendCommsPrior x + x@BDFlushCommentsPost{} -> descendCommsPost x x@BDAddBaseY{} -> descendAddB x x@BDBaseYPushCur{} -> descendBYPush x x@BDBaseYPop{} -> descendBYPop x @@ -160,6 +138,10 @@ transformSimplifyFloating = stepBO .> stepFull x -> x stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ Uniplate.rewrite $ \case + BDSeq (BDEmpty : x) -> Just (BDSeq x) + -- TODO92 This could be rewritten, so that we re-use the + -- (BriDoc -> Maybe Bridoc) part of the descend* functions instead of + -- copying them here (incompletely). BDAddBaseY BrIndentNone x -> Just $ x -- AddIndent floats into Lines. BDAddBaseY indent (BDLines lines) -> @@ -176,15 +158,6 @@ transformSimplifyFloating = stepBO .> stepFull BDAddBaseY ind (BDBaseYPushCur x) -> Just $ BDBaseYPushCur (BDAddBaseY ind x) BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr) -- EnsureIndent float-in -- BDEnsureIndent indent (BDCols sig (col:colr)) -> -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) @@ -192,22 +165,23 @@ transformSimplifyFloating = stepBO .> stepFull -- unaffected. -- BDEnsureIndent indent (BDLines lines) -> -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] + -- flush-prior floating in + BDFlushCommentsPrior loc (BDPar ind line indented) -> + Just $ BDPar ind (BDFlushCommentsPrior loc line) indented + BDFlushCommentsPrior loc (BDSeq (l : lr)) -> + Just $ BDSeq (BDFlushCommentsPrior loc l : lr) + BDFlushCommentsPrior loc (BDLines (l : lr)) -> + Just $ BDLines (BDFlushCommentsPrior loc l : lr) + BDFlushCommentsPrior loc (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDFlushCommentsPrior loc l : lr) + -- flush-post floating in + BDFlushCommentsPost comms1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDFlushCommentsPost comms1 indented + BDFlushCommentsPost loc (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] + BDFlushCommentsPost loc (BDLines list) -> Just + $ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] + BDFlushCommentsPost loc (BDCols sig list) -> Just + $ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T3_Par.hs similarity index 66% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/T3_Par.hs index 6fe374a..4054df4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T3_Par.hs @@ -1,11 +1,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Par where +module Language.Haskell.Brittany.Internal.Transformations.T3_Par where import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Components.BriDoc @@ -16,7 +15,12 @@ transformSimplifyPar = transformUp $ \case -- Just $ BDLines [line, indented] -- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 -> -- Just $ BDPar ind1 line (BDLines [p1, p2]) + + -- TODO92 is this still necessary? No tests fail, but maybe + -- performance gets worse. x@(BDPar _ (BDPar _ BDPar{} _) _) -> x + -- this is a combination of other transformations below, the + -- important one is the next one. BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) -> BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 (BDPar ind2 line p1) p2 -> @@ -29,13 +33,16 @@ transformSimplifyPar = transformUp $ \case _ -> False ) lines - -> case go lines of + -> case lines >>= flattenToDocList of [] -> BDEmpty [x] -> x xs -> BDLines xs where - go = (=<<) $ \case - BDLines l -> go l + flattenToDocList = \case + -- note that this is a transformUp, so we create the invariant that + -- BDLines does not contain BDEmpty or BDLines, but we may assume the + -- BDLines below are already flattened. + BDLines xs -> xs BDEmpty -> [] x -> [x] BDLines [] -> BDEmpty diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs similarity index 72% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs index 0d2231e..8c6cf50 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs @@ -1,12 +1,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Columns where +module Language.Haskell.Brittany.Internal.Transformations.T4_Columns where import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified GHC.OldList as List import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Components.BriDoc @@ -32,6 +32,8 @@ transformSimplifyColumns = Uniplate.rewrite $ \case | all (\case BDSeparator -> True + BDFlushCommentsPrior _ BDSeparator -> True + BDFlushCommentsPost _ BDSeparator -> True _ -> False ) rest @@ -47,41 +49,20 @@ transformSimplifyColumns = Uniplate.rewrite $ \case -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l x -> [x] - -- prior floating in - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) - -- post floating in - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationKW annKey1 kw $ List.last cols] + -- flush-prior floating in + BDFlushCommentsPrior loc (BDSeq (l : lr)) -> + Just $ BDSeq (BDFlushCommentsPrior loc l : lr) + BDFlushCommentsPrior loc (BDLines (l : lr)) -> + Just $ BDLines (BDFlushCommentsPrior loc l : lr) + BDFlushCommentsPrior loc (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDFlushCommentsPrior loc l : lr) + -- flush-post floating in + BDFlushCommentsPost loc (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] + BDFlushCommentsPost loc (BDLines list) -> Just + $ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] + BDFlushCommentsPost loc (BDCols sig list) -> Just + $ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] -- ensureIndent float-in -- not sure if the following rule is necessary; tests currently are -- unaffected. @@ -151,10 +132,9 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDExternal{} -> Nothing BDPlain{} -> Nothing BDLines{} -> Nothing - BDAnnotationPrior{} -> Nothing - BDAnnotationKW{} -> Nothing - BDAnnotationRest{} -> Nothing - BDMoveToKWDP{} -> Nothing + BDQueueComments{} -> Nothing + BDFlushCommentsPrior{} -> Nothing + BDFlushCommentsPost{} -> Nothing BDEnsureIndent{} -> Nothing BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T5_Indent.hs similarity index 79% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs rename to source/library/Language/Haskell/Brittany/Internal/Transformations/T5_Indent.hs index 613c5f0..3f1ee73 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T5_Indent.hs @@ -1,12 +1,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.Transformations.Indent where +module Language.Haskell.Brittany.Internal.Transformations.T5_Indent where import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified GHC.OldList as List import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Components.BriDoc @@ -16,6 +16,7 @@ import Language.Haskell.Brittany.Internal.Types transformSimplifyIndent :: BriDoc -> BriDoc transformSimplifyIndent = Uniplate.rewrite $ \case BDPar ind (BDLines lines) indented -> + -- error "foo" Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented] BDPar ind (BDCols sig cols) indented -> Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented]) @@ -39,12 +40,10 @@ transformSimplifyIndent = Uniplate.rewrite $ \case BDLines l -> l x -> [x] BDLines [l] -> Just l - BDAddBaseY i (BDAnnotationPrior k x) -> - Just $ BDAnnotationPrior k (BDAddBaseY i x) - BDAddBaseY i (BDAnnotationKW k kw x) -> - Just $ BDAnnotationKW k kw (BDAddBaseY i x) - BDAddBaseY i (BDAnnotationRest k x) -> - Just $ BDAnnotationRest k (BDAddBaseY i x) + BDAddBaseY i (BDFlushCommentsPrior c x) -> + Just $ BDFlushCommentsPrior c (BDAddBaseY i x) + BDAddBaseY i (BDFlushCommentsPost c x) -> + Just $ BDFlushCommentsPost c (BDAddBaseY i x) BDAddBaseY i (BDSeq l) -> Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l] BDAddBaseY i (BDCols sig l) -> diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index 6a2c8af..c6b7765 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -1,118 +1,197 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingStrategies #-} module Language.Haskell.Brittany.Internal.Types where import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Data.Data -import Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Kind as Kind -import qualified Data.Strict.Maybe as Strict +import qualified GHC.OldList as List import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) +import GHC ( Anno + , DeltaPos + ( DifferentLine + , SameLine + ) + , EpaCommentTok + , LHsDecl + , ParsedSource + , XRec + , LImportDecl + ) +import GHC.Utils.Outputable(Outputable) 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 qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Types (Anns) -import qualified Safe +import Language.Haskell.Brittany.Internal.Components.BriDoc -data PerItemConfig = PerItemConfig - { _icd_perBinding :: Map String (CConfig Maybe) - , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) - } - deriving Data.Data.Data -type PPM = MultiRWSS.MultiRWS - '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] - '[Text.Builder.Builder, [BrittanyError], Seq String] - '[] +-- brittany-internal error type, part of the brittany library public interface. +data BrittanyError + = ErrorInput String + -- ^ parsing failed + | ErrorUnusedComment String + -- ^ internal error: some comment went missing. Since ghc-9.2 the one below + -- is used for missing comments while layouting top-level decls. + -- You might still get thse for import/export statement comments (right?) + -- (TODO this needs updating once the ghc-9.2 implementation is complete) + | ErrorUnusedComments (LHsDecl GhcPs) Int Int + -- ^ internal error: some comments went missing while layouting the + -- specified top-level declaration (module child). + | ErrorMacroConfig String String + -- ^ in-source config string parsing error; first argument is the parser + -- output and second the corresponding, ill-formed input. + | LayoutWarning String + -- ^ some warning + | forall ast . (Data.Data.Data (XRec GhcPs ast), Outputable (Anno ast)) => ErrorUnknownNode String (XRec GhcPs ast) + -- ^ internal error: pretty-printing is not implemented for type of node + -- in the syntax-tree + | ErrorOutputCheck + -- ^ checking the output for syntactic validity failed + + +-- General-purpose structure. Church-encoded version of a list that has a +-- parameterized final value. +-- That is: +-- 1) Start with a dumb old `List a = Cons a (List a) | Empty` +-- 2) Parameterize the empty `ListEnd a b = Cons a (List a b) | Final b` +-- 3) Church-encode the result for good measure (and better perf?) +-- +-- This is similar to a Writer Monad, and maybe it already exists somewhere, +-- but it feels like a) This abstraction doesn't leak by itself b) you can +-- trivially turn it into something that streams into some "consuming" monadic +-- action c) it is _simple_, doesn't require a monoid or anything without +-- losing anything. +data FinalList a b = FinalList (forall r . (a -> r -> r) -> (b -> r) -> r) + +finalPure :: b -> FinalList a b +finalPure b = FinalList $ \_ f -> f b +finalCons :: a -> FinalList a b -> FinalList a b +finalCons a (FinalList l) = FinalList (\f1 f2 -> f1 a $ l f1 f2) +finalBind :: FinalList a b -> (b -> FinalList a b) -> FinalList a b +finalBind (FinalList l) f = + FinalList (\f1 f2 -> l f1 (\b -> let FinalList c = (f b) in c f1 f2)) +_finalSingleton :: a -> b -> FinalList a b +_finalSingleton a b = FinalList (\f1 f2 -> f1 a (f2 b)) +_finalLMap :: (a -> a') -> FinalList a b -> FinalList a' b +_finalLMap f (FinalList l) = FinalList (\f1 f2 -> l (f1 . f) f2) +_finalRMap :: (b -> b') -> FinalList a b -> FinalList a b' +_finalRMap f (FinalList l) = FinalList (\f1 f2 -> l f1 (f2 . f)) +finalYield :: a -> FinalList a () +finalYield x = FinalList $ \f1 f2 -> f1 x (f2 ()) +finalToList_ :: FinalList a () -> [a] +finalToList_ (FinalList l) = l (:) (\() -> []) +finalToList :: FinalList a b -> ([a], b) +finalToList (FinalList l) = l (\x (a, b) -> (x:a, b)) (\b -> ([], b)) + +instance Functor (FinalList a) where + fmap = _finalRMap + +instance Applicative (FinalList a) where + pure = finalPure + FinalList ff <*> FinalList fx = + FinalList $ \f1 f2 -> ff f1 (\g -> fx f1 (f2 . g)) + +instance Monad (FinalList a) where + FinalList fx >>= f = + FinalList $ \f1 f2 -> fx f1 (\x -> let FinalList c = f x in c f1 f2) + +-- After parsing, we split a module into a series of these so that +-- we can process them independently. +data ModuleElement + = MEExactModuleHead ParsedSource + -- ^ When not pretty-printing the module head: + -- module name, imports, exports, but without decls. + -- Could split out the relevant fields, but we need the full (with decls + -- set to []) for exactprinting anyway. + | MEPrettyModuleHead ParsedSource + -- ^ Similar, but when pretty-printing the head: + -- This encompasses just the module name, the exports and + -- the where keyword. Everything else (including comments in + -- various places) get + | MEImportDecl (LImportDecl GhcPs) [(Int, EpaCommentTok)] + -- ^ an import decl, only occurs if pretty-printing the module head. + | MEDecl (LHsDecl GhcPs) [(Int, EpaCommentTok)] + -- ^ a top-level declaration + | MEComment (Int, EpaCommentTok) + -- ^ a top-level comment, i.e. a comment located between top-level elements + -- (and not associated to some nested node, which might in theory happen). + -- The Int carries the indentation of the comment. + | MEWhitespace DeltaPos + -- ^ Empty lines around decls. + + +newtype TraceFunc = TraceFunc { useTraceFunc :: String -> IO () } type PPMLocal = MultiRWSS.MultiRWS - '[Config, ExactPrint.Anns] + '[Config, TraceFunc] '[Text.Builder.Builder, [BrittanyError], Seq String] - '[] + '[CommentCounter] -newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) +-- type LayoutConstraints m +-- = ( MonadMultiReader Config m +-- , MonadMultiWriter TextL.Builder.Builder m +-- , MonadMultiWriter (Seq String) m +-- , MonadMultiState LayoutState m +-- , MonadMultiState CommentCounter m +-- , MonadMultiState [GHC.LEpaComment] m +-- ) -data LayoutState = LayoutState - { _lstate_baseYs :: [Int] - -- ^ stack of number of current indentation columns - -- (not number of indentations). - , _lstate_curYOrAddNewline :: Either Int Int - -- ^ Either: - -- 1) number of chars in the current line. - -- 2) number of newlines to be inserted before inserting any - -- non-space elements. - , _lstate_indLevels :: [Int] - -- ^ stack of current indentation levels. set for - -- any layout-affected elements such as - -- let/do/case/where elements. - -- The main purpose of this member is to - -- properly align comments, as their - -- annotation positions are relative to the - -- current layout indentation level. - , _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for - -- properly treating cases where comments - -- on the first indented element have an - -- annotation offset relative to the last - -- non-indented element, which is confusing. - , _lstate_comments :: Anns - , _lstate_commentCol :: Maybe Int -- this communicates two things: - -- firstly, that cursor is currently - -- at the end of a comment (so needs - -- newline before any actual content). - -- secondly, the column at which - -- insertion of comments started. - , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone - -- writes (any non-spaces) in the - -- current line. - -- , _lstate_isNewline :: NewLineState - -- -- captures if the layouter currently is in a new line, i.e. if the - -- -- current line only contains (indentation) spaces. - -- this is mostly superseeded by curYOrAddNewline, iirc. - , _lstate_commentNewlines :: Int -- number of newlines inserted due to - -- move-to-DP at a start of a comment. - -- Necessary because some keyword DPs - -- are relative to the last non-comment - -- entity (for some reason). - -- This is not very strictly reset to 0, - -- so we might in some cases get "artifacts" - -- from previous document elements. - -- But the worst effect at the moment would - -- be that we introduce less newlines on - -- moveToKWDP, which seems harmless enough. - } +ppmMoveToExactLoc + :: MonadMultiWriter Text.Builder.Builder m => GHC.DeltaPos -> m () +ppmMoveToExactLoc = \case + SameLine c -> + mTell $ Text.Builder.fromString (List.replicate c ' ') + DifferentLine l c -> mTell $ Text.Builder.fromString + (List.replicate l '\n' ++ List.replicate (c - 1) ' ') -lstate_baseY :: LayoutState -> Int -lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs -lstate_indLevel :: LayoutState -> Int -lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels +type ToBriDocM = MultiRWSS.MultiRWS + '[Config, TraceFunc] -- reader + '[[BrittanyError], Seq String] -- writer + '[NodeAllocIndex, CommentCounter] -- state + +type ToBriDoc (sym :: Kind.Type -> Kind.Type) = XRec GhcPs (sym GhcPs) -> ToBriDocM BriDocNumbered +type ToBriDoc' sym = XRec GhcPs (sym GhcPs) -> ToBriDocM BriDocNumbered +type ToBriDocC sym c = XRec GhcPs (sym GhcPs) -> ToBriDocM c +type ToBriDocP sym = sym GhcPs -> ToBriDocM BriDocNumbered + + +newtype CommentCounter = CommentCounter { unCommentCounter :: Int } + deriving (Eq, Ord, Num, Data.Data.Data) + deriving newtype (Show) + +-- Why does this live in types? As long as it does, you _have_ +-- to remember to call `docFlushRemaining` in combination with this! +briDocMToPPM :: ToBriDocM a -> PPMLocal (a, Int) +briDocMToPPM m = do + readers <- MultiRWSS.mGetRawR + initCount <- MultiRWSS.mGet @CommentCounter + let + (((x, errs), debugs), commentCount) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStateAS initCount + $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) + $ MultiRWSS.withMultiReaders readers + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ m + mTell debugs + mTell errs + mSet commentCount + pure (x, length errs) + + + +newtype NodeAllocIndex = NodeAllocIndex Int + --- evil, incomplete Show instance; only for debugging. -instance Show LayoutState where - show state = - "LayoutState" - ++ "{baseYs=" ++ show (_lstate_baseYs state) - ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) - ++ ",indLevels=" ++ show (_lstate_indLevels state) - ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) - ++ ",commentCol=" ++ show (_lstate_commentCol state) - ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) - ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) - ++ "}" -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a -- -- newline, really. by special-casing @@ -134,330 +213,13 @@ instance Show LayoutState where -- , _lsettings_initialAnns :: ExactPrint.Anns -- } -data BrittanyError - = ErrorInput String - -- ^ parsing failed - | ErrorUnusedComment String - -- ^ internal error: some comment went missing - | ErrorMacroConfig String String - -- ^ in-source config string parsing error; first argument is the parser - -- output and second the corresponding, ill-formed input. - | LayoutWarning String - -- ^ some warning - | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast) - -- ^ internal error: pretty-printing is not implemented for type of node - -- in the syntax-tree - | ErrorOutputCheck - -- ^ checking the output for syntactic validity failed -data BriSpacing = BriSpacing - { _bs_spacePastLineIndent :: Int -- space in the current, - -- potentially somewhat filled - -- line. - , _bs_spacePastIndent :: Int -- space required in properly - -- indented blocks below the - -- current line. - } - -data ColSig - = ColTyOpPrefix - -- any prefixed operator/paren/"::"/.. - -- expected to have exactly two colums. - -- e.g. ":: foo" - -- 111222 - -- "-> bar asd asd" - -- 11122222222222 - | ColPatternsFuncPrefix - -- pattern-part of the lhs, e.g. "func (foo a b) c _". - -- Has variable number of columns depending on the number of patterns. - | ColPatternsFuncInfix - -- pattern-part of the lhs, e.g. "Foo a <> Foo b". - -- Has variable number of columns depending on the number of patterns. - | ColPatterns - | ColCasePattern - | ColBindingLine (Maybe Text) - -- e.g. "func pat pat = expr" - -- 1111111111111222222 - -- or "pat | stmt -> expr" - -- 111111111112222222 - -- expected to have exactly two columns. - | ColGuard - -- e.g. "func pat pat | cond = ..." - -- 11111111111112222222 - -- or "pat | cond1, cond2 -> ..." - -- 1111222222222222222 - -- expected to have exactly two columns - | ColGuardedBody - -- e.g. | foofoo = 1 - -- | bar = 2 - -- 111111111222 - -- expected to have exactly two columns - | ColBindStmt - | ColDoLet -- the non-indented variant - | ColRec - | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? - | ColRecDecl - | ColListComp - | ColList - | ColApp Text - | ColTuple - | ColTuples - | ColOpPrefix -- merge with ColList ? other stuff? - | ColImport - - -- TODO - deriving (Eq, Ord, Data.Data.Data, Show) - -data BrIndent = BrIndentNone - | BrIndentRegular - | BrIndentSpecial Int - deriving (Eq, Ord, Data.Data.Data, Show) - -type ToBriDocM = MultiRWSS.MultiRWS - '[Config, Anns] -- reader - '[[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 - -data DocMultiLine - = MultiLineNo - | MultiLinePossible - deriving (Eq) - --- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot --- of transformations on `BriDocF Identity`s and it is really annoying to --- `Identity`/`runIdentity` everywhere. -data BriDoc - = -- BDWrapAnnKey AnnKey BriDoc - BDEmpty - | BDLit !Text - | BDSeq [BriDoc] -- elements other than the last should - -- not contains BDPars. - | BDCols ColSig [BriDoc] -- elements other than the last - -- should not contains BDPars - | BDSeparator -- semantically, space-unless-at-end-of-line. - | BDAddBaseY BrIndent BriDoc - | BDBaseYPushCur BriDoc - | BDBaseYPop BriDoc - | BDIndentLevelPushCur BriDoc - | BDIndentLevelPop BriDoc - | BDPar - { _bdpar_indent :: BrIndent - , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars - , _bdpar_indented :: BriDoc - } - -- | BDAddIndent BrIndent (BriDocF f) - -- | BDNewline - | BDAlt [BriDoc] - | BDForwardLineMode BriDoc - | BDExternal AnnKey - (Set AnnKey) -- set of annkeys contained within the node - -- to be printed via exactprint - Bool -- should print extra comment ? - Text - | BDPlain !Text -- used for QuasiQuotes, content can be multi-line - -- (contrast to BDLit) - | BDAnnotationPrior AnnKey BriDoc - | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc - | BDAnnotationRest AnnKey BriDoc - | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset - | BDLines [BriDoc] - | BDEnsureIndent BrIndent BriDoc - -- the following constructors are only relevant for the alt transformation - -- and are removed afterwards. They should never occur in any BriDoc - -- after the alt transformation. - | BDForceMultiline BriDoc - | BDForceSingleline BriDoc - | BDNonBottomSpacing Bool BriDoc - | BDSetParSpacing BriDoc - | BDForceParSpacing BriDoc - -- pseudo-deprecated - | BDDebug String BriDoc - deriving (Data.Data.Data, Eq, Ord) - -data BriDocF f - = -- BDWrapAnnKey AnnKey BriDoc - BDFEmpty - | BDFLit !Text - | BDFSeq [f (BriDocF f)] -- elements other than the last should - -- not contains BDPars. - | BDFCols ColSig [f (BriDocF f)] -- elements other than the last - -- should not contains BDPars - | BDFSeparator -- semantically, space-unless-at-end-of-line. - | BDFAddBaseY BrIndent (f (BriDocF f)) - | BDFBaseYPushCur (f (BriDocF f)) - | BDFBaseYPop (f (BriDocF f)) - | BDFIndentLevelPushCur (f (BriDocF f)) - | BDFIndentLevelPop (f (BriDocF f)) - | BDFPar - { _bdfpar_indent :: BrIndent - , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars - , _bdfpar_indented :: f (BriDocF f) - } - -- | BDAddIndent BrIndent (BriDocF f) - -- | BDNewline - | BDFAlt [f (BriDocF f)] - | BDFForwardLineMode (f (BriDocF f)) - | BDFExternal AnnKey - (Set AnnKey) -- set of annkeys contained within the node - -- to be printed via exactprint - Bool -- should print extra comment ? - Text - | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line - -- (contrast to BDLit) - | BDFAnnotationPrior AnnKey (f (BriDocF f)) - | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) - | BDFAnnotationRest AnnKey (f (BriDocF f)) - | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset - | BDFLines [(f (BriDocF f))] - | BDFEnsureIndent BrIndent (f (BriDocF f)) - | BDFForceMultiline (f (BriDocF f)) - | BDFForceSingleline (f (BriDocF f)) - | BDFNonBottomSpacing Bool (f (BriDocF f)) - | BDFSetParSpacing (f (BriDocF f)) - | BDFForceParSpacing (f (BriDocF f)) - | BDFDebug String (f (BriDocF f)) - --- deriving instance Data.Data.Data (BriDocF Identity) -deriving instance Data.Data.Data (BriDocF ((,) Int)) - -type BriDocFInt = BriDocF ((,) Int) -type BriDocNumbered = (Int, BriDocFInt) - -instance Uniplate.Uniplate BriDoc where - uniplate x@BDEmpty{} = plate x - uniplate x@BDLit{} = plate x - uniplate (BDSeq list ) = plate BDSeq ||* list - uniplate (BDCols sig list) = plate BDCols |- sig ||* list - uniplate x@BDSeparator = plate x - uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd - uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd - uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts ) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd - uniplate x@BDExternal{} = plate x - uniplate x@BDPlain{} = plate x - uniplate (BDAnnotationPrior annKey bd) = - plate BDAnnotationPrior |- annKey |* bd - uniplate (BDAnnotationKW annKey kw bd) = - plate BDAnnotationKW |- annKey |- kw |* bd - uniplate (BDAnnotationRest annKey bd) = - plate BDAnnotationRest |- annKey |* bd - uniplate (BDMoveToKWDP annKey kw b bd) = - plate BDMoveToKWDP |- annKey |- kw |- b |* bd - uniplate (BDLines lines ) = plate BDLines ||* lines - uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd - uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd - uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd - uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd - -newtype NodeAllocIndex = NodeAllocIndex Int - --- TODO: rename to "dropLabels" ? -unwrapBriDocNumbered :: BriDocNumbered -> BriDoc -unwrapBriDocNumbered tpl = case snd tpl of - BDFEmpty -> BDEmpty - BDFLit t -> BDLit t - BDFSeq list -> BDSeq $ rec <$> list - BDFCols sig list -> BDCols sig $ rec <$> list - BDFSeparator -> BDSeparator - BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd - BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd - BDFBaseYPop bd -> BDBaseYPop $ rec bd - BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd - BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd - BDFPar ind line indented -> BDPar ind (rec line) (rec indented) - BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen - BDFForwardLineMode bd -> BDForwardLineMode $ rec bd - BDFExternal k ks c t -> BDExternal k ks c t - BDFPlain t -> BDPlain t - BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd - BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd - BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd - BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd - BDFLines lines -> BDLines $ rec <$> lines - BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd - BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd - where rec = unwrapBriDocNumbered - -isNotEmpty :: BriDoc -> Bool -isNotEmpty BDEmpty = False -isNotEmpty _ = True - --- this might not work. is not used anywhere either. -briDocSeqSpine :: BriDoc -> () -briDocSeqSpine = \case - BDEmpty -> () - BDLit _t -> () - BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list - BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list - BDSeparator -> () - BDAddBaseY _ind bd -> briDocSeqSpine bd - BDBaseYPushCur bd -> briDocSeqSpine bd - BDBaseYPop bd -> briDocSeqSpine bd - BDIndentLevelPushCur bd -> briDocSeqSpine bd - BDIndentLevelPop bd -> briDocSeqSpine bd - BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented - BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts - BDForwardLineMode bd -> briDocSeqSpine bd - BDExternal{} -> () - BDPlain{} -> () - BDAnnotationPrior _annKey bd -> briDocSeqSpine bd - BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd - BDAnnotationRest _annKey bd -> briDocSeqSpine bd - BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd - BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines - BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing _ bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd - BDDebug _s bd -> briDocSeqSpine bd - -briDocForceSpine :: BriDoc -> BriDoc -briDocForceSpine bd = briDocSeqSpine bd `seq` bd - - -data VerticalSpacingPar - = VerticalSpacingParNone -- no indented lines - | VerticalSpacingParSome Int -- indented lines, requiring this much - -- vertical space at most - | VerticalSpacingParAlways Int -- indented lines, requiring this much - -- vertical space at most, but should - -- be considered as having space for - -- any spacing validity check. - -- TODO: it might be wrong not to extend "always" to the none case, i.e. - -- we might get better properties of spacing operators by having a - -- product like (Normal|Always, None|Some Int). - deriving (Eq, Show) - -data VerticalSpacing - = VerticalSpacing - { _vs_sameLine :: !Int - , _vs_paragraph :: !VerticalSpacingPar - , _vs_parFlag :: !Bool - } - deriving (Eq, Show) - -newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) - deriving (Functor, Applicative, Monad, Show, Alternative) - -pattern LineModeValid :: forall t. t -> LineModeValidity t -pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t -pattern LineModeInvalid :: forall t. LineModeValidity t -pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t +-- TODO92 is this old leftover, or useful future idea? +-- data BriSpacing = BriSpacing +-- { _bs_spacePastLineIndent :: Int -- space in the current, +-- -- potentially somewhat filled +-- -- line. +-- , _bs_spacePastIndent :: Int -- space required in properly +-- -- indented blocks below the +-- -- current line. +-- } diff --git a/source/library/Language/Haskell/Brittany/Internal/Util/AST.hs b/source/library/Language/Haskell/Brittany/Internal/Util/AST.hs new file mode 100644 index 0000000..9573c6b --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/Util/AST.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Language.Haskell.Brittany.Internal.Util.AST where + +import Language.Haskell.Brittany.Internal.Prelude + +import qualified Data.Text as Text +import GHC ( moduleName + , moduleNameString + , GenLocated(L) + ) +import qualified GHC +import GHC.Types.Name ( getOccString ) +import GHC.Types.Name.Occurrence ( occNameString + ) +import GHC.Types.Name.Reader ( RdrName + ( Exact + , Orig + , Qual + , Unqual + ) + ) + + + +rdrNameToText :: RdrName -> Text +-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr +rdrNameToText (Unqual occname) = Text.pack $ occNameString occname +rdrNameToText (Qual mname occname) = + Text.pack $ moduleNameString mname ++ "." ++ occNameString occname +rdrNameToText (Orig modul occname) = + Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname +rdrNameToText (Exact name) = Text.pack $ getOccString name + +getDeclBindingNames :: GHC.LHsDecl GhcPs -> [String] +getDeclBindingNames (L _ decl) = case decl of + GHC.SigD _ (GHC.TypeSig _ ns _) -> + ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) + GHC.ValD _ (GHC.FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] + _ -> [] diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs index b62028f..962c401 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -12,23 +12,23 @@ import qualified Data.Coerce import Data.Data import Data.Generics.Aliases import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified Data.Semigroup as Semigroup -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.OldList as List -import GHC.Types.Name.Occurrence as OccName (occNameString) +import GHC.Types.Name.Occurrence (OccName, occNameString) +import qualified GHC.Types.Name.Reader as RdrName (rdrNameOcc) import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Outputable as GHC -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified GHC.Parser.Annotation as GHC import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils import qualified Text.PrettyPrint as PP +import qualified Data.Semigroup as Semigroup +import qualified System.IO.Unsafe as Unsafe + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.Components.BriDoc +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types @@ -40,10 +40,10 @@ parDocW = PP.fsep . fmap PP.text . List.words . List.unwords showSDoc_ :: GHC.SDoc -> String -showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags +showSDoc_ = GHC.showSDocUnsafe showOutputable :: (GHC.Outputable a) => a -> String -showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags +showOutputable = GHC.showPprUnsafe fromMaybeIdentity :: Identity a -> Maybe a -> Identity a fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y @@ -55,7 +55,7 @@ fromOptionIdentity x y = -- maximum monoid over N+0 -- or more than N, because Num is allowed. newtype Max a = Max { getMax :: a } - deriving (Eq, Ord, Show, Bounded, Num) + deriving (Eq, Ord, Show, Num) instance (Num a, Ord a) => Semigroup (Max a) where (<>) = Data.Coerce.coerce (max :: a -> a -> a) @@ -72,75 +72,112 @@ instance Show ShowIsId where data A x = A ShowIsId x deriving Data -customLayouterF :: ExactPrint.Types.Anns -> LayouterF -customLayouterF anns layoutF = +data DeltaComment = DeltaComment GHC.DeltaPos GHC.EpaCommentTok + deriving Data + +customLayouterF :: LayouterF +customLayouterF layoutF = DataToLayouter $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan - `ext2Q` located + `extQ` internalLayouterShowIsId + `extQ` internalLayouterFastString + `extQ` internalLayouterBytestring + `extQ` internalLayouterOccName + `extQ` internalLayouterSrcSpan + `extQ` internalLayouterRdrName + `extQ` realSrcSpan + -- `extQ` deltaComment + -- `extQ` anchored + -- `ext1Q` srcSpanAnn + -- `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF - simpleLayouter :: String -> NodeLayouter - simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) - showIsId :: ShowIsId -> NodeLayouter - showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s - fastString = - simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString - -> NodeLayouter - bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = - simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString - srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = - simpleLayouter - -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - $ "{" - ++ showOutputable ss - ++ "}" - located :: (Data b, Data loc) => GHC.GenLocated loc 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) - Nothing -> ShowIsId "nnnnnnnn" + realSrcSpan :: GHC.RealSrcSpan -> NodeLayouter + realSrcSpan span = internalLayouterSimple (show span) + -- anchored :: (Data b) => GHC.GenLocated GHC.Anchor b -> NodeLayouter + -- anchored (GHC.L (GHC.Anchor _ op) a) = f $ GHC.L op a + +customLayouterNoSrcSpansF :: LayouterF +customLayouterNoSrcSpansF layoutF = + DataToLayouter + $ f + `extQ` internalLayouterShowIsId + `extQ` internalLayouterFastString + `extQ` internalLayouterBytestring + `extQ` internalLayouterOccName + `extQ` internalLayouterSrcSpan + `extQ` internalLayouterRdrName + `extQ` realSrcSpan + `extQ` deltaComment + `extQ` anchored + `ext1Q` srcSpanAnn + -- `ext2Q` located + where + DataToLayouter f = defaultLayouterF layoutF + realSrcSpan :: GHC.RealSrcSpan -> NodeLayouter + realSrcSpan span = internalLayouterSimple (show span) + -- anchored :: (Data b) => GHC.GenLocated GHC.Anchor b -> NodeLayouter + -- anchored (GHC.L (GHC.Anchor _ op) a) = f $ GHC.L op a + anchored :: GHC.Anchor -> NodeLayouter + anchored (GHC.Anchor _ op) = f op + srcSpanAnn :: forall a . Data a => GHC.SrcSpanAnn' a -> NodeLayouter + srcSpanAnn (GHC.SrcSpanAnn ann _loc) = f ann + deltaComment :: GHC.LEpaComment -> NodeLayouter + deltaComment (GHC.L anchor (GHC.EpaComment token prior)) = + f (GHC.L (ExactPrint.Utils.ss2deltaEnd prior (GHC.anchor anchor)) token) + -- located :: (Data b, Data loc) => GHC.GenLocated loc 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) + -- Nothing -> ShowIsId "nnnnnnnn" customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF layoutF = DataToLayouter $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + `extQ` internalLayouterShowIsId + `extQ` internalLayouterFastString + `extQ` internalLayouterBytestring + `extQ` internalLayouterOccName + `extQ` internalLayouterSrcSpan + `extQ` internalLayouterRdrName `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF - simpleLayouter :: String -> NodeLayouter - simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) - showIsId :: ShowIsId -> NodeLayouter - showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case + located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter + located (GHC.L _ss a) = runDataToLayouter layoutF a + +internalLayouterSimple :: String -> NodeLayouter +internalLayouterSimple s = NodeLayouter (length s) False (const $ PP.text s) +internalLayouterShowIsId :: ShowIsId -> NodeLayouter +internalLayouterShowIsId (ShowIsId s) = + NodeLayouter (length s + 2) True $ \case Left True -> PP.parens $ PP.text s Left False -> PP.text s Right _ -> PP.text s - fastString = - simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString - -> NodeLayouter - bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = - simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString - srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" - located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter - located (GHC.L _ss a) = runDataToLayouter layoutF a +internalLayouterFastString :: GHC.FastString -> NodeLayouter +internalLayouterFastString = + internalLayouterSimple . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString + -> NodeLayouter +internalLayouterBytestring :: B.ByteString -> NodeLayouter +internalLayouterBytestring = + internalLayouterSimple . show :: B.ByteString -> NodeLayouter +internalLayouterSrcSpan :: GHC.SrcSpan -> NodeLayouter +internalLayouterSrcSpan ss = + internalLayouterSimple + -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" + $ "{" + ++ showOutputable ss + ++ "}" +internalLayouterOccName :: OccName -> NodeLayouter +internalLayouterOccName = + internalLayouterSimple . ("{OccName: " ++) . (++ "}") . occNameString +internalLayouterRdrName :: RdrName -> NodeLayouter +internalLayouterRdrName = + internalLayouterSimple . ("{RdrName: " ++) . (++ "}") . occNameString . RdrName.rdrNameOcc + -- displayBriDocTree :: BriDoc -> PP.Doc -- displayBriDocTree = \case @@ -190,26 +227,19 @@ customLayouterNoAnnsF layoutF = -- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr] -- ++ [PP.text "]"] -traceIfDumpConf - :: (MonadMultiReader Config m, Show a) - => String - -> (DebugConfig -> Identity (Semigroup.Last Bool)) - -> a - -> m () -traceIfDumpConf s accessor val = do - whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do - trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () +-- traceWhen +-- :: (Show a) +-- => String +-- -> Bool +-- -> a +-- -> IO () +-- traceWhen s accessor val = do +-- TraceFunc f <- mAsk +-- whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do +-- Unsafe.unsafePerformIO $ do +-- f ("---- " ++ s ++ " ----\n" ++ show val) +-- pure $ pure () -tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m () -tellDebugMess s = mTell $ Seq.singleton s - -tellDebugMessShow - :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () -tellDebugMessShow = tellDebugMess . show - --- i should really put that into multistate.. -mModify :: MonadMultiState s m => (s -> s) -> m () -mModify f = mGet >>= mSet . f astToDoc :: Data ast => ast -> PP.Doc astToDoc ast = printTreeWithCustom 160 customLayouterNoAnnsF ast @@ -218,17 +248,17 @@ briDocToDoc :: BriDoc -> PP.Doc briDocToDoc = astToDoc . removeAnnotations where removeAnnotations = Uniplate.transform $ \case - BDAnnotationPrior _ x -> x - BDAnnotationKW _ _ x -> x - BDAnnotationRest _ x -> x + BDFlushCommentsPrior _ x -> x + BDFlushCommentsPost _ x -> x + BDQueueComments _ x -> x x -> x briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns = astToDoc -annsDoc :: ExactPrint.Types.Anns -> PP.Doc -annsDoc = - printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) +-- annsDoc :: ExactPrint.Types.Anns -> PP.Doc +-- annsDoc = +-- printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) breakEither _ [] = ([], []) @@ -252,17 +282,6 @@ splitFirstLast [] = FirstLastEmpty splitFirstLast [x] = FirstLastSingleton x splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr) --- TODO: move to uniplate upstream? --- aka `transform` -transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) -transformUp f = g where g = f . Uniplate.descend g -_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on) -_transformDown f = g where g = Uniplate.descend g . f -transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) -transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x -_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) -_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x - -- | similar to List.lines, but treating the case of final newline character -- in such a manner that this function is the inverse of @intercalate "\n"@. lines' :: String -> [String] @@ -271,5 +290,18 @@ lines' s = case break (== '\n') s of (s1, [_]) -> [s1, ""] (s1, (_ : r)) -> s1 : lines' r -absurdExt :: HsExtension.NoExtCon -> a -absurdExt = HsExtension.noExtCon +-- absurdExt :: HsExtension.NoExtCon -> a +-- absurdExt = HsExtension.noExtCon + +traceIfDumpConf + :: (MonadMultiReader TraceFunc m, MonadMultiReader Config m, Show a) + => String + -> (DebugConfig -> Identity (Semigroup.Last Bool)) + -> a + -> m () +traceIfDumpConf s accessor val = do + TraceFunc f <- mAsk + whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do + Unsafe.unsafePerformIO $ do + f ("---- " ++ s ++ " ----\n" ++ show val) + pure $ pure () diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs similarity index 57% rename from source/library/Language/Haskell/Brittany/Internal/Backend.hs rename to source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs index 55a3c97..6de5d81 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs +++ b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs @@ -1,33 +1,27 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.Backend where +module Language.Haskell.Brittany.Internal.WriteBriDoc.AlignmentAlgo + ( alignColsLines + ) +where -import qualified Control.Monad.Trans.State.Strict as StateS -import qualified Data.Either as Either -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -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 qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import Language.Haskell.Brittany.Internal.Prelude + +import qualified Control.Monad.Trans.State.Strict + as StateS +import qualified Data.Either as Either +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import qualified GHC.OldList as List + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.WriteBriDoc.Operators +import Language.Haskell.Brittany.Internal.WriteBriDoc.Types +import Language.Haskell.Brittany.Internal.Components.BriDoc @@ -60,340 +54,10 @@ instance Show ColInfo where "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list data ColBuildState = ColBuildState - { _cbs_map :: ColMap1 + { _cbs_map :: ColMap1 , _cbs_index :: ColIndex } -type LayoutConstraints m - = ( MonadMultiReader Config m - , MonadMultiReader ExactPrint.Types.Anns m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - , MonadMultiState LayoutState m - ) - -layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () -layoutBriDocM = \case - BDEmpty -> do - return () -- can it be that simple - BDLit t -> do - layoutIndentRestorePostComment - layoutRemoveIndentLevelLinger - layoutWriteAppend t - BDSeq list -> do - list `forM_` layoutBriDocM - -- in this situation, there is nothing to do about cols. - -- i think this one does not happen anymore with the current simplifications. - -- BDCols cSig list | BDPar sameLine lines <- List.last list -> - -- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines - BDCols _ list -> do - list `forM_` layoutBriDocM - BDSeparator -> do - layoutAddSepSpace - BDAddBaseY indent bd -> do - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ layoutBriDocM bd - BDBaseYPushCur bd -> do - layoutBaseYPushCur - layoutBriDocM bd - BDBaseYPop bd -> do - layoutBriDocM bd - layoutBaseYPop - BDIndentLevelPushCur bd -> do - layoutIndentLevelPushCur - layoutBriDocM bd - BDIndentLevelPop bd -> do - layoutBriDocM bd - layoutIndentLevelPop - BDEnsureIndent indent bd -> do - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ do - layoutWriteEnsureBlock - layoutBriDocM bd - BDPar indent sameLine indented -> do - layoutBriDocM sameLine - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ do - layoutWriteNewlineBlock - layoutBriDocM indented - BDLines lines -> alignColsLines lines - BDAlt [] -> error "empty BDAlt" - BDAlt (alt : _) -> layoutBriDocM alt - BDForceMultiline bd -> layoutBriDocM bd - BDForceSingleline bd -> layoutBriDocM bd - BDForwardLineMode bd -> layoutBriDocM bd - BDExternal annKey subKeys shouldAddComment t -> do - let - tlines = Text.lines $ t <> Text.pack "\n" - tlineCount = length tlines - anns :: ExactPrint.Anns <- mAsk - when shouldAddComment $ do - layoutWriteAppend - $ Text.pack - $ "{-" - ++ show (annKey, Map.lookup annKey anns) - ++ "-}" - zip [1 ..] tlines `forM_` \(i, l) -> do - layoutWriteAppend $ l - unless (i == tlineCount) layoutWriteNewlineBlock - do - state <- mGet - let filterF k _ = not $ k `Set.member` subKeys - mSet $ state - { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state - } - BDPlain t -> do - layoutWriteAppend t - BDAnnotationPrior annKey bd -> do - state <- mGet - let m = _lstate_comments state - let - moveToExactLocationAction = case _lstate_curYOrAddNewline state of - Left{} -> pure () - Right{} -> moveToExactAnn annKey - mAnn <- do - let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annPriorComments = [] }) - annKey - m - } - return mAnn - case mAnn of - Nothing -> moveToExactLocationAction - 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 } - moveToExactLocationAction - layoutBriDocM bd - BDAnnotationKW annKey keyword bd -> do - layoutBriDocM bd - mComments <- do - state <- mGet - let m = _lstate_comments state - let mAnn = ExactPrint.annsDP <$> 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 - _ -> Nothing - case mToSpan of - Just anns -> do - let - (comments, rest) = flip spanMaybe anns $ \case - (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) - _ -> Nothing - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annsDP = rest }) - annKey - m - } - return $ nonEmpty comments - _ -> 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 } - BDAnnotationRest annKey bd -> do - layoutBriDocM bd - annMay <- do - state <- mGet - let m = _lstate_comments state - pure $ Map.lookup annKey m - let mComments = nonEmpty . extractAllComments =<< annMay - let - semiCount = length - [ () - | Just ann <- [annMay] - , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann - ] - shouldAddSemicolonNewlines <- - mAsk - <&> _conf_layout - .> _lconfig_experimentalSemicolonNewlines - .> confUnpack - 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 - } - ) - annKey - (_lstate_comments state) - } - case mComments of - 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 } - BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do - mDP <- do - state <- mGet - let m = _lstate_comments state - let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let - relevant = - [ 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) - case mDP of - Nothing -> pure () - Just (y, x) -> - -- we abuse this, as we probably will print the KW next, which is - -- _not_ a comment.. - layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 - layoutBriDocM bd - BDNonBottomSpacing _ bd -> layoutBriDocM bd - BDSetParSpacing bd -> layoutBriDocM bd - BDForceParSpacing bd -> layoutBriDocM bd - BDDebug s bd -> do - mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" - layoutBriDocM bd - -briDocLineLength :: BriDoc -> Int -briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc - -- the state encodes whether a separator was already - -- appended at the current position. - where - rec = \case - BDEmpty -> return $ 0 - BDLit t -> StateS.put False $> Text.length t - BDSeq bds -> sum <$> rec `mapM` bds - BDCols _ bds -> sum <$> rec `mapM` bds - BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ line _ -> rec line - BDAlt{} -> error "briDocLineLength BDAlt" - BDForceMultiline bd -> rec bd - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t -> return $ Text.length t - BDPlain t -> return $ Text.length t - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_ : _) -> do - x <- StateS.get - return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd - -briDocIsMultiLine :: BriDoc -> Bool -briDocIsMultiLine briDoc = rec briDoc - where - rec :: BriDoc -> Bool - rec = \case - BDEmpty -> False - BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds - BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar{} -> True - BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal{} -> True - BDPlain t | [_] <- Text.lines t -> False - BDPlain _ -> True - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines (_ : _ : _) -> True - BDLines [_] -> False - BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd - -- In theory -- ========= @@ -469,25 +133,26 @@ briDocIsMultiLine briDoc = rec briDoc -- are executed in the same recursion, too. -- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue -- mentioned in the first "possible improvement". -alignColsLines :: LayoutConstraints m => [BriDoc] -> m () -alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do +alignColsLines :: LayoutConstraints m => (BriDoc -> m ()) -> [BriDoc] -> m () +alignColsLines layoutBriDocM bridocs = do -- colInfos `forM_` \colInfo -> do -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs)) curX <- do state <- mGet return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe 0 (_lstate_addSepSpace state) - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack + colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack alignBreak <- mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack case () of _ -> do + -- tellDebugMess ("colInfos:\n" ++ List.unlines [ "> " ++ prettyColInfos "> " x | x <- colInfos]) -- tellDebugMess ("processedMap: " ++ show processedMap) sequence_ - $ List.intersperse layoutWriteEnsureNewlineBlock - $ colInfos - <&> processInfo colMax processedMap + $ List.intersperse layoutWriteEnsureNewlineBlock + $ colInfos + <&> processInfo layoutBriDocM colMax processedMap where (colInfos, finalState) = StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0) @@ -511,11 +176,11 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do (xN : xR) -> reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR where - fLast (ColumnSpacingLeaf len) = len + fLast (ColumnSpacingLeaf len ) = len fLast (ColumnSpacingRef len _) = len fInit (ColumnSpacingLeaf len) = len - fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of - Nothing -> 0 + fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of + Nothing -> 0 Just (_, maxs, _) -> sum maxs maxCols = {-Foldable.foldl1 maxZipper-} fmap colAggregation $ transpose $ Foldable.toList colss @@ -524,18 +189,19 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do counter count l = if List.last posXs + List.last l <= colMax then count + 1 else count - ratio = fromIntegral (foldl counter (0 :: Int) colss) + ratio = fromIntegral (foldl' counter (0 :: Int) colss) / fromIntegral (length colss) - in (ratio, maxCols, colss) + in + (ratio, maxCols, colss) mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocs bds = mergeBriDocsW ColInfoStart bds mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocsW _ [] = return [] + mergeBriDocsW _ [] = return [] mergeBriDocsW lastInfo (bd : bdr) = do - info <- mergeInfoBriDoc True lastInfo bd + info <- mergeInfoBriDoc True lastInfo bd infor <- mergeBriDocsW -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) (if shouldBreakAfter bd then ColInfoStart else info) @@ -591,7 +257,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do -> BriDoc -> StateS.StateT ColBuildState Identity ColInfo mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = \case brdc@(BDCols colSig subDocs) @@ -602,56 +268,26 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do else repeat False infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd - let curLengths = briDocLineLength <$> subDocs + let curLengths = briDocLineLength <$> subDocs let trueSpacings = getTrueSpacings (zip curLengths infos) do -- update map s <- StateS.get let m = _cbs_map s - let (Just (_, spaces)) = IntMapS.lookup infoInd m - StateS.put s - { _cbs_map = IntMapS.insert - infoInd - (lastFlag, spaces Seq.|> trueSpacings) - m - } + case IntMapS.lookup infoInd m of + Just (_, spaces) -> StateS.put s + { _cbs_map = IntMapS.insert + infoInd + (lastFlag, spaces Seq.|> trueSpacings) + m + } + Nothing -> pure () -- shouldn't be possible return $ ColInfo infoInd colSig (zip curLengths infos) | otherwise -> briDocToColInfo lastFlag brdc brdc -> return $ ColInfoNo brdc -briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo -briDocToColInfo lastFlag = \case - BDCols sig list -> withAlloc lastFlag $ \ind -> do - let - isLastList = - if lastFlag then (== length list) <$> [1 ..] else repeat False - subInfos <- zip isLastList list `forM` uncurry briDocToColInfo - let lengthInfos = zip (briDocLineLength <$> list) subInfos - let trueSpacings = getTrueSpacings lengthInfos - return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) - bd -> return $ ColInfoNo bd -getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] -getTrueSpacings lengthInfos = lengthInfos <&> \case - (len, ColInfo i _ _) -> ColumnSpacingRef len i - (len, _) -> ColumnSpacingLeaf len - -withAlloc - :: Bool - -> ( ColIndex - -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) - ) - -> StateS.State ColBuildState ColInfo -withAlloc lastFlag f = do - cbs <- StateS.get - let ind = _cbs_index cbs - StateS.put $ cbs { _cbs_index = ind + 1 } - (space, info) <- f ind - StateS.get >>= \c -> StateS.put - $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c } - return info - -processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () -processInfo maxSpace m = \case +processInfo :: LayoutConstraints m => (BriDoc -> m ()) -> Int -> ColMap2 -> ColInfo -> m () +processInfo layoutBriDocM maxSpace m = \case ColInfoStart -> error "should not happen (TM)" ColInfoNo doc -> layoutBriDocM doc ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ @@ -660,7 +296,9 @@ processInfo maxSpace m = \case alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack curX <- do state <- mGet - -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) + -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) + -- ++ " - " ++ show (_lstate_addSepSpace state) + -- ++ " - " ++ show (_lstate_commentCol state)) let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state return $ case _lstate_curYOrAddNewline state of Left i -> case _lstate_commentCol state of @@ -669,11 +307,12 @@ processInfo maxSpace m = \case Right{} -> spaceAdd let colMax = min colMaxConf (curX + maxSpace) -- tellDebugMess $ show curX - let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m + let (ratio, maxCols1, _colss) = case IntMapS.lookup ind m of + Just x -> x + Nothing -> error "internal brittany error: processInfo bad lookup" let maxCols2 = list <&> \case - (_, ColInfo i _ _) -> - let Just (_, ms, _) = IntMapS.lookup i m in sum ms + (_, ColInfo i _ _) | Just (_, ms, _) <- IntMapS.lookup i m -> sum ms (l, _) -> l let maxCols = zipWith max maxCols1 maxCols2 let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols @@ -701,18 +340,20 @@ processInfo maxSpace m = \case spacings = zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs -- tellDebugMess $ "ind = " ++ show ind + -- tellDebugMess $ "spacings = " ++ show spacings -- tellDebugMess $ "maxCols = " ++ show maxCols -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs -- tellDebugMess $ "list = " ++ show list -- tellDebugMess $ "maxSpace = " ++ show maxSpace let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do + -- tellDebugMess $ "layoutWriteEnsureAbsoluteN " ++ show destX layoutWriteEnsureAbsoluteN destX - processInfo s m (snd x) - noAlignAct = list `forM_` (snd .> processInfoIgnore) - animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ + processInfo layoutBriDocM s m (snd x) + noAlignAct = list `forM_` (snd .> processInfoIgnore layoutBriDocM) + animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax=" ++ show colMax) $ if List.last fixedPosXs + fst (List.last list) > colMax - -- per-item check if there is overflowing. + -- per-item check if there is overflowing. then noAlignAct else alignAct case alignMode of @@ -725,8 +366,145 @@ processInfo maxSpace m = \case ColumnAlignModeAnimously -> animousAct ColumnAlignModeAlways -> alignAct -processInfoIgnore :: LayoutConstraints m => ColInfo -> m () -processInfoIgnore = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc - ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) + +getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] +getTrueSpacings lengthInfos = lengthInfos <&> \case + (len, ColInfo i _ _) -> ColumnSpacingRef len i + (len, _) -> ColumnSpacingLeaf len + +withAlloc + :: Bool + -> ( ColIndex + -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) + ) + -> StateS.State ColBuildState ColInfo +withAlloc lastFlag f = do + cbs <- StateS.get + let ind = _cbs_index cbs + StateS.put $ cbs { _cbs_index = ind + 1 } + (space, info) <- f ind + StateS.get >>= \c -> StateS.put + $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c } + return info + +briDocLineLength :: BriDoc -> Int +briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc + -- the state encodes whether a separator was already + -- appended at the current position. + where + rec = \case + BDEmpty -> return $ 0 + BDLit t -> StateS.put False $> Text.length t + BDSeq bds -> sum <$> rec `mapM` bds + BDCols _ bds -> sum <$> rec `mapM` bds + BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar _ line _ -> rec line + BDAlt{} -> error "briDocLineLength BDAlt" + BDForceMultiline bd -> rec bd + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ t -> return $ Text.length t + BDPlain t -> return $ Text.length t + BDQueueComments _ bd -> rec bd + BDFlushCommentsPrior _ bd -> rec bd + BDFlushCommentsPost _ bd -> rec bd + BDLines ls@(_ : _) -> do + x <- StateS.get + return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd + +briDocIsMultiLine :: BriDoc -> Bool +briDocIsMultiLine briDoc = rec briDoc + where + rec :: BriDoc -> Bool + rec = \case + BDEmpty -> False + BDLit _ -> False + BDSeq bds -> any rec bds + BDCols _ bds -> any rec bds + BDSeparator -> False + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar{} -> True + BDAlt{} -> error "briDocIsMultiLine BDAlt" + BDForceMultiline _ -> True + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ t | [_] <- Text.lines t -> False + BDExternal{} -> True + BDPlain t | [_] <- Text.lines t -> False + BDPlain _ -> True + BDQueueComments _ bd -> rec bd + BDFlushCommentsPrior _ bd -> rec bd + BDFlushCommentsPost _ bd -> rec bd + BDLines (_ : _ : _) -> True + BDLines [_] -> False + BDLines [] -> error "briDocIsMultiLine BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd + +briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo +briDocToColInfo lastFlag = \case + BDCols sig list -> withAlloc lastFlag $ \ind -> do + let + isLastList = + if lastFlag then (== length list) <$> [1 ..] else repeat False + subInfos <- zip isLastList list `forM` uncurry briDocToColInfo + let lengthInfos = zip (briDocLineLength <$> list) subInfos + let trueSpacings = getTrueSpacings lengthInfos + return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) + bd -> return $ ColInfoNo bd + +processInfoIgnore :: LayoutConstraints m => (BriDoc -> m ()) -> ColInfo -> m () +processInfoIgnore layoutBriDocM = go + where + go = \case + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc + ColInfo _ _ list -> list `forM_` (snd .> go) + + +_prettyColInfos :: String -> ColInfo -> String +_prettyColInfos prefix = \case + ColInfoStart -> "start (?)" + ColInfoNo bd -> "X" ++ replicate (briDocLineLength bd - 1) '_' + ColInfo _ind sig below -> + let + (total, belowStrs) = List.mapAccumL + (\x (add, info) -> + (x + add, _prettyColInfos (prefix ++ replicate (x) ' ') info) + ) + 0 + below + in + "X" + ++ replicate (total - 1) 'x' + ++ " as " + ++ show sig + ++ " " + ++ show _ind + ++ "\n" + ++ prefix + ++ List.concat belowStrs + ++ "\n" + ++ prefix + ++ replicate total ' ' + -- [ prefix ++ show k ++ ": " ++ prettyColInfos (prefix ++ " ") v + -- | (k, v) <- below + -- ] diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs similarity index 69% rename from source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs rename to source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs index 310ea56..01f3540 100644 --- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs @@ -1,29 +1,24 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Haskell.Brittany.Internal.BackendUtils where +module Language.Haskell.Brittany.Internal.WriteBriDoc.Operators where -import qualified Data.Data -import qualified Data.Either -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC (Located) -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types 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 qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint + +import qualified Data.Maybe +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified GHC.OldList as List +import qualified GHC.Parser.Annotation as GHC + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.WriteBriDoc.Types traceLocal :: (MonadMultiState LayoutState m) => a -> m () traceLocal _ = return () +-- traceLocal :: (MonadMultiState LayoutState m, Show a) => a -> m () +-- traceLocal x = trace (show x) $ pure () layoutWriteAppend @@ -31,8 +26,8 @@ layoutWriteAppend => Text -> m () layoutWriteAppend t = do - traceLocal ("layoutWriteAppend", t) state <- mGet + traceLocal ("layoutWriteAppend", t, _lstate_curYOrAddNewline state, _lstate_addSepSpace state) case _lstate_curYOrAddNewline state of Right i -> do replicateM_ i $ mTell $ Text.Builder.fromString $ "\n" @@ -115,23 +110,31 @@ layoutSetCommentCol = do -- to be harmless so far.. layoutMoveToCommentPos :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => Int + => Bool + -> Int -> Int -> Int -> m () -layoutMoveToCommentPos y x commentLines = do - traceLocal ("layoutMoveToCommentPos", y, x, commentLines) +layoutMoveToCommentPos absolute y x commentLines = do state <- mGet + traceLocal ("layoutMoveToCommentPos", y, x, commentLines, _lstate_curYOrAddNewline state, _lstate_addSepSpace state, lstate_baseY state) mSet state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of Left i -> if y == 0 then Left i else Right y Right{} -> Right y , _lstate_addSepSpace = - Just $ if Data.Maybe.isJust (_lstate_commentCol state) - then case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x - Right{} -> _lstate_indLevelLinger state + x - else if y == 0 then x else _lstate_indLevelLinger state + x + Just $ if + | y > 0 -> if absolute then x - 1 else lstate_baseY state + x + | Data.Maybe.isNothing (_lstate_commentCol state) -> x + | otherwise -> x + -- TODO92 we had more complex logic here for otherwise previously, + -- but I don't think it can happen. Leaving this here until some + -- more testing is done as a reminder. + -- Also, if this _is_ necessary, the "absolute" handling might to + -- be adapted. + -- case _lstate_curYOrAddNewline state of + -- Left{} -> x + -- Right{} -> _lstate_indLevelLinger state + x , _lstate_commentCol = Just $ case _lstate_commentCol state of Just existing -> existing Nothing -> case _lstate_curYOrAddNewline state of @@ -163,8 +166,8 @@ layoutWriteEnsureNewlineBlock :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => m () layoutWriteEnsureNewlineBlock = do - traceLocal ("layoutWriteEnsureNewlineBlock") state <- mGet + traceLocal ("layoutWriteEnsureNewlineBlock", lstate_baseY state) mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of Left{} -> Right 1 @@ -292,15 +295,20 @@ layoutWithAddBaseColN amount m = do layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m () layoutBaseYPushCur = do - traceLocal ("layoutBaseYPushCur") state <- mGet - case _lstate_commentCol state of - Nothing -> - case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i, Just j) -> layoutBaseYPushInternal (i + j) - (Left i, Nothing) -> layoutBaseYPushInternal i - (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state - Just cCol -> layoutBaseYPushInternal cCol + traceLocal + ( "layoutBaseYPushCur" + , _lstate_curYOrAddNewline state + , _lstate_addSepSpace state + ) + layoutBaseYPushInternal + (case _lstate_commentCol state of + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state + Just cCol -> cCol + fromMaybe 0 (_lstate_addSepSpace state) + ) + layoutBaseYPop :: (MonadMultiState LayoutState m) => m () layoutBaseYPop = do @@ -338,39 +346,48 @@ 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 -> - let - upd = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right i -> Right $ max y i - in - state - { _lstate_curYOrAddNewline = upd - , _lstate_addSepSpace = if Data.Either.isRight upd - then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just - (lstate_baseY state) - else Nothing - , _lstate_commentCol = Nothing - } +moveToCommentPos + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => Bool + -> GHC.DeltaPos + -> m () +moveToCommentPos absolute = \case + GHC.SameLine c -> layoutMoveToCommentPos absolute 0 c 1 + GHC.DifferentLine l c -> layoutMoveToCommentPos absolute l c 1 + +-- moveToY :: MonadMultiState LayoutState m => Int -> m () +-- moveToY y = mModify $ \state -> +-- let +-- upd = case _lstate_curYOrAddNewline state of +-- Left i -> if y == 0 then Left i else Right y +-- Right i -> Right $ max y i +-- in +-- state +-- { _lstate_curYOrAddNewline = upd +-- , _lstate_addSepSpace = if Data.Either.isRight upd +-- then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just +-- (lstate_baseY state) +-- else Nothing +-- , _lstate_commentCol = Nothing +-- } -- fixMoveToLineByIsNewline :: MonadMultiState -- LayoutState m => Int -> m Int -- fixMoveToLineByIsNewline x = do @@ -379,77 +396,71 @@ 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 " " - -- 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/WriteBriDoc/Types.hs b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Types.hs new file mode 100644 index 0000000..870336e --- /dev/null +++ b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Types.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} + +module Language.Haskell.Brittany.Internal.WriteBriDoc.Types where + +import Language.Haskell.Brittany.Internal.Prelude + +import qualified Safe +import GHC ( LEpaComment + ) +import qualified Data.Text.Lazy.Builder as TextL.Builder + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + + + +data LayoutState = LayoutState + { _lstate_baseYs :: [Int] + -- ^ stack of number of current indentation columns + -- (not number of indentations). + , _lstate_curYOrAddNewline :: Either Int Int + -- ^ Either: + -- 1) number of chars in the current line. + -- 2) number of newlines to be inserted before inserting any + -- non-space elements. + , _lstate_indLevels :: [Int] + -- ^ stack of current indentation levels. set for + -- any layout-affected elements such as + -- let/do/case/where elements. + -- The main purpose of this member is to + -- properly align comments, as their + -- annotation positions are relative to the + -- current layout indentation level. + , _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for + -- properly treating cases where comments + -- on the first indented element have an + -- annotation offset relative to the last + -- non-indented element, which is confusing. + -- , _lstate_comments :: Anns + , _lstate_commentCol :: Maybe Int -- this communicates two things: + -- firstly, that cursor is currently + -- at the end of a comment (so needs + -- newline before any actual content). + -- secondly, the column at which + -- insertion of comments started. + , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone + -- writes (any non-spaces) in the + -- current line. + -- , _lstate_isNewline :: NewLineState + -- -- captures if the layouter currently is in a new line, i.e. if the + -- -- current line only contains (indentation) spaces. + -- this is mostly superseeded by curYOrAddNewline, iirc. + , _lstate_commentNewlines :: Int -- number of newlines inserted due to + -- move-to-DP at a start of a comment. + -- Necessary because some keyword DPs + -- are relative to the last non-comment + -- entity (for some reason). + -- This is not very strictly reset to 0, + -- so we might in some cases get "artifacts" + -- from previous document elements. + -- But the worst effect at the moment would + -- be that we introduce less newlines on + -- moveToKWDP, which seems harmless enough. + } + +lstate_baseY :: LayoutState -> Int +lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs + +lstate_indLevel :: LayoutState -> Int +lstate_indLevel = Safe.headNote "lstate_indLevel" . _lstate_indLevels + +-- evil, incomplete Show instance; only for debugging. +instance Show LayoutState where + show state = + "LayoutState" + ++ "{baseYs=" ++ show (_lstate_baseYs state) + ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) + ++ ",indLevels=" ++ show (_lstate_indLevels state) + ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) + ++ ",commentCol=" ++ show (_lstate_commentCol state) + ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) + ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) + ++ "}" + + +type LayoutConstraints m + = ( MonadMultiReader Config m + , MonadMultiWriter TextL.Builder.Builder m + , MonadMultiWriter (Seq String) m + , MonadMultiState LayoutState m + , MonadMultiState CommentCounter m + , MonadMultiState [GHC.LEpaComment] m + ) diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs index 44eac1d..466ede4 100644 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ b/source/library/Language/Haskell/Brittany/Main.hs @@ -10,22 +10,21 @@ import Data.CZipWith import qualified Data.Either import qualified Data.List.Extra import qualified Data.Monoid -import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Data.Text.Lazy as TextL import DataTreePrint import GHC (GenLocated(L)) +import qualified GHC import qualified GHC.Driver.Session as GHC import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.OldList as List import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Config import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Obfuscation +import Language.Haskell.Brittany.Internal.Components.Obfuscation 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 qualified Language.Haskell.GHC.ExactPrint as ExactPrint @@ -60,6 +59,51 @@ main = do args <- Environment.getArgs mainWith progName args +testMain :: IO () +testMain = do + h <- System.IO.openFile "local/sample-folder/err.txt" System.IO.WriteMode + let cmdlineR = + runCmdParser + Nothing + (InputArgs + [ "--output-on-errors" + , "--dump-ast-full" + , "--omit-output-check" + -- , "--dump-bridoc-alt" + , "--dump-bridoc-floating" + -- , "--dump-bridoc-par" + -- , "--dump-bridoc-columns" + , "--dump-bridoc-final" + ] + ) + $ do + reorderStart + c <- cmdlineConfigParser + reorderStop + addCmdImpl c + let cmdlineConfig = case _ppi_value cmdlineR of + Left err -> error (show err) + Right (Nothing) -> error "could not parse config" + Right (Just r ) -> r + configsToLoad <- + maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) + config <- runMaybeT (readConfigs cmdlineConfig configsToLoad) + -- (readConfigsWithUserConfig cmdlineConfig configsToLoad) + >>= \case + Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) + Just x -> return x + System.IO.hPutStrLn h $ showConfigYaml config + e <- coreIO (System.IO.hPutStrLn h) + config + False + False + (Just "local/sample-folder/Test.hs") + (Just "local/sample-folder/out.txt") + case e of + Left i -> print i + Right Changes -> putStrLn "Changes" + Right NoChanges -> putStrLn "NoChanges" + mainWith :: String -> [String] -> IO () mainWith progName args = Environment.withProgName progName @@ -246,7 +290,6 @@ mainCmdParser = do [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) - data ChangeStatus = Changes | NoChanges deriving (Eq) @@ -337,11 +380,11 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = putErrorLn "parse error:" putErrorLn left ExceptT.throwE 60 - Right (anns, parsedSource, hasCPP) -> do - (inlineConf, perItemConf) <- - case - extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - of + Right (parsedSource, hasCPP) -> do + (inlineConf, perItemConf) <- do + resE <- + liftIO $ ExceptT.runExceptT $ extractCommentConfigs putErrorLnIO parsedSource + case resE of Left (err, input) -> do putErrorLn $ "Error: parse error in inline configuration:" putErrorLn err @@ -351,8 +394,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = pure c let moduleConf = cZipWith fromOptionIdentity config inlineConf when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do - let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource - trace ("---- ast ----\n" ++ show val) $ return () + let val = printTreeWithCustom 160 customLayouterF parsedSource + putErrorLn ("---- ast ----\n" ++ show val) let disableFormatting = moduleConf & _conf_disable_formatting & confUnpack @@ -361,7 +404,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = | disableFormatting -> do pure ([], originalContents, False) | exactprintOnly -> do - let r = Text.pack $ ExactPrint.exactPrint parsedSource anns + let r = Text.pack $ ExactPrint.exactPrint parsedSource pure ([], r, r /= originalContents) | otherwise -> do let @@ -371,13 +414,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = .> _econf_omit_output_valid_check .> confUnpack (ews, outRaw) <- if hasCPP || omitCheck - then return - $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck - moduleConf - perItemConf - anns - parsedSource + then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource + else liftIO + $ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") @@ -398,6 +437,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = customErrOrder LayoutWarning{} = -1 :: Int customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnusedComments{} = 3 customErrOrder ErrorUnknownNode{} = -2 :: Int customErrOrder ErrorMacroConfig{} = 5 unless (null errsWarns) $ do @@ -445,6 +485,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = unused `forM_` \case ErrorUnusedComment str -> putErrorLn str _ -> error "cannot happen (TM)" + unused@(ErrorUnusedComments{} : _) -> do + unused `forM_` \case + ErrorUnusedComments (L (GHC.SrcSpanAnn _ ann) _) cIn cOut -> do + putErrorLn + $ "Error: detected unprocessed comments (" + ++ show cOut ++ " out of " ++ show cIn ++ ")." + ++ " The transformation output will most likely" + ++ " not contain some of the comments" + ++ " present in the input haskell source file." + putErrorLn $ "Affected is the declaration at " ++ show (astToDoc ann) + _ -> error "cannot happen (TM)" (ErrorMacroConfig err input : _) -> do putErrorLn $ "Error: parse error in inline configuration:" putErrorLn err @@ -473,10 +524,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = Nothing -> liftIO $ Text.IO.putStr $ outSText Just p -> liftIO $ do let - isIdentical = case inputPathM of - Nothing -> False - Just _ -> not hasChanges - unless isIdentical $ Text.IO.writeFile p $ outSText + shouldWrite = case inputPathM of + Nothing -> True + Just p2 -> hasChanges || p /= p2 + when shouldWrite $ Text.IO.writeFile p $ outSText when (checkMode && hasChanges) $ case inputPathM of Nothing -> pure () diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index 056e025..63636ac 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -12,10 +12,9 @@ import qualified GHC.OldList as List import qualified Data.Map.Strict as Map import Data.These import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Config import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils import qualified System.Directory import System.FilePath (()) import System.Timeout (timeout)