From 5e9744ad15f2ff2d9ff3da9e7fde0afe61ffa972 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 24 Jul 2016 23:14:00 +0200 Subject: [PATCH] stablememo --- .gitignore | 11 + ChangeLog.md | 5 + Setup.hs | 2 + brittany.cabal | 232 ++++ src-brittany/Main.hs | 205 +++ src-idemtests/.gitignore | 4 + src-idemtests/README | 17 + src-idemtests/brittany.yaml | 23 + src-idemtests/cases/LayoutBasics.hs | 747 ++++++++++ src-idemtests/run.sh | 36 + src-unittests/AsymptoticPerfTests.hs | 31 + src-unittests/IdentityTests.hs | 537 ++++++++ src-unittests/TestMain.hs | 26 + src-unittests/TestUtils.hs | 51 + src/Language/Haskell/Brittany.hs | 195 +++ src/Language/Haskell/Brittany/BriLayouter.hs | 1218 +++++++++++++++++ src/Language/Haskell/Brittany/Config.hs | 164 +++ src/Language/Haskell/Brittany/Config/Types.hs | 225 +++ src/Language/Haskell/Brittany/LayoutBasics.hs | 769 +++++++++++ .../Haskell/Brittany/Layouters/Decl.hs | 264 ++++ .../Haskell/Brittany/Layouters/Expr.hs | 649 +++++++++ .../Haskell/Brittany/Layouters/Expr.hs-boot | 28 + .../Haskell/Brittany/Layouters/Pattern.hs | 76 + .../Haskell/Brittany/Layouters/Stmt.hs | 77 ++ .../Haskell/Brittany/Layouters/Type.hs | 648 +++++++++ src/Language/Haskell/Brittany/Prelude.hs | 28 + src/Language/Haskell/Brittany/Types.hs | 207 +++ src/Language/Haskell/Brittany/Utils.hs | 229 ++++ srcinc/prelude.inc | 788 +++++++++++ 29 files changed, 7492 insertions(+) create mode 100644 .gitignore create mode 100644 ChangeLog.md create mode 100644 Setup.hs create mode 100644 brittany.cabal create mode 100644 src-brittany/Main.hs create mode 100644 src-idemtests/.gitignore create mode 100644 src-idemtests/README create mode 100644 src-idemtests/brittany.yaml create mode 100644 src-idemtests/cases/LayoutBasics.hs create mode 100755 src-idemtests/run.sh create mode 100644 src-unittests/AsymptoticPerfTests.hs create mode 100644 src-unittests/IdentityTests.hs create mode 100644 src-unittests/TestMain.hs create mode 100644 src-unittests/TestUtils.hs create mode 100644 src/Language/Haskell/Brittany.hs create mode 100644 src/Language/Haskell/Brittany/BriLayouter.hs create mode 100644 src/Language/Haskell/Brittany/Config.hs create mode 100644 src/Language/Haskell/Brittany/Config/Types.hs create mode 100644 src/Language/Haskell/Brittany/LayoutBasics.hs create mode 100644 src/Language/Haskell/Brittany/Layouters/Decl.hs create mode 100644 src/Language/Haskell/Brittany/Layouters/Expr.hs create mode 100644 src/Language/Haskell/Brittany/Layouters/Expr.hs-boot create mode 100644 src/Language/Haskell/Brittany/Layouters/Pattern.hs create mode 100644 src/Language/Haskell/Brittany/Layouters/Stmt.hs create mode 100644 src/Language/Haskell/Brittany/Layouters/Type.hs create mode 100644 src/Language/Haskell/Brittany/Prelude.hs create mode 100644 src/Language/Haskell/Brittany/Types.hs create mode 100644 src/Language/Haskell/Brittany/Utils.hs create mode 100644 srcinc/prelude.inc diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..60ed26c --- /dev/null +++ b/.gitignore @@ -0,0 +1,11 @@ +*.prof +*.aux +*.eventlog +*.hp +*.ps +/*.pdf +dist/ +local/ +.cabal-sandbox/ +.stack-work/ +cabal.sandbox.config diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..a8dfa0a --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for brittany + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/brittany.cabal b/brittany.cabal new file mode 100644 index 0000000..24180f1 --- /dev/null +++ b/brittany.cabal @@ -0,0 +1,232 @@ +name: brittany +version: 0.1.0.0 +-- synopsis: +-- description: +license: AllRightsReserved +-- license-file: LICENSE +author: Lennart Spitzner +maintainer: lsp@informatik.uni-kiel.de +-- copyright: +category: Language +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +flag brittany-dev + description: dev options + default: False + +flag brittany-dev-lib + description: set buildable false for anything but lib + default: False + +library { + default-language: + Haskell2010 + hs-source-dirs: + src + exposed-modules: { + Language.Haskell.Brittany.Prelude + Language.Haskell.Brittany + Language.Haskell.Brittany.Types + Language.Haskell.Brittany.Utils + Language.Haskell.Brittany.Config + Language.Haskell.Brittany.Config.Types + Language.Haskell.Brittany.LayoutBasics + Language.Haskell.Brittany.BriLayouter + Language.Haskell.Brittany.Layouters.Type + Language.Haskell.Brittany.Layouters.Decl + Language.Haskell.Brittany.Layouters.Expr + Language.Haskell.Brittany.Layouters.Stmt + Language.Haskell.Brittany.Layouters.Pattern + } + ghc-options: { + -Wall + -fprof-auto -fprof-cafs -fno-spec-constr + -j + -fno-warn-unused-imports + -fno-warn-orphans + } + if flag(brittany-dev) { + ghc-options: -O0 -Werror -fobject-code + } + build-depends: + { base >=4.9 && <4.10 + -- , ghc-parser >=0.1 && <0.2 + , ghc + , ghc-paths + , ghc-exactprint + , stable-memo + , transformers + , containers + , qualified-prelude + , mtl + , text + , multistate + , syb + , neat-interpolation + , hspec + , data-tree-print + , pretty + , bytestring + , directory + , lens + , butcher + , yaml + , extra + , uniplate + , strict + , unsafe + } + default-extensions: { + CPP + + NoImplicitPrelude + + GADTs + + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + } + include-dirs: + srcinc +} + +executable brittany + if flag(brittany-dev-lib) { + buildable: False + } else { + buildable: True + } + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: + { brittany + , base >=4.9 && <4.10 + -- , ghc-parser >=0.1 && <0.2 + , ghc + , ghc-paths + , ghc-exactprint + , stable-memo + , transformers + , containers + , qualified-prelude + , mtl + , text + , multistate + , syb + , neat-interpolation + , hspec + , data-tree-print + , pretty + , bytestring + , directory + , lens + , butcher + , yaml + , extra + , uniplate + , strict + } + hs-source-dirs: src-brittany + default-language: Haskell2010 + default-extensions: { + CPP + + NoImplicitPrelude + + GADTs + + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + } + ghc-options: { + -Wall + -fprof-auto -fprof-cafs -fno-spec-constr + -j + -fno-warn-unused-imports + -fno-warn-orphans + -rtsopts + } + if flag(brittany-dev) { + ghc-options: -O0 -Werror -fobject-code + } + +test-suite unittests + if flag(brittany-dev-lib) { + buildable: False + } else { + buildable: True + } + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: + { brittany + , base >=4.9 && <4.10 + -- , ghc-parser >=0.1 && <0.2 + , ghc + , ghc-paths + , ghc-exactprint + , stable-memo + , transformers + , containers + , qualified-prelude + , mtl + , text + , multistate + , syb + , neat-interpolation + , hspec + , data-tree-print + , pretty + , bytestring + , directory + , lens + , butcher + , yaml + , extra + , uniplate + , strict + } + ghc-options: -Wall + main-is: TestMain.hs + other-modules: IdentityTests + TestUtils + AsymptoticPerfTests + hs-source-dirs: src-unittests + default-extensions: { + CPP + + NoImplicitPrelude + + GADTs + + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + } + ghc-options: { + -Wall + -fprof-auto -fprof-cafs -fno-spec-constr + -j + -fno-warn-unused-imports + -fno-warn-orphans + } + if flag(brittany-dev) { + ghc-options: -O0 -Werror -fobject-code + } diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs new file mode 100644 index 0000000..558e787 --- /dev/null +++ b/src-brittany/Main.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE DataKinds #-} + +module Main where + + + +#include "prelude.inc" + +import DynFlags ( getDynFlags ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import qualified Parser as GHC.Parser +import RdrName ( RdrName(..) ) +import Control.Monad.IO.Class +import GHC.Paths (libdir) +import HsSyn +import SrcLoc ( SrcSpan, Located ) +-- import Outputable ( ppr, runSDoc ) +-- import DynFlags ( unsafeGlobalDynFlags ) + +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers +import qualified Data.Map as Map + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import qualified Debug.Trace as Trace + +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.LayoutBasics +import Language.Haskell.Brittany +import Language.Haskell.Brittany.Config +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Utils + +import qualified Text.PrettyPrint as PP + +import DataTreePrint +import UI.Butcher.Monadic + +import qualified System.Exit + +import Paths_brittany + + + +main :: IO () +main = mainFromCmdParser mainCmdParser + +mainCmdParser :: CmdParser Identity (IO ()) () +mainCmdParser = do + addCmdSynopsis "haskell source pretty printer" + addCmdHelp $ PP.vcat $ List.intersperse (PP.text "") + [ parDoc $ "Transforms one haskell module by reformatting" + ++ " (parts of) the source code, while preserving the" + ++ " parts not transformed." + ++ " Especially, comments are preserved completely" + ++ " and newlines are in many cases." + , parDoc $ "Based on ghc-exactprint, thus supporting all that" + ++ " ghc does." + ] + -- addCmd "debugArgs" $ do + addHelpCommand + -- addButcherDebugCommand + reorderStart + printHelp <- addSimpleBoolFlag "" ["help"] mempty + printVersion <- addSimpleBoolFlag "" ["version"] mempty + inputPaths <- addFlagStringParam "i" ["input"] "PATH" (flagHelpStr "path to input haskell source file") + outputPaths <- addFlagStringParam "o" ["output"] "PATH" (flagHelpStr "output file path") + configPaths <- addFlagStringParam "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- configParser + suppressOutput <- addSimpleBoolFlag "" ["suppress-output"] (flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source") + _verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]") + reorderStop + desc <- peekCmdDesc + addCmdImpl $ void $ do + when printVersion $ do + liftIO $ putStrLn $ "brittany version " ++ showVersion version + System.Exit.exitSuccess + when printHelp $ do + liftIO $ print $ ppHelpShallow desc + System.Exit.exitSuccess + -- runGhc (Just libdir) $ do + -- dynflags <- getDynFlags + -- input <- liftIO $ readFile "local/Sample.hs" + -- let parseOutput = runParser dynflags parserModule input + -- liftIO $ case parseOutput of + -- Failure msg strloc -> do + -- putStrLn "some failed parse" + -- putStrLn msg + -- print strloc + -- Parsed a -> putStrLn "some successful parse." + -- Partial a (x,y) -> do + -- putStrLn "some partial parse" + -- print x + -- print y + inputPathM <- case inputPaths of + [] -> do + return Nothing + [x] -> return $ Just x + _ -> do + liftIO $ putStrLn $ "more than one input, aborting" + System.Exit.exitWith (System.Exit.ExitFailure 50) + outputPath <- case outputPaths of + [] -> do + return Nothing + [x] -> return $ Just x + _ -> do + liftIO $ putStrLn $ "more than one output, aborting" + System.Exit.exitWith (System.Exit.ExitFailure 50) + let configPath = maybe "brittany.yaml" id $ listToMaybe $ reverse configPaths + config <- do + may <- runMaybeT $ readMergePersConfig cmdlineConfig configPath + case may of + Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 50) + Just x -> return x + when (runIdentity $ _dconf_dump_config $ _conf_debug $ config) $ do + trace (showTree config) $ return () + liftIO $ do + parseResult <- case inputPathM of + Nothing -> ExactPrint.Parsers.parseModuleFromString "stdin" + =<< System.IO.hGetContents System.IO.stdin + Just p -> ExactPrint.parseModule p + case parseResult of + Left left -> do + putStrLn "parse error:" + print left + System.Exit.exitWith (System.Exit.ExitFailure 60) + Right (anns, parsedSource) -> do + when (config & _conf_debug .> _dconf_dump_ast_full .> runIdentity) $ do + let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + trace ("---- ast ----\n" ++ show val) $ return () + -- mapM_ print (Map.toList anns) + -- let L _ (HsModule name exports imports decls _ _) = parsedSource + -- let someDecls = take 3 decls + -- -- let out = ExactPrint.exactPrint parsedSource anns + -- let out = do + -- decl <- someDecls + -- ExactPrint.exactPrint decl anns + let (errsWarns, outLText) = pPrintModule config anns parsedSource + let customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder LayoutErrorUnusedComment{} = 1 + customErrOrder LayoutErrorUnknownNode{} = 2 + when (not $ null errsWarns) $ do + let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns + groupedErrsWarns `forM_` \case + uns@(LayoutErrorUnknownNode{}:_) -> do + putStrLn $ "ERROR: encountered unknown syntactical constructs:" + uns `forM_` \case + LayoutErrorUnknownNode str ast -> do + putStrLn str + putStrLn $ " " ++ show (astToDoc ast) + _ -> error "cannot happen (TM)" + warns@(LayoutWarning{}:_) -> do + putStrLn $ "WARNINGS:" + warns `forM_` \case + LayoutWarning str -> putStrLn str + _ -> error "cannot happen (TM)" + unused@(LayoutErrorUnusedComment{}:_) -> do + putStrLn $ "Error: detected unprocessed comments. the transformation " + ++ "output will most likely not contain certain of the comments " + ++ "present in the input haskell source file." + putStrLn $ "Affected are the following comments:" + unused `forM_` \case + LayoutErrorUnusedComment str -> putStrLn str + _ -> error "cannot happen (TM)" + [] -> error "cannot happen" + -- TODO: don't output anything when there are errors unless user + -- adds some override? + let hasErrors = case config + & _conf_errorHandling + & _econf_Werror + & runIdentity of + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + outputOnErrs = config + & _conf_errorHandling + & _econf_produceOutputOnErrors + & runIdentity + let shouldOutput = not suppressOutput + && (not hasErrors || outputOnErrs) + + when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPath of + Nothing -> TextL.IO.putStr $ outLText + Just p -> TextL.IO.writeFile p $ outLText + + when hasErrors $ + System.Exit.exitWith (System.Exit.ExitFailure 70) + where + addTraceSep conf = if foldr1 (||) + [ runIdentity $ _dconf_dump_annotations conf + , runIdentity $ _dconf_dump_ast_unknown conf + , runIdentity $ _dconf_dump_ast_full conf + , runIdentity $ _dconf_dump_bridoc_raw conf + , runIdentity $ _dconf_dump_bridoc_simpl_alt conf + , runIdentity $ _dconf_dump_bridoc_simpl_floating conf + , runIdentity $ _dconf_dump_bridoc_simpl_columns conf + , runIdentity $ _dconf_dump_bridoc_simpl_indent conf + , runIdentity $ _dconf_dump_bridoc_final conf + ] + then trace "----" + else id diff --git a/src-idemtests/.gitignore b/src-idemtests/.gitignore new file mode 100644 index 0000000..4830bd8 --- /dev/null +++ b/src-idemtests/.gitignore @@ -0,0 +1,4 @@ +iterOne/ +iterTwo/ +brittany +report.txt diff --git a/src-idemtests/README b/src-idemtests/README new file mode 100644 index 0000000..3560f17 --- /dev/null +++ b/src-idemtests/README @@ -0,0 +1,17 @@ +idempotency testing on real-life examples, i.e. checks that brittany(x) is +equal to brittany(brittany(x)) for some x's. The idea is that these testcases +are not yet transformed, i.e. that x is not brittany(x). This can capture +certain bugs that are not detected by checking that brittany behaves as +identity on "well-formed" input. + +to run: + +- put a "brittany" executable into this directory. +- cd into this directory. +- ./run.sh + +report.txt will contain the results. + +note that only the configuration in brittany.yaml is tested, which contains +the default settings. ideally this would be managed in some other, more +transparent fashion. diff --git a/src-idemtests/brittany.yaml b/src-idemtests/brittany.yaml new file mode 100644 index 0000000..1f18887 --- /dev/null +++ b/src-idemtests/brittany.yaml @@ -0,0 +1,23 @@ +_conf_errorHandling: + _econf_Werror: false + _econf_produceOutputOnErrors: false +_conf_layout: + _lconfig_indentPolicy: IndentPolicyFree + _lconfig_cols: 80 + _lconfig_indentAmount: 2 + _lconfig_importColumn: 60 + _lconfig_altChooser: AltChooserShallowBest + _lconfig_indentWhereSpecial: true + _lconfig_indentListSpecial: true +_conf_debug: + _dconf_dump_annotations: false + _dconf_dump_bridoc_simpl_par: false + _dconf_dump_bridoc_simpl_indent: false + _dconf_dump_bridoc_simpl_floating: false + _dconf_dump_ast_full: false + _dconf_dump_bridoc_simpl_columns: false + _dconf_dump_ast_unknown: false + _dconf_dump_bridoc_simpl_alt: false + _dconf_dump_bridoc_final: false + _dconf_dump_bridoc_raw: false + _dconf_dump_config: false diff --git a/src-idemtests/cases/LayoutBasics.hs b/src-idemtests/cases/LayoutBasics.hs new file mode 100644 index 0000000..4f853cc --- /dev/null +++ b/src-idemtests/cases/LayoutBasics.hs @@ -0,0 +1,747 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE KindSignatures #-} + +module Language.Haskell.Brittany.LayoutBasics + ( processDefault + , layoutByExact + -- , layoutByExactR + , descToBlockStart + , descToBlockMinMax + , descToMinMax + , rdrNameToText + , lrdrNameToText + , lrdrNameToTextAnn + , askIndent + , calcLayoutMin + , calcLayoutMax + , getCurRemaining + , layoutWriteAppend + , layoutWriteAppendMultiline + , layoutWriteNewline + , layoutWriteNewlinePlain + , layoutWriteEnsureNewline + , layoutWriteEnsureBlock + , layoutWriteEnsureBlockPlusN + , layoutWithAddIndent + , layoutWithAddIndentBlock + , layoutWithAddIndentN + , layoutWithAddIndentNBlock + , layoutWithNonParamIndent + , layoutWriteEnsureAbsoluteN + , layoutAddSepSpace + , moveToExactAnn + , moveToExactAnn' + , setOpIndent + , stringLayouter + , layoutWritePriorComments + , layoutWritePostComments + , layoutIndentRestorePostComment + , layoutWritePriorCommentsRestore + , layoutWritePostCommentsRestore + , extractCommentsPrior + , extractCommentsPost + , applyLayouter + , applyLayouterRestore + , filterAnns + , layouterFToLayouterM + , ppmMoveToExactLoc + , customLayouterF + , docEmpty + , docLit + , docAlt + , docSeq + , docPar + -- , docCols + , docPostComment + , docWrapNode + , briDocByExact + , fromMaybeIdentity + , foldedAnnKeys + ) +where + + + +-- more imports here.. + +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.Utils as ExactPrint.Utils + +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.Utils + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import qualified Outputable as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified SrcLoc as GHC +import SrcLoc ( SrcSpan ) +import OccName ( occNameString ) +import Name ( getOccString ) +import Module ( moduleName ) +import ApiAnnotation ( AnnKeywordId(..) ) + +import Data.Data +import Data.Generics.Schemes +import Data.Generics.Aliases + +import DataTreePrint + +import qualified Text.PrettyPrint as PP + +import Data.Function ( fix ) + + + +processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter + Text.Builder.Builder m, + MonadMultiReader ExactPrint.Types.Anns m) + => GenLocated SrcSpan 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! + --test + case str of + "\n" -> return () + _ -> mTell $ Text.Builder.fromString $ str + + +layoutByExact :: ( MonadMultiReader Config m + , MonadMultiReader (ExactPrint.Types.Anns) m + , ExactPrint.Annotate.Annotate ast + ) + => GenLocated SrcSpan ast -> m Layouter +layoutByExact x = do + anns <- mAsk + trace (showTreeWithCustom (customLayouterF anns) x) $ layoutByExactR x + -- trace (ExactPrint.Utils.showAnnData anns 2 x) $ layoutByExactR x + +layoutByExactR :: (MonadMultiReader Config m + , MonadMultiReader (ExactPrint.Types.Anns) m + , ExactPrint.Annotate.Annotate ast) + => GenLocated SrcSpan ast -> m Layouter +layoutByExactR x = do + indent <- askIndent + anns <- mAsk + let t = Text.pack $ ExactPrint.exactPrint x anns + let tlines = Text.lines $ t <> Text.pack "\n" + tlineCount = length tlines + let len = indent + maximum (Text.length <$> tlines) + return $ Layouter + { _layouter_desc = LayoutDesc Nothing $ Just $ BlockDesc AllSameIndent len len Nothing + , _layouter_func = \_ -> do + -- layoutWriteEnsureBlock + layoutWriteAppend $ Text.pack $ "{-" ++ show (ExactPrint.Types.mkAnnKey x, Map.lookup (ExactPrint.Types.mkAnnKey x) anns) ++ "-}" + zip [1..] tlines `forM_` \(i, l) -> do + layoutWriteAppend $ l + unless (i==tlineCount) layoutWriteNewline + do + let subKeys = foldedAnnKeys x + state <- mGet + let filterF k _ = not $ k `Set.member` subKeys + mSet $ state + { _lstate_commentsPrior = Map.filterWithKey filterF + $ _lstate_commentsPrior state + , _lstate_commentsPost = Map.filterWithKey filterF + $ _lstate_commentsPost state + } + , _layouter_ast = x + } + +briDocByExact :: (ExactPrint.Annotate.Annotate ast, + MonadMultiReader Config m, + MonadMultiReader ExactPrint.Types.Anns m + ) => GenLocated SrcSpan ast -> m BriDoc +briDocByExact ast = do + anns <- mAsk + traceIfDumpConf "ast" _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) + return $ docExt ast anns + +descToBlockStart :: LayoutDesc -> Maybe BlockStart +descToBlockStart (LayoutDesc _ (Just (BlockDesc bs _ _ _))) = Just bs +descToBlockStart (LayoutDesc (Just line) _) = Just $ RestOfLine line +descToBlockStart _ = Nothing + +descToBlockMinMax :: LayoutDesc -> Maybe (Int, Int) +descToBlockMinMax (LayoutDesc _ (Just (BlockDesc _ bmin bmax _))) = Just (bmin, bmax) +descToBlockMinMax _ = Nothing + +descToMinMax :: Int -> LayoutDesc -> Maybe (Int, Int) +descToMinMax p (LayoutDesc _ (Just (BlockDesc start bmin bmax _))) = + Just (max rolMin bmin, max rolMin bmax) + where + rolMin = case start of + RestOfLine rol -> p + _lColumns_min rol + AllSameIndent -> 0 + +descToMinMax p (LayoutDesc (Just (LayoutColumns _ _ lmin)) _) = + Just (len, len) + where + len = p + lmin +descToMinMax _ _ = + Nothing + +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 + +lrdrNameToTextAnn :: ( MonadMultiReader Config m + , MonadMultiReader (Map AnnKey Annotation) m + ) + => GenLocated SrcSpan RdrName + -> m Text +lrdrNameToTextAnn ast@(L _ n) = do + anns <- mAsk + let t = 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 -> traceShow "Nothing" t + Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> if + | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" + | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" + | otherwise -> t + + +askIndent :: (MonadMultiReader Config m) => m Int +askIndent = runIdentity . _lconfig_indentAmount . _conf_layout <$> mAsk + +-- minimum block width, judged from block info or line, whichever is +-- available. +-- example: calcLayoutMin doBlock ~~~ atomically $ do +-- foo +-- ## indent +-- ############# linepre +-- ############### result (in this case) +calcLayoutMin :: Int -- basic indentation amount + -> Int -- currently used width in current line (after indent) + -- used to accurately calc placing of the current-line + -- stuff ("do" in the above example) and its width. + -> LayoutDesc + -> Int +calcLayoutMin indent linePre (LayoutDesc line block) = case (line, block) of + (_, Just (BlockDesc AllSameIndent m _ _)) -> indent + m + (_, Just (BlockDesc (RestOfLine inl) m _ _)) -> max (linePre + _lColumns_min inl) (indent + m) + (Just s, _) -> indent + _lColumns_min s + _ -> error "bad LayoutDesc mnasdoiucxvlkjasd" + +-- see +calcLayoutMax :: Int -- basic indentation amount + -> Int -- currently used width in current line (after indent) + -- used to accurately calc placing of the current-line + -- stuff ("do" in the above example) and its width. + -> LayoutDesc + -> Int +calcLayoutMax indent linePre (LayoutDesc line block) = case (line, block) of + (Just s, _) -> linePre + _lColumns_min s + (_, Just (BlockDesc AllSameIndent _ m _)) -> indent + m + (_, Just (BlockDesc (RestOfLine inl) _ m _)) -> max (linePre + _lColumns_min inl) (indent + m) + _ -> error "bad LayoutDesc msdnfgouvadnfoiu" + +getCurRemaining :: ( MonadMultiReader Config m + , MonadMultiState LayoutState m + ) + => m Int +getCurRemaining = do + cols <- mAsk <&> _conf_layout .> _lconfig_cols .> runIdentity + clc <- _lstate_curLineCols <$> mGet + return $ cols - clc + +layoutWriteAppend :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Text + -> m () +layoutWriteAppend t = do + state <- mGet + if _lstate_addSepSpace state + then do + mSet $ state { _lstate_curLineCols = _lstate_curLineCols state + Text.length t + 1 + , _lstate_addSepSpace = False + } + mTell $ Text.Builder.fromText $ Text.pack " " <> t + else do + mSet $ state { _lstate_curLineCols = _lstate_curLineCols state + Text.length t } + mTell $ Text.Builder.fromText t + +layoutWriteAppendMultiline :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Text + -> m () +layoutWriteAppendMultiline t = case Text.lines t of + [] -> return () + (l:lr) -> do + layoutWriteAppend l + lr `forM_` \x -> do + layoutWriteNewlinePlain + layoutWriteAppend x + +-- adds a newline and adds spaces to reach the current indentation level. +-- TODO: rename newline -> newlineBlock and newlinePlain -> newline +layoutWriteNewline :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => m () +layoutWriteNewline = do + state <- mGet + mSet $ state { _lstate_curLineCols = _lstate_indent state + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = False + } + mTell $ Text.Builder.fromString $ "\n" ++ replicate (_lstate_indent state) ' ' + +-- | does _not_ add spaces to again reach the current indentation levels. +layoutWriteNewlinePlain :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => m () +layoutWriteNewlinePlain = do + state <- mGet + mSet $ state { _lstate_curLineCols = 0 + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = False + } + mTell $ Text.Builder.fromString $ "\n" + +layoutWriteEnsureNewline :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => m () +layoutWriteEnsureNewline = do + state <- mGet + when (_lstate_curLineCols state /= _lstate_indent state) + $ layoutWriteNewline + +layoutWriteEnsureBlock :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => m () +layoutWriteEnsureBlock = do + state <- mGet + let diff = _lstate_curLineCols state - _lstate_indent state + if diff>0 + then layoutWriteNewline + else if diff<0 + then do + layoutWriteAppend $ Text.pack $ replicate (negate diff) ' ' + mSet $ state { _lstate_curLineCols = _lstate_indent state + , _lstate_addSepSpace = False + } + else return () + +layoutWriteEnsureAbsoluteN :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Int -> m () +layoutWriteEnsureAbsoluteN n = do + state <- mGet + let diff = n - _lstate_curLineCols state + if diff>0 + then do + layoutWriteAppend $ Text.pack $ replicate diff ' ' + mSet $ state { _lstate_curLineCols = n + , _lstate_addSepSpace = False + } + else return () + +layoutWriteEnsureBlockPlusN :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Int -> m () +layoutWriteEnsureBlockPlusN n = do + state <- mGet + let diff = _lstate_curLineCols state - _lstate_indent state - n + if diff>0 + then layoutWriteNewline + else if diff<0 + then do + layoutWriteAppend $ Text.pack $ replicate (negate diff) ' ' + mSet $ state { _lstate_addSepSpace = False } + else return () + +layoutWithAddIndent :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + ,MonadMultiReader Config m) + => m () + -> m () +layoutWithAddIndent m = do + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + state <- mGet + mSet state { _lstate_indent = _lstate_indent state + amount } + m + do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } + +layoutWithAddIndentBlock :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + ,MonadMultiReader Config m) + => m () + -> m () +layoutWithAddIndentBlock m = do + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + state <- mGet + mSet state { _lstate_indent = _lstate_indent state + amount } + layoutWriteEnsureBlock + m + do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } + +layoutWithAddIndentNBlock :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Int + -> m () + -> m () +layoutWithAddIndentNBlock amount m = do + state <- mGet + mSet state { _lstate_indent = _lstate_indent state + amount } + layoutWriteEnsureBlock + m + do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } + +layoutWithAddIndentN :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Int + -> m () + -> m () +layoutWithAddIndentN amount m = do + state <- mGet + mSet state { _lstate_indent = _lstate_indent state + amount } + m + do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } + +layoutAddSepSpace :: MonadMultiState LayoutState m => m () +layoutAddSepSpace = do + state <- mGet + mSet $ state { _lstate_addSepSpace = True } + +moveToExactAnn :: (Data.Data.Data x, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m, + MonadMultiReader (Map AnnKey Annotation) m) => GenLocated SrcSpan x -> m () +moveToExactAnn ast = do + anns <- mAsk + case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of + Nothing -> return () + Just ann -> do + let ExactPrint.Types.DP (x, _y) = ExactPrint.Types.annEntryDelta ann + replicateM_ x $ layoutWriteNewline + +-- 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 + anns <- mAsk + case Map.lookup annKey anns of + Nothing -> return () + Just ann -> do + -- curY <- mGet <&> _lstate_curLineCols + let ExactPrint.Types.DP (x, _y) = ExactPrint.Types.annEntryDelta ann + replicateM_ x $ layoutWriteNewline + -- when (x/=0) $ do + -- replicateM_ x $ layoutWriteNewlinePlain + -- mModify $ \s -> s { _lstate_curLineCols = curY } + -- mTell $ Text.Builder.fromString $ replicate curY ' ' + +ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m + => ExactPrint.Types.DeltaPos + -> m () +ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do + replicateM_ x $ mTell $ Text.Builder.fromString "\n" + replicateM_ y $ mTell $ Text.Builder.fromString " " + +layoutWithNonParamIndent :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => LayoutFuncParams -> m () -> m () +layoutWithNonParamIndent params m = do + case _params_opIndent params of + Nothing -> m + Just x -> layoutWithAddIndentN x m + +setOpIndent :: Int -> LayoutDesc -> LayoutFuncParams -> LayoutFuncParams +setOpIndent i desc p = p + { _params_opIndent = Just $ case _bdesc_opIndentFloatUp =<< _ldesc_block desc of + Nothing -> i + Just j -> max i j + } + +stringLayouter :: Data.Data.Data ast + => GenLocated SrcSpan ast -> Text -> Layouter +stringLayouter ast t = Layouter + { _layouter_desc = LayoutDesc + { _ldesc_line = Just $ LayoutColumns + { _lColumns_key = ColumnKeyUnique + , _lColumns_lengths = [Text.length t] + , _lColumns_min = Text.length t + } + , _ldesc_block = Nothing + } + , _layouter_func = \_ -> do + layoutWritePriorCommentsRestore ast + layoutWriteAppend t + layoutWritePostComments ast + , _layouter_ast = ast + } + +layoutWritePriorComments :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m) + => GenLocated SrcSpan ast -> m () +layoutWritePriorComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.Types.mkAnnKey ast + let m = _lstate_commentsPrior state + let mAnn = Map.lookup key m + mSet $ state { _lstate_commentsPrior = Map.delete key m } + return mAnn + case mAnn of + Nothing -> return () + Just priors -> do + when (not $ null priors) $ do + state <- mGet + mSet $ state { _lstate_commentCol = Just $ _lstate_curLineCols state } + priors `forM_` \( ExactPrint.Types.Comment comment _ _ + , ExactPrint.Types.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewlinePlain + layoutWriteAppend $ Text.pack $ replicate y ' ' + layoutWriteAppendMultiline $ Text.pack $ comment + +-- 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) + => GenLocated SrcSpan ast -> m () +layoutWritePostComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.Types.mkAnnKey ast + let m = _lstate_commentsPost state + let mAnn = Map.lookup key m + mSet $ state { _lstate_commentsPost = Map.delete key m } + return mAnn + case mAnn of + Nothing -> return () + Just posts -> do + when (not $ null posts) $ do + state <- mGet + mSet $ state { _lstate_commentCol = Just $ _lstate_curLineCols state } + posts `forM_` \( ExactPrint.Types.Comment comment _ _ + , ExactPrint.Types.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewlinePlain + layoutWriteAppend $ Text.pack $ replicate y ' ' + layoutWriteAppendMultiline $ Text.pack $ comment + +layoutIndentRestorePostComment :: ( Monad m + , MonadMultiState LayoutState m + , MonadMultiWriter Text.Builder.Builder m + ) + => m () +layoutIndentRestorePostComment = do + mCommentCol <- _lstate_commentCol <$> mGet + case mCommentCol of + Nothing -> return () + Just commentCol -> do + layoutWriteNewlinePlain + layoutWriteAppend $ Text.pack $ replicate commentCol ' ' + +layoutWritePriorCommentsRestore :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m) + => GenLocated SrcSpan ast -> m () +layoutWritePriorCommentsRestore x = do + layoutWritePriorComments x + layoutIndentRestorePostComment + +layoutWritePostCommentsRestore :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m) + => GenLocated SrcSpan ast -> m () +layoutWritePostCommentsRestore x = do + layoutWritePostComments x + layoutIndentRestorePostComment + +extractCommentsPrior :: ExactPrint.Types.Anns -> PriorMap +extractCommentsPrior anns = flip Map.mapMaybe anns $ \ann -> + [r | let r = ExactPrint.Types.annPriorComments ann, not (null r)] +extractCommentsPost :: ExactPrint.Types.Anns -> PostMap +extractCommentsPost anns = flip Map.mapMaybe anns $ \ann -> + [r + | let + r = ExactPrint.Types.annsDP ann + >>= \case + (ExactPrint.Types.AnnComment comment, dp) -> [(comment, dp)] + _ -> [] + , not (null r) + ] + + +applyLayouter :: Layouter -> LayoutFuncParams -> LayoutM () +applyLayouter l@(Layouter _ _ ast) params = do + -- (always) write the prior comments at this point. + layoutWritePriorCommentsRestore ast + -- run the real stuff. + _layouter_func l params + -- if the _layouter_func has not done so already at some point + -- (there are nodes for which this makes sense), + -- write the post comments. + -- effect is `return ()` if there are no postComments. + layoutWritePostComments ast + +applyLayouterRestore :: Layouter -> LayoutFuncParams -> LayoutM () +applyLayouterRestore l@(Layouter _ _ ast) params = do + -- (always) write the prior comments at this point. + layoutWritePriorCommentsRestore ast + -- run the real stuff. + _layouter_func l params + -- if the _layouter_func has not done so already at some point + -- (there are nodes for which this makes sense), + -- write the post comments. + -- effect is `return ()` if there are no postComments. + layoutWritePostCommentsRestore ast + +foldedAnnKeys :: Data.Data.Data ast + => ast + -> Set ExactPrint.Types.AnnKey +foldedAnnKeys ast = everything + Set.union + (\x -> maybe + Set.empty + Set.singleton + [ gmapQi 1 (\t -> ExactPrint.Types.mkAnnKey $ L l t) x + | typeRepTyCon (typeOf (L () ())) == (typeRepTyCon (typeOf x)) + , l <- gmapQi 0 cast x + ] + ) + ast + +filterAnns :: Data.Data.Data ast + => ast + -> ExactPrint.Types.Anns + -> ExactPrint.Types.Anns +filterAnns ast anns = + Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns + +layouterFToLayouterM :: MultiReader '[Config, ExactPrint.Types.Anns] a -> LayoutM a +layouterFToLayouterM m = do + settings <- mAsk + anns <- mAsk + return $ runIdentity + $ runMultiReaderTNil + $ Control.Monad.Trans.MultiReader.Lazy.withMultiReader anns + $ Control.Monad.Trans.MultiReader.Lazy.withMultiReader settings + $ m + +-- new BriDoc stuff + +docEmpty :: BriDoc +docEmpty = BDEmpty + +docLit :: Text -> BriDoc +docLit t = BDLit t + +docExt :: ExactPrint.Annotate.Annotate ast + => GenLocated SrcSpan ast -> ExactPrint.Types.Anns -> BriDoc +docExt x anns = BDExternal + (ExactPrint.Types.mkAnnKey x) + (foldedAnnKeys x) + (Text.pack $ ExactPrint.exactPrint x anns) + +docAlt :: [BriDoc] -> BriDoc +docAlt = BDAlt + + +docSeq :: [BriDoc] -> BriDoc +docSeq = BDSeq + + +docPostComment :: Data.Data.Data ast + => GenLocated SrcSpan ast + -> BriDoc + -> BriDoc +docPostComment ast bd = BDAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd + +docWrapNode :: Data.Data.Data ast + => GenLocated SrcSpan ast + -> BriDoc + -> BriDoc +docWrapNode ast bd = BDAnnotationPrior (ExactPrint.Types.mkAnnKey ast) + $ BDAnnotationPost (ExactPrint.Types.mkAnnKey ast) + $ bd + +docPar :: BriDoc + -> BriDoc + -> BriDoc +docPar line indented = BDPar BrIndentNone line indented + +-- docPar :: BriDoc +-- -> BrIndent +-- -> [BriDoc] +-- -> BriDoc +-- docPar = BDPar + +-- docCols :: ColSig +-- -> [BriDoc] +-- -> BriDoc +-- docCols = BDCols + + +fromMaybeIdentity :: Identity a -> Maybe a -> Identity a +fromMaybeIdentity x y = Data.Coerce.coerce + $ fromMaybe (Data.Coerce.coerce x) y diff --git a/src-idemtests/run.sh b/src-idemtests/run.sh new file mode 100755 index 0000000..e4b2f69 --- /dev/null +++ b/src-idemtests/run.sh @@ -0,0 +1,36 @@ +#!/bin/bash + +# set -x +set -e + +rm report.txt &> /dev/null || true + +mkdir iterOne &> /dev/null || true +mkdir iterTwo &> /dev/null || true + +for FILE in ./cases/* +do + NAME=$(basename "$FILE") + ITERNAMEONE="./iterOne/$NAME" + ITERNAMETWO="./iterTwo/$NAME" + if ! ./brittany -i "$FILE" -o "$ITERNAMEONE" + then + echo "FAILED step 1 for $FILE" | tee -a report.txt + continue + fi + if ! ./brittany -i "$ITERNAMEONE" -o "$ITERNAMETWO" + then + echo "FAILED step 2 for $FILE" | tee -a report.txt + continue + fi + if ! diff "$ITERNAMEONE" "$ITERNAMETWO" > diff.temp + then + echo "FAILED diff for $FILE with diff:" | tee -a report.txt + cat diff.temp | tee -a report.txt + echo "# meld $(realpath $ITERNAMEONE) $(realpath $ITERNAMETWO)" | tee -a report.txt + continue + fi + echo "success for $FILE" | tee -a report.txt +done + +rm diff.temp diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs new file mode 100644 index 0000000..812aa85 --- /dev/null +++ b/src-unittests/AsymptoticPerfTests.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} + +module AsymptoticPerfTests + ( asymptoticPerfTest + ) +where + + + +#include "prelude.inc" + +import Test.Hspec + +import NeatInterpolation + +import Language.Haskell.Brittany + +import TestUtils + + + +asymptoticPerfTest :: Spec +asymptoticPerfTest = do + it "1000 do statements" $ roundTripEqualWithTimeout 50000 $ + ( Text.pack "func = do\n") + <> Text.replicate 1000 (Text.pack " statement\n") + it "1000 do nestings" $ roundTripEqualWithTimeout 500000 $ + ( Text.pack "func = ") + <> mconcat ([0..999] <&> \(i::Int) -> (Text.replicate (2*i) (Text.pack " ") <> Text.pack "do\n")) + <> Text.replicate 2000 (Text.pack " ") <> Text.pack "return\n" + <> Text.replicate 2002 (Text.pack " ") <> Text.pack "()" diff --git a/src-unittests/IdentityTests.hs b/src-unittests/IdentityTests.hs new file mode 100644 index 0000000..08d3ea1 --- /dev/null +++ b/src-unittests/IdentityTests.hs @@ -0,0 +1,537 @@ +{-# LANGUAGE QuasiQuotes #-} + +module IdentityTests + ( identityTests + ) +where + + + +#include "prelude.inc" + +import Test.Hspec + +import NeatInterpolation + +import Language.Haskell.Brittany + +import TestUtils + + + +identityTests :: Spec +identityTests = do + describe "type signatures" $ typeSignatureTests + describe "equation" $ do + describe "basic" $ basicEquationTests + describe "patterns" $ patternTests + describe "guards" $ guardTests + describe "expression" $ do + describe "basic" $ basicExpressionTests + describe "do statements" $ doStatementTests + describe "alignment" $ alignmentTests + describe "regression" $ regressionTests + +typeSignatureTests :: Spec +typeSignatureTests = do + it "simple001" $ roundTripEqual $ + [text| + func :: a -> a + |] + it "long typeVar" $ roundTripEqual $ + [text| + func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + |] + it "keep linebreak mode" $ roundTripEqual $ + [text| + func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj + |] + it "simple parens 1" $ roundTripEqual $ + [text| + func :: ((a)) + |] + it "simple parens 2" $ roundTripEqual $ + [text| + func :: (a -> a) -> a + |] + it "simple parens 3" $ roundTripEqual $ + [text| + func :: a -> (a -> a) + |] + it "did anyone say parentheses?" $ roundTripEqual $ + [text| + func :: (((((((((()))))))))) + |] + before_ pending $ it "give me more!" $ roundTripEqual $ + -- current output is.. funny. wonder if that can/needs to be improved.. + [text| + func :: ((((((((((((((((((((((((((((((((((((((((((())))))))))))))))))))))))))))))))))))))))))) + |] + it "unit" $ roundTripEqual $ + [text| + func :: () + |] + -- ################################################################## -- + -- ################################################################## -- + -- ################################################################## -- + it "paren'd func 1" $ roundTripEqual $ + [text| + func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj + ) + |] + it "paren'd func 2" $ roundTripEqual $ + [text| + func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> (lakjsdlkjasldkj -> lakjsdlkjasldkj) + |] + it "paren'd func 3" $ roundTripEqual $ + [text| + func + :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj) + -> lakjsdlkjasldkj + |] + it "paren'd func 4" $ roundTripEqual $ + [text| + func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> lakjsdlkjasldkj + |] + it "paren'd func 5" $ roundTripEqual $ + [text| + func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) + |] + -- ################################################################## -- + -- ################################################################## -- + -- ################################################################## -- + it "type application 1" $ roundTripEqual $ + [text| + func :: asd -> Either a b + |] + it "type application 2" $ roundTripEqual $ + [text| + func + :: asd + -> Either + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + |] + it "type application 3" $ roundTripEqual $ + [text| + func + :: asd + -> Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + |] + it "type application 4" $ roundTripEqual $ + [text| + func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd + |] + it "type application 5" $ roundTripEqual $ + [text| + func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd) + |] + it "type application 6" $ roundTripEqual $ + [text| + func + :: Trither + asd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + |] + it "type application paren 1" $ roundTripEqual $ + [text| + func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + |] + it "type application paren 2" $ roundTripEqual $ + [text| + func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + |] + it "type application paren 3" $ roundTripEqual $ + [text| + func + :: ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd + |] + -- ################################################################## -- + -- ################################################################## -- + -- ################################################################## -- + it "list simple" $ roundTripEqual $ + [text| + func :: [a -> b] + |] + it "list func" $ roundTripEqual $ + [text| + func + :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ] + |] + it "list paren" $ roundTripEqual $ + [text| + func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] + |] + -- ################################################################## -- + -- ################################################################## -- + -- ################################################################## -- + it "tuple type 1" $ roundTripEqual $ + [text| + func :: (a, b, c) + |] + it "tuple type 2" $ roundTripEqual $ + [text| + func :: ((a, b, c), (a, b, c), (a, b, c)) + |] + it "tuple type long" $ roundTripEqual $ + [text| + func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + |] + it "tuple type nested" $ roundTripEqual $ + [text| + func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd) + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) + |] + it "tuple type function" $ roundTripEqual $ + [text| + func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] + |] + -- ################################################################## -- + -- ################################################################## -- + -- ################################################################## -- + before_ pending $ it "type operator stuff" $ roundTripEqual $ + [text| + test050 :: a :+: b + test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + |] + -- ################################################################## -- + -- ################################################################## -- + -- ################################################################## -- + it "forall oneliner" $ roundTripEqual $ + [text| + {-# LANGUAGE ScopedTypeVariables #-} + --this comment is necessary for whatever reason.. + func :: forall (a :: *) b . a -> b + |] + it "language pragma issue" $ roundTripEqual $ + [text| + {-# LANGUAGE ScopedTypeVariables #-} + func :: forall (a :: *) b . a -> b + |] + it "comments 1" $ roundTripEqual $ + [text| + func :: a -> b -- comment + |] + it "comments 2" $ roundTripEqual $ + [text| + funcA :: a -> b -- comment A + funcB :: a -> b -- comment B + |] + before_ pending $ it "comments all" $ roundTripEqual $ + [text| + -- a + func -- b + :: -- c + a -- d + -> -- e + ( -- f + c -- g + , -- h + d -- i + ) -- j + -- k + |] + -- ################################################################## -- + -- ################################################################## -- + -- ################################################################## -- + it "ImplicitParams 1" $ roundTripEqual $ + [text| + {-# LANGUAGE ImplicitParams #-} + func :: (?asd::Int) -> () + |] + it "ImplicitParams 2" $ roundTripEqual $ + [text| + {-# LANGUAGE ImplicitParams #-} + func + :: ( ?asd + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> () + |] + + + +-- some basic testing of different kinds of equations. +-- some focus on column layouting for multiple-equation definitions. +-- (that part probably is not implemented in any way yet.) +basicEquationTests :: Spec +basicEquationTests = do + it "basic 1" $ roundTripEqual $ + [text| + func x = x + |] + it "infix 1" $ roundTripEqual $ + [text| + x *** y = x + |] + it "symbol prefix" $ roundTripEqual $ + [text| + (***) x y = x + |] + + + +patternTests :: Spec +patternTests = do + it "wildcard" $ roundTripEqual $ + [text| + func _ = x + |] + before_ pending $ it "simple long pattern" $ roundTripEqual $ + [text| + func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + = x + |] + before_ pending $ it "simple multiline pattern" $ roundTripEqual $ + [text| + func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + = x + |] + before_ pending $ it "another multiline pattern" $ roundTripEqual $ + [text| + func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + a + b + = x + |] + before_ pending $ it "simple constructor" $ roundTripEqual $ + [text| + func (A a) = a + |] + before_ pending $ it "list constructor" $ roundTripEqual $ + [text| + func (x:xr) = x + |] + before_ pending $ it "some other constructor symbol" $ roundTripEqual $ + [text| + func (x:+:xr) = x + |] + +guardTests :: Spec +guardTests = do + it "simple guard" $ roundTripEqual $ + [text| + func | True = x + |] + +basicExpressionTests :: Spec +basicExpressionTests = do + it "var" $ roundTripEqual $ + [text| + func = x + |] + describe "infix op" $ do + it "1" $ roundTripEqual $ + [text| + func = x + x + |] + before_ pending $ it "long" $ roundTripEqual $ + [text| + func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + |] + before_ pending $ it "long keep linemode 1" $ roundTripEqual $ + [text| + func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj + |] + before_ pending $ it "long keep linemode 2" $ roundTripEqual $ + [text| + func = mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + |] + it "literals" $ roundTripEqual $ + [text| + func = 1 + func = "abc" + func = 1.1e5 + func = 'x' + func = 981409823458910394810928414192837123987123987123 + |] + it "lambdacase" $ roundTripEqual $ + [text| + {-# LANGUAGE LambdaCase #-} + func = \case + FooBar -> x + Baz -> y + |] + + +doStatementTests :: Spec +doStatementTests = do + it "simple" $ roundTripEqual $ + [text| + func = do + stmt + stmt + |] + it "bind" $ roundTripEqual $ + [text| + func = do + x <- stmt + stmt x + |] + it "let" $ roundTripEqual $ + [text| + func = do + let x = 13 + stmt x + |] + return () + +alignmentTests :: Spec +alignmentTests = do + return () + +regressionTests :: Spec +regressionTests = do + it "newlines-comment" $ do + roundTripEqual $ + [text| + func = do + abc <- foo + + --abc + return () + |] + it "parenthesis-around-unit" $ do + roundTripEqual $ + [text| + func = (()) + |] + it "let-defs indentation" $ do + roundTripEqual $ + [text| + func = do + let foo True = True + foo _ = False + return () + |] + it "record update indentation" $ do + roundTripEqual $ + [text| + func = do + s <- mGet + mSet $ s + { _lstate_indent = _lstate_indent state + } + |] + it "post-indent comment" $ do + roundTripEqual $ + [text| + func = do + -- abc + -- def + return () + |] + it "post-unindent comment" $ do + roundTripEqual $ + [text| + func = do + do + return () + -- abc + -- def + return () + |] + it "CPP empty comment case" $ do + pendingWith "CPP parsing needs fixing for roundTripEqual" + roundTripEqual $ + [text| + {-# LANGUAGE CPP #-} + module Test where + func = do + #if FOO + let x = 13 + #endif + stmt x + |] + -- really, the following should be handled by forcing the Alt to multiline + -- because there are comments. as long as this is not implemented though, + -- we should ensure the trivial solution works. + it "comment inline placement (temporary)" $ do + roundTripEqual $ + [text| + func :: Int -> -- basic indentation amount + Int -> -- currently used width in current line (after indent) + -- used to accurately calc placing of the current-line + LayoutDesc -> Int + |] diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs new file mode 100644 index 0000000..fe6d099 --- /dev/null +++ b/src-unittests/TestMain.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Main where + + + +#include "prelude.inc" + +import Test.Hspec + +import NeatInterpolation + +import Language.Haskell.Brittany + +import IdentityTests +import AsymptoticPerfTests + + + +main :: IO () +main = hspec $ tests + +tests :: Spec +tests = do + describe "identity roundtrips" $ identityTests + describe "asymptotic perf roundtrips" $ asymptoticPerfTest diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs new file mode 100644 index 0000000..3d43a70 --- /dev/null +++ b/src-unittests/TestUtils.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE QuasiQuotes #-} + +module TestUtils where + + + +#include "prelude.inc" + +import Test.Hspec + +import NeatInterpolation + +import Language.Haskell.Brittany + +import Language.Haskell.Brittany.Config.Types + +import System.Timeout ( timeout ) + + + +roundTripEqual :: Text -> Expectation +roundTripEqual t = fmap (fmap PPTextWrapper) (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t) + `shouldReturn` Right (PPTextWrapper t) + +roundTripEqualWithTimeout :: Int -> Text -> Expectation +roundTripEqualWithTimeout time t = + timeout time action `shouldReturn` Just (Right (PPTextWrapper t)) + where + action = fmap (fmap PPTextWrapper) + (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t) + +newtype PPTextWrapper = PPTextWrapper Text + deriving Eq + +instance Show PPTextWrapper where + show (PPTextWrapper t) = "\n" ++ Text.unpack t + +defaultTestConfig :: Config +defaultTestConfig = Config + { _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig + { _lconfig_cols = Identity 80 + , _lconfig_indentPolicy = Identity IndentPolicyFree + , _lconfig_indentAmount = Identity 2 + , _lconfig_indentWhereSpecial = Identity True + , _lconfig_indentListSpecial = Identity True + , _lconfig_importColumn = Identity 60 + , _lconfig_altChooser = Identity $ AltChooserBoundedSearch 3 + } + , _conf_errorHandling = _conf_errorHandling staticDefaultConfig + } diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs new file mode 100644 index 0000000..cc28c09 --- /dev/null +++ b/src/Language/Haskell/Brittany.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany + ( parsePrintModule + , pPrintModule + ) +where + + + +#include "prelude.inc" + +import DynFlags ( getDynFlags ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import qualified Parser as GHC +import qualified ApiAnnotation as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified GHC as GHC hiding (parseModule) +import qualified HeaderInfo as GHC +import qualified Lexer as GHC +import qualified MonadUtils as GHC +import qualified Outputable as GHC +import qualified Parser as GHC +import qualified SrcLoc as GHC +import qualified StringBuffer as GHC +import RdrName ( RdrName(..) ) +import Control.Monad.IO.Class +import GHC.Paths (libdir) +import HsSyn +import SrcLoc ( SrcSpan, Located ) +-- import Outputable ( ppr, runSDoc ) +-- import DynFlags ( unsafeGlobalDynFlags ) + +import ApiAnnotation ( AnnKeywordId(..) ) +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers +import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint.Preprocess +import qualified Data.Map as Map + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import qualified Debug.Trace as Trace + +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.LayoutBasics +import Language.Haskell.Brittany.Layouters.Type +import Language.Haskell.Brittany.Layouters.Decl +import Language.Haskell.Brittany.Utils +import Language.Haskell.Brittany.BriLayouter + + + +-- LayoutErrors 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 + -> ExactPrint.Types.Anns + -> GHC.ParsedSource + -> ([LayoutError], TextL.Text) +pPrintModule conf anns parsedModule = + let ((out, errs), debugStrings) + = runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader conf + $ do + traceIfDumpConf "bridoc annotations" _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 () + +-- used for testing mostly, currently. +parsePrintModule + :: Config + -> String + -> Text + -> IO (Either String Text) +parsePrintModule conf filename input = do + let inputStr = Text.unpack input + parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr + case parseResult of + Left (_, s) -> return $ Left $ "parsing error: " ++ s + Right (anns, parsedModule) -> + let (errs, ltext) = pPrintModule conf anns parsedModule + in return $ if null errs + then Right $ TextL.toStrict $ ltext + else + let errStrs = errs <&> \case + LayoutErrorUnusedComment str -> str + LayoutWarning str -> str + LayoutErrorUnknownNode str _ -> str + in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs + +-- this approach would for with there was a pure GHC.parseDynamicFilePragma. +-- Unfortunately that does not exist yet, so we cannot provide a nominally +-- pure interface. + +-- parsePrintModule :: Text -> Either String Text +-- parsePrintModule input = do +-- let dflags = GHC.unsafeGlobalDynFlags +-- let fakeFileName = "SomeTestFakeFileName.hs" +-- let pragmaInfo = GHC.getOptions +-- dflags +-- (GHC.stringToStringBuffer $ Text.unpack input) +-- fakeFileName +-- (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags pragmaInfo +-- let parseResult = ExactPrint.Parsers.parseWith +-- dflags1 +-- fakeFileName +-- GHC.parseModule +-- inputStr +-- case parseResult of +-- Left (_, s) -> Left $ "parsing error: " ++ s +-- Right (anns, parsedModule) -> do +-- let (out, errs) = runIdentity +-- $ runMultiRWSTNil +-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterAW +-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterW +-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiReader anns +-- $ ppModule parsedModule +-- if (not $ null errs) +-- then do +-- let errStrs = errs <&> \case +-- LayoutErrorUnusedComment str -> str +-- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs +-- else return $ TextL.toStrict $ Text.Builder.toLazyText out + +ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM () +ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do + let emptyModule = L loc m { hsmodDecls = [] } + (anns', post) <- do + anns <- mAsk + -- evil partiality. but rather unlikely. + return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of + Nothing -> (anns, []) + Just mAnn -> + let + modAnnsDp = ExactPrint.Types.annsDP mAnn + isWhere (ExactPrint.Types.G AnnWhere) = True + isWhere _ = False + isEof (ExactPrint.Types.G 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.Types.annsDP = pre } + anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns + in (anns', post) + MultiRWSS.withMultiReader anns' $ processDefault emptyModule + decls `forM_` ppDecl + let + finalComments = filter (fst .> \case ExactPrint.Types.AnnComment{} -> True + _ -> False) + post + post `forM_` \case + (ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do + ppmMoveToExactLoc l + mTell $ Text.Builder.fromString cmStr + (ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX,eofY))) -> + let cmX = foldl' (\acc (_, ExactPrint.Types.DP (x, _)) -> acc+x) 0 finalComments + in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY) + _ -> return () + +ppDecl :: LHsDecl RdrName -> PPM () +ppDecl d@(L loc decl) = case decl of + SigD sig -> do + -- runLayouter $ Old.layoutSig (L loc sig) + briDoc <- briDocMToPPM $ layoutSig (L loc sig) + layoutBriDoc d briDoc + ValD bind -> do + -- Old.layoutBind (L loc bind) + briDoc <- fmap (either BDLines id) $ briDocMToPPM $ layoutBind (L loc bind) + layoutBriDoc d briDoc + _ -> + briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs new file mode 100644 index 0000000..63e8214 --- /dev/null +++ b/src/Language/Haskell/Brittany/BriLayouter.hs @@ -0,0 +1,1218 @@ +#define INSERTTRACESGETSPACING 0 +#define INSERTTRACESALT 0 + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeApplications #-} + +module Language.Haskell.Brittany.BriLayouter + ( layoutBriDoc + ) +where + + + +#include "prelude.inc" + +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.Utils as ExactPrint.Utils + +import qualified Data.StableMemo as StableMemo +import qualified Data.StableMemo.Weak as StableMemo.Weak +import qualified System.Mem.StableName as StableName +import qualified System.Unsafe as Unsafe + +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) +import Language.Haskell.Brittany.LayoutBasics +import Language.Haskell.Brittany.Utils + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Types + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import qualified Outputable as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified SrcLoc as GHC +import SrcLoc ( SrcSpan ) +import OccName ( occNameString ) +import Name ( getOccString ) +import Module ( moduleName ) +import ApiAnnotation ( AnnKeywordId(..) ) +import Data.HList.ContainsType + +import Data.Data +import Data.Generics.Schemes +import Data.Generics.Aliases + +import qualified Data.ByteString as B + +import DataTreePrint + +import qualified Text.PrettyPrint as PP + +import Data.Function ( fix ) + +import Control.Monad.Extra ( whenM ) + +import qualified Data.Generics.Uniplate.Data as Uniplate +-- import qualified Data.Generics.Uniplate as Uniplate + + + +layoutBriDoc :: Data.Data.Data ast + => ast + -> BriDoc + -> PPM () +layoutBriDoc ast briDoc = do + -- first step: transform the briDoc. + briDoc' <- MultiRWSS.withMultiStateS briDoc $ do + mGet >>= traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw . briDocToDoc + -- bridoc transformation: remove alts + mGet >>= transformAlts >>= mSet + mGet >>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt . briDocToDoc + -- bridoc transformation: float stuff in + mGet <&> transformSimplifyFloating >>= mSet + mGet >>= traceIfDumpConf "bridoc post-floating" _dconf_dump_bridoc_simpl_floating . briDocToDoc + -- bridoc transformation: par removal + mGet <&> transformSimplifyPar >>= mSet + mGet >>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par . briDocToDoc + -- bridoc transformation: float stuff in + mGet <&> transformSimplifyColumns >>= mSet + mGet >>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns . briDocToDoc + -- -- bridoc transformation: indent + mGet <&> transformSimplifyIndent >>= mSet + mGet >>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent . briDocToDoc + mGet >>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final . briDocToDoc + -- -- convert to Simple type + -- simpl <- mGet <&> transformToSimple + -- return simpl + + anns :: ExactPrint.Types.Anns <- mAsk + let filteredAnns = filterAnns ast anns + + let state = LayoutState + { _lstate_baseY = 0 + , _lstate_curY = 0 + , _lstate_indLevel = 0 + , _lstate_indLevelLinger = 0 + , _lstate_commentsPrior = extractCommentsPrior filteredAnns + , _lstate_commentsPost = extractCommentsPost filteredAnns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + , _lstate_inhibitMTEL = False + , _lstate_isNewline = NewLineStateInit + } + + state' <- MultiRWSS.withMultiStateS state + $ layoutBriDocM briDoc' + + let remainingComments = Map.elems (_lstate_commentsPrior state') + ++ Map.elems (_lstate_commentsPost state') + remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fmap fst) + + return $ () + +data AltCurPos = AltCurPos + { _acp_line :: Int -- chars in the current line + , _acp_indent :: Int -- current indentation level + , _acp_forceMLFlag :: AltLineModeState + } + deriving (Show) + +data AltLineModeState + = AltLineModeStateNone + | AltLineModeStateForceML Bool -- true ~ decays on next wrap + | AltLineModeStateForceSL + | AltLineModeStateContradiction + -- i.e. ForceX False -> ForceX True -> None + deriving (Show) + +altLineModeDecay :: AltLineModeState -> AltLineModeState +altLineModeDecay AltLineModeStateNone = AltLineModeStateNone +altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True +altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone +altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction + +altLineModeRefresh :: AltLineModeState -> AltLineModeState +altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone +altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False +altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction + +mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos +mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of + (AltLineModeStateContradiction, _) -> acp + (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x } + (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp + (AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> acp { _acp_forceMLFlag = s } + _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction } + +-- removes any BDAlt's from the BriDoc +transformAlts + :: forall r w s + . ( Data.HList.ContainsType.ContainsType Config r + , Data.HList.ContainsType.ContainsType (Seq String) w + ) + => BriDoc + -> MultiRWSS.MultiRWS r w s BriDoc +transformAlts briDoc + = MultiRWSS.withMultiStateA + (AltCurPos 0 0 AltLineModeStateNone) + $ rec briDoc + where + rec :: BriDoc -> MultiRWSS.MultiRWS r w (AltCurPos ': s) BriDoc + rec brDc = do +#if INSERTTRACESALT + tellDebugMess $ "transformAlts: visiting: " ++ show (toConstr brDc) +#endif + -- debugAcp :: AltCurPos <- mGet + case brDc of + -- BDWrapAnnKey annKey bd -> do + -- acp <- mGet + -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + -- BDWrapAnnKey annKey <$> rec bd + bd@BDEmpty{} -> processSpacingSimple bd $> bd + bd@BDLit{} -> processSpacingSimple bd $> bd + BDSeq list -> BDSeq <$> rec `mapM` list + BDCols sig list -> BDCols sig <$> rec `mapM` list + bd@BDSeparator -> processSpacingSimple bd $> bd + BDAddBaseY indent bd -> do + acp <- mGet + indAdd <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + let ind = case indent of + BrIndentNone -> _acp_indent acp + BrIndentRegular -> _acp_indent acp + indAdd + BrIndentSpecial i -> _acp_indent acp + i + mSet $ acp { _acp_indent = ind } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> BDAddBaseY (BrIndentSpecial indAdd) r + BrIndentSpecial i -> BDAddBaseY (BrIndentSpecial i) r + BDSetBaseY bd -> do + acp <- mGet + mSet $ acp { _acp_indent = _acp_line acp } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ BDSetBaseY r + BDSetIndentLevel bd -> do + BDSetIndentLevel <$> rec bd + BDPar indent sameLine indented -> do + acp <- mGet + indAdd <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + let ind = case indent of + BrIndentNone -> _acp_indent acp + BrIndentRegular -> _acp_indent acp + indAdd + BrIndentSpecial i -> _acp_indent acp + i + mSet $ acp + { _acp_indent = ind + } + sameLine' <- rec sameLine + mSet $ acp + { _acp_line = ind + , _acp_indent = ind + } + indented' <- rec indented + return $ BDPar indent sameLine' indented' + BDAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a + -- possibility, but i will prefer a + -- fail-early approach; BDEmpty does not + -- make sense semantically for Alt[]. + BDAlt alts -> do + altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> runIdentity + case altChooser of + AltChooserSimpleQuick -> do + rec $ head alts + AltChooserShallowBest -> do + spacings <- alts `forM` getSpacing + acp <- mGet + let lineCheck LineModeInvalid = False + lineCheck (LineModeValid (VerticalSpacing _ p)) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> Strict.isNothing p + AltLineModeStateForceML{} -> Strict.isJust p + AltLineModeStateContradiction -> False + lineCheck _ = error "ghc exhaustive check is insufficient" + lconf <- _conf_layout <$> mAsk +#if INSERTTRACESALT + tellDebugMess $ "considering options with " ++ show (length alts, acp) +#endif + let options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + ( hasSpace1 lconf acp vs && lineCheck vs, bd)) +#if INSERTTRACESALT + zip spacings options `forM_` \(vs, (_, bd)) -> + tellDebugMess $ " " ++ "spacing=" ++ show vs + ++ ",hasSpace=" ++ show (hasSpace1 lconf acp vs) + ++ ",lineCheck=" ++ show (lineCheck vs) + ++ " " ++ show (toConstr bd) +#endif + id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x) + $ rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> + [ -- traceShow ("choosing option " ++ show i) $ + x + | b + ]) + $ zip [1..] options + AltChooserBoundedSearch limit -> do + spacings <- alts `forM` getSpacings limit + acp <- mGet + let lineCheck (VerticalSpacing _ p) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> Strict.isNothing p + AltLineModeStateForceML{} -> Strict.isJust p + AltLineModeStateContradiction -> False + lconf <- _conf_layout <$> mAsk +#if INSERTTRACESALT + tellDebugMess $ "considering options with " ++ show (length alts, acp) +#endif + let options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + ( any (hasSpace2 lconf acp) vs + && any lineCheck vs, bd)) +#if INSERTTRACESALT + zip spacings options `forM_` \(vs, (_, bd)) -> + tellDebugMess $ " " ++ "spacing=" ++ show vs + ++ ",hasSpace=" ++ show (hasSpace2 lconf acp <$> vs) + ++ ",lineCheck=" ++ show (lineCheck <$> vs) + ++ " " ++ show (toConstr bd) +#endif + id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x) + $ rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> + [ -- traceShow ("choosing option " ++ show i) $ + x + | b + ]) + $ zip [1..] options + BDForceMultiline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp (AltLineModeStateForceML False) + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDForceSingleline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp AltLineModeStateForceSL + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDForwardLineMode bd -> do + acp <- mGet + x <- do + mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp } + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + bd@BDExternal{} -> processSpacingSimple bd $> bd + BDAnnotationPrior annKey bd -> do + acp <- mGet + mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + bd' <- rec bd + return $ BDAnnotationPrior annKey bd' + BDAnnotationPost annKey bd -> BDAnnotationPost annKey <$> rec bd + BDLines [] -> return $ BDEmpty -- evil transformation. or harmless. + BDLines (l:lr) -> do + acp <- mGet + let ind = _acp_indent acp + l' <- rec l + lr' <- lr `forM` \x -> do + mSet $ acp + { _acp_line = ind + , _acp_indent = ind + } + rec x + return $ BDLines (l':lr') + BDEnsureIndent indent bd -> BDEnsureIndent indent <$> rec bd + BDProhibitMTEL bd -> BDProhibitMTEL <$> rec bd + processSpacingSimple :: (MonadMultiReader + Config m, + MonadMultiState AltCurPos m, MonadMultiWriter (Seq String) m) => BriDoc -> m () + processSpacingSimple bd = getSpacing bd >>= \case + LineModeInvalid -> error "processSpacingSimple inv" + LineModeValid (VerticalSpacing _ Strict.Just{}) -> error "processSpacingSimple par" + LineModeValid (VerticalSpacing i Strict.Nothing) -> do + acp <- mGet + mSet $ acp { _acp_line = _acp_line acp + i } + _ -> error "ghc exhaustive check is insufficient" + hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool + hasSpace1 _ _ LineModeInvalid = False + hasSpace1 lconf (AltCurPos line _indent _) (LineModeValid (VerticalSpacing sameLine Strict.Nothing)) + = line + sameLine <= runIdentity (_lconfig_cols lconf) + hasSpace1 lconf (AltCurPos line indent _) (LineModeValid (VerticalSpacing sameLine (Strict.Just par))) + = line + sameLine <= runIdentity (_lconfig_cols lconf) + && indent + par <= runIdentity (_lconfig_cols lconf) + hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" + hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool + hasSpace2 lconf (AltCurPos line _indent _) (VerticalSpacing sameLine Strict.Nothing) + = line + sameLine <= runIdentity (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line indent _) (VerticalSpacing sameLine (Strict.Just par)) + = line + sameLine <= runIdentity (_lconfig_cols lconf) + && indent + par <= runIdentity (_lconfig_cols lconf) + +getSpacing :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) => BriDoc -> m (LineModeValidity VerticalSpacing) +getSpacing !bridoc = do + !config <- mAsk + let (w, x) = getSpacingMemo config bridoc + mTell w + return x + +getSpacingMemo :: Config -> BriDoc -> (Seq String, LineModeValidity VerticalSpacing) +getSpacingMemo !config' !bridoc' = -- traceShow ((\x -> (toConstr x, StableName.hashStableName $ Unsafe.performIO $ StableName.makeStableName x)) <$> Uniplate.universe bridoc') $ + StableMemo.memo go config' + where + go :: Config -> (Seq String, LineModeValidity VerticalSpacing) + go config = rec bridoc' + where + rec :: BriDoc -> (Seq String, LineModeValidity VerticalSpacing) + rec = StableMemo.memo $ \bridoc -> -- traceShow ("getSpacingMemo1", toConstr bridoc, StableName.hashStableName $ Unsafe.performIO $ StableName.makeStableName bridoc) $ + let result = case bridoc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDEmpty -> + return $ LineModeValid $ VerticalSpacing 0 Strict.Nothing + BDLit t -> + return $ LineModeValid $ VerticalSpacing (Text.length t) Strict.Nothing + BDSeq list -> + sumVs <$> rec `mapM` list + BDCols _sig list -> sumVs <$> rec `mapM` list + BDSeparator -> + return $ LineModeValid $ VerticalSpacing 1 Strict.Nothing + BDAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = _vs_paragraph vs <&> case indent of + BrIndentNone -> id + BrIndentRegular -> (+) + $ runIdentity + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> (+ i) + } + BDSetBaseY bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max (_vs_sameLine vs) + (Strict.fromMaybe 0 $ _vs_paragraph vs) + } + BDSetIndentLevel bd -> rec bd + BDPar BrIndentNone sameLine indented -> do + mVs <- rec sameLine + indSp <- rec indented + return $ [ VerticalSpacing lsp $ Strict.Just $ case mPsp of + Strict.Just psp -> max psp lineMax + Strict.Nothing -> lineMax + | VerticalSpacing lsp mPsp <- mVs + , lineMax <- getMaxVS $ indSp + ] + BDPar{} -> error "BDPar with indent in getSpacing" + BDAlt [] -> error "empty BDAlt" + BDAlt (alt:_) -> rec alt + BDForceMultiline bd -> rec bd + BDForceSingleline bd -> do + mVs <- rec bd + return $ mVs >>= \(VerticalSpacing _ psp) -> + case psp of + Strict.Nothing -> mVs + Strict.Just{} -> LineModeInvalid + BDForwardLineMode bd -> rec bd + BDExternal{} -> + return $ LineModeValid $ VerticalSpacing 999 Strict.Nothing + BDAnnotationPrior _annKey bd -> rec bd + BDAnnotationPost _annKey bd -> rec bd + BDLines [] -> return $ LineModeValid $ VerticalSpacing 0 Strict.Nothing + BDLines ls@(_:_) -> do + lSps@(mVs:_) <- rec `mapM` ls + return $ [ VerticalSpacing lsp $ Strict.Just $ lineMax + | VerticalSpacing lsp _ <- mVs + , lineMax <- getMaxVS $ maxVs $ lSps + ] + BDEnsureIndent indent bd -> do + mVs <- rec bd + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> runIdentity + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp) -> + VerticalSpacing (lsp + addInd) psp + BDProhibitMTEL bd -> rec bd +#if INSERTTRACESGETSPACING + addition = Seq.singleton ("getSpacing: visiting: " + ++ show (toConstr bridoc) + ++ " -> " + ++ show result) + in (fst result <> addition, snd result) +#else + in -- traceShow ("getSpacingMemo2", toConstr bridoc, StableName.hashStableName $ Unsafe.performIO $ StableName.makeStableName bridoc) $ + result +#endif + maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + maxVs = foldl' + (liftM2 (\(VerticalSpacing x1 x2) (VerticalSpacing y1 y2) -> + VerticalSpacing (max x1 y1) (case (x2, y2) of + (x, Strict.Nothing) -> x + (Strict.Nothing, x) -> x + (Strict.Just x, Strict.Just y) -> Strict.Just $ max x y))) + (LineModeValid $ VerticalSpacing 0 Strict.Nothing) + sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + sumVs = foldl' + (liftM2 (\(VerticalSpacing x1 x2) (VerticalSpacing y1 y2) -> + VerticalSpacing (x1 + y1) (case (x2, y2) of + (x, Strict.Nothing) -> x + (Strict.Nothing, x) -> x + (Strict.Just x, Strict.Just y) -> Strict.Just $ x + y))) + (LineModeValid $ VerticalSpacing 0 Strict.Nothing) + getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int + getMaxVS = fmap $ \(VerticalSpacing x1 x2) -> x1 `max` Strict.fromMaybe 0 x2 + +getSpacings :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) => Int -> BriDoc -> m [VerticalSpacing] +getSpacings limit !bridoc = do + !config <- mAsk + let (w, x) = getSpacingsMemo (limit, config) bridoc + mTell w + return x + +getSpacingsMemo :: (Int, Config) -> BriDoc -> (Seq String, [VerticalSpacing]) +getSpacingsMemo !limitConfig' !bridoc' = -- traceShow ((\x -> (toConstr x, StableName.hashStableName $ Unsafe.performIO $ StableName.makeStableName x)) <$> Uniplate.universe bridoc') $ + StableMemo.memo go limitConfig' + where + go :: (Int, Config) -> (Seq String, [VerticalSpacing]) + go (limit, config) = rec bridoc' + where + rec :: BriDoc -> (Seq String, [VerticalSpacing]) + rec = StableMemo.memo $ \bridoc -> -- traceShow ("getSpacingMemo1", toConstr bridoc, StableName.hashStableName $ Unsafe.performIO $ StableName.makeStableName bridoc) $ + let result = case bridoc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDEmpty -> + return $ [VerticalSpacing 0 Strict.Nothing] + BDLit t -> + return $ [VerticalSpacing (Text.length t) Strict.Nothing] + BDSeq list -> + filterAndLimit . fmap sumVs . sequence <$> rec `mapM` list + BDCols _sig list -> + filterAndLimit . fmap sumVs . sequence <$> rec `mapM` list + BDSeparator -> + return $ [VerticalSpacing 1 Strict.Nothing] + BDAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = _vs_paragraph vs <&> case indent of + BrIndentNone -> id + BrIndentRegular -> (+) + $ runIdentity + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> (+ i) + } + BDSetBaseY bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max (_vs_sameLine vs) + (Strict.fromMaybe 0 $ _vs_paragraph vs) + } + BDSetIndentLevel bd -> rec bd + BDPar BrIndentNone sameLine indented -> do + mVss <- rec sameLine + indSps <- rec indented + let mVsIndSp = take limit + $ [ (x,y) + | x<-mVss + , y<-indSps + , hasOkColCount x + , hasOkColCount y + ] + return $ mVsIndSp <&> + \(VerticalSpacing lsp mPsp, indSp) -> + VerticalSpacing lsp $ Strict.Just $ case mPsp of + Strict.Just psp -> max psp $ getMaxVS indSp + Strict.Nothing -> getMaxVS indSp + BDPar{} -> error "BDPar with indent in getSpacing" + BDAlt [] -> error "empty BDAlt" + -- BDAlt (alt:_) -> rec alt + BDAlt alts -> filterAndLimit . join . transpose <$> rec `mapM` alts + BDForceMultiline bd -> rec bd + BDForceSingleline bd -> do + mVs <- rec bd + return $ filter (Strict.isNothing . _vs_paragraph) mVs + BDForwardLineMode bd -> rec bd + BDExternal{} -> + return $ [VerticalSpacing 999 Strict.Nothing] + BDAnnotationPrior _annKey bd -> rec bd + BDAnnotationPost _annKey bd -> rec bd + BDLines [] -> return $ [VerticalSpacing 0 Strict.Nothing] + BDLines ls@(_:_) -> do + lSpss@(mVs:_) <- rec `mapM` ls + return $ case transpose lSpss of -- TODO: we currently only + -- consider the first alternative for the + -- line's spacings. + -- also i am not sure if always including + -- the first line length in the paragraph + -- length gives the desired results. + -- it is the safe path though, for now. + [] -> [] + (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> + VerticalSpacing lsp $ Strict.Just $ getMaxVS $ maxVs lSps + BDEnsureIndent indent bd -> do + mVs <- rec bd + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> runIdentity + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp) -> + VerticalSpacing (lsp + addInd) psp + BDProhibitMTEL bd -> rec bd +#if INSERTTRACESGETSPACING + addition = Seq.fromList ["getSpacing: visiting: " + ++ show (briDocToDoc bridoc) + , " -> " + ++ show (snd result) + ] + in (fst result <> addition, snd result) +#else + in -- traceShow ("getSpacingMemo2", toConstr bridoc, StableName.hashStableName $ Unsafe.performIO $ StableName.makeStableName bridoc) $ + result +#endif + maxVs :: [VerticalSpacing] -> VerticalSpacing + maxVs = foldl' + (\(VerticalSpacing x1 x2) (VerticalSpacing y1 y2) -> + VerticalSpacing (max x1 y1) (case (x2, y2) of + (x, Strict.Nothing) -> x + (Strict.Nothing, x) -> x + (Strict.Just x, Strict.Just y) -> Strict.Just $ max x y)) + (VerticalSpacing 0 Strict.Nothing) + sumVs :: [VerticalSpacing] -> VerticalSpacing + sumVs = foldl' + (\(VerticalSpacing x1 x2) (VerticalSpacing y1 y2) -> + VerticalSpacing (x1 + y1) (case (x2, y2) of + (x, Strict.Nothing) -> x + (Strict.Nothing, x) -> x + (Strict.Just x, Strict.Just y) -> Strict.Just $ x + y)) + (VerticalSpacing 0 Strict.Nothing) + getMaxVS :: VerticalSpacing -> Int + getMaxVS (VerticalSpacing x1 x2) = x1 `max` Strict.fromMaybe 0 x2 + colMax = config & _conf_layout & _lconfig_cols & runIdentity + hasOkColCount (VerticalSpacing lsp psp) = + lsp <= colMax && Strict.maybe True (<=colMax) psp + filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] + filterAndLimit = take limit . filter hasOkColCount + +-- note that this is not total, and cannot be with that exact signature. +mergeIndents :: BrIndent -> BrIndent -> BrIndent +mergeIndents BrIndentNone x = x +mergeIndents x BrIndentNone = x +mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) +mergeIndents _ _ = error "mergeIndents" + +transformSimplifyFloating :: BriDoc -> BriDoc +transformSimplifyFloating = stepBO .> stepFull + -- note that semantically, stepFull is completely sufficient. + -- but the bottom-up switch-to-top-down-on-match transformation has much + -- better complexity. + where + descendPost = Uniplate.descend $ \case + -- post floating in + BDAnnotationPost annKey1 (BDPar ind line indented) -> + BDPar ind line $ BDAnnotationPost annKey1 indented + BDAnnotationPost annKey1 (BDSeq list) -> + BDSeq $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] + BDAnnotationPost annKey1 (BDLines list) -> + BDLines $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] + BDAnnotationPost annKey1 (BDCols sig cols) -> + BDCols sig $ List.init cols ++ [BDAnnotationPost annKey1 $ List.last cols] + BDAnnotationPost annKey1 (BDAddBaseY indent x) -> + BDAddBaseY indent $ BDAnnotationPost annKey1 x + x -> x + descendPrior = Uniplate.descend $ \case + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + BDSeq (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + BDLines (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + BDCols sig (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> + BDAddBaseY indent $ BDAnnotationPrior annKey1 x + x -> x + descendAddB = Uniplate.descend $ \case + -- AddIndent floats into Lines. + BDAddBaseY BrIndentNone x -> + x + BDAddBaseY indent (BDLines lines) -> + BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> + BDAnnotationPrior annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationPost annKey1 x) -> + BDAnnotationPost annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDSeq list) -> + BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + x -> x + stepBO = -- traceFunctionWith "stepB0" (show . briDocToDoc) (show . briDocToDoc) $ + Uniplate.transform $ \case + -- post floating in + BDAnnotationPost annKey1 (BDPar ind line indented) -> + descendPost $ BDPar ind line $ BDAnnotationPost annKey1 indented + BDAnnotationPost annKey1 (BDSeq list) -> + descendPost $ BDSeq $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] + BDAnnotationPost annKey1 (BDLines list) -> + descendPost $ BDLines $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] + BDAnnotationPost annKey1 (BDCols sig cols) -> + descendPost $ BDCols sig $ List.init cols ++ [BDAnnotationPost annKey1 $ List.last cols] + BDAnnotationPost annKey1 (BDAddBaseY indent x) -> + descendPost $ BDAddBaseY indent $ BDAnnotationPost annKey1 x + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + descendPrior $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + descendPrior $ BDSeq (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + descendPrior $ BDLines (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + descendPrior $ BDCols sig (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> + descendPrior $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x + -- AddIndent floats into Lines. + BDAddBaseY BrIndentNone x -> + x + BDAddBaseY indent (BDLines lines) -> + descendAddB $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + descendAddB $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + descendAddB $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> + descendAddB $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationPost annKey1 x) -> + descendAddB $ BDAnnotationPost annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDSeq list) -> + descendAddB $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + x -> x + stepFull = Uniplate.rewrite $ \case + -- AddIndent floats into Lines. + BDAddBaseY BrIndentNone x -> + Just x + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + -- 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)) + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + BDEnsureIndent indent (BDLines lines) -> + Just $ BDLines $ BDEnsureIndent indent <$> lines + -- post floating in + BDAnnotationPost annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationPost annKey1 indented + BDAnnotationPost annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] + BDAnnotationPost annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] + BDAnnotationPost annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationPost annKey1 $ List.last cols] + _ -> Nothing + +transformSimplifyPar :: BriDoc -> BriDoc +transformSimplifyPar = Uniplate.rewrite $ \case + -- BDPar BrIndentNone line1 line2 -> Just $ BDLines [line1, line2] + -- BDPar line indented -> + -- Just $ BDLines [line, indented] + -- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 -> + -- Just $ BDPar ind1 line (BDLines [p1, p2]) + BDPar _ (BDPar _ BDPar{} _) _ -> Nothing + BDPar ind1 (BDPar ind2 line p1) p2 -> + Just $ BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) + BDLines lines | any (\case BDLines{} -> True + BDEmpty{} -> True + _ -> False) lines -> + Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines l -> l + x -> [x] + BDLines [] -> Just $ BDEmpty + BDLines [x] -> Just $ x + -- BDCols sig cols | BDPar ind line indented <- List.last cols -> + -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented + -- BDPar BrIndentNone line indented -> + -- Just $ BDLines [line, indented] + BDEnsureIndent BrIndentNone x -> Just $ x + _ -> Nothing + +isNotEmpty :: BriDoc -> Bool +isNotEmpty BDEmpty = False +isNotEmpty _ = True + +transformSimplifyColumns :: BriDoc -> BriDoc +transformSimplifyColumns = Uniplate.rewrite $ \case + -- BDWrapAnnKey annKey bd -> + -- BDWrapAnnKey annKey $ transformSimplify bd + BDEmpty -> Nothing + BDLit{} -> Nothing + BDSeq list | any (\case BDSeq{} -> True + BDEmpty{} -> True + _ -> False) list -> Just $ BDSeq $ + filter isNotEmpty list >>= \case + BDSeq l -> l + x -> [x] + BDLines lines | any (\case BDLines{} -> True + BDEmpty{} -> True + _ -> False) lines -> + 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 + BDAnnotationPost annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] + BDAnnotationPost annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationPost annKey1 $ List.last list] + BDAnnotationPost annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationPost annKey1 $ List.last cols] + -- ensureIndent float-in + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + BDEnsureIndent indent (BDLines lines) -> + Just $ BDLines $ BDEnsureIndent indent <$> lines + -- matching col special transformation + BDCols sig1 cols1@(_:_) + | BDLines lines@(_:_:_) <- List.last cols1 + , BDCols sig2 cols2 <- List.last lines + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDCols sig1 cols1@(_:_) + | BDLines lines@(_:_:_) <- List.last cols1 + , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> + Just $ BDAddBaseY ind (BDLines [col1, col2]) + BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) + | sig1==sig2 -> + Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) + BDPar ind (BDLines lines1) col2@(BDCols sig2 _) + | BDCols sig1 _ <- List.last lines1 + , sig1==sig2 -> + Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) + BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) + | BDCols sig1 _ <- List.last lines1 + , sig1==sig2 -> + Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) + -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) + -- | sig1==sig2 -> + -- Just $ BDPar + -- ind1 + -- (BDLines [BDCols sig1 cols1, BDCols sig]) + BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 (List.init cols ++ [line]) + , BDCols sig2 cols2 + ] + BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols + , BDCols sig2 cols2 <- List.last lines + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] + , BDCols sig2 cols2 + ] + BDLines [x] -> Just $ x + BDLines [] -> Just $ BDEmpty + BDSeq{} -> Nothing + BDCols{} -> Nothing + BDSeparator -> Nothing + BDAddBaseY{} -> Nothing + BDSetBaseY{} -> Nothing + BDSetIndentLevel{} -> Nothing + BDPar{} -> Nothing + BDAlt{} -> Nothing + BDForceMultiline{} -> Nothing + BDForceSingleline{} -> Nothing + BDForwardLineMode{} -> Nothing + BDExternal{} -> Nothing + BDLines{} -> Nothing + BDAnnotationPrior{} -> Nothing + BDAnnotationPost{} -> Nothing + BDEnsureIndent{} -> Nothing + BDProhibitMTEL{} -> Nothing + +-- prepare layouting by translating BDPar's, replacing them with Indents and +-- floating those in. This gives a more clear picture of what exactly is +-- affected by what amount of indentation. +transformSimplifyIndent :: BriDoc -> BriDoc +transformSimplifyIndent = Uniplate.rewrite $ \case + BDPar ind (BDLines lines) indented -> + Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented] + BDPar ind (BDCols sig cols) indented -> + Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented]) + BDPar ind x indented -> + Just $ BDLines + [ BDAddBaseY ind x + , BDEnsureIndent ind indented + ] + BDLines lines | any (\case BDLines{} -> True + BDEmpty{} -> True + _ -> False) lines -> + Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines l -> l + x -> [x] + BDAddBaseY i (BDAnnotationPost k x) -> + Just $ BDAnnotationPost k (BDAddBaseY i x) + BDAddBaseY i (BDAnnotationPrior k x) -> + Just $ BDAnnotationPrior k (BDAddBaseY i x) + BDAddBaseY i (BDSeq l) -> + Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l] + BDAddBaseY i (BDCols sig l) -> + Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] + BDAddBaseY _ lit@BDLit{} -> + Just lit + + _ -> Nothing + + +briDocLineLength :: BriDoc -> Int +briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc + -- the state encodes whether a separate 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 + BDSetBaseY bd -> rec bd + BDSetIndentLevel 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 + BDAnnotationPrior _ bd -> rec bd + BDAnnotationPost _ bd -> rec bd + BDLines (l:_) -> rec l + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDProhibitMTEL bd -> rec bd + +layoutBriDocM + :: forall w m + . ( m ~ MultiRWSS.MultiRWST + '[Config, ExactPrint.Types.Anns] + w + '[LayoutState] + Identity + , ContainsType Text.Builder.Builder w + , ContainsType [LayoutError] w + , ContainsType (Seq String) w + ) + => BriDoc + -> m () +layoutBriDocM = \case + BDEmpty -> do + return () -- can it be that simple + BDLit t -> do + 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 + BDSetBaseY bd -> do + layoutSetBaseColCur $ layoutBriDocM bd + BDSetIndentLevel bd -> do + layoutSetIndentLevel $ layoutBriDocM bd + 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.Types.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_commentsPrior = Map.filterWithKey filterF + $ _lstate_commentsPrior state + , _lstate_commentsPost = Map.filterWithKey filterF + $ _lstate_commentsPost state + } + BDAnnotationPrior annKey bd -> do + do + state <- mGet + let m = _lstate_commentsPrior state + let allowMTEL = not (_lstate_inhibitMTEL state) + && _lstate_isNewline state /= NewLineStateNo + mAnn <- do + let mAnn = Map.lookup annKey m + mSet $ state { _lstate_commentsPrior = Map.delete annKey m } + return mAnn + case mAnn of + Nothing -> when allowMTEL $ moveToExactAnn annKey + Just [] -> when allowMTEL $ moveToExactAnn annKey + Just priors -> do + -- layoutResetSepSpace + layoutSetCommentCol + priors `forM_` \( ExactPrint.Types.Comment comment _ _ + , ExactPrint.Types.DP (x, y) + ) -> do + fixedX <- fixMoveToLineByIsNewline x + replicateM_ fixedX layoutWriteNewline + layoutMoveToIndentCol y + -- layoutWriteAppend $ Text.pack $ replicate y ' ' + layoutWriteAppendMultiline $ Text.pack $ comment + when allowMTEL $ moveToExactAnn annKey + layoutIndentRestorePostComment + layoutBriDocM bd + BDAnnotationPost annKey bd -> do + layoutBriDocM bd + do + mAnn <- do + state <- mGet + let m = _lstate_commentsPost state + let mAnn = Map.lookup annKey m + mSet $ state { _lstate_commentsPost = Map.delete annKey m } + return mAnn + case mAnn of + Nothing -> return () + Just posts -> do + when (not $ null posts) $ layoutSetCommentCol + posts `forM_` \( ExactPrint.Types.Comment comment _ _ + , ExactPrint.Types.DP (x, y) + ) -> do + fixedX <- fixMoveToLineByIsNewline x + replicateM_ fixedX layoutWriteNewline + -- layoutWriteAppend $ Text.pack $ replicate y ' ' + layoutMoveToIndentCol y + layoutWriteAppendMultiline $ Text.pack $ comment + layoutIndentRestorePostComment + BDProhibitMTEL bd -> do + -- set flag to True for this child, but disable afterwards. + -- two hard aspects + -- 1) nesting should be allowed. this means that resetting at the end must + -- not indiscriminantely set to False, but take into account the + -- previous value + -- 2) nonetheless, newlines cancel inhibition. this means that if we ever + -- find the flag set to False afterwards, we must not return it to + -- the previous value, which might be True in the case of testing; it + -- must remain False. + state <- mGet + mSet $ state { _lstate_inhibitMTEL = True } + layoutBriDocM bd + state' <- mGet + when (_lstate_inhibitMTEL state') $ do + mSet $ state' { _lstate_inhibitMTEL = _lstate_inhibitMTEL state } + where + -- alignColsPar :: [BriDoc] + -- -> m () + -- alignColsPar l = colInfos `forM_` \colInfo -> do + -- layoutWriteNewlineBlock + -- processInfo (_cbs_map finalState) colInfo + -- where + -- (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0) + alignColsLines :: [BriDoc] + -> m () + alignColsLines l = -- colInfos `forM_` \colInfo -> do + sequence_ $ List.intersperse layoutWriteNewlineBlock $ colInfos <&> processInfo (_cbs_map finalState) + where + (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0) + briDocToColInfo :: BriDoc -> StateS.State ColBuildState ColInfo + briDocToColInfo = \case + BDCols sig list -> withAlloc $ \ind -> do + subInfos <- mapM briDocToColInfo list + return $ (briDocLineLength <$> list, ColInfo ind sig subInfos) -- TODO: replace 0 + bd -> return $ ColInfoNo bd + + mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] + mergeBriDocs bds = mergeBriDocsW ColInfoStart bds + + mergeBriDocsW :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] + mergeBriDocsW _ [] = return [] + mergeBriDocsW lastInfo (bd:bdr) = do + info <- mergeInfoBriDoc lastInfo bd + infor <- mergeBriDocsW info bdr + return $ info : infor + + mergeInfoBriDoc :: ColInfo + -> BriDoc + -> StateS.StateT ColBuildState Identity ColInfo + mergeInfoBriDoc ColInfoStart = briDocToColInfo + mergeInfoBriDoc ColInfoNo{} = briDocToColInfo + mergeInfoBriDoc (ColInfo infoInd infoSig subInfos) = \case + bd@(BDCols colSig subDocs) + | infoSig == colSig + && length subInfos == length subDocs -> do + infos <- zip subInfos subDocs + `forM` uncurry mergeInfoBriDoc + do -- update map + s <- StateS.get + let m = _cbs_map s + let (Just spaces) = IntMapS.lookup infoInd m + let new = briDocLineLength <$> subDocs + StateS.put s + { _cbs_map = IntMapS.insert infoInd + (zipWith max spaces new) + m + } + return $ ColInfo infoInd colSig infos + | otherwise -> briDocToColInfo bd + bd -> return $ ColInfoNo bd + + withAlloc :: (ColIndex -> StateS.State ColBuildState (ColSpace, ColInfo)) + -> StateS.State ColBuildState ColInfo + withAlloc 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 space $ _cbs_map c } + return info + + processInfo :: ColMap -> ColInfo -> m () + processInfo m = \case + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc + ColInfo ind _ list -> do + curX <- do + state <- mGet + return $ _lstate_curY state + fromMaybe 0 (_lstate_addSepSpace state) + -- tellDebugMess $ show curX + let Just cols = IntMapS.lookup ind m + let posXs = snd (mapAccumL (\acc x -> (acc+x,acc)) curX cols) + zip posXs list `forM_` \(destX, x) -> do + layoutWriteEnsureAbsoluteN destX + processInfo m x + +type ColIndex = Int +type ColSpace = [Int] +type ColMap = IntMapS.IntMap {- ColIndex -} ColSpace + +data ColInfo + = ColInfoStart -- start value to begin the mapAccumL. + | ColInfoNo BriDoc + | ColInfo ColIndex ColSig [ColInfo] + +data ColBuildState = ColBuildState + { _cbs_map :: ColMap + , _cbs_index :: ColIndex + } diff --git a/src/Language/Haskell/Brittany/Config.hs b/src/Language/Haskell/Brittany/Config.hs new file mode 100644 index 0000000..c357f92 --- /dev/null +++ b/src/Language/Haskell/Brittany/Config.hs @@ -0,0 +1,164 @@ +module Language.Haskell.Brittany.Config + ( ConfigF(..) + , DebugConfigF(..) + , LayoutConfigF(..) + , DebugConfig + , LayoutConfig + , Config + , configParser + , staticDefaultConfig + , readMergePersConfig + ) +where + + + +#include "prelude.inc" + +import DynFlags ( getDynFlags ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import qualified Parser as GHC +import qualified ApiAnnotation as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified GHC as GHC hiding (parseModule) +import qualified HeaderInfo as GHC +import qualified Lexer as GHC +import qualified MonadUtils as GHC +import qualified Outputable as GHC +import qualified Parser as GHC +import qualified SrcLoc as GHC +import qualified StringBuffer as GHC +import RdrName ( RdrName(..) ) +import Control.Monad.IO.Class +import GHC.Paths (libdir) +import HsSyn +import SrcLoc ( SrcSpan, Located ) +-- import Outputable ( ppr, runSDoc ) +-- import DynFlags ( unsafeGlobalDynFlags ) + +import ApiAnnotation ( AnnKeywordId(..) ) +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers +import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint.Preprocess +import qualified Data.Map as Map + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import qualified Debug.Trace as Trace + +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.LayoutBasics + +-- import Data.Aeson +import GHC.Generics +import Control.Lens + +import qualified Data.Yaml + +import UI.Butcher.Monadic + +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Utils + + + +configParser :: CmdParser Identity out (ConfigF Maybe) +configParser = do + -- TODO: why does the default not trigger; ind never should be []!! + ind <- addFlagReadParam "" ["indent"] "AMOUNT" + (flagHelpStr "spaces per indentation level") + cols <- addFlagReadParam "" ["columns"] "AMOUNT" + (flagHelpStr "target max columns (80 is an old default for this)") + importCol <- addFlagReadParam "" ["import-col"] "N" + (flagHelpStr "column to align import lists at") + + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)") + dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") + dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") + dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") + dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") + dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") + dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") + dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") + dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") + dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") + dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") + + outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible") + wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") + + return $ Config + { _conf_debug = DebugConfig + { _dconf_dump_config = falseToNothing dumpConfig + , _dconf_dump_annotations = falseToNothing dumpAnnotations + , _dconf_dump_ast_unknown = falseToNothing dumpUnknownAST + , _dconf_dump_ast_full = falseToNothing dumpCompleteAST + , _dconf_dump_bridoc_raw = falseToNothing dumpBriDocRaw + , _dconf_dump_bridoc_simpl_alt = falseToNothing dumpBriDocAlt + , _dconf_dump_bridoc_simpl_par = falseToNothing dumpBriDocPar + , _dconf_dump_bridoc_simpl_floating = falseToNothing dumpBriDocFloating + , _dconf_dump_bridoc_simpl_columns = falseToNothing dumpBriDocColumns + , _dconf_dump_bridoc_simpl_indent = falseToNothing dumpBriDocIndent + , _dconf_dump_bridoc_final = falseToNothing dumpBriDocFinal + } + , _conf_layout = LayoutConfig + { _lconfig_cols = listLastMaybe cols + , _lconfig_indentPolicy = Nothing + , _lconfig_indentAmount = listLastMaybe ind + , _lconfig_indentWhereSpecial = Nothing -- falseToNothing _ + , _lconfig_indentListSpecial = Nothing -- falseToNothing _ + , _lconfig_importColumn = listLastMaybe importCol + , _lconfig_altChooser = Nothing + } + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = falseToNothing outputOnErrors + , _econf_Werror = falseToNothing wError + } + } + where falseToNothing = Bool.bool Nothing (Just True) + listLastMaybe = listToMaybe . reverse + +-- configParser :: Parser Config +-- configParser = Config +-- <$> option (eitherReader $ maybe (Left "required !") Right . readMaybe) +-- (long "indent" <> value 2 <> metavar "AMOUNT" <> help "spaces per indentation level") +-- <*> (Bar +-- <$> switch (long "bara" <> help "bara help") +-- <*> switch (long "barb") +-- <*> flag 3 5 (long "barc") +-- ) +-- +-- configParserInfo :: ParserInfo Config +-- configParserInfo = ParserInfo +-- { infoParser = configParser +-- , infoFullDesc = True +-- , infoProgDesc = return $ PP.text "a haskell code formatting utility based on ghc-exactprint" +-- , infoHeader = return $ PP.text "brittany" +-- , infoFooter = empty +-- , infoFailureCode = (-55) +-- , infoIntersperse = True +-- } + +readMergePersConfig :: ConfigF Maybe -> System.IO.FilePath -> MaybeT IO Config +readMergePersConfig conf path = do + exists <- liftIO $ System.Directory.doesFileExist path + if exists + then do + contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. + fileConf <- case Data.Yaml.decodeEither contents of + Left e -> do + liftIO $ putStrLn $ "error reading in brittany config from " ++ path ++ ":" + liftIO $ putStrLn e + mzero + Right x -> return x + return $ cZip fromMaybeIdentity staticDefaultConfig + $ cZip (<|>) conf fileConf + else do + liftIO $ ByteString.writeFile path + $ Data.Yaml.encode + $ cMap (Just . runIdentity) staticDefaultConfig + return $ cZip fromMaybeIdentity staticDefaultConfig + $ conf diff --git a/src/Language/Haskell/Brittany/Config/Types.hs b/src/Language/Haskell/Brittany/Config/Types.hs new file mode 100644 index 0000000..2323a3b --- /dev/null +++ b/src/Language/Haskell/Brittany/Config/Types.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Language.Haskell.Brittany.Config.Types +where + + + +#include "prelude.inc" + +import Data.Yaml +import GHC.Generics +import Control.Lens + +import Data.Data ( Data ) + + + +data DebugConfigF f = DebugConfig + { _dconf_dump_config :: f Bool + , _dconf_dump_annotations :: f Bool + , _dconf_dump_ast_unknown :: f Bool + , _dconf_dump_ast_full :: f Bool + , _dconf_dump_bridoc_raw :: f Bool + , _dconf_dump_bridoc_simpl_alt :: f Bool + , _dconf_dump_bridoc_simpl_floating :: f Bool + , _dconf_dump_bridoc_simpl_par :: f Bool + , _dconf_dump_bridoc_simpl_columns :: f Bool + , _dconf_dump_bridoc_simpl_indent :: f Bool + , _dconf_dump_bridoc_final :: f Bool + } + deriving (Generic) + +data LayoutConfigF f = LayoutConfig + { _lconfig_cols :: f Int -- the thing that has default 80. + , _lconfig_indentPolicy :: f IndentPolicy + , _lconfig_indentAmount :: f Int + , _lconfig_indentWhereSpecial :: f Bool -- indent where only 1 sometimes (TODO). + , _lconfig_indentListSpecial :: f Bool -- use some special indentation for "," + -- when creating zero-indentation + -- multi-line list literals. + , _lconfig_importColumn :: f Int + , _lconfig_altChooser :: f AltChooser + } + deriving (Generic) + +data ErrorHandlingConfigF f = ErrorHandlingConfig + { _econf_produceOutputOnErrors :: f Bool + , _econf_Werror :: f Bool + } + deriving (Generic) + +data ConfigF f = Config + { _conf_debug :: DebugConfigF f + , _conf_layout :: LayoutConfigF f + , _conf_errorHandling :: ErrorHandlingConfigF f + } + deriving (Generic) + +-- i wonder if any Show1 stuff could be leveraged. +deriving instance Show (DebugConfigF Identity) +deriving instance Show (LayoutConfigF Identity) +deriving instance Show (ErrorHandlingConfigF Identity) +deriving instance Show (ConfigF Identity) + +deriving instance Show (DebugConfigF Maybe) +deriving instance Show (LayoutConfigF Maybe) +deriving instance Show (ErrorHandlingConfigF Maybe) +deriving instance Show (ConfigF Maybe) + +deriving instance Data (DebugConfigF Identity) +deriving instance Data (LayoutConfigF Identity) +deriving instance Data (ErrorHandlingConfigF Identity) +deriving instance Data (ConfigF Identity) + +type Config = ConfigF Identity +type DebugConfig = DebugConfigF Identity +type LayoutConfig = LayoutConfigF Identity +type ErrorHandlingConfig = ErrorHandlingConfigF Identity + +instance FromJSON (DebugConfigF Maybe) +instance ToJSON (DebugConfigF Maybe) + +instance FromJSON IndentPolicy +instance ToJSON IndentPolicy +instance FromJSON AltChooser +instance ToJSON AltChooser + +instance FromJSON (LayoutConfigF Maybe) +instance ToJSON (LayoutConfigF Maybe) + +instance FromJSON (ErrorHandlingConfigF Maybe) +instance ToJSON (ErrorHandlingConfigF Maybe) + +instance FromJSON (ConfigF Maybe) +instance ToJSON (ConfigF Maybe) + +-- instance Monoid DebugConfig where +-- mempty = DebugConfig Nothing Nothing +-- DebugConfig x1 x2 `mappend` DebugConfig y1 y2 +-- = DebugConfig (y1 <|> x1) +-- (y2 <|> x2) +-- +-- instance Monoid LayoutConfig where +-- mempty = LayoutConfig Nothing Nothing Nothing Nothing Nothing Nothing +-- LayoutConfig x1 x2 x3 x4 x5 x6 `mappend` LayoutConfig y1 y2 y3 y4 y5 y6 +-- = LayoutConfig (y1 <|> x1) +-- (y2 <|> x2) +-- (y3 <|> x3) +-- (y4 <|> x4) +-- (y5 <|> x5) +-- (y6 <|> x6) +-- +-- instance Monoid Config where +-- mempty = Config +-- { _conf_debug = mempty +-- , _conf_layout = mempty +-- } +-- mappend c1 c2 = Config +-- { _conf_debug = _conf_debug c1 <> _conf_debug c2 +-- , _conf_layout = _conf_layout c1 <> _conf_layout c2 +-- } + +data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more + -- than old indentation + amount + | IndentPolicyFree -- can create new indentations whereever + | IndentPolicyMultiple -- can create indentations only + -- at any n * amount. + deriving (Show, Generic, Data) + +data AltChooser = AltChooserSimpleQuick -- always choose last alternative. + -- leads to tons of sparsely filled + -- lines. + | AltChooserShallowBest -- choose the first matching alternative + -- using the simplest spacing + -- information for the children. + | AltChooserBoundedSearch Int + -- choose the first matching alternative + -- using a bounded list of recursive + -- options having sufficient space. + deriving (Show, Generic, Data) + +staticDefaultConfig :: Config +staticDefaultConfig = Config + { _conf_debug = DebugConfig + { _dconf_dump_config = Identity False + , _dconf_dump_annotations = Identity False + , _dconf_dump_ast_unknown = Identity False + , _dconf_dump_ast_full = Identity False + , _dconf_dump_bridoc_raw = Identity False + , _dconf_dump_bridoc_simpl_alt = Identity False + , _dconf_dump_bridoc_simpl_floating = Identity False + , _dconf_dump_bridoc_simpl_par = Identity False + , _dconf_dump_bridoc_simpl_columns = Identity False + , _dconf_dump_bridoc_simpl_indent = Identity False + , _dconf_dump_bridoc_final = Identity False + } + , _conf_layout = LayoutConfig + { _lconfig_cols = Identity 80 + , _lconfig_indentPolicy = Identity IndentPolicyFree + , _lconfig_indentAmount = Identity 2 + , _lconfig_indentWhereSpecial = Identity True + , _lconfig_indentListSpecial = Identity True + , _lconfig_importColumn = Identity 60 + , _lconfig_altChooser = Identity $ AltChooserBoundedSearch 3 + } + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = Identity False + , _econf_Werror = Identity False + } + } + +-- TODO: automate writing instances for this to get +-- the above Monoid instance for free. +-- potentially look at http://hackage.haskell.org/package/fieldwise-0.1.0.0/docs/src/Data-Fieldwise.html#deriveFieldwise +class CZip k where + cZip :: (forall a . f a -> g a -> h a) -> k f -> k g -> k h + +instance CZip DebugConfigF where + cZip f (DebugConfig x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) + (DebugConfig y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 y11) = DebugConfig + (f x1 y1) + (f x2 y2) + (f x3 y3) + (f x4 y4) + (f x5 y5) + (f x6 y6) + (f x7 y7) + (f x8 y8) + (f x9 y9) + (f x10 y10) + (f x11 y11) + +instance CZip LayoutConfigF where + cZip f (LayoutConfig x1 x2 x3 x4 x5 x6 x7) + (LayoutConfig y1 y2 y3 y4 y5 y6 y7) = LayoutConfig + (f x1 y1) + (f x2 y2) + (f x3 y3) + (f x4 y4) + (f x5 y5) + (f x6 y6) + (f x7 y7) + +instance CZip ErrorHandlingConfigF where + cZip f (ErrorHandlingConfig x1 x2) + (ErrorHandlingConfig y1 y2) = ErrorHandlingConfig + (f x1 y1) + (f x2 y2) + +instance CZip ConfigF where + cZip f (Config x1 x2 x3) (Config y1 y2 y3) = Config + (cZip f x1 y1) + (cZip f x2 y2) + (cZip f x3 y3) + +cMap :: CZip k => (forall a . f a -> g a) -> k f -> k g +cMap f c = cZip (\_ -> f) c c + +makeLenses ''DebugConfigF +makeLenses ''ConfigF +makeLenses ''LayoutConfigF diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayoutBasics.hs new file mode 100644 index 0000000..d124e70 --- /dev/null +++ b/src/Language/Haskell/Brittany/LayoutBasics.hs @@ -0,0 +1,769 @@ +#define INSERTTRACES 0 + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +#if !INSERTTRACES +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif + +module Language.Haskell.Brittany.LayoutBasics + ( processDefault + , rdrNameToText + , lrdrNameToText + , lrdrNameToTextAnn + , askIndent + , getCurRemaining + , layoutWriteAppend + , layoutWriteAppendMultiline + , layoutWriteNewlineBlock + , layoutWriteNewline + , layoutWriteEnsureNewline + , layoutWriteEnsureBlock + , layoutWriteEnsureBlockPlusN + , layoutWithAddBaseCol + , layoutWithAddBaseColBlock + , layoutWithAddBaseColN + , layoutWithAddBaseColNBlock + , layoutSetBaseColCur + , layoutSetIndentLevel + , layoutWriteEnsureAbsoluteN + , layoutAddSepSpace + , layoutMoveToIndentCol + , layoutSetCommentCol + , moveToExactAnn + , layoutWritePriorComments + , layoutWritePostComments + , layoutIndentRestorePostComment + , layoutWritePriorCommentsRestore + , layoutWritePostCommentsRestore + , layoutRemoveIndentLevelLinger + , extractCommentsPrior + , extractCommentsPost + , fixMoveToLineByIsNewline + , filterAnns + , ppmMoveToExactLoc + , docEmpty + , docLit + , docAlt + , docSeq + , docPar + , docPostComment + , docWrapNode + , briDocByExact + , briDocByExactNoComment + , fromMaybeIdentity + , foldedAnnKeys + , unknownNodeError + , appSep + , docCommaSep + , docParenLSep + , spacifyDocs + , briDocMToPPM + ) +where + + + +#include "prelude.inc" + +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.Utils as ExactPrint.Utils + +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.Utils + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import qualified Outputable as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified SrcLoc as GHC +import SrcLoc ( SrcSpan ) +import OccName ( occNameString ) +import Name ( getOccString ) +import Module ( moduleName ) +import ApiAnnotation ( AnnKeywordId(..) ) + +import Data.Data +import Data.Generics.Schemes +import Data.Generics.Aliases + +import DataTreePrint + +import qualified Text.PrettyPrint as PP + +import Data.Function ( fix ) + + + +processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter + Text.Builder.Builder m, + MonadMultiReader ExactPrint.Types.Anns m) + => GenLocated SrcSpan 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 + +briDocByExact :: (ExactPrint.Annotate.Annotate ast, + MonadMultiReader Config m, + MonadMultiReader ExactPrint.Types.Anns m + ) => GenLocated SrcSpan ast -> m BriDoc +briDocByExact ast = do + anns <- mAsk + traceIfDumpConf "ast" _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) + return $ docExt ast anns True + +briDocByExactNoComment :: (ExactPrint.Annotate.Annotate ast, + MonadMultiReader Config m, + MonadMultiReader ExactPrint.Types.Anns m + ) => GenLocated SrcSpan ast -> m BriDoc +briDocByExactNoComment ast = do + anns <- mAsk + traceIfDumpConf "ast" _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) + return $ docExt ast anns False + +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 + +lrdrNameToTextAnn :: ( MonadMultiReader Config m + , MonadMultiReader (Map AnnKey Annotation) m + ) + => GenLocated SrcSpan RdrName + -> m Text +lrdrNameToTextAnn ast@(L _ n) = do + anns <- mAsk + let t = 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 + _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" + _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" + _ | otherwise -> t + + +askIndent :: (MonadMultiReader Config m) => m Int +askIndent = runIdentity . _lconfig_indentAmount . _conf_layout <$> mAsk + +getCurRemaining :: ( MonadMultiReader Config m + , MonadMultiState LayoutState m + ) + => m Int +getCurRemaining = do + cols <- mAsk <&> _conf_layout .> _lconfig_cols .> runIdentity + clc <- _lstate_curY <$> mGet + return $ cols - clc + +layoutWriteAppend :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => Text + -> m () +layoutWriteAppend t = do +#if INSERTTRACES + tellDebugMessShow ("layoutWriteAppend", t) +#endif + state <- mGet + case _lstate_addSepSpace state of + Just i -> do +#if INSERTTRACES + tellDebugMessShow ("inserting spaces: ", i) +#endif + mSet $ state { _lstate_curY = _lstate_curY state + Text.length t + i + , _lstate_addSepSpace = Nothing + , _lstate_isNewline = NewLineStateNo + } + mTell $ Text.Builder.fromText $ Text.pack (replicate i ' ') <> t + Nothing -> do +#if INSERTTRACES + tellDebugMessShow ("inserting no spaces") +#endif + mSet $ state { _lstate_curY = _lstate_curY state + Text.length t + , _lstate_isNewline = NewLineStateNo + } + mTell $ Text.Builder.fromText t + +layoutWriteAppendSpaces :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => Int + -> m () +layoutWriteAppendSpaces i = do +#if INSERTTRACES + tellDebugMessShow ("layoutWriteAppendSpaces", i) +#endif + unless (i==0) $ do + state <- mGet + mSet $ state { _lstate_addSepSpace = Just + $ maybe i (+i) + $ _lstate_addSepSpace state + } + +layoutWriteAppendMultiline :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => Text + -> m () +layoutWriteAppendMultiline t = do +#if INSERTTRACES + tellDebugMessShow ("layoutWriteAppendMultiline", t) +#endif + case Text.lines t of + [] -> + layoutWriteAppend t -- need to write empty, too. + (l:lr) -> do + layoutWriteAppend l + lr `forM_` \x -> do + layoutWriteNewline + layoutWriteAppend x + +-- adds a newline and adds spaces to reach the base column. +layoutWriteNewlineBlock :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => m () +layoutWriteNewlineBlock = do +#if INSERTTRACES + tellDebugMessShow ("layoutWriteNewlineBlock") +#endif + state <- mGet + mSet $ state { _lstate_curY = 0 -- _lstate_baseY state + , _lstate_addSepSpace = Just $ _lstate_baseY state + , _lstate_inhibitMTEL = False + , _lstate_isNewline = NewLineStateYes + } + mTell $ Text.Builder.fromString $ "\n" -- ++ replicate (_lstate_baseY state) ' ' + +layoutMoveToIndentCol :: ( MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) => Int -> m () +layoutMoveToIndentCol i = do +#if INSERTTRACES + tellDebugMessShow ("layoutMoveToIndentCol", i) +#endif + state <- mGet + mSet $ state + { _lstate_addSepSpace = Just + $ if _lstate_isNewline state == NewLineStateNo + then i + else _lstate_indLevelLinger state + i - _lstate_curY state + } + +-- | does _not_ add spaces to again reach the current base column. +layoutWriteNewline :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => m () +layoutWriteNewline = do +#if INSERTTRACES + tellDebugMessShow ("layoutWriteNewline") +#endif + state <- mGet + mSet $ state { _lstate_curY = 0 + , _lstate_addSepSpace = Nothing + , _lstate_inhibitMTEL = False + , _lstate_isNewline = NewLineStateYes + } + mTell $ Text.Builder.fromString $ "\n" + +layoutWriteEnsureNewline :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => m () +layoutWriteEnsureNewline = do +#if INSERTTRACES + tellDebugMessShow ("layoutWriteEnsureNewline") +#endif + state <- mGet + when (_lstate_curY state /= _lstate_baseY state) + $ layoutWriteNewlineBlock + +layoutWriteEnsureBlock :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => m () +layoutWriteEnsureBlock = do +#if INSERTTRACES + tellDebugMessShow ("layoutWriteEnsureBlock") +#endif + state <- mGet + let diff = case _lstate_addSepSpace state of + Nothing -> _lstate_curY state - _lstate_baseY state + Just sp -> _lstate_baseY state - sp - _lstate_curY state + -- when (diff>0) $ layoutWriteNewlineBlock + when (diff>0) $ do + mSet $ state { _lstate_addSepSpace = Just + $ _lstate_baseY state + - _lstate_curY state + } + +layoutWriteEnsureAbsoluteN :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => Int -> m () +layoutWriteEnsureAbsoluteN n = do +#if INSERTTRACES + tellDebugMessShow ("layoutWriteEnsureAbsoluteN", n) +#endif + state <- mGet + let diff = n - _lstate_curY state + when (diff>0) $ do + mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to + -- at least (Just 1), so we won't + -- overwrite any old value in any + -- bad way. + } + +layoutWriteEnsureBlockPlusN :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => Int -> m () +layoutWriteEnsureBlockPlusN n = do +#if INSERTTRACES + tellDebugMessShow ("layoutWriteEnsureBlockPlusN", n) +#endif + state <- mGet + let diff = _lstate_curY state - _lstate_baseY state - n + if diff>0 + then layoutWriteNewlineBlock + else if diff<0 + then do + layoutWriteAppendSpaces $ negate diff + else return () + +layoutSetBaseColInternal :: ( MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) => Int -> m () +layoutSetBaseColInternal i = do +#if INSERTTRACES + tellDebugMessShow ("layoutSetBaseColInternal", i) +#endif + mModify $ \s -> s { _lstate_baseY = i } + +layoutSetIndentLevelInternal :: ( MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) => Int -> m () +layoutSetIndentLevelInternal i = do +#if INSERTTRACES + tellDebugMessShow ("layoutSetIndentLevelInternal", i) +#endif + mModify $ \s -> s { _lstate_indLevelLinger = _lstate_indLevel s + , _lstate_indLevel = i + } + +layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) => m () +layoutRemoveIndentLevelLinger = do +#if INSERTTRACES + tellDebugMessShow ("layoutRemoveIndentLevelLinger") +#endif + mModify $ \s -> s { _lstate_indLevelLinger = _lstate_indLevel s + } + +layoutWithAddBaseCol :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + ,MonadMultiReader Config m + , MonadMultiWriter (Seq String) m) + => m () + -> m () +layoutWithAddBaseCol m = do +#if INSERTTRACES + tellDebugMessShow ("layoutWithAddBaseCol") +#endif + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + state <- mGet + layoutSetBaseColInternal $ _lstate_baseY state + amount + m + layoutSetBaseColInternal $ _lstate_baseY state + +layoutWithAddBaseColBlock :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + ,MonadMultiReader Config m + , MonadMultiWriter (Seq String) m) + => m () + -> m () +layoutWithAddBaseColBlock m = do +#if INSERTTRACES + tellDebugMessShow ("layoutWithAddBaseColBlock") +#endif + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + state <- mGet + layoutSetBaseColInternal $ _lstate_baseY state + amount + layoutWriteEnsureBlock + m + layoutSetBaseColInternal $ _lstate_baseY state + +layoutWithAddBaseColNBlock :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => Int + -> m () + -> m () +layoutWithAddBaseColNBlock amount m = do +#if INSERTTRACES + tellDebugMessShow ("layoutWithAddBaseColNBlock", amount) +#endif + state <- mGet + layoutSetBaseColInternal $ _lstate_baseY state + amount + layoutWriteEnsureBlock + m + layoutSetBaseColInternal $ _lstate_baseY state + +layoutWithAddBaseColN :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => Int + -> m () + -> m () +layoutWithAddBaseColN amount m = do +#if INSERTTRACES + tellDebugMessShow ("layoutWithAddBaseColN", amount) +#endif + state <- mGet + layoutSetBaseColInternal $ _lstate_baseY state + amount + m + layoutSetBaseColInternal $ _lstate_baseY state + +layoutSetBaseColCur :: (MonadMultiState + LayoutState m, + MonadMultiWriter (Seq String) m) + => m () -> m () +layoutSetBaseColCur m = do +#if INSERTTRACES + tellDebugMessShow ("layoutSetBaseColCur") +#endif + state <- mGet + layoutSetBaseColInternal $ case _lstate_addSepSpace state of + Nothing -> _lstate_curY state + Just i -> _lstate_curY state + i + m + layoutSetBaseColInternal $ _lstate_baseY state + +layoutSetIndentLevel :: (MonadMultiState + LayoutState m, + MonadMultiWriter (Seq String) m) + => m () -> m () +layoutSetIndentLevel m = do +#if INSERTTRACES + tellDebugMessShow ("layoutSetIndentLevel") +#endif + state <- mGet + layoutSetIndentLevelInternal $ _lstate_curY state + fromMaybe 0 (_lstate_addSepSpace state) + m + layoutSetIndentLevelInternal $ _lstate_indLevel state + -- why are comment indentations relative to the previous indentation on + -- the first node of an additional indentation, and relative to the outer + -- indentation after the last node of some indented stuff? sure does not + -- make sense. + layoutRemoveIndentLevelLinger + +layoutAddSepSpace :: (MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => m () +layoutAddSepSpace = do +#if INSERTTRACES + tellDebugMessShow ("layoutAddSepSpace") +#endif + state <- mGet + mSet $ state { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } + +-- 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 + , MonadMultiWriter (Seq String) m) => AnnKey -> m () +moveToExactAnn annKey = do +#if INSERTTRACES + tellDebugMessShow ("moveToExactAnn'", annKey) +#endif + anns <- mAsk + case Map.lookup annKey anns of + Nothing -> return () + Just ann -> do + -- curY <- mGet <&> _lstate_curY + let ExactPrint.Types.DP (x, _y) = ExactPrint.Types.annEntryDelta ann + fixedX <- fixMoveToLineByIsNewline x + replicateM_ fixedX $ layoutWriteNewlineBlock + +fixMoveToLineByIsNewline :: MonadMultiState + LayoutState m => Int -> m Int +fixMoveToLineByIsNewline x = do + newLineState <- mGet <&> _lstate_isNewline + return $ if newLineState == NewLineStateYes + then x-1 + else x + +ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m + => ExactPrint.Types.DeltaPos + -> m () +ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do + replicateM_ x $ mTell $ Text.Builder.fromString "\n" + replicateM_ y $ mTell $ Text.Builder.fromString " " + +layoutSetCommentCol :: ( MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m ) + => m () +layoutSetCommentCol = do + state <- mGet + let col = _lstate_curY state + + fromMaybe 0 (_lstate_addSepSpace state) +#if INSERTTRACES + tellDebugMessShow ("layoutSetCommentCol", col) +#endif + mSet state { _lstate_commentCol = Just col } + +layoutWritePriorComments :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => GenLocated SrcSpan ast -> m () +layoutWritePriorComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.Types.mkAnnKey ast + let m = _lstate_commentsPrior state + let mAnn = Map.lookup key m + mSet $ state { _lstate_commentsPrior = Map.delete key m } + return mAnn + case mAnn of + Nothing -> return () + Just priors -> do + when (not $ null priors) $ do + state <- mGet + mSet $ state { _lstate_commentCol = Just $ _lstate_curY state } + priors `forM_` \( ExactPrint.Types.Comment comment _ _ + , ExactPrint.Types.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppendSpaces y + layoutWriteAppendMultiline $ Text.pack $ comment + +-- 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 + , MonadMultiWriter (Seq String) m) + => GenLocated SrcSpan ast -> m () +layoutWritePostComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.Types.mkAnnKey ast + let m = _lstate_commentsPost state + let mAnn = Map.lookup key m + mSet $ state { _lstate_commentsPost = Map.delete key m } + return mAnn + case mAnn of + Nothing -> return () + Just posts -> do + when (not $ null posts) $ do + state <- mGet + mSet $ state { _lstate_commentCol = Just $ _lstate_curY state } + posts `forM_` \( ExactPrint.Types.Comment comment _ _ + , ExactPrint.Types.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppend $ Text.pack $ replicate y ' ' + layoutWriteAppendMultiline $ Text.pack $ comment + +layoutIndentRestorePostComment :: ( Monad m + , MonadMultiState LayoutState m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + ) + => m () +layoutIndentRestorePostComment = do + isNotNewline <- mGet <&> _lstate_isNewline .> (==NewLineStateNo) + mCommentCol <- _lstate_commentCol <$> mGet + mModify $ \s -> s { _lstate_commentCol = Nothing } + case mCommentCol of + Just commentCol | isNotNewline -> do + layoutWriteNewline + layoutWriteAppend $ Text.pack $ replicate commentCol ' ' + _ -> return () + +layoutWritePriorCommentsRestore :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => GenLocated SrcSpan ast -> m () +layoutWritePriorCommentsRestore x = do + layoutWritePriorComments x + layoutIndentRestorePostComment + +layoutWritePostCommentsRestore :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => GenLocated SrcSpan ast -> m () +layoutWritePostCommentsRestore x = do + layoutWritePostComments x + layoutIndentRestorePostComment + +extractCommentsPrior :: ExactPrint.Types.Anns -> PriorMap +extractCommentsPrior anns = flip Map.mapMaybe anns $ \ann -> + [r | let r = ExactPrint.Types.annPriorComments ann, not (null r)] +extractCommentsPost :: ExactPrint.Types.Anns -> PostMap +extractCommentsPost anns = flip Map.mapMaybe anns $ \ann -> + [r + | let r = ExactPrint.Types.annsDP ann >>= \case + (ExactPrint.Types.AnnComment comment, dp) -> [(comment, dp)] + _ -> [] + , not (null r) + ] + + +foldedAnnKeys :: Data.Data.Data ast + => ast + -> Set ExactPrint.Types.AnnKey +foldedAnnKeys ast = everything + Set.union + (\x -> maybe + Set.empty + Set.singleton + [ gmapQi 1 (\t -> ExactPrint.Types.mkAnnKey $ L l t) x + | locTyCon == typeRepTyCon (typeOf x) + , l <- gmapQi 0 cast x + ] + ) + ast + where + locTyCon = typeRepTyCon (typeOf (L () ())) + +filterAnns :: Data.Data.Data ast + => ast + -> ExactPrint.Types.Anns + -> ExactPrint.Types.Anns +filterAnns ast anns = + Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns + +-- new BriDoc stuff + +docEmpty :: BriDoc +docEmpty = BDEmpty + +docLit :: Text -> BriDoc +docLit t = BDLit t + +docExt :: ExactPrint.Annotate.Annotate ast + => GenLocated SrcSpan ast -> ExactPrint.Types.Anns -> Bool -> BriDoc +docExt x anns shouldAddComment = BDExternal + (ExactPrint.Types.mkAnnKey x) + (foldedAnnKeys x) + shouldAddComment + (Text.pack $ ExactPrint.exactPrint x anns) + +docAlt :: [BriDoc] -> BriDoc +docAlt = BDAlt + + +docSeq :: [BriDoc] -> BriDoc +docSeq = BDSeq + + +appSep :: BriDoc -> BriDoc +appSep x = BDSeq [x, BDSeparator] + +docCommaSep :: BriDoc +docCommaSep = appSep $ BDLit $ Text.pack "," + +docParenLSep :: BriDoc +docParenLSep = appSep $ BDLit $ Text.pack "(" + + +docPostComment :: Data.Data.Data ast + => GenLocated SrcSpan ast + -> BriDoc + -> BriDoc +docPostComment ast bd = BDAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd + +docWrapNode :: Data.Data.Data ast + => GenLocated SrcSpan ast + -> BriDoc + -> BriDoc +docWrapNode ast bd = BDAnnotationPrior (ExactPrint.Types.mkAnnKey ast) + $ BDAnnotationPost (ExactPrint.Types.mkAnnKey ast) + $ bd + +docPar :: BriDoc + -> BriDoc + -> BriDoc +docPar line indented = BDPar BrIndentNone line indented + + +fromMaybeIdentity :: Identity a -> Maybe a -> Identity a +fromMaybeIdentity x y = Data.Coerce.coerce + $ fromMaybe (Data.Coerce.coerce x) y + +unknownNodeError + :: MonadMultiWriter [LayoutError] m + => Data.Data.Data ast => String -> ast -> m BriDoc +unknownNodeError infoStr ast = do + mTell $ [LayoutErrorUnknownNode infoStr ast] + return $ BDLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" + +spacifyDocs :: [BriDoc] -> [BriDoc] +spacifyDocs [] = [] +spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds] + +briDocMToPPM :: ToBriDocM a -> PPM a +briDocMToPPM m = do + readers <- MultiRWSS.mGetRawR + let ((x, errs), debugs) = runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiReaders readers + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ m + mTell debugs + mTell errs + return x diff --git a/src/Language/Haskell/Brittany/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Layouters/Decl.hs new file mode 100644 index 0000000..6b78791 --- /dev/null +++ b/src/Language/Haskell/Brittany/Layouters/Decl.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Layouters.Decl + ( layoutSig + , layoutBind + , layoutLocalBinds + , layoutGuardLStmt + , layoutGrhs + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.LayoutBasics + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import SrcLoc ( SrcSpan ) +import HsSyn +import Name +import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) + +import Language.Haskell.Brittany.Layouters.Type +import {-# SOURCE #-} Language.Haskell.Brittany.Layouters.Expr +import Language.Haskell.Brittany.Layouters.Pattern + +import Bag ( mapBagM ) + + + +layoutSig :: ToBriDoc Sig +layoutSig lsig@(L _loc sig) = case sig of + TypeSig names (HsIB _ (HsWC _ _ typ)) -> do + nameStrs <- names `forM` lrdrNameToTextAnn + let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs + typeDoc <- layoutType typ + return $ docWrapNode lsig $ docAlt + [ docSeq + [ docPostComment lsig $ docLit nameStr + , docLit $ Text.pack " :: " + , BDForceSingleline typeDoc + ] + , BDAddBaseY BrIndentRegular + $ docPar + (docPostComment lsig $ docLit nameStr) + ( BDCols ColTyOpPrefix + [ docLit $ Text.pack ":: " + , BDAddBaseY (BrIndentSpecial 3) $ typeDoc + ] + ) + ] + _ -> briDocByExact lsig -- TODO: should not be necessary + +layoutGuardLStmt :: ToBriDoc' (Stmt RdrName (LHsExpr RdrName)) +layoutGuardLStmt lgstmt@(L _ stmtLR) = case stmtLR of + BodyStmt body _ _ _ -> layoutExpr body + _ -> briDocByExact lgstmt -- TODO + +layoutGrhs :: Maybe BriDoc -> ToBriDoc' (GRHS RdrName (LHsExpr RdrName)) +layoutGrhs mPatPart lgrhs@(L _ (GRHS guards body)) = do + bodyDoc <- BDAddBaseY BrIndentRegular <$> layoutExpr body + let patPart = fromMaybe BDEmpty mPatPart + docWrapNode lgrhs <$> case guards of + [] -> + return $ BDCols ColEquation + [appSep $ patPart, BDSeq [appSep $ BDLit $ Text.pack "=", bodyDoc]] + [guard1] -> do + guardDoc1 <- layoutGuardLStmt guard1 + return $ BDAlt + [ BDCols ColGuardedEquation + [ patPart + , BDSeq [appSep $ BDLit $ Text.pack "|", appSep $ guardDoc1] + , BDSeq [appSep $ BDLit $ Text.pack "=", bodyDoc] + ] + , BDAddBaseY BrIndentRegular + $ docPar patPart + $ BDSeq + [ appSep $ BDLit $ Text.pack "|" + , appSep $ guardDoc1 + , appSep $ BDSeq [BDLit $ Text.pack "="] + , bodyDoc + ] + , BDAddBaseY BrIndentRegular + $ docPar patPart + $ BDLines + [ BDSeq [appSep $ BDLit $ Text.pack "|", guardDoc1] + , BDSeq [appSep $ BDLit $ Text.pack "=", bodyDoc] + ] + ] + (guard1:guardr) -> do + guardDoc1 <- layoutGuardLStmt guard1 + guardDocr <- layoutGuardLStmt `mapM` guardr + let hat = BDCols ColGuardedEquation + [appSep $ patPart, BDSeq [appSep $ BDLit $ Text.pack "|", guardDoc1]] + middle = guardDocr <&> \gd -> BDCols ColGuardedEquation + [BDEmpty, BDSeq [appSep $ BDLit $ Text.pack ",", gd]] + last = BDCols ColGuardedEquation + [BDEmpty, BDSeq [appSep $ BDLit $ Text.pack "=", bodyDoc]] + return $ BDAlt + [ BDCols ColGuardedEquation + [ appSep $ BDForceSingleline patPart + , BDSeq $ [appSep $ BDLit $ Text.pack "|", appSep $ BDForceSingleline guardDoc1] + ++ (guardDocr >>= \gd -> + [appSep $ BDLit $ Text.pack ",", appSep $ BDForceSingleline gd]) + , BDSeq [appSep $ BDLit $ Text.pack "=", bodyDoc] + ] + , BDLines $ [hat] ++ middle ++ [last] + ] + +layoutBind :: ToBriDocC (HsBindLR RdrName RdrName) (Either [BriDoc] BriDoc) +layoutBind lbind@(L _ bind) = case bind of + FunBind fId (MG (L _ matches) _ _ _) _ _ [] -> do + funcPatDocs <- matches `forM` \(L _ match@(Match _ + pats + _mType -- not an actual type sig + (GRHSs grhss whereBinds))) -> do + let isInfix = isInfixMatch match + let mId = fId + idStr <- lrdrNameToTextAnn mId + patDocs <- pats `forM` layoutPat + let funcPatternPartLine = case patDocs of + (p1:pr) | isInfix -> BDCols ColFuncPatternsInfix + ( [ appSep $ BDForceSingleline p1 + , appSep $ BDLit idStr + ] + ++ (pr <&> (\p -> appSep $ BDForceSingleline p)) + ) + ps -> BDCols ColFuncPatternsPrefix + $ appSep (BDLit $ idStr) + : (ps <&> (\p -> BDSeq [BDForceSingleline p, BDSeparator])) + grhssDocsNoInd <- do + case grhss of + [grhs1] -> layoutGrhs (Just funcPatternPartLine) grhs1 + (grhs1:grhsr) -> do + grhsDoc1 <- layoutGrhs (Just funcPatternPartLine) grhs1 + grhsDocr <- layoutGrhs Nothing `mapM` grhsr + return $ BDLines $ grhsDoc1 : grhsDocr + [] -> error "layoutBind grhssDocsNoInd" + let grhssDocs = BDAlt [grhssDocsNoInd {-, grhssDocsInd TODO-}] + layoutLocalBinds whereBinds >>= \case + Nothing -> return $ grhssDocs + Just whereDocs -> do + return $ docPar grhssDocs + $ BDEnsureIndent BrIndentRegular + $ BDAddBaseY BrIndentRegular + $ docPar (BDLit $ Text.pack "where") + $ BDSetIndentLevel $ BDLines whereDocs + return $ Left $ case funcPatDocs of + [] -> [] + [x1] -> [docWrapNode lbind x1] + (x1:xs) | (xL:xMR) <- reverse xs -> + [ BDAnnotationPrior (mkAnnKey lbind) $ x1 ] + ++ reverse xMR + ++ [ BDAnnotationPost (mkAnnKey lbind) $ xL ] + _ -> error "cannot happen (TM)" + PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do + patDoc <- layoutPat pat + mWhereDocs <- layoutLocalBinds whereBinds + grhssDocsNoInd <- do + case grhss of + [grhs1] -> layoutGrhs (Just $ appSep patDoc) grhs1 + (grhs1:grhsr) -> do + grhsDoc1 <- layoutGrhs (Just $ appSep patDoc) grhs1 + grhsDocr <- layoutGrhs Nothing `mapM` grhsr + return $ BDLines $ grhsDoc1 : grhsDocr + [] -> error "layoutBind grhssDocsNoInd" + let grhssDocs = BDAlt [grhssDocsNoInd {-, grhssDocsInd TODO-}] + case mWhereDocs of + Nothing -> + return $ Right grhssDocs + Just whereDocs -> do + return $ Right + $ BDAddBaseY BrIndentRegular + $ docPar grhssDocs + $ BDAddBaseY BrIndentRegular + $ docPar (BDLit $ Text.pack "where") + $ BDSetIndentLevel $ BDLines whereDocs + _ -> Right <$> briDocByExact lbind + +layoutLocalBinds :: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDoc]) +layoutLocalBinds (L _ 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 + x@(HsValBinds (ValBindsOut _binds _lsigs)) -> + -- i _think_ this case never occurs in non-processed ast + Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x + x@(HsIPBinds _ipBinds) -> + Just . (:[]) <$> unknownNodeError "HsIPBinds" x + EmptyLocalBinds -> + return $ Nothing + +-- layoutBind :: LayouterFType' (HsBindLR RdrName RdrName) +-- layoutBind lbind@(L _ bind) = case bind of +-- #if MIN_VERSION_ghc(8,0,0) +-- FunBind fId (MG (L _ matches) _ _ _) _ _ [] -> do +-- #else +-- FunBind fId fInfix (MG matches _ _ _) _ _ [] -> do +-- #endif +-- return $ Layouter +-- { _layouter_desc = LayoutDesc +-- { _ldesc_line = Nothing -- no parent +-- , _ldesc_block = Nothing -- no parent +-- } +-- , _layouter_func = \_params -> do +-- layoutWritePriorCommentsRestore lbind +-- moveToExactAnn lbind +-- -- remaining <- getCurRemaining +-- #if MIN_VERSION_ghc(8,0,0) +-- matches `forM_` \(L _ match@(Match _ +-- pats +-- mType +-- (GRHSs grhss (L _ whereBinds)))) -> do +-- let isInfix = isInfixMatch match +-- let mId = fId +-- #else +-- matches `forM_` \(L _ (Match mIdInfix +-- pats +-- mType +-- (GRHSs grhss whereBinds))) -> do +-- let isInfix = maybe fInfix snd mIdInfix +-- let mId = maybe fId fst mIdInfix +-- #endif +-- idStr <- lrdrNameToTextAnn mId +-- patLays <- pats `forM` \p -> layouterFToLayouterM $ layoutPat p +-- case patLays of +-- (p1:pr) | isInfix -> do +-- applyLayouter p1 defaultParams +-- layoutWriteAppend $ (Text.pack " ") <> idStr +-- pr `forM_` \p -> do +-- layoutWriteAppend $ Text.pack " " +-- applyLayouter p defaultParams +-- ps -> do +-- layoutWriteAppend $ idStr +-- ps `forM_` \p -> do +-- layoutWriteAppend $ Text.pack " " +-- applyLayouter p defaultParams +-- case mType of +-- Nothing -> return () +-- Just t -> do +-- tLay <- layouterFToLayouterM $ layoutType t +-- layoutWriteAppend $ Text.pack " :: " +-- applyLayouter tLay defaultParams +-- grhss `forM_` \case +-- L _ (GRHS [] body) -> do +-- layoutWriteAppend $ Text.pack " = " +-- l <- layouterFToLayouterM $ layoutExpr body +-- layoutWithAddIndent $ do +-- applyLayouter l defaultParams +-- grhs -> do +-- l <- layoutByExact grhs +-- applyLayouter l defaultParams +-- case whereBinds of +-- HsValBinds valBinds -> undefined valBinds -- TODO +-- HsIPBinds ipBinds -> undefined ipBinds -- TODO +-- EmptyLocalBinds -> return () +-- layoutWritePostCommentsRestore lbind +-- , _layouter_ast = lbind +-- } +-- _ -> layoutByExact lbind diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Layouters/Expr.hs new file mode 100644 index 0000000..a48dea3 --- /dev/null +++ b/src/Language/Haskell/Brittany/Layouters/Expr.hs @@ -0,0 +1,649 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Layouters.Expr + ( layoutExpr + , litBriDoc + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.LayoutBasics + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import SrcLoc ( SrcSpan ) +import HsSyn +import Name +import qualified FastString +import BasicTypes + +import Language.Haskell.Brittany.Layouters.Pattern +import Language.Haskell.Brittany.Layouters.Decl +import Language.Haskell.Brittany.Layouters.Stmt + + + +layoutExpr :: ToBriDoc HsExpr +layoutExpr lexpr@(L _ expr) = fmap (docWrapNode lexpr) + $ case expr of + HsVar vname -> do + BDLit <$> lrdrNameToTextAnn vname + HsUnboundVar var -> return $ case var of + OutOfScope oname _ -> BDLit $ Text.pack $ occNameString oname + TrueExprHole oname -> BDLit $ Text.pack $ occNameString oname + HsRecFld{} -> do + -- TODO + briDocByExact lexpr + HsOverLabel{} -> do + -- TODO + briDocByExact lexpr + HsIPVar{} -> do + -- TODO + briDocByExact lexpr + HsOverLit (OverLit olit _ _ _) -> do + return $ overLitValBriDoc olit + HsLit lit -> do + return $ litBriDoc lit + HsLam (MG (L _ [L _ (Match _ pats _ (GRHSs [L _ (GRHS [] body)] (L _ EmptyLocalBinds)))]) _ _ _) -> do + patDocs <- pats `forM` layoutPat + bodyDoc <- BDAddBaseY BrIndentRegular <$> layoutExpr body + let funcPatternPartLine = + BDCols ColCasePattern + $ (patDocs <&> (\p -> BDSeq [BDForceSingleline p, BDSeparator])) + return $ BDAlt + [ BDSeq + [ BDLit $ Text.pack "\\" + , funcPatternPartLine + , appSep $ BDLit $ Text.pack "->" + , bodyDoc + ] + -- TODO + ] + HsLam{} -> + unknownNodeError "HsLam too complex" lexpr + HsLamCase _ (MG (L _ matches) _ _ _) -> do + funcPatDocs <- matches `forM` \(L _ (Match _ + pats + _mType -- not an actual type sig + (GRHSs grhss whereBinds))) -> do + patDocs <- pats `forM` layoutPat + let funcPatternPartLine = case patDocs of + ps -> BDCols ColFuncPatternsPrefix + $ (ps <&> (\p -> BDSeq [BDForceSingleline p, BDSeparator])) + grhssDocsNoInd <- do + case grhss of + [grhs1] -> layoutGrhsLCase (Just funcPatternPartLine) grhs1 + (grhs1:grhsr) -> do + grhsDoc1 <- layoutGrhsLCase (Just funcPatternPartLine) grhs1 + grhsDocr <- layoutGrhsLCase Nothing `mapM` grhsr + return $ BDLines $ grhsDoc1 : grhsDocr + [] -> error "layoutBind grhssDocsNoInd" + let grhssDocs = BDAlt [grhssDocsNoInd {-, grhssDocsInd TODO-}] + layoutLocalBinds whereBinds >>= \case + Nothing -> return $ grhssDocs + Just whereDocs -> do + return $ BDAddBaseY BrIndentRegular + $ docPar grhssDocs + $ BDAddBaseY BrIndentRegular + $ docPar (BDLit $ Text.pack "where") + $ BDSetIndentLevel $ BDLines whereDocs + return $ BDAddBaseY BrIndentRegular $ docPar + (BDLit $ Text.pack "\\case") + (BDLines funcPatDocs) + HsApp exp1 exp2 -> do + -- TODO: if expDoc1 is some literal, we may want to create a BDCols here. + expDoc1 <- layoutExpr exp1 + expDoc2 <- layoutExpr exp2 + return $ BDAlt + [ BDSeq [appSep $ BDForceSingleline expDoc1, BDForceSingleline expDoc2] + , BDAddBaseY BrIndentRegular + $ docPar + expDoc1 + expDoc2 + ] + HsAppType{} -> do + -- TODO + briDocByExact lexpr + HsAppTypeOut{} -> do + -- TODO + briDocByExact lexpr + OpApp expLeft expOp _ expRight -> do + expDocLeft <- layoutExpr expLeft + expDocOp <- layoutExpr expOp + expDocRight <- layoutExpr expRight + return $ BDAlt + [ BDSeq + [ appSep $ BDForceSingleline expDocLeft + , appSep $ BDForceSingleline expDocOp + , BDForceSingleline expDocRight + ] + , BDAddBaseY BrIndentRegular + $ docPar + expDocLeft + -- TODO: turn this into BDCols? + (BDSeq [appSep $ expDocOp, expDocRight]) + ] + NegApp{} -> do + -- TODO + briDocByExact lexpr + HsPar innerExp -> do + innerExpDoc <- layoutExpr innerExp + return $ BDAlt + [ BDSeq + [ BDLit $ Text.pack "(" + , BDForceSingleline innerExpDoc + , BDLit $ Text.pack ")" + ] + -- TODO + ] + SectionL{} -> do + -- TODO + briDocByExact lexpr + SectionR{} -> do + -- TODO + briDocByExact lexpr + ExplicitTuple args boxity + | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do + argDocs <- layoutExpr `mapM` argExprs + return $ case boxity of + Boxed -> BDAlt + [ BDSeq + $ [ BDLit $ Text.pack "(" ] + ++ List.intersperse (appSep $ BDLit $ Text.pack ",") argDocs + ++ [ BDLit $ Text.pack ")"] + -- TODO + ] + Unboxed -> BDAlt + [ BDSeq + $ [ BDLit $ Text.pack "(#" ] + ++ List.intersperse (appSep $ BDLit $ Text.pack ",") argDocs + ++ [ BDLit $ Text.pack "#)"] + -- TODO + ] + ExplicitTuple{} -> + unknownNodeError "ExplicitTuple|.." lexpr + HsCase cExp (MG (L _ matches) _ _ _) -> do + cExpDoc <- layoutExpr cExp + funcPatDocs <- matches `forM` \(L _ (Match _ + pats + _mType -- not an actual type sig + (GRHSs grhss whereBinds))) -> do + patDocs <- pats `forM` layoutPat + let funcPatternPartLine = + BDCols ColCasePattern + $ (patDocs <&> (\p -> BDSeq [BDForceSingleline p, BDSeparator])) + grhssDocsNoInd <- do + case grhss of + [grhs1] -> layoutGrhsCase (Just funcPatternPartLine) grhs1 + (grhs1:grhsr) -> do + grhsDoc1 <- layoutGrhsCase (Just funcPatternPartLine) grhs1 + grhsDocr <- layoutGrhsCase Nothing `mapM` grhsr + return $ BDLines $ grhsDoc1 : grhsDocr + [] -> error "layoutBind grhssDocsNoInd" + let grhssDocs = BDAlt [grhssDocsNoInd {-, grhssDocsInd TODO-}] + layoutLocalBinds whereBinds >>= \case + Nothing -> return $ grhssDocs + Just lhsBindsLRDoc -> do + return $ BDAddBaseY BrIndentRegular + $ docPar grhssDocs + $ BDAddBaseY BrIndentRegular + $ docPar (BDLit $ Text.pack "where") + $ BDSetIndentLevel $ BDLines lhsBindsLRDoc + return $ BDAlt + [ BDAddBaseY BrIndentRegular + $ docPar + ( BDSeq + [ appSep $ BDLit $ Text.pack "case" + , appSep $ BDForceSingleline cExpDoc + , BDLit $ Text.pack "of" + ]) + (BDSetIndentLevel $ BDLines funcPatDocs) + , docPar + ( BDAddBaseY BrIndentRegular + $ docPar (BDLit $ Text.pack "case") cExpDoc + ) + ( BDAddBaseY BrIndentRegular + $ docPar (BDLit $ Text.pack "of") + (BDSetIndentLevel $ BDLines funcPatDocs) + ) + ] + HsIf _ ifExpr thenExpr elseExpr -> do + ifExprDoc <- layoutExpr ifExpr + thenExprDoc <- layoutExpr thenExpr + elseExprDoc <- layoutExpr elseExpr + return $ BDAlt + [ BDSeq + [ appSep $ BDLit $ Text.pack "if" + , appSep $ BDForceSingleline ifExprDoc + , appSep $ BDLit $ Text.pack "then" + , appSep $ BDForceSingleline thenExprDoc + , appSep $ BDLit $ Text.pack "else" + , BDForceSingleline elseExprDoc + ] + , BDAddBaseY BrIndentRegular + $ docPar + ( BDAddBaseY (BrIndentSpecial 3) + $ BDSeq [appSep $ BDLit $ Text.pack "if", ifExprDoc]) + (BDLines + [ BDAddBaseY BrIndentRegular + $ BDAlt + [ BDSeq [appSep $ BDLit $ Text.pack "then", BDForceSingleline thenExprDoc] + , BDAddBaseY BrIndentRegular + $ docPar (BDLit $ Text.pack "then") thenExprDoc + ] + , BDAddBaseY BrIndentRegular + $ BDAlt + [ BDSeq [appSep $ BDLit $ Text.pack "else", BDForceSingleline elseExprDoc] + , BDAddBaseY BrIndentRegular + $ docPar (BDLit $ Text.pack "else") elseExprDoc + ] + ]) + , BDLines + [ BDAddBaseY (BrIndentSpecial 3) + $ BDSeq [appSep $ BDLit $ Text.pack "if", ifExprDoc] + , BDAddBaseY BrIndentRegular + $ docPar (BDLit $ Text.pack "then") thenExprDoc + , BDAddBaseY BrIndentRegular + $ docPar (BDLit $ Text.pack "else") elseExprDoc + ] + ] + HsMultiIf _ cases -> do + caseDocs <- cases `forM` layoutGrhsMWIf + return $ BDAddBaseY BrIndentRegular $ docPar + (BDLit $ Text.pack "if") + (BDLines caseDocs) + HsLet{} -> do + -- TODO + briDocByExact lexpr + HsDo DoExpr (L _ stmts) _ -> do + stmtDocs <- layoutStmt `mapM` stmts + return $ BDAddBaseY BrIndentRegular + $ docPar + (BDLit $ Text.pack "do") + (BDSetIndentLevel $ BDLines stmtDocs) + HsDo x (L _ stmts) _ | case x of { ListComp -> True + ; MonadComp -> True + ; _ -> False } -> do + stmtDocs <- layoutStmt `mapM` stmts + return $ BDAlt + [ BDSeq + [ appSep $ BDLit $ Text.pack "[" + , appSep $ BDForceSingleline $ List.last stmtDocs + , appSep $ BDLit $ Text.pack "|" + , BDSeq $ List.intersperse docCommaSep + $ fmap BDForceSingleline $ List.init stmtDocs + , BDLit $ Text.pack "]" + ] + , let + start = BDCols ColListComp + [appSep $ BDLit $ Text.pack "[", List.last stmtDocs] + (s1:sM) = List.init stmtDocs + line1 = BDCols ColListComp + [appSep $ BDLit $ Text.pack "|", s1] + lineM = sM <&> \d -> + BDCols ColListComp [docCommaSep, d] + end = BDLit $ Text.pack "]" + in BDSetBaseY $ BDLines $ [start, line1] ++ lineM ++ [end] + ] + HsDo{} -> do + -- TODO + briDocByExact lexpr + ExplicitList _ _ elems@(_:_) -> do + elemDocs <- elems `forM` layoutExpr + return $ BDAlt + [ BDSeq + $ [BDLit $ Text.pack "["] + ++ List.intersperse docCommaSep (BDForceSingleline <$> elemDocs) + ++ [BDLit $ Text.pack "]"] + , let + start = BDCols ColList + [appSep $ BDLit $ Text.pack "[", List.head elemDocs] + lines = List.tail elemDocs <&> \d -> + BDCols ColList [docCommaSep, d] + end = BDLit $ Text.pack "]" + in BDSetBaseY $ BDLines $ [start] ++ lines ++ [end] + ] + ExplicitList _ _ [] -> + return $ BDLit $ Text.pack "[]" + ExplicitPArr{} -> do + -- TODO + briDocByExact lexpr + RecordCon lname _ _ (HsRecFields [] Nothing) -> do + let t = lrdrNameToText lname + return $ BDLit $ t <> Text.pack "{}" + RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do + let t = lrdrNameToText lname + (fd1:fdr) <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr _)) -> do + fExpDoc <- layoutExpr fExpr + return $ (lrdrNameToText lnameF, fExpDoc) + return $ BDAlt + [ BDAddBaseY BrIndentRegular + $ docPar + (BDLit t) + (BDLines $ let + line1 = BDCols ColRecUpdate + [ appSep $ BDLit $ Text.pack "{" + , appSep $ BDLit $ fst fd1 + , BDSeq [ appSep $ BDLit $ Text.pack "=" + , BDAddBaseY BrIndentRegular $ snd fd1 + ] + ] + lineR = fdr <&> \(fText, fDoc) -> BDCols ColRecUpdate + [ appSep $ BDLit $ Text.pack "," + , appSep $ BDLit $ fText + , BDSeq [ appSep $ BDLit $ Text.pack "=" + , BDAddBaseY BrIndentRegular fDoc + ] + ] + lineN = BDLit $ Text.pack "}" + in [line1] ++ lineR ++ [lineN]) + -- TODO oneliner (?) + ] + RecordCon{} -> + unknownNodeError "RecordCon with puns" lexpr + RecordUpd rExpr [] _ _ _ _ -> do + rExprDoc <- layoutExpr rExpr + return $ BDSeq [rExprDoc, BDLit $ Text.pack "{}"] + RecordUpd rExpr fields@(_:_) _ _ _ _ -> do + rExprDoc <- layoutExpr rExpr + rF1:rFr <- fields `forM` \(L _ (HsRecField (L _ ambName) rFExpr _)) -> do + rFExpDoc <- layoutExpr rFExpr + return $ case ambName of + Unambiguous n _ -> (lrdrNameToText n, rFExpDoc) + Ambiguous n _ -> (lrdrNameToText n, rFExpDoc) + return $ BDAlt + [ BDAddBaseY BrIndentRegular + $ docPar + rExprDoc + (BDLines $ let + line1 = BDCols ColRecUpdate + [ appSep $ BDLit $ Text.pack "{" + , appSep $ BDLit $ fst rF1 + , BDSeq [ appSep $ BDLit $ Text.pack "=" + , BDAddBaseY BrIndentRegular $ snd rF1 + ] + ] + lineR = rFr <&> \(fText, fDoc) -> BDCols ColRecUpdate + [ appSep $ BDLit $ Text.pack "," + , appSep $ BDLit $ fText + , BDSeq [ appSep $ BDLit $ Text.pack "=" + , BDAddBaseY BrIndentRegular fDoc + ] + ] + lineN = BDLit $ Text.pack "}" + in [line1] ++ lineR ++ [lineN]) + -- TODO oneliner (?) + ] + ExprWithTySig{} -> do + -- TODO + briDocByExact lexpr + ExprWithTySigOut{} -> do + -- TODO + briDocByExact lexpr + ArithSeq _ Nothing info -> + case info of + From e1 -> do + e1Doc <- layoutExpr e1 + return $ BDSeq + [ BDLit $ Text.pack "[" + , BDForceSingleline e1Doc + , BDLit $ Text.pack "..]" + ] + FromThen e1 e2 -> do + e1Doc <- layoutExpr e1 + e2Doc <- layoutExpr e2 + return $ BDSeq + [ BDLit $ Text.pack "[" + , BDForceSingleline e1Doc + , BDLit $ Text.pack "," + , BDForceSingleline e2Doc + , BDLit $ Text.pack "..]" + ] + FromTo e1 eN -> do + e1Doc <- layoutExpr e1 + eNDoc <- layoutExpr eN + return $ BDSeq + [ BDLit $ Text.pack "[" + , BDForceSingleline e1Doc + , BDLit $ Text.pack ".." + , BDForceSingleline eNDoc + , BDLit $ Text.pack "]" + ] + FromThenTo e1 e2 eN -> do + e1Doc <- layoutExpr e1 + e2Doc <- layoutExpr e2 + eNDoc <- layoutExpr eN + return $ BDSeq + [ BDLit $ Text.pack "[" + , BDForceSingleline e1Doc + , BDLit $ Text.pack "," + , BDForceSingleline e2Doc + , BDLit $ Text.pack ".." + , BDForceSingleline eNDoc + , BDLit $ Text.pack "]" + ] + ArithSeq{} -> + unknownNodeError "ArithSeq" lexpr + PArrSeq{} -> do + -- TODO + briDocByExact lexpr + HsSCC{} -> do + -- TODO + briDocByExact lexpr + HsCoreAnn{} -> do + -- TODO + briDocByExact lexpr + HsBracket{} -> do + -- TODO + briDocByExact lexpr + HsRnBracketOut{} -> do + -- TODO + briDocByExact lexpr + HsTcBracketOut{} -> do + -- TODO + briDocByExact lexpr + HsSpliceE{} -> do + -- TODO + briDocByExact lexpr + HsProc{} -> do + -- TODO + briDocByExact lexpr + HsStatic{} -> do + -- TODO + briDocByExact lexpr + HsArrApp{} -> do + -- TODO + briDocByExact lexpr + HsArrForm{} -> do + -- TODO + briDocByExact lexpr + HsTick{} -> do + -- TODO + briDocByExact lexpr + HsBinTick{} -> do + -- TODO + briDocByExact lexpr + HsTickPragma{} -> do + -- TODO + briDocByExact lexpr + EWildPat{} -> do + -- TODO + briDocByExact lexpr + EAsPat{} -> do + -- TODO + briDocByExact lexpr + EViewPat{} -> do + -- TODO + briDocByExact lexpr + ELazyPat{} -> do + -- TODO + briDocByExact lexpr + HsWrap{} -> do + -- TODO + briDocByExact lexpr + + +layoutGrhsCase :: Maybe BriDoc -> ToBriDoc' (GRHS RdrName (LHsExpr RdrName)) +layoutGrhsCase mPatPart lgrhs@(L _ (GRHS guards body)) = do + bodyDoc <- BDAddBaseY BrIndentRegular + <$> layoutExpr body + let patPart = fromMaybe BDEmpty mPatPart + docWrapNode lgrhs <$> case guards of + [] -> + return $ BDCols ColEquation [patPart, BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc]] + [guard1] -> do + guardDoc1 <- layoutGuardLStmt guard1 + return $ BDAlt + [ BDCols ColGuardedEquation + [ patPart + , BDSeq [BDLit $ Text.pack "| ", appSep $ guardDoc1] + , BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc] + ] + , BDAddBaseY BrIndentRegular + $ docPar patPart + $ BDSeq + [ BDLit $ Text.pack "| " + , guardDoc1 + , appSep $ BDSeq [BDLit $ Text.pack "->"] + , bodyDoc + ] + , BDAddBaseY BrIndentRegular + $ docPar patPart + $ BDLines + [ BDSeq [appSep $ BDLit $ Text.pack "|", appSep guardDoc1] + , BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc] + ] + ] + (guard1:guardr) -> do + guardDoc1 <- layoutGuardLStmt guard1 + guardDocr <- layoutGuardLStmt `mapM` guardr + let hat = BDCols ColGuardedEquation + [patPart, BDSeq [appSep $ BDLit $ Text.pack "|", appSep guardDoc1]] + middle = guardDocr <&> \gd -> BDCols ColGuardedEquation + [BDEmpty, BDSeq [appSep $ BDLit $ Text.pack ",", gd]] + last = BDCols ColGuardedEquation + [BDEmpty, BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc]] + return $ BDAlt + [ BDCols ColGuardedEquation + [ BDForceSingleline patPart + , BDSeq $ [appSep $ BDLit $ Text.pack "|", appSep $ BDForceSingleline guardDoc1] + ++ (guardDocr >>= \gd -> + [appSep $ BDLit $ Text.pack ",", BDForceSingleline gd]) + , BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc] + ] + , BDLines $ [hat] ++ middle ++ [last] + ] + +layoutGrhsMWIf :: ToBriDoc' (GRHS RdrName (LHsExpr RdrName)) +layoutGrhsMWIf lgrhs@(L _ (GRHS guards body)) = do + bodyDoc <- BDAddBaseY BrIndentRegular + <$> layoutExpr body + docWrapNode lgrhs <$> case guards of + [] -> + unknownNodeError "layoutGrhsMWIf no guards" lgrhs + [guard1] -> do + guardDoc1 <- layoutGuardLStmt guard1 + return $ BDAlt + [ BDCols ColGuardedEquation + [ BDSeq [appSep $ BDLit $ Text.pack "|", appSep $ BDForceSingleline guardDoc1] + , BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc] + ] + , BDLines + [ BDSeq [appSep $ BDLit $ Text.pack "|", appSep guardDoc1, BDLit $ Text.pack "->"] + , BDEnsureIndent BrIndentRegular $ bodyDoc + ] + ] + (guard1:guardr) -> do + guardDoc1 <- layoutGuardLStmt guard1 + guardDocr <- layoutGuardLStmt `mapM` guardr + let hat = BDCols ColGuardedEquation + [BDSeq [appSep $ BDLit $ Text.pack "|", guardDoc1]] + middle = guardDocr <&> \gd -> BDCols ColGuardedEquation + [BDSeq [appSep $ BDLit $ Text.pack " ,", appSep gd, BDLit $ Text.pack "->"]] + last = BDCols ColGuardedEquation + [BDSeq [BDLit $ Text.pack " ", bodyDoc]] + return $ BDAlt + [ BDCols ColGuardedEquation + [ BDSeq $ [appSep $ BDLit $ Text.pack "|", BDForceSingleline guardDoc1] + ++ (guardDocr >>= \gd -> + [appSep $ BDLit $ Text.pack ",", BDForceSingleline gd]) + , BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc] + ] + , BDLines $ [hat] ++ middle ++ [last] + ] + +layoutGrhsLCase :: Maybe BriDoc -> ToBriDoc' (GRHS RdrName (LHsExpr RdrName)) +layoutGrhsLCase mPatPart lgrhs@(L _ (GRHS guards body)) = do + bodyDoc <- BDAddBaseY BrIndentRegular <$> layoutExpr body + let patPart = fromMaybe BDEmpty mPatPart + docWrapNode lgrhs <$> case guards of + [] -> + return $ BDCols ColEquation [patPart, BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc]] + [guard1] -> do + guardDoc1 <- layoutGuardLStmt guard1 + return $ BDAlt + [ BDCols ColGuardedEquation + [ patPart + , BDSeq [appSep $ BDLit $ Text.pack "|", appSep guardDoc1] + , BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc] + ] + , BDAddBaseY BrIndentRegular + $ docPar patPart + $ BDSeq + [ BDLit $ Text.pack "| " + , guardDoc1 + , appSep $ BDSeq [BDLit $ Text.pack "->"] + , bodyDoc + ] + , BDAddBaseY BrIndentRegular + $ docPar patPart + $ BDLines + [ BDSeq [appSep $ BDLit $ Text.pack "|", appSep guardDoc1] + , BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc] + ] + ] + (guard1:guardr) -> do + guardDoc1 <- layoutGuardLStmt guard1 + guardDocr <- layoutGuardLStmt `mapM` guardr + let hat = BDCols ColGuardedEquation + [patPart, BDSeq [appSep $ BDLit $ Text.pack "|", guardDoc1]] + middle = guardDocr <&> \gd -> BDCols ColGuardedEquation + [BDEmpty, BDSeq [appSep $ BDLit $ Text.pack ",", gd]] + last = BDCols ColGuardedEquation + [BDEmpty, BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc]] + return $ BDAlt + [ BDCols ColGuardedEquation + [ BDForceSingleline patPart + , BDSeq $ [appSep $ BDLit $ Text.pack "|", appSep $ BDForceSingleline guardDoc1] + ++ (guardDocr >>= \gd -> + [appSep $ BDLit $ Text.pack ",", appSep $ BDForceSingleline gd]) + , BDSeq [appSep $ BDLit $ Text.pack "->", bodyDoc] + ] + , BDLines $ [hat] ++ middle ++ [last] + ] + +litBriDoc :: HsLit -> BriDoc +litBriDoc = \case + HsChar t _c -> BDLit $ Text.pack t -- BDLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim t _c -> BDLit $ Text.pack t -- BDLit $ Text.pack $ ['\'', c, '\''] + HsString t _fastString -> BDLit $ Text.pack t -- BDLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim t _byteString -> BDLit $ Text.pack t -- BDLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt t _i -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i + HsIntPrim t _i -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i + HsWordPrim t _i -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i + HsInt64Prim t _i -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i + HsWord64Prim t _i -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i + HsInteger t _i _type -> BDLit $ Text.pack t -- BDLit $ Text.pack $ show i + HsRat (FL t _) _type -> BDLit $ Text.pack t + HsFloatPrim (FL t _) -> BDLit $ Text.pack t + HsDoublePrim (FL t _) -> BDLit $ Text.pack t + +overLitValBriDoc :: OverLitVal -> BriDoc +overLitValBriDoc = \case + HsIntegral t _ -> BDLit $ Text.pack t + HsFractional (FL t _) -> BDLit $ Text.pack t + HsIsString t _ -> BDLit $ Text.pack t diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Layouters/Expr.hs-boot new file mode 100644 index 0000000..b3b7d28 --- /dev/null +++ b/src/Language/Haskell/Brittany/Layouters/Expr.hs-boot @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Layouters.Expr + ( layoutExpr + , litBriDoc + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.LayoutBasics + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import SrcLoc ( SrcSpan ) +import HsSyn +import Name + + + +layoutExpr :: ToBriDoc HsExpr + +-- layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) + +litBriDoc :: HsLit -> BriDoc diff --git a/src/Language/Haskell/Brittany/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Layouters/Pattern.hs new file mode 100644 index 0000000..e7b7533 --- /dev/null +++ b/src/Language/Haskell/Brittany/Layouters/Pattern.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Layouters.Pattern + ( layoutPat + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.LayoutBasics + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import SrcLoc ( SrcSpan ) +import HsSyn +import Name +import BasicTypes + +import {-# SOURCE #-} Language.Haskell.Brittany.Layouters.Expr + + + +layoutPat :: ToBriDoc Pat +layoutPat lpat@(L _ pat) = fmap (docWrapNode lpat) $ case pat of + WildPat _ -> return $ BDLit $ Text.pack "_" + VarPat n -> return $ BDLit $ lrdrNameToText n + LitPat lit -> return $ litBriDoc lit + ParPat inner -> do + innerDoc <- layoutPat inner + return $ BDSeq + [ BDLit $ Text.pack "(" + , innerDoc + , BDLit $ Text.pack ")" + ] + ConPatIn lname (PrefixCon args) -> do + let nameDoc = lrdrNameToText lname + argDocs <- layoutPat `mapM` args + return $ BDSeq $ + appSep (BDLit nameDoc) : spacifyDocs argDocs + ConPatIn lname (InfixCon left right) -> do + let nameDoc = lrdrNameToText lname + leftDoc <- layoutPat left + rightDoc <- layoutPat right + return $ BDSeq [leftDoc, BDLit nameDoc, rightDoc] + TuplePat args boxity _ -> do + argDocs <- layoutPat `mapM` args + return $ case boxity of + Boxed -> BDAlt + [ BDSeq + $ [ BDLit $ Text.pack "(" ] + ++ List.intersperse (appSep $ BDLit $ Text.pack ",") argDocs + ++ [ BDLit $ Text.pack ")"] + -- TODO + ] + Unboxed -> BDAlt + [ BDSeq + $ [ BDLit $ Text.pack "(#" ] + ++ List.intersperse (appSep $ BDLit $ Text.pack ",") argDocs + ++ [ BDLit $ Text.pack "#)"] + -- TODO + ] + AsPat asName asPat -> do + patDoc <- layoutPat asPat + return $ BDSeq + [ BDLit $ lrdrNameToText asName <> Text.pack "@" + , patDoc + ] +-- #if MIN_VERSION_ghc(8,0,0) +-- VarPat n -> return $ stringLayouter lpat $ lrdrNameToText n +-- #else +-- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n +-- #endif + _ -> briDocByExact lpat diff --git a/src/Language/Haskell/Brittany/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Layouters/Stmt.hs new file mode 100644 index 0000000..b11af79 --- /dev/null +++ b/src/Language/Haskell/Brittany/Layouters/Stmt.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Layouters.Stmt + ( layoutStmt + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.LayoutBasics + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import SrcLoc ( SrcSpan ) +import HsSyn +import Name +import qualified FastString +import BasicTypes + +import Language.Haskell.Brittany.Layouters.Pattern +import Language.Haskell.Brittany.Layouters.Decl +import {-# SOURCE #-} Language.Haskell.Brittany.Layouters.Expr + + + +layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) +layoutStmt lstmt@(L _ stmt) = case stmt of + LastStmt body False _ -> do + layoutExpr body + BindStmt lPat expr _ _ _ -> do + patDoc <- layoutPat lPat + expDoc <- layoutExpr expr + return $ docWrapNode lstmt + $ BDCols ColDoBind + [patDoc, BDSeq [BDLit $ Text.pack " <- ", expDoc]] + LetStmt binds -> layoutLocalBinds binds >>= \case + Nothing -> + return $ docWrapNode lstmt $ BDLit $ Text.pack "let" -- i just tested + -- it, and it is + -- indeed allowed. + -- heh. + Just [] -> + return $ docWrapNode lstmt $ BDLit $ Text.pack "let" -- this probably never happens + Just [bindDoc] -> return $ docWrapNode lstmt $ BDAlt + [ BDCols ColDoLet + [ appSep $ BDLit $ Text.pack "let" + , BDAddBaseY (BrIndentSpecial 4) bindDoc + ] + , BDAddBaseY BrIndentRegular $ docPar + (BDLit $ Text.pack "let") + bindDoc + ] + Just bindDocs@(bindDoc1:bindDocr) -> do + return $ docWrapNode lstmt + $ BDAlt + [ BDLines + $ (BDCols ColDoLet + [ appSep $ BDLit $ Text.pack "let" + , BDAddBaseY (BrIndentSpecial 4) bindDoc1 + ]) + : (bindDocr <&> \bindDoc -> + BDCols ColDoLet + [ appSep $ BDEmpty + , BDAddBaseY (BrIndentSpecial 4) bindDoc + ]) + , BDAddBaseY BrIndentRegular + $ docPar + (BDLit $ Text.pack "let") + (BDLines bindDocs) + ] + BodyStmt expr _ _ _ -> do + expDoc <- layoutExpr expr + return $ docWrapNode lstmt $ BDAddBaseY BrIndentRegular $ expDoc + _ -> briDocByExact lstmt diff --git a/src/Language/Haskell/Brittany/Layouters/Type.hs b/src/Language/Haskell/Brittany/Layouters/Type.hs new file mode 100644 index 0000000..dbd0284 --- /dev/null +++ b/src/Language/Haskell/Brittany/Layouters/Type.hs @@ -0,0 +1,648 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Layouters.Type + ( layoutType + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany.LayoutBasics + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) +import SrcLoc ( SrcSpan ) +import HsSyn +import Name +import Outputable ( ftext, showSDocUnsafe ) + +import DataTreePrint + + + +layoutType :: ToBriDoc HsType +layoutType ltype@(L _ typ) = case typ of + -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" + HsTyVar name -> do + let t = lrdrNameToText name + return $ docWrapNode ltype $ docLit t + HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts@(_:_)) typ2)) -> do + typeDoc <- layoutType typ2 + tyVarDocs <- bndrs `forM` \case + (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do + d <- layoutType kind + return $ (lrdrNameToText lrdrName, Just d) + cntxtDocs <- cntxts `forM` layoutType + let + tyVarDocLineList = tyVarDocs >>= \case + (tname, Nothing) -> [BDLit $ Text.pack " " <> tname] + (tname, Just doc) -> [ BDLit $ Text.pack " (" + <> tname + <> Text.pack " :: " + , BDForceSingleline doc + , BDLit $ Text.pack ")" + ] + forallDoc = BDAlt + [ let + open = BDLit $ Text.pack "forall" + in BDSeq ([open]++tyVarDocLineList) + , docPar + (BDLit (Text.pack "forall")) + (BDLines + $ tyVarDocs <&> \case + (tname, Nothing) -> BDEnsureIndent BrIndentRegular $ BDLit tname + (tname, Just doc) -> BDEnsureIndent BrIndentRegular + $ BDLines + [ BDCols ColTyOpPrefix + [ docParenLSep + , BDLit tname + ] + , BDCols ColTyOpPrefix + [ BDLit $ Text.pack ":: " + , doc + ] + , BDLit $ Text.pack ")" + ]) + ] + contextDoc = case cntxtDocs of + [x] -> x + _ -> BDAlt + [ let + open = BDLit $ Text.pack "(" + close = BDLit $ Text.pack ")" + list = List.intersperse docCommaSep + $ BDForceSingleline <$> cntxtDocs + in BDSeq ([open]++list++[close]) + , let + open = BDCols ColTyOpPrefix + [ docParenLSep + , BDAddBaseY (BrIndentSpecial 2) $ head cntxtDocs + ] + close = BDLit $ Text.pack ")" + list = List.tail cntxtDocs <&> \cntxtDoc -> + BDCols ColTyOpPrefix + [ docCommaSep + , BDAddBaseY (BrIndentSpecial 2) cntxtDoc + ] + in docPar open $ BDLines $ list ++ [close] + ] + return $ docWrapNode ltype $ BDAlt + -- :: forall a b c . (Foo a b c) => a b -> c + [ BDSeq + [ if null bndrs + then BDEmpty + else let + open = BDLit $ Text.pack "forall" + close = BDLit $ Text.pack " . " + in BDSeq ([open]++tyVarDocLineList++[close]) + , BDForceSingleline contextDoc + , BDLit $ Text.pack " => " + , typeDoc + ] + -- :: forall a b c + -- . (Foo a b c) + -- => a b + -- -> c + , docPar + forallDoc + ( BDLines + [ BDCols ColTyOpPrefix + [ docPostComment ltype $ BDLit $ Text.pack " . " + , BDAddBaseY (BrIndentSpecial 3) + $ BDForceSingleline contextDoc + ] + , BDCols ColTyOpPrefix + [ BDLit $ Text.pack "=> " + , BDAddBaseY (BrIndentSpecial 3) $ BDForceMultiline typeDoc + ] + ] + ) + ] + HsForAllTy bndrs typ2 -> do + typeDoc <- layoutType typ2 + tyVarDocs <- bndrs `forM` \case + (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do + d <- layoutType kind + return $ (lrdrNameToText lrdrName, Just d) + let + tyVarDocLineList = tyVarDocs >>= \case + (tname, Nothing) -> [BDLit $ Text.pack " " <> tname] + (tname, Just doc) -> [ BDLit $ Text.pack " (" + <> tname + <> Text.pack " :: " + , BDForceSingleline doc + , BDLit $ Text.pack ")" + ] + return $ docWrapNode ltype $ BDAlt + [ BDSeq + [ if null bndrs + then BDEmpty + else let + open = BDLit $ Text.pack "forall" + close = BDLit $ Text.pack " . " + in BDSeq ([open]++tyVarDocLineList++[close]) + , typeDoc + ] + , docPar + (BDSeq $ BDLit (Text.pack "forall") : tyVarDocLineList) + ( BDCols ColTyOpPrefix + [ docPostComment ltype $ BDLit $ Text.pack ". " + , typeDoc + ] + ) + , docPar + (BDLit (Text.pack "forall")) + (BDLines + $ (tyVarDocs <&> \case + (tname, Nothing) -> BDEnsureIndent BrIndentRegular $ BDLit tname + (tname, Just doc) -> BDEnsureIndent BrIndentRegular + $ BDLines + [ BDCols ColTyOpPrefix + [ docParenLSep + , BDLit tname + ] + , BDCols ColTyOpPrefix + [ BDLit $ Text.pack ":: " + , doc + ] + , BDLit $ Text.pack ")" + ] + ) + ++[ BDCols ColTyOpPrefix + [ docPostComment ltype $ BDLit $ Text.pack ". " + , typeDoc + ] + ] + ) + ] + x@(HsQualTy (L _ []) _) -> + unknownNodeError "HsQualTy [] _" x + HsQualTy (L _ cntxts@(_:_)) typ1 -> do + typeDoc <- layoutType typ1 + cntxtDocs <- cntxts `forM` layoutType + let + contextDoc = case cntxtDocs of + [x] -> x + _ -> BDAlt + [ let + open = BDLit $ Text.pack "(" + close = BDLit $ Text.pack ")" + list = List.intersperse docCommaSep + $ BDForceSingleline <$> cntxtDocs + in BDSeq ([open]++list++[close]) + , let + open = BDCols ColTyOpPrefix + [ docParenLSep + , BDAddBaseY (BrIndentSpecial 2) + $ head cntxtDocs + ] + close = BDLit $ Text.pack ")" + list = List.tail cntxtDocs <&> \cntxtDoc -> + BDCols ColTyOpPrefix + [ docCommaSep + , BDAddBaseY (BrIndentSpecial 2) + $ cntxtDoc + ] + in docPar open $ BDLines $ list ++ [close] + ] + return $ docWrapNode ltype $ BDAlt + -- (Foo a b c) => a b -> c + [ BDSeq + [ BDForceSingleline contextDoc + , BDLit $ Text.pack " => " + , typeDoc + ] + -- (Foo a b c) + -- => a b + -- -> c + , docPar + (BDForceSingleline contextDoc) + ( BDCols ColTyOpPrefix + [ BDLit $ Text.pack "=> " + , BDAddBaseY (BrIndentSpecial 3) $ BDForceMultiline typeDoc + ] + ) + ] + -- HsQualTy (L _ cntxts) typ2 -> do + -- layouter@(Layouter desc _ _) <- layoutType typ2 + -- cntxtLayouters <- cntxts `forM` layoutType + -- let mLine = + -- [ LayoutColumns ColumnKeyUnique [len] len + -- | -- (A a, B b) => + -- -- 1 2 6 + -- constraintLen <- if null cntxts + -- then return 0 + -- else ( sequence + -- $ cntxtLayouters <&> _layouter_desc .> _ldesc_line) + -- <&> \cols -> 5 + -- + 2 * length cols + -- + sum (_lColumns_min <$> cols) + -- , tyLen <- _lColumns_min <$> _ldesc_line desc + -- , let len = constraintLen + tyLen + -- ] + -- let mBlock = + -- [ BlockDesc + -- { _bdesc_blockStart = AllSameIndent -- this might not be accurate, + -- -- but it should simply not matter. + -- -- *lazy* + -- , _bdesc_min = minR + -- , _bdesc_max = maxR + -- , _bdesc_opIndentFloatUp = Nothing + -- } + -- | (tyMin, tyMax) <- descToMinMax 0 desc + -- , constrMinMaxs <- sequence $ cntxtLayouters <&> _layouter_desc .> descToMinMax 0 + -- , let constrMin = constrMinMaxs <&> fst & maximum + -- , let constrMax = constrMinMaxs <&> snd & maximum + -- , let minR = 3 + maximum [constrMin, tyMin] + -- , let maxR = 3 + maximum [constrMax, tyMax] + -- ] + -- return $ Layouter + -- { _layouter_desc = LayoutDesc + -- { _ldesc_line = mLine + -- , _ldesc_block = mBlock + -- } + -- , _layouter_func = \params -> do + -- layoutWritePriorCommentsRestore ltype + -- remaining <- getCurRemaining + -- case mLine of + -- Just (LayoutColumns _ _ m) | m <= remaining -> do + -- when (not $ null cntxts) $ do + -- layoutWriteAppend $ Text.pack "(" + -- sequence_ $ intersperse (layoutWriteAppend $ Text.pack ", ") + -- $ cntxtLayouters <&> \lay -> applyLayouterRestore lay defaultParams + -- layoutWriteAppend $ Text.pack ") => " + -- applyLayouterRestore layouter defaultParams + -- _ -> do + -- if null cntxts + -- then do + -- layoutWriteAppend $ Text.pack "()" + -- else do + -- layoutWithNonParamIndent params $ do + -- layoutWriteAppend $ Text.pack "( " + -- let iAct = do + -- layoutWriteNewline + -- layoutWriteAppend $ Text.pack ", " + -- sequence_ $ intersperse iAct + -- $ cntxtLayouters <&> \lay -> applyLayouter lay defaultParams + -- layoutWriteNewline + -- layoutWriteAppend $ Text.pack ")" + -- layoutWriteNewline + -- layoutWriteAppend $ Text.pack "=> " + -- applyLayouterRestore layouter defaultParams + -- { _params_opIndent = _params_opIndent params + -- } + -- , _layouter_ast = ltype + -- } + HsFunTy typ1 typ2 -> do + typeDoc1 <- layoutType typ1 + typeDoc2 <- layoutType typ2 + let shouldForceML = case typ2 of + (L _ HsFunTy{}) -> True + _ -> False + return $ docWrapNode ltype $ BDAlt + [ BDSeq + [ BDForceSingleline typeDoc1 + , docPostComment ltype $ appSep $ BDLit $ Text.pack " ->" + , BDForceSingleline typeDoc2 + ] + , docPar + typeDoc1 + ( BDCols ColTyOpPrefix + [ docPostComment ltype $ appSep $ BDLit $ Text.pack "->" + , BDAddBaseY (BrIndentSpecial 3) + $ if shouldForceML then BDForceMultiline typeDoc2 + else typeDoc2 + ] + ) + ] + HsParTy typ1 -> do + typeDoc1 <- layoutType typ1 + return $ docWrapNode ltype $ BDAlt + [ BDSeq + [ docPostComment ltype $ BDLit $ Text.pack "(" + , BDForceSingleline typeDoc1 + , BDLit $ Text.pack ")" + ] + , docPar + ( BDCols ColTyOpPrefix + [ docPostComment ltype $ docParenLSep + , BDAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (BDLit $ Text.pack ")") + ] + HsAppTy typ1 typ2 -> do + typeDoc1 <- layoutType typ1 + typeDoc2 <- layoutType typ2 + return $ docWrapNode ltype $ BDAlt + [ BDSeq + [ BDForceSingleline typeDoc1 + , BDLit $ Text.pack " " + , BDForceSingleline typeDoc2 + ] + , docPar + typeDoc1 + (BDEnsureIndent BrIndentRegular typeDoc2) + ] + HsAppsTy [] -> error "HsAppsTy []" + HsAppsTy [L _ (HsAppPrefix typ1)] -> do + typeDoc1 <- layoutType typ1 + return $ docWrapNode ltype $ typeDoc1 + HsAppsTy [L l (HsAppInfix name)] -> do + -- this redirection is somewhat hacky, but whatever. + -- TODO: a general problem when doing deep inspections on + -- the type (and this is not the only instance) + -- is that we potentially omit annotations on some of + -- the middle constructors. i have no idea under which + -- circumstances exactly important annotations (comments) + -- would be assigned to such constructors. + typeDoc1 <- layoutType $ (L l $ HsTyVar name) + return $ docWrapNode ltype $ typeDoc1 + HsAppsTy (L _ (HsAppPrefix typHead):typRestA) + | Just typRest <- mapM (\case L _ (HsAppPrefix t) -> Just t + _ -> Nothing) typRestA -> do + docHead <- layoutType typHead + docRest <- mapM layoutType typRest + return $ docWrapNode ltype $ BDAlt + [ BDSeq + $ BDForceSingleline docHead : (docRest >>= \d -> + [ BDLit $ Text.pack " ", BDForceSingleline d ]) + , docPar docHead (BDLines $ BDEnsureIndent BrIndentRegular <$> docRest) + ] + HsAppsTy (typHead:typRest) -> do + docHead <- layoutAppType typHead + docRest <- mapM layoutAppType typRest + return $ docWrapNode ltype $ BDAlt + [ BDSeq + $ BDForceSingleline docHead : (docRest >>= \d -> + [ BDLit $ Text.pack " ", BDForceSingleline d ]) + , docPar docHead (BDLines $ BDEnsureIndent BrIndentRegular <$> docRest) + ] + where + layoutAppType (L _ (HsAppPrefix t)) = layoutType t + layoutAppType (L _ (HsAppInfix t)) = BDLit <$> lrdrNameToTextAnn t + HsListTy typ1 -> do + typeDoc1 <- layoutType typ1 + return $ docWrapNode ltype $ BDAlt + [ BDSeq + [ docPostComment ltype $ BDLit $ Text.pack "[" + , BDForceSingleline typeDoc1 + , BDLit $ Text.pack "]" + ] + , docPar + ( BDCols ColTyOpPrefix + [ docPostComment ltype $ BDLit $ Text.pack "[ " + , BDAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (BDLit $ Text.pack "]") + ] + HsPArrTy typ1 -> do + typeDoc1 <- layoutType typ1 + return $ docWrapNode ltype $ BDAlt + [ BDSeq + [ docPostComment ltype $ BDLit $ Text.pack "[:" + , BDForceSingleline typeDoc1 + , BDLit $ Text.pack ":]" + ] + , docPar + ( BDCols ColTyOpPrefix + [ docPostComment ltype $ BDLit $ Text.pack "[:" + , BDAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (BDLit $ Text.pack ":]") + ] + HsTupleTy tupleSort typs -> docWrapNode ltype <$> case tupleSort of + HsUnboxedTuple -> unboxed + HsBoxedTuple -> simple + HsConstraintTuple -> simple + HsBoxedOrConstraintTuple -> simple + where + unboxed = if null typs then error "unboxed unit?" else unboxedL + simple = if null typs then unitL else simpleL + unitL = return $ BDLit $ Text.pack "()" + simpleL = do + docs <- mapM layoutType typs + return $ BDAlt + [ BDSeq $ [BDLit $ Text.pack "("] + ++ List.intersperse docCommaSep docs + ++ [BDLit $ Text.pack ")"] + , let + start = BDCols ColTyOpPrefix [docParenLSep, head docs] + lines = List.tail docs <&> \d -> + BDCols ColTyOpPrefix [docCommaSep, d] + end = BDLit $ Text.pack ")" + in docPar + (BDAddBaseY (BrIndentSpecial 2) $ start) + (BDLines $ (BDAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) + ] + unboxedL = do + docs <- mapM layoutType typs + return $ BDAlt + [ BDSeq $ [BDLit $ Text.pack "(#"] + ++ List.intersperse docCommaSep docs + ++ [BDLit $ Text.pack "#)"] + , let + start = BDCols ColTyOpPrefix [BDLit $ Text.pack "(#", head docs] + lines = List.tail docs <&> \d -> + BDCols ColTyOpPrefix [docCommaSep, d] + end = BDLit $ Text.pack "#)" + in docPar + (BDAddBaseY (BrIndentSpecial 2) start) + (BDLines $ (BDAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) + ] + HsOpTy{} -> -- TODO + briDocByExact 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 (HsIPName ipName) typ1 -> do + typeDoc1 <- layoutType typ1 + return $ docWrapNode ltype $ BDAlt + [ BDSeq + [ docPostComment ltype + $ BDLit + $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") + , BDForceSingleline typeDoc1 + ] + , docPar + ( BDLit + $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) + ) + (BDCols ColTyOpPrefix + [ docPostComment ltype + $ BDLit $ Text.pack "::" + , BDAddBaseY (BrIndentSpecial 2) typeDoc1 + ]) + ] + HsEqTy typ1 typ2 -> do + typeDoc1 <- layoutType typ1 + typeDoc2 <- layoutType typ2 + return $ docWrapNode ltype $ BDAlt + [ BDSeq + [ BDForceSingleline typeDoc1 + , docPostComment ltype + $ BDLit $ Text.pack " ~ " + , BDForceSingleline typeDoc2 + ] + , docPar + typeDoc1 + ( BDCols ColTyOpPrefix + [ docPostComment ltype + $ BDLit $ Text.pack "~ " + , BDAddBaseY (BrIndentSpecial 2) typeDoc2 + ]) + ] + -- TODO: test KindSig + HsKindSig typ1 kind1 -> do + typeDoc1 <- layoutType typ1 + kindDoc1 <- layoutType kind1 + return $ docWrapNode ltype $ BDAlt + [ BDSeq + [ BDForceSingleline typeDoc1 + , BDLit $ Text.pack " :: " + , BDForceSingleline kindDoc1 + ] + , docPar + typeDoc1 + ( BDCols ColTyOpPrefix + [ docPostComment ltype + $ BDLit $ Text.pack ":: " + , BDAddBaseY (BrIndentSpecial 3) kindDoc1 + ]) + ] + HsBangTy{} -> -- TODO + briDocByExact 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 + briDocByExact ltype + HsDocTy{} -> -- TODO + briDocByExact ltype + HsRecTy{} -> -- TODO + briDocByExact ltype + HsExplicitListTy _ typs -> do + typDocs <- typs `forM` layoutType + return $ BDAlt + [ BDSeq + $ [BDLit $ Text.pack "'["] + ++ List.intersperse docCommaSep typDocs + ++ [BDLit $ Text.pack "]"] + -- TODO + ] + HsExplicitTupleTy{} -> -- TODO + briDocByExact ltype + HsTyLit{} -> -- TODO + briDocByExact ltype + HsCoreTy{} -> -- TODO + briDocByExact ltype + HsWildCardTy{} -> -- TODO + briDocByExact ltype diff --git a/src/Language/Haskell/Brittany/Prelude.hs b/src/Language/Haskell/Brittany/Prelude.hs new file mode 100644 index 0000000..de30ed3 --- /dev/null +++ b/src/Language/Haskell/Brittany/Prelude.hs @@ -0,0 +1,28 @@ +module Language.Haskell.Brittany.Prelude +where + + + +import Prelude +import qualified Data.Strict.Maybe as Strict +import Debug.Trace + + + +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 + return = Strict.Just + Strict.Nothing >>= _ = Strict.Nothing + Strict.Just x >>= f = f 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 diff --git a/src/Language/Haskell/Brittany/Types.hs b/src/Language/Haskell/Brittany/Types.hs new file mode 100644 index 0000000..2a0130e --- /dev/null +++ b/src/Language/Haskell/Brittany/Types.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} + +module Language.Haskell.Brittany.Types +where + + + +#include "prelude.inc" + +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import SrcLoc ( SrcSpan ) + +import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment ) +import Language.Haskell.GHC.ExactPrint.Types ( Anns, DeltaPos, mkAnnKey ) + +import Language.Haskell.Brittany.Config.Types + + + +type PPM a = MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] '[Text.Builder.Builder, [LayoutError], Seq String] '[] a + +type PriorMap = Map AnnKey [(Comment, DeltaPos)] +type PostMap = Map AnnKey [(Comment, DeltaPos)] + +data LayoutState = LayoutState + { _lstate_baseY :: Int -- ^ number of current indentation columns + -- (not number of indentations). + , _lstate_curY :: Int -- ^ number of chars in the current line. + , _lstate_indLevel :: Int -- ^ current indentation level. 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_commentsPrior :: PriorMap -- map of "true" pre-node comments that + -- really _should_ be included in the + -- output. + , _lstate_commentsPost :: PostMap -- similarly, for post-node comments. + , _lstate_commentCol :: Maybe Int + , _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone + -- writes (any non-spaces) in the + -- current line. + , _lstate_inhibitMTEL :: Bool + -- ^ inhibit move-to-exact-location. + -- normally, processing a node's annotation involves moving to the exact + -- (vertical) location of the node. this ensures that newlines in the + -- input are retained in the output. + -- While this flag is on, this behaviour will be disabled. + -- The flag is automatically turned off when inserting any kind of + -- newline. + , _lstate_isNewline :: NewLineState + -- captures if the layouter currently is in a new line, i.e. if the + -- current line only contains (indentation) spaces. + } + +data NewLineState = NewLineStateInit -- initial state. we do not know if in a + -- newline, really. by special-casing + -- this we can appropriately handle it + -- differently at use-site. + | NewLineStateYes + | NewLineStateNo + deriving Eq + +-- data LayoutSettings = LayoutSettings +-- { _lsettings_cols :: Int -- the thing that has default 80. +-- , _lsettings_indentPolicy :: IndentPolicy +-- , _lsettings_indentAmount :: Int +-- , _lsettings_indentWhereSpecial :: Bool -- indent where only 1 sometimes (TODO). +-- , _lsettings_indentListSpecial :: Bool -- use some special indentation for "," +-- -- when creating zero-indentation +-- -- multi-line list literals. +-- , _lsettings_importColumn :: Int +-- , _lsettings_initialAnns :: ExactPrint.Anns +-- } + +data LayoutError = LayoutErrorUnusedComment String + | LayoutWarning String + | forall ast . Data.Data.Data ast => LayoutErrorUnknownNode String ast + +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 + | ColFuncPatternsPrefix + -- pattern-part of the lhs, e.g. "func (foo a b) c _". + -- Has variable number of columns depending on the number of patterns. + | ColFuncPatternsInfix + -- pattern-part of the lhs, e.g. "Foo a <> Foo b". + -- Has variable number of columns depending on the number of patterns. + | ColCasePattern + | ColEquation + -- e.g. "func pat pat = expr" + -- 1111111111111222222 + -- expected to have exactly two columns. + | ColGuardedEquation + -- e.g. "func pat pat | cond = expr" + -- 11111111111112222222222222 + -- or "func pat pat | cond" + -- 1111111111111222222 + -- expected to have exactly two or three columns. + | ColDoBind + | ColDoLet -- the non-indented variant + | ColRecUpdate + | ColListComp + | ColList + | ColOpPrefix -- merge with ColList ? other stuff? + + -- TODO + deriving (Eq, Data.Data.Data, Show) + +data BrIndent = BrIndentNone + | BrIndentRegular + | BrIndentSpecial Int + deriving (Eq, Typeable, Data.Data.Data, Show) + +type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[LayoutError], Seq String] '[] + +type ToBriDoc (sym :: * -> *) = GenLocated SrcSpan (sym RdrName) -> ToBriDocM BriDoc +type ToBriDoc' sym = GenLocated SrcSpan sym -> ToBriDocM BriDoc +type ToBriDocC sym c = GenLocated SrcSpan sym -> ToBriDocM c + +data DocMultiLine + = MultiLineNo + | MultiLinePossible + deriving (Eq, Typeable) + +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 + | BDSetBaseY BriDoc + | BDSetIndentLevel BriDoc + | BDPar + { _bdpar_indent :: BrIndent + , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars + , _bdpar_indented :: BriDoc + } + -- | BDAddIndent BrIndent BriDoc + -- | BDNewline + | BDAlt [BriDoc] + | BDForceMultiline BriDoc + | BDForceSingleline 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 + | BDAnnotationPrior AnnKey BriDoc + | BDAnnotationPost AnnKey BriDoc + | BDLines [BriDoc] + | BDEnsureIndent BrIndent BriDoc + | BDProhibitMTEL BriDoc -- move to exact location + -- TODO: this constructor is deprecated. should + -- still work, but i should probably completely + -- remove it, as i have no proper usecase for + -- it anymore. + deriving Data.Data.Data + +data VerticalSpacing + = VerticalSpacing + { _vs_sameLine :: !Int + , _vs_paragraph :: !(Strict.Maybe Int) + } + deriving Show + +newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) + deriving (Functor, Applicative, Monad, Show) + +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 diff --git a/src/Language/Haskell/Brittany/Utils.hs b/src/Language/Haskell/Brittany/Utils.hs new file mode 100644 index 0000000..4fbb488 --- /dev/null +++ b/src/Language/Haskell/Brittany/Utils.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Language.Haskell.Brittany.Utils + ( (.=+) + , (%=+) + , parDoc + , traceIfDumpConf + , mModify + , customLayouterF + , astToDoc + , briDocToDoc + -- , displayBriDocSimpleTree + , annsDoc + , Max (..) + , tellDebugMess + , tellDebugMessShow + ) +where + + + +#include "prelude.inc" + +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.Utils as ExactPrint.Utils + +import Data.Data +import Data.Generics.Schemes +import Data.Generics.Aliases + +import qualified Text.PrettyPrint as PP +import Text.PrettyPrint ( ($+$), (<+>) ) + +import qualified Outputable as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified SrcLoc as GHC +import OccName ( occNameString ) +import qualified Data.ByteString as B + +import DataTreePrint + +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Types + +import qualified Control.Lens as Lens + +import qualified Data.Generics.Uniplate.Data as Uniplate + + + +(.=+) :: MonadMultiState s m + => Lens.ASetter s s a b -> b -> m () +l .=+ b = mModify $ l Lens..~ b + +(%=+) :: MonadMultiState s m + => Lens.ASetter s s a b -> (a -> b) -> m () +l %=+ f = mModify (l Lens.%~ f) + +parDoc :: String -> PP.Doc +parDoc = PP.fsep . fmap PP.text . List.words + + +showSDoc_ :: GHC.SDoc -> String +showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags + +showGhc :: (GHC.Outputable a) => a -> String +showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags + +-- 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) + +instance (Num a, Ord a) => Monoid (Max a) where + mempty = Max 0 + mappend = Data.Coerce.coerce (max :: a -> a -> a) + +newtype ShowIsId = ShowIsId String deriving Data + +instance Show ShowIsId where show (ShowIsId x) = x + +data A x = A ShowIsId x deriving Data + +customLayouterF :: ExactPrint.Types.Anns -> LayouterF +customLayouterF anns layoutF = + DataToLayouter $ f `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan + `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)++"}" + $ "{" ++ showGhc 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" + +customLayouterNoAnnsF :: LayouterF +customLayouterNoAnnsF layoutF = + DataToLayouter $ f `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan + `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)++"}" + located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter + located (GHC.L _ss a) = runDataToLayouter layoutF a + +-- displayBriDocTree :: BriDoc -> PP.Doc +-- displayBriDocTree = \case +-- BDWrapAnnKey annKey doc -> def "BDWrapAnnKey" +-- $ PP.text (show annKey) +-- $+$ displayBriDocTree doc +-- BDEmpty -> PP.text "BDEmpty" +-- BDLit t -> def "BDLit" $ PP.text (show t) +-- BDSeq list -> def "BDSeq" $ displayList list +-- BDCols sig list -> def "BDCols" $ PP.text (show sig) +-- $+$ displayList list +-- BDSeparator -> PP.text "BDSeparator" +-- BDPar rol indent lines -> def "BDPar" $ displayBriDocTree rol +-- $+$ PP.text (show indent) +-- $+$ displayList lines +-- BDAlt alts -> def "BDAlt" $ displayList alts +-- BDExternal ast _t -> def "BDExternal" (astToDoc ast) +-- BDSpecialPostCommentLoc _ -> PP.text "BDSpecialPostCommentLoc" +-- where +-- def x r = PP.text x $+$ PP.nest 2 r +-- displayList :: [BriDoc] -> PP.Doc +-- displayList [] = PP.text "[]" +-- displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocTree x +-- : [PP.text "," <+> displayBriDocTree t | t<-xr] +-- ++ [PP.text "]"] + +-- displayBriDocSimpleTree :: BriDocSimple -> PP.Doc +-- displayBriDocSimpleTree = \case +-- BDSWrapAnnKey annKey doc -> def "BDSWrapAnnKey" +-- $ PP.text (show annKey) +-- $+$ displayBriDocSimpleTree doc +-- BDSLit t -> def "BDSLit" $ PP.text (show t) +-- BDSSeq list -> def "BDSSeq" $ displayList list +-- BDSCols sig list -> def "BDSCols" $ PP.text (show sig) +-- $+$ displayList list +-- BDSSeparator -> PP.text "BDSSeparator" +-- BDSPar rol indent lines -> def "BDSPar" $ displayBriDocSimpleTree rol +-- $+$ PP.text (show indent) +-- $+$ displayList lines +-- BDSExternal annKey _subKeys _t -> def "BDSExternal" (PP.text $ show annKey) +-- BDSSpecialPostCommentLoc _ -> PP.text "BDSSpecialPostCommentLoc" +-- where +-- def x r = PP.text x $+$ PP.nest 2 r +-- displayList :: [BriDocSimple] -> PP.Doc +-- displayList [] = PP.text "[]" +-- displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocSimpleTree x +-- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr] +-- ++ [PP.text "]"] + +traceIfDumpConf :: (MonadMultiReader + Config m, + Show a) + => String + -> (DebugConfig -> Identity Bool) + -> a + -> m () +traceIfDumpConf s accessor val = do + whenM (mAsk <&> _conf_debug .> accessor .> runIdentity) $ do + trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () + +tellDebugMess :: MonadMultiWriter + (Seq String) m => String -> m () +tellDebugMess s = mTell $ Seq.singleton s + +tellDebugMessShow :: (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 + +briDocToDoc :: BriDoc -> PP.Doc +briDocToDoc = astToDoc . removeAnnotations + where + removeAnnotations = Uniplate.transform $ \case + BDAnnotationPrior _ x -> x + BDAnnotationPost _ x -> x + x -> x + +annsDoc :: ExactPrint.Types.Anns -> PP.Doc +annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc new file mode 100644 index 0000000..e08e948 --- /dev/null +++ b/srcinc/prelude.inc @@ -0,0 +1,788 @@ +import qualified Data.ByteString +import qualified Data.ByteString.Builder +import qualified Data.ByteString.Builder.Extra +import qualified Data.ByteString.Builder.Prim +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy.Builder +import qualified Data.ByteString.Lazy.Builder.ASCII +import qualified Data.ByteString.Lazy.Builder.Extras +import qualified Data.ByteString.Lazy.Char8 +import qualified Data.ByteString.Lazy +import qualified Data.ByteString.Short +import qualified Data.ByteString.Unsafe + +import qualified Data.Graph +import qualified Data.IntMap +import qualified Data.IntMap.Lazy +import qualified Data.IntMap.Strict +import qualified Data.IntSet +import qualified Data.Map +import qualified Data.Map.Lazy +import qualified Data.Map.Strict +import qualified Data.Sequence +import qualified Data.Set +import qualified Data.Tree + +import qualified System.Directory + +import qualified Control.Concurrent.Extra +import qualified Control.Exception.Extra +import qualified Control.Monad.Extra +import qualified Data.Either.Extra +import qualified Data.IORef.Extra +import qualified Data.List.Extra +import qualified Data.Tuple.Extra +import qualified Data.Version.Extra +import qualified Numeric.Extra +import qualified System.Directory.Extra +import qualified System.Environment.Extra +import qualified System.IO.Extra +import qualified System.Info.Extra +import qualified System.Process.Extra +import qualified System.Time.Extra + +import qualified Test.Hspec +import qualified Test.Hspec.Formatters +import qualified Test.Hspec.QuickCheck +import qualified Test.Hspec.Runner + +-- import qualified Control.Exception.Lens +import qualified Control.Lens +-- import qualified Control.Lens.At +-- import qualified Control.Lens.Combinators +-- import qualified Control.Lens.Cons +-- import qualified Control.Lens.Each +-- import qualified Control.Lens.Empty +-- import qualified Control.Lens.Equality +-- import qualified Control.Lens.Extras +-- import qualified Control.Lens.Fold +-- import qualified Control.Lens.Getter +-- import qualified Control.Lens.Indexed +-- import qualified Control.Lens.Internal +-- import qualified Control.Lens.Internal.Bazaar +-- import qualified Control.Lens.Internal.ByteString +-- import qualified Control.Lens.Internal.Coerce +-- import qualified Control.Lens.Internal.Context +-- import qualified Control.Lens.Internal.Deque +-- import qualified Control.Lens.Internal.Exception +-- import qualified Control.Lens.Internal.FieldTH +-- import qualified Control.Lens.Internal.Fold +-- import qualified Control.Lens.Internal.Getter +-- import qualified Control.Lens.Internal.Indexed +-- import qualified Control.Lens.Internal.Instances +-- import qualified Control.Lens.Internal.Iso +-- import qualified Control.Lens.Internal.Level +-- import qualified Control.Lens.Internal.List +-- import qualified Control.Lens.Internal.Magma +-- import qualified Control.Lens.Internal.Prism +-- import qualified Control.Lens.Internal.PrismTH +-- import qualified Control.Lens.Internal.Review +-- import qualified Control.Lens.Internal.Setter +-- import qualified Control.Lens.Internal.TH +-- import qualified Control.Lens.Internal.Zoom +-- import qualified Control.Lens.Iso +-- import qualified Control.Lens.Lens +-- import qualified Control.Lens.Level +-- import qualified Control.Lens.Operators +-- import qualified Control.Lens.Plated +-- import qualified Control.Lens.Prism +-- import qualified Control.Lens.Reified +-- import qualified Control.Lens.Review +-- import qualified Control.Lens.Setter +-- import qualified Control.Lens.TH +-- import qualified Control.Lens.Traversal +-- import qualified Control.Lens.Tuple +-- import qualified Control.Lens.Type +-- import qualified Control.Lens.Wrapped +-- import qualified Control.Lens.Zoom +-- import qualified Control.Monad.Error.Lens +-- import qualified Control.Parallel.Strategies.Lens +-- import qualified Control.Seq.Lens +-- import qualified Data.Array.Lens +-- import qualified Data.Bits.Lens +-- import qualified Data.ByteString.Lazy.Lens +-- import qualified Data.ByteString.Lens +-- import qualified Data.ByteString.Strict.Lens +-- import qualified Data.Complex.Lens +-- import qualified Data.Data.Lens +-- import qualified Data.Dynamic.Lens +-- import qualified Data.HashSet.Lens +-- import qualified Data.IntSet.Lens +-- import qualified Data.List.Lens +-- import qualified Data.Map.Lens +-- import qualified Data.Sequence.Lens +-- import qualified Data.Set.Lens +-- import qualified Data.Text.Lazy.Lens +-- import qualified Data.Text.Lens +-- import qualified Data.Text.Strict.Lens +-- import qualified Data.Tree.Lens +-- import qualified Data.Typeable.Lens +-- import qualified Data.Vector.Generic.Lens +-- import qualified Data.Vector.Lens +-- import qualified GHC.Generics.Lens +-- import qualified Generics.Deriving.Lens +-- import qualified Language.Haskell.TH.Lens +-- import qualified Numeric.Lens +-- import qualified System.Exit.Lens +-- import qualified System.FilePath.Lens +-- import qualified System.IO.Error.Lens + +-- import qualified Control.Monad.Cont +-- import qualified Control.Monad.Cont.Class +-- import qualified Control.Monad.Error.Class +-- import qualified Control.Monad.Except +-- import qualified Control.Monad.Identity +-- import qualified Control.Monad.List +-- import qualified Control.Monad.RWS +-- import qualified Control.Monad.RWS.Class +-- import qualified Control.Monad.RWS.Lazy +-- import qualified Control.Monad.RWS.Strict +-- import qualified Control.Monad.Reader +-- import qualified Control.Monad.Reader.Class +-- import qualified Control.Monad.State +-- import qualified Control.Monad.State.Class +-- import qualified Control.Monad.State.Lazy +-- import qualified Control.Monad.State.Strict +-- import qualified Control.Monad.Trans +-- import qualified Control.Monad.Writer +-- import qualified Control.Monad.Writer.Class +-- import qualified Control.Monad.Writer.Lazy +-- import qualified Control.Monad.Writer.Strict + +-- import qualified Control.Monad.Trans.MultiRWS +import qualified Control.Monad.Trans.MultiRWS.Lazy +import qualified Control.Monad.Trans.MultiRWS.Strict +import qualified Control.Monad.Trans.MultiReader +import qualified Control.Monad.Trans.MultiReader.Class +import qualified Control.Monad.Trans.MultiReader.Lazy +import qualified Control.Monad.Trans.MultiReader.Strict +import qualified Control.Monad.Trans.MultiState +import qualified Control.Monad.Trans.MultiState.Class +import qualified Control.Monad.Trans.MultiState.Lazy +import qualified Control.Monad.Trans.MultiState.Strict +import qualified Control.Monad.Trans.MultiWriter +import qualified Control.Monad.Trans.MultiWriter.Class +import qualified Control.Monad.Trans.MultiWriter.Lazy +import qualified Control.Monad.Trans.MultiWriter.Strict + +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL + +import qualified Text.PrettyPrint + +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass + +import qualified Text.PrettyPrint.HughesPJ +import qualified Text.PrettyPrint.HughesPJClass + +import qualified Data.Generics +import qualified Data.Generics.Aliases +import qualified Data.Generics.Basics +import qualified Data.Generics.Builders +import qualified Data.Generics.Instances +import qualified Data.Generics.Schemes +import qualified Data.Generics.Text +import qualified Data.Generics.Twins +import qualified Generics.SYB +-- import qualified Generics.SYB.Aliases +-- import qualified Generics.SYB.Basics +-- import qualified Generics.SYB.Builders +-- import qualified Generics.SYB.Instances +-- import qualified Generics.SYB.Schemes +-- import qualified Generics.SYB.Text +-- import qualified Generics.SYB.Twins + +import qualified Data.Text +import qualified Data.Text.Array +import qualified Data.Text.Encoding +import qualified Data.Text.Encoding.Error +import qualified Data.Text.Foreign +import qualified Data.Text.IO +-- import qualified Data.Text.Internal +-- import qualified Data.Text.Internal.Builder +-- import qualified Data.Text.Internal.Builder.Functions +-- import qualified Data.Text.Internal.Builder.Int.Digits +-- import qualified Data.Text.Internal.Builder.RealFloat.Functions +-- import qualified Data.Text.Internal.Encoding.Fusion +-- import qualified Data.Text.Internal.Encoding.Fusion.Common +-- import qualified Data.Text.Internal.Encoding.Utf16 +-- import qualified Data.Text.Internal.Encoding.Utf32 +-- import qualified Data.Text.Internal.Encoding.Utf8 +-- import qualified Data.Text.Internal.Functions +-- import qualified Data.Text.Internal.Fusion +-- import qualified Data.Text.Internal.Fusion.CaseMapping +-- import qualified Data.Text.Internal.Fusion.Common +-- import qualified Data.Text.Internal.Fusion.Size +-- import qualified Data.Text.Internal.Fusion.Types +-- import qualified Data.Text.Internal.IO +-- import qualified Data.Text.Internal.Lazy +-- import qualified Data.Text.Internal.Lazy.Encoding.Fusion +-- import qualified Data.Text.Internal.Lazy.Fusion +-- import qualified Data.Text.Internal.Lazy.Search +-- import qualified Data.Text.Internal.Private +-- import qualified Data.Text.Internal.Read +-- import qualified Data.Text.Internal.Search +-- import qualified Data.Text.Internal.Unsafe +-- import qualified Data.Text.Internal.Unsafe.Char +-- import qualified Data.Text.Internal.Unsafe.Shift +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +-- import qualified Data.Text.Lazy.Builder.Int +-- import qualified Data.Text.Lazy.Builder.RealFloat +-- import qualified Data.Text.Lazy.Encoding +-- import qualified Data.Text.Lazy.IO +-- import qualified Data.Text.Lazy.Read +-- import qualified Data.Text.Read +-- import qualified Data.Text.Unsafe + +-- import qualified Control.Applicative.Backwards +-- import qualified Control.Applicative.Lift +-- import qualified Control.Monad.IO.Class +-- import qualified Control.Monad.Signatures +-- import qualified Control.Monad.Trans.Class +-- import qualified Control.Monad.Trans.Cont +-- import qualified Control.Monad.Trans.Except +-- import qualified Control.Monad.Trans.Identity +-- import qualified Control.Monad.Trans.List +-- import qualified Control.Monad.Trans.Maybe +-- import qualified Control.Monad.Trans.RWS +-- import qualified Control.Monad.Trans.RWS.Lazy +-- import qualified Control.Monad.Trans.RWS.Strict +-- import qualified Control.Monad.Trans.Reader +-- import qualified Control.Monad.Trans.State +-- import qualified Control.Monad.Trans.State.Lazy +-- import qualified Control.Monad.Trans.State.Strict +-- import qualified Control.Monad.Trans.Writer +-- import qualified Control.Monad.Trans.Writer.Lazy +-- import qualified Control.Monad.Trans.Writer.Strict +-- import qualified Data.Functor.Classes +-- import qualified Data.Functor.Compose +-- import qualified Data.Functor.Constant +-- import qualified Data.Functor.Product +-- import qualified Data.Functor.Reverse +-- import qualified Data.Functor.Sum + +-- import qualified Prelude +-- import qualified Control.Applicative +-- import qualified Control.Arrow +-- import qualified Control.Category +-- import qualified Control.Concurrent +-- import qualified Control.Concurrent.Chan +-- import qualified Control.Concurrent.MVar +-- import qualified Control.Concurrent.QSem +-- import qualified Control.Concurrent.QSemN +-- import qualified Control.Exception +-- import qualified Control.Exception.Base +-- import qualified Control.Monad +-- import qualified Control.Monad.Fix +-- import qualified Control.Monad.ST +-- import qualified Control.Monad.ST.Lazy +-- import qualified Control.Monad.ST.Lazy.Unsafe +-- import qualified Control.Monad.ST.Strict +-- import qualified Control.Monad.ST.Unsafe +-- import qualified Control.Monad.Zip +import qualified Data.Bifunctor +import qualified Data.Bits +import qualified Data.Bool +import qualified Data.Char +import qualified Data.Coerce +import qualified Data.Complex +import qualified Data.Data +import qualified Data.Dynamic +import qualified Data.Either +import qualified Data.Eq +import qualified Data.Fixed +import qualified Data.Foldable +import qualified Data.Function +import qualified Data.Functor +import qualified Data.Functor.Identity +import qualified Data.IORef +import qualified Data.Int +import qualified Data.Ix +import qualified Data.List +import qualified Data.Maybe +import qualified Data.Monoid +import qualified Data.Ord +import qualified Data.Proxy +-- import qualified Data.Ratio +-- import qualified Data.STRef +-- import qualified Data.STRef.Lazy +-- import qualified Data.STRef.Strict +-- import qualified Data.String +-- import qualified Data.Traversable +-- import qualified Data.Tuple +-- import qualified Data.Type.Bool +-- import qualified Data.Type.Coercion +-- import qualified Data.Type.Equality +-- import qualified Data.Typeable +-- import qualified Data.Typeable.Internal +-- import qualified Data.Unique +-- import qualified Data.Version +-- import qualified Data.Void +-- import qualified Data.Word +import qualified Debug.Trace +-- import qualified Foreign.C +-- import qualified Foreign.C.Error +-- import qualified Foreign.C.String +-- import qualified Foreign.C.Types +-- import qualified Foreign.Concurrent +-- import qualified Foreign.ForeignPtr +-- import qualified Foreign.ForeignPtr.Unsafe +-- import qualified Foreign.Marshal +-- import qualified Foreign.Marshal.Alloc +-- import qualified Foreign.Marshal.Array +-- import qualified Foreign.Marshal.Error +-- import qualified Foreign.Marshal.Pool +-- import qualified Foreign.Marshal.Unsafe +-- import qualified Foreign.Marshal.Utils +-- import qualified Foreign.Ptr +-- import qualified Foreign.StablePtr +-- import qualified Foreign.Storable +import qualified Numeric +import qualified Numeric.Natural +-- import qualified System.CPUTime +-- import qualified System.Console.GetOpt +-- import qualified System.Environment +-- import qualified System.Exit +import qualified System.IO +-- import qualified System.IO.Error +-- import qualified System.IO.Unsafe +-- import qualified System.Info +-- import qualified System.Mem +-- import qualified System.Mem.StableName +-- import qualified System.Mem.Weak +-- import qualified System.Posix.Types +-- import qualified System.Timeout +-- import qualified Text.ParserCombinators.ReadP +-- import qualified Text.ParserCombinators.ReadPrec +-- import qualified Text.Printf +-- import qualified Text.Read +-- import qualified Text.Read.Lex +-- import qualified Text.Show +-- import qualified Text.Show.Functions +import qualified Unsafe.Coerce + +-- import qualified Control.Arrow as Arrow +-- import qualified Control.Category as Category +-- import qualified Control.Concurrent as Concurrent +-- import qualified Control.Concurrent.Chan as Chan +-- import qualified Control.Concurrent.MVar as MVar +-- import qualified Control.Exception as Exception +-- import qualified Control.Exception.Base as Exception.Base +-- import qualified Control.Monad as Monad +-- import qualified Data.Bits as Bits +import qualified Data.Bool as Bool +-- import qualified Data.Char as Char +-- import qualified Data.Complex as Complex +-- import qualified Data.Either as Either +-- import qualified Data.Eq as Eq +-- import qualified Data.Foldable as Foldable +-- import qualified Data.Fixed as Fixed +-- import qualified Data.Functor.Identity as Identity +-- import qualified Data.IORef as IORef +-- import qualified Data.Int as Int +-- import qualified Data.Ix as Ix +-- import qualified Data.Maybe as Maybe +-- import qualified Data.Monoid as Monoid +-- import qualified Data.Ord as Ord +-- import qualified Data.Proxy as Proxy +-- import qualified Data.Traversable as Traversable +-- import qualified Data.Void as Void +import qualified GHC.OldList as List +-- import qualified Text.Printf as Printf + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as ByteStringL + +import qualified Data.IntMap as IntMap +-- import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +-- import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +-- import qualified Data.Map.Lazy as MapL +-- import qualified Data.Map.Strict as MapS +import qualified Data.Sequence as Seq +import qualified Data.Set as Set + +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Writer.Class as Writer.Class + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO + +-- import qualified Control.Monad.Trans.Class as Trans.Class +-- import qualified Control.Monad.Trans.Maybe as Trans.Maybe +-- import qualified Control.Monad.Trans.RWS as RWS +-- import qualified Control.Monad.Trans.RWS.Lazy as RWSL +-- import qualified Control.Monad.Trans.RWS.Strict as RWSS +-- import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.State as State +import qualified Control.Monad.Trans.State.Lazy as StateL +import qualified Control.Monad.Trans.State.Strict as StateS +-- import qualified Control.Monad.Trans.Writer as Writer +-- import qualified Control.Monad.Trans.Writer.Lazy as WriterL +-- import qualified Control.Monad.Trans.Writer.Strict as Writer + +import qualified Data.Strict.Maybe as Strict + +import Data.Functor.Identity ( Identity(..) ) +import Control.Concurrent.Chan ( Chan ) +import Control.Concurrent.MVar ( MVar ) +import Data.Int ( Int ) +import Data.Word ( Word ) +import Prelude ( Integer, Float, Double ) +import Control.Monad.ST ( ST ) +import Data.Bool ( Bool(..) ) +import Data.Char ( Char ) +import Data.Either ( Either(..) ) +import Data.IORef ( IORef ) +import Data.Maybe ( Maybe(..) ) +import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), First(..), Last(..), Alt(..), ) +import Data.Ord ( Ordering(..), Down(..) ) +import Data.Ratio ( Ratio, Rational ) +import Data.String ( String ) +import Data.Void ( Void ) +import System.IO ( IO ) +import Data.Proxy ( Proxy(..) ) +import Data.Sequence ( Seq ) + +import Data.Map ( Map ) +import Data.Set ( Set ) + +import Data.Text ( Text ) + +import QPrelude.Basics +import QPrelude.ErrorIf + +import Prelude ( Char + , String + , Int + , Integer + , Float + , Double + , Bool (..) + , undefined + , Eq (..) + , Ord (..) + , Enum (..) + , Bounded (..) + , Maybe (..) + , Either (..) + , IO + , (<$>) + , (.) + , ($) + , ($!) + , Num (..) + , Integral (..) + , Fractional (..) + , Floating (..) + , RealFrac (..) + , RealFloat (..) + , fromIntegral + , error + , foldr + , foldl + , foldr1 + , id + , map + , subtract + , putStrLn + , putStr + , Show (..) + , print + , fst + , snd + , (++) + , not + , (&&) + , (||) + , curry + , uncurry + , Ordering (..) + , flip + , const + , seq + , reverse + , otherwise + , traverse + , realToFrac + , or + , and + , head + , any + , (^) + , Foldable + , Traversable + ) + +import Data.Foldable ( foldl' + , foldr' + , fold + , asum + ) + +import Data.List ( partition + , null + , elem + , notElem + , minimum + , maximum + , length + , all + , take + , drop + , find + , sum + , zip + , zip3 + , zipWith + , repeat + , replicate + , iterate + , nub + , filter + , intersperse + , intercalate + , isSuffixOf + , isPrefixOf + , dropWhile + , takeWhile + , unzip + , break + , transpose + , sortBy + , mapAccumL + , mapAccumR + , uncons + ) + +import Data.Tuple ( swap + ) + +import Data.Char ( ord + , chr + ) + +import Data.Maybe ( fromMaybe + , maybe + , listToMaybe + , maybeToList + , catMaybes + ) + +import Data.Word ( Word32 + ) + +import Data.Ord ( comparing + , Down (..) + ) + +import Data.Either ( either + ) + +import Data.Ratio ( Ratio + , (%) + , numerator + , denominator + ) + +import Text.Read ( readMaybe + ) + +import Control.Monad ( Functor (..) + , Monad (..) + , MonadPlus (..) + , mapM + , mapM_ + , forM + , forM_ + , sequence + , sequence_ + , (=<<) + , (>=>) + , (<=<) + , forever + , void + , join + , replicateM + , replicateM_ + , guard + , when + , unless + , liftM + , liftM2 + , liftM3 + , liftM4 + , liftM5 + , filterM + , (<$!>) + ) + +import Control.Applicative ( Applicative (..) + , Alternative (..) + ) + +import Foreign.Storable ( Storable ) +import GHC.Exts ( Constraint ) + +import Control.Concurrent ( threadDelay + , forkIO + , forkOS + ) + +import Control.Concurrent.MVar ( MVar + , newEmptyMVar + , newMVar + , putMVar + , readMVar + , takeMVar + , swapMVar + ) + +import Control.Exception ( evaluate + , bracket + , assert + ) + +import Debug.Trace ( trace + , traceId + , traceShowId + , traceShow + , traceStack + , traceShowId + , traceIO + , traceM + , traceShowM + ) + +import Foreign.ForeignPtr ( ForeignPtr + ) + +import Data.Monoid ( (<>) + , mconcat + , Monoid (..) + ) + +import Data.Bifunctor ( bimap ) +import Data.Functor ( (<$), ($>) ) +import Data.Function ( (&) ) +import System.IO ( hFlush + , stdout + ) + +import Data.Typeable ( Typeable + ) + +import Control.Arrow ( first + , second + , (***) + , (&&&) + , (>>>) + , (<<<) + ) + +import Data.Functor.Identity ( Identity (..) + ) + +import Data.Proxy ( Proxy (..) + ) + +import Data.Version ( showVersion + ) + +import Data.List.Extra ( nubOrd + , stripSuffix + ) +import Control.Monad.Extra ( whenM + , unlessM + , ifM + , notM + , orM + , andM + , anyM + , allM + ) + +import Data.Tree ( Tree(..) + ) + +import Control.Monad.Trans.MultiRWS ( -- MultiRWST (..) + -- , MultiRWSTNull + -- , MultiRWS + -- , + MonadMultiReader(..) + , MonadMultiWriter(..) + , MonadMultiState(..) + -- , runMultiRWST + -- , runMultiRWSTASW + -- , runMultiRWSTW + -- , runMultiRWSTAW + -- , runMultiRWSTSW + -- , runMultiRWSTNil + -- , runMultiRWSTNil_ + -- , withMultiReader + -- , withMultiReader_ + -- , withMultiReaders + -- , withMultiReaders_ + -- , withMultiWriter + -- , withMultiWriterAW + -- , withMultiWriterWA + -- , withMultiWriterW + -- , withMultiWriters + -- , withMultiWritersAW + -- , withMultiWritersWA + -- , withMultiWritersW + -- , withMultiState + -- , withMultiStateAS + -- , withMultiStateSA + -- , withMultiStateA + -- , withMultiStateS + -- , withMultiState_ + -- , withMultiStates + -- , withMultiStatesAS + -- , withMultiStatesSA + -- , withMultiStatesA + -- , withMultiStatesS + -- , withMultiStates_ + -- , inflateReader + -- , inflateMultiReader + -- , inflateWriter + -- , inflateMultiWriter + -- , inflateState + -- , inflateMultiState + -- , mapMultiRWST + -- , mGetRawR + -- , mGetRawW + -- , mGetRawS + -- , mPutRawR + -- , mPutRawW + -- , mPutRawS + ) + +import Control.Monad.Trans.MultiReader ( runMultiReaderTNil + , runMultiReaderTNil_ + , MultiReaderT (..) + , MultiReader + , MultiReaderTNull + ) + +import Data.Text ( Text ) + +import Control.Monad.IO.Class ( MonadIO (..) + ) + +import Control.Monad.Trans.Class ( lift + ) +import Control.Monad.Trans.Maybe ( MaybeT (..) + ) + +import Language.Haskell.Brittany.Prelude